UNIT TAGDEV;
{
╒══════════════════════════════════════════════════════════════════════════╕
│ ▄██████████▄ ▄███████▄ ▄████████▄ ▄████████▄ ▄█████████▄ ▄██▄ ▄██▄ │
│ ▀▀▀▀████▀▀▀▀ ████▀▀▀████ ████▀ ▀▀▀ ████ ▀███ ████ ▀▀▀ ████ ████ │
│ ████ ████▄▄▄████ ████ ▄▄▄▄ ████ ███ ████▄▄▄▄▄ ████ ████ │
│ ████ ███████████ ████ ▀▀███ ████ ███ ████▀▀▀▀▀ ▀███▄ ▄███▀ │
│ ████ ████ ████ █████▄▄▄███ ████▄▄▄███▀ ████ ▄▄▄ ▀███████▀ │
│ ▀██▀ ▀██▀ ▀██▀ ▀████████▀ ▀███████▀ ▀█████████▀ ▀███▀ │
╘══════════════════════════════════════════════════════════════════════════╛
Version 1.00 Standard
All routines are public domain/free to distribute, modify, and steal!
Routines compiled by Joe McElmeel.
Send all bug reports, questions, inquiries or comments to:
Joe McElmeel (1:2410/480)
}
INTERFACE
USES
CRT, {* Required for various screen/color routines. *}
DOS, {* Required for various time/date/file routines. *}
TAGR27; {* Required for some TAG-specific functions. *}
CONST
MonthDays : ARRAY [1..12] of ShortInt = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 31, 31);
VAR
Year, Month, Date, Day, Hour, Min, Sec, Sec100 : Word;
Pm : Boolean;
StartClock, StopClock : Real;
FUNCTION FileExistWild(Mask : String): Boolean;
{* Tells you if "Mask" exists. Fully supports MS-DOS wildcards. *}
FUNCTION SizeFile(FName : String): LongInt;
{* Reports the size of an MS-DOS file. Returns -1 if file doesn't exist. *}
FUNCTION Int_To_Str(Number : LongInt): String;
{* Converts an Integer to a string. *}
FUNCTION Real_to_Str(Number : Real): String;
{* Converts a real number to a string. *}
FUNCTION Str_To_Int(St : String): Integer;
{* Converts a String to an Integer. *}
FUNCTION RWithCommas(W : Real): String;
{* Converts a Real number to a string and adds commas every three places. *}
FUNCTION WithCommas(W : LongInt): String;
{* Converts an Integer to a string and adds commas every three places. *}
PROCEDURE TC(I : Byte);
{* Works the same way as "TextColor()" except it saves you keystrokes. *}
PROCEDURE ResetColor;
{* Sets foreground color to 7, background color to 0, and disables blinking. *}
PROCEDURE NL;
{* A shorter way of saying "WriteLn;". "NL" = "Next line". *}
PROCEDURE CStr(Str : String);
{* Writes a string to the screen the same way "Write()" does, but it fully *}
{* supports Renegade-like pipe codes! (e.g. '|15Hello!' would come out in *}
{* high-intensity white on black. *}
PROCEDURE CStrLn(Str : String);
{* The same as "CStr()" except it puts a blank line after it. *}
PROCEDURE CenterStr(S : String);
{* Centers "S" on an 80-column line, fully supportive of pipe codes. *}
FUNCTION AllCaps(S : String): String;
{* Capitalizes all lower-case letters in a string. *}
FUNCTION RemoveCtrlP(Stri: String): String;
{* Removes ^C# codes from a color-string in a TAG data file. *}
FUNCTION FullDate : String;
{* Reports the current date in "Wednesday August 10th, 1994" format. *}
FUNCTION Lower(Str : String): String;
{* Changes all upper-case letters in a string to lower-case. *}
FUNCTION Proper(Str : String): String;
{* Changes the first letter of each word to upper-case and all the rest to *}
{* lower-case in a string. Accomodates for "'"'s and "."'s properly. *}
PROCEDURE ClockOn;
PROCEDURE ClockOff;
{* Enables the program timer. Use at the beginning of your program, and *}
{* use ClockOff; at the end to figure out how long it ran for. The *}
{* results are stored in StartClock and StopClock. Simple subtraction *}
{* will tell you exactly how many seconds your program took to run. *}
FUNCTION Ynq(S : String; Mode : Byte): Boolean;
{* Sends a Yes/No question ("S"), and prompts for an answer where the user *}
{* can use the cursor keys to select between a highlighted Yes or No box. *}
{* "Mode" controls the default position of the Yes/No highlight. See the *}
{* code for more details. *}
PROCEDURE FixSpaces(var S : String);
{* Converts all underscore characters in a string to spaces. Useful if *}
{* your command-line parameter checking chokes on spaces. *}
FUNCTION ListARFlags(AR : ARFlagSet): String;
FUNCTION ListSFFlags(SF : FlagSet): String;
{* Lists AR and SF flags in the exact same way as TAG's SDR codes list them *}
{* if you were to use them in a displayable file. *}
FUNCTION UnpakTagDate(TagDate : Word): String;
FUNCTION UnpakTagTime(TagTime : Word): String;
FUNCTION PakTagDate(S : String): Word;
FUNCTION PakTagTime(S : String): Word;
{* These routines are used to pack and un-pack TAG "Semi MS-DOS 1900 format" *}
{* dates that are used in the USER.LST and other data files. *}
FUNCTION GetWord(S : String; W : Integer): String;
{* Returns "word" number "W" from string "S". *}
FUNCTION CoolDate : String;
FUNCTION CoolTime : String;
{* Returns the current date/time in 00/00/00 format for the date and 00:00:00 *}
{* format for the time. *}
FUNCTION OutDate(KMonth, KDate, KYear : Word): String;
FUNCTION OutTime(KHour, KMin, KSec : Word): String;
{* Returns the dates/times in "cool" format, but these functions accept *}
{* other values for the time/date instead of using the system time/date *}
FUNCTION ExtendedDate : String;
{* Returns the date in the same way the TAG SDR code ^S! does. *}
FUNCTION SeeWords(St: String): Integer;
{* Tells you how many words are in a text string. *}
FUNCTION PadRight(St: String; Ch: Char; L: Integer): String;
FUNCTION PadLeft(St: String; Ch: Char; L: Integer): String;
{* The best way to explain these functions is by example.
VAR
S : String
BEGIN
S := '1';
WriteLn(PadLeft(S,'0',5));
END.
...Would output:
00001
It's useful when you're lining up output in columns (on either the right side
or the left. *}
PROCEDURE Exec(Path,CmdLine : String);
{* This is a drop-in replacement for the DOS.Exec procedure, except that *}
{* this one has more features. It FULLY supports pipe-ins and pipe-outs. *}
{* For instance, you can "muffle" the output of PKZIP by adding "> NUL" *}
{* on the end of your Exec() procedure that calls it. *}
FUNCTION DayNum(Dt : String): Word;
{* Tells you how many days it's been since "Dt". Dt is a "cool" date string. *}
{* For instance, August 10th, 1994 in a "cool" date string is "08/10/94". *}
{* TAG stores some of its dates in this format (like in the *.DIR files). *}
FUNCTION WordToHex(W : Word): String;
{* Simply converts any Integer or Word value to a Hexadecimal number. *}
PROCEDURE TNTExitProc;
{* The error handling routines that I have packaged for you. It does quite a *}
{* bit for you. When there is a runtime error in your program, instead of *}
{* just saying "Runtime error 002 at 0000:ABCD" it says exactly what kind of *}
{* error it was (to the user), when it happened (time/date), and has a five *}
{* second pause in case the screen gets cleared somehow. It also creates a *}
{* text capture of the current 80x25 user screen and saves it to a file so *}
{* you, the author, knows exactly what was on the screen (and the cursor *}
{* position!) when it happened. *}
FUNCTION StatusBar(Total, Amt : LongInt): String;
{* Ever see those programs that have those percentage (%) status bars along *}
{* with a nice graph that increments as the program gets complete? Well, *}
{* I found this routines in SWAG snippets so I thought I'd share it here. *}
{* Basically, it figures out the math for you so all you have to do it feed *}
{* it the record number or whatever that you're on and how many there are *}
{* total in the operation, and you can use a For loop to print the graph. *}
{* Quick example:
VAR
I : ShortInt;
Whatever : WhateverRec;
WhateverFile : File of WhateverRec;
BEGIN
For I := 1 to FileSize(WhateverFile) do
BEGIN
GotoXY(10,10);
WriteLn(StatusBar(I,FileSize(WhateverFile));
Seek(WhateverFile,I);
Read(WhateverFile,Whatever);
END;
END. *}
FUNCTION EraseFiles(Path, Mask : String): Integer;
{* Erases file(s) without questions (fully wildcard supportive). *}
IMPLEMENTATION
VAR
H, M, S, S100, VS : Word;
TNTExitPtr : Pointer;
{****************************************************************************}
FUNCTION FileExistWild(Mask : String): Boolean;
VAR
SR : SearchRec;
BEGIN
FindFirst(Mask,AnyFile,SR);
If DosError <> 18 then FileExistWild := TRUE ELSE FileExistWild := FALSE;
END;
{****************************************************************************}
FUNCTION SizeFile(FName : String): LongInt;
VAR
SR : SearchRec;
Idx : Integer;
BEGIN
SizeFile := 0;
FindFirst(FName,AnyFile,SR);
If DosError = 0 then SizeFile := SR.Size ELSE SizeFile := -1;
END;
{****************************************************************************}
FUNCTION VidSeg : Word;
BEGIN
If Mem[$0000:$0049] = 7 then
VidSeg := $B000 ELSE VidSeg := $B800;
END;
{****************************************************************************}
PROCEDURE ClockOn;
VAR
Hr, Mn, Sc, Sc100 : Real;
BEGIN
GetTime(H,M,S,S100);
Hr := H; Mn := M; Sc := S; Sc100 := S100;
StartClock := Hr * 3600 + (Mn * 60) + Sc + (Sc100 / 100);
END;
{****************************************************************************}
PROCEDURE ClockOff;
VAR
Hr, Mn, Sc, Sc100 : Real;
BEGIN
GetTime(H,M,S,S100);
Hr := H; Mn := M; Sc := S; Sc100 := S100;
StopClock := Hr * 3600 + (Mn * 60) + Sc + (Sc100 / 100);
END;
{******************************************************************************}
FUNCTION Int_To_Str(Number : LongInt): String;
VAR
Temp : String[64];
BEGIN
Str(Number,Temp);
Int_To_Str := Temp;
END;
{******************************************************************************}
FUNCTION Real_to_Str(Number : Real): String;
BEGIN
Real_to_Str := Int_To_Str(Trunc(Number));
END;
{******************************************************************************}
FUNCTION Str_To_Int(St: String): Integer;
VAR
I, Ecode : Integer;
BEGIN
Val(St,I,Ecode);
If (Ecode = 0) then Str_To_Int := I ELSE Str_to_Int := 0;
END;
{******************************************************************************}
FUNCTION RWithCommas(W : Real): String;
VAR
CC : LongInt;
S : String[64];
BEGIN
S := Real_to_str(W);
CC := Length(S)-3;
While (CC > 0) do
BEGIN
Insert(',',S,CC+1);
CC := CC-3;
END;
RWithCommas := S;
END;
{***************************************************************************}
FUNCTION WithCommas(W : LongInt): String;
VAR
CC : LongInt;
S : String[64];
BEGIN
S := int_to_str(W);
CC := Length(S)-3;
While (CC > 0) do
BEGIN
Insert(',',S,CC+1);
CC := CC-3;
END;
WithCommas := S;
END;
{******************************************************************************}
PROCEDURE TC(I : Byte);
BEGIN
TextColor(I);
END;
{******************************************************************************}
PROCEDURE ResetColor;
BEGIN
TC(7);
TextBackGround(0);
END;
{******************************************************************************}
PROCEDURE NL;
BEGIN
WriteLn;
END;
{******************************************************************************
PROCEDURE CStr(S : String);
VAR
I : Byte;
SmallStr : String[2];
IntColor : Byte;
Code : Integer;
PROCEDURE DoColor(Color : Byte; VAR B : Byte);
BEGIN
Inc(B);
If (Color < 16) then TC(Color) ELSE TextBackGround(Color-16);
END;
FUNCTION Test(C : Char): Boolean;
VAR
I, Ecode : Integer;
BEGIN
Ecode := 0;
Val(C,I,Ecode);
If (Ecode = 0) then Test := TRUE ELSE Test := FALSE;
END;
BEGIN
ResetColor;
I := 1;
WHILE (I <= Length(S)) do
BEGIN
If (S[I] = '|') and (Test(S[I+1]) = TRUE) then
BEGIN
SmallStr := Copy(S,I+1,I+2);
Inc(I);
Val(SmallStr,IntColor,Code);
If (IntColor > 22) then
BEGIN
Inc(I,2);
Write(SmallStr);
Continue;
END ELSE DoColor(IntColor,I);
END ELSE Write(S[I]); Inc(I);
END;
ResetColor;
END;
******************************************************************************}
PROCEDURE CStr(Str : String);
VAR
StrPos, Err: Integer;
Col: Byte;
BEGIN
StrPos := 1;
IF Length(Str) < 1 THEN Exit;
REPEAT
IF (Str[StrPos] = '|') THEN
BEGIN
Val(Copy(Str,StrPos+1,2),Col,Err);
IF (Err = 0) AND (Col IN [0..23]) THEN
IF Col IN [0..15] THEN TextColor(Col)
ELSE TextBackGround(Col-16);
Inc(StrPos,3);
END
ELSE
BEGIN
Write(Str[StrPos]);
Inc(StrPos);
END;
UNTIL (StrPos > Length(Str));
END;
{******************************************************************************}
PROCEDURE CStrLn(Str : String);
BEGIN
CStr(Str);
NL;
END;
{******************************************************************************}
PROCEDURE CenterStr(S : String);
VAR
X, J, Counter : Byte;
BEGIN
Counter := 0;
For J := 1 to Length(S) do If (S[J] = '|') then Inc(Counter,3);
X := (Length(S)-Counter);
J := X DIV 2;
For X := 1 to (40-J) do Write(' ');
CStrLn(S);
END;
{******************************************************************************}
FUNCTION AllCaps(S : String): String;
VAR
I : Integer;
BEGIN
For I := 1 to ord(S[0]) do S[I] := Upcase(S[I]);
AllCaps := S;
END;
{******************************************************************************}
FUNCTION RemoveCtrlP(Stri : String): String;
VAR
CtrlPStr : String;
Location : Integer;
BEGIN
CtrlPStr := Stri;
REPEAT
If (Pos('',CtrlPStr) <> 0) then
BEGIN
Location := Pos('',CtrlPStr);
Delete(CtrlPStr,Location,2);
END;
UNTIL Pos('',CtrlPStr) = 0;
RemoveCtrlP := CtrlPStr;
END;
{******************************************************************************}
FUNCTION FullDate : String;
TYPE
WeekDays = ARRAY [0..6] of String[9];
Months = ARRAY [1..12] of String[9];
CONST
DayNames : WeekDays = ('Sunday','Monday','Tuesday','Wednesday',
'Thursday','Friday','Saturday');
MonthNames : Months = ('January','February','March','April','May',
'June','July','August','September',
'October','November','December');
BEGIN
GetDate(Year,Month,Date,Day);
FullDate := DayNames[Day]+' '+MonthNames[Month]+' '+int_to_str(Date)+', '+int_to_str(Year);
END;
{******************************************************************************}
FUNCTION Lower(Str: String): String;
VAR
I : Integer;
BEGIN
For I := 1 to Length(Str) do
If ord(Str[I]) in [65..90] then Str[I] := chr(ord(Str[I]) + 32);
Lower := Str;
END;
{******************************************************************************}
FUNCTION Proper(Str: String): String;
VAR
I : Integer;
SpaceBefore : Boolean;
BEGIN
SpaceBefore := TRUE;
Str := Lower(Str);
For I := 1 to Length(Str) do
If ((SpaceBefore) or (ord(Str[I-1]) in [33..47])) and (ord(Str[I]) in [97..122]) then
BEGIN
SpaceBefore := FALSE;
If (Str[I-1] <> '''') then Str[I] := UpCase(Str[I]);
END ELSE
If (not SpaceBefore) and (Str[I] = ' ') then SpaceBefore := TRUE;
Proper := Str;
END;
{******************************************************************************}
PROCEDURE ReadTime;
BEGIN
GetTime(Hour,Min,Sec,Sec100);
GetDate(Year,Month,Date,Day);
If (Hour < 12) then Pm := FALSE;
If (Hour >= 12) then
BEGIN
Pm := True;
Dec(Hour,12);
END;
END;
{****************************************************************************}
FUNCTION Ynq(S : String; Mode: Byte): Boolean;
VAR
Ch : Char;
J, X, Y : Byte;
PROCEDURE Yes;
BEGIN
CStr('|17|15 Yes |16|15 No ');
END;
PROCEDURE No;
BEGIN
CStr('|16|15 Yes |17|15 No ');
END;
BEGIN
Ch := #0;
TC(9);
CStr(S+' ');
X := WhereX;
Y := WhereY;
If (Mode = 1) then Yes ELSE No;
WHILE not (Ch in ['Y', 'N', #13]) do
BEGIN
REPEAT
Ch := UpCase(ReadKey);
UNTIL (Ch in ['Y', 'N', #13, #0]);
CASE Ch of
'Y' : BEGIN
GotoXY(X,Y);
Yes;
Ynq := TRUE;
END;
'N' : BEGIN
GotoXY(X,Y);
No;
Ynq := FALSE;
END;
#13 : If (Mode = 1) then Ynq := TRUE ELSE Ynq := FALSE;
#0 : BEGIN
Ch := ReadKey;
If (Ch = 'K') or (Ch = 'M') then
If (Mode = 1) then
BEGIN
GotoXY(X,Y);
No;
Mode := 2;
END ELSE
BEGIN
GotoXY(X,Y);
Yes;
Mode := 1;
END;
END;
END;
END;
NL;
END;
{****************************************************************************}
PROCEDURE FixSpaces(var S : String);
VAR
I : Integer;
BEGIN
For I := 1 to Length(S) do If S[I] = '_' then S[I] := ' ';
END;
{****************************************************************************}
FUNCTION ListARFlags(AR : ARFlagSet): String;
VAR
S : String[26];
C : Char;
BEGIN
S := '';
For C := 'A' to 'Z' do
If C in AR then S := S + C ELSE S := S + '-';
ListARFlags := S;
END;
{******************************************************************************}
FUNCTION ListSFFlags(SF : FlagSet): String;
VAR
S : String[24];
I : Integer;
BEGIN
S := '';
If AutoPrivDel in SF then S := S + 'A' ELSE S := S + '-';
If NoPostCall in SF then S := S + 'B' ELSE S := S + '-';
If ForceULScan in SF then S := S + 'C' ELSE S := S + '-';
If RAnon in SF then S := S + 'D' ELSE S := S + '-';
If RBBSlist in SF then S := S + 'E' ELSE S := S + '-';
If RChat in SF then S := S + 'F' ELSE S := S + '-';
If NoDlLimit in SF then S := S + 'G' ELSE S := S + '-';
If RPubMsg in SF then S := S + 'H' ELSE S := S + '-';
If RPrivMsg in SF then S := S + 'I' ELSE S := S + '-';
If RVoting in SF then S := S + 'J' ELSE S := S + '-';
If OneCall in SF then S := S + 'K' ELSE S := S + '-';
If PubNotVal in SF then S := S + 'L' ELSE S := S + '-';
If ProtDel in SF then S := S + 'M' ELSE S := S + '-';
If NoFilePts in SF then S := S + 'N' ELSE S := S + '-';
If RFileVal in SF then S := S + 'O' ELSE S := S + '-';
If Pause in SF then S := S + 'P' ELSE S := S + '-';
If ANSI in SF then S := S + 'Q' ELSE S := S + '-';
If Color in SF then S := S + 'R' ELSE S := S + '-';
If OneKey in SF then S := S + 'S' ELSE S := S + '-';
If Alert in SF then S := S + 'T' ELSE S := S + '-';
If FlagRecUnused in SF then S := S + 'U' ELSE S := S + '-';
If MBoxClosed in SF then S := S + 'V' ELSE S := S + '-';
If Tabs in SF then S := S + 'W' ELSE S := S + '-';
If ClsChar in SF then S := S + 'X' ELSE S := S + '-';
ListSFFlags := S;
END;
{****************************************************************************}
FUNCTION UnpakTagDate(TagDate : Word): String;
VAR
S : String[8];
MM, DD, YY : Word;
BEGIN
S := '';
MM := (TagDate SHR 5) AND $0F;
DD := (TagDate AND $1F);
YY := (TagDate SHR 9) AND $7F;
If (MM < 10) then S := '0';
S := S + int_to_str(MM) + '/';
If (DD < 10) then S := S + '0';
S := S + int_to_str(DD) + '/';
If (YY < 10) then S := S + '0';
S := S + int_to_str(YY);
UnpakTagDate := S;
END;
{******************************************************************************}
FUNCTION UnpakTagTime(TagTime : Word): String;
VAR
S : String[8];
HH, MM, SS : Word;
BEGIN
S := '';
HH := (TagTime SHR 11) AND $1F;
MM := (TagTime SHR 5) AND $35;
SS := (TagTime AND $1F) * 2;
If (HH < 10) then S := '0';
S := S + int_to_str(HH) + ':';
If (MM < 10) then S := S + '0';
S := S + int_to_str(MM) + ':';
If (SS < 10) then S := S + '0';
S := S + int_to_str(SS);
UnpakTagTime := S;
END;
{******************************************************************************}
FUNCTION GetWord(S : String; W : Integer): String;
VAR
WordNum : ARRAY [0..60] of String[60];
WCount, I : Integer;
BEGIN
S := S + ' ';
WCount := 0;
For I := 0 to 60 do WordNum[I] := ' ';
WHILE (Length(S) > 0) do
BEGIN
WordNum[WCount] := Copy(S,1,Pos(' ',S)-1);
Delete(S,1,Length(WordNum[WCount])+1);
Inc(WCount);
END;
GetWord := WordNum[W-1];
END;
{******************************************************************************}
FUNCTION CoolDate : String;
VAR
Temp : String[8];
BEGIN
Temp := '';
GetDate(Year,Month,Date,Day);
If (Month < 10) then Temp := '0';
Temp := Temp + int_to_str(Month) + '/';
If (Date < 10) then Temp := Temp + '0';
Temp := Temp + int_to_str(Date) + '/' + int_to_str(Year-1900);
CoolDate := Temp;
END;
{******************************************************************************}
FUNCTION CoolTime : String;
VAR
Temp : String[8];
BEGIN
Temp := '';
GetTime(Hour,Min,Sec,Sec100);
If (Hour < 10) then Temp := '0';
Temp := Temp + int_to_str(Hour) + ':';
If (Min < 10) then Temp := Temp + '0';
Temp := Temp + int_to_str(Min) + ':';
If (Sec < 10) then Temp := Temp + '0';
Temp := Temp + int_to_str(Sec);
CoolTime := Temp;
END;
{******************************************************************************}
FUNCTION ExtendedDate : String;
CONST
DayName : ARRAY [0..6] of String[3] = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
MonthName : ARRAY [1..12] of String[3] = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov',
'Dec');
VAR
TempStr : String;
Pm : Boolean;
BEGIN
TempStr := '';
GetDate(Year,Month,Date,Day);
GetTime(Hour,Min,Sec,Sec100);
If (Hour < 12) then Pm := FALSE;
If (Hour >= 12) then
BEGIN
Pm := TRUE;
Dec(Hour,12);
END;
If (Hour = 0) then TempStr := '12:' ELSE
If (Hour < 10) then TempStr := '0';
TempStr := TempStr + int_to_str(Hour) + ':';
If (Min < 10) then TempStr := TempStr + '0'; TempStr := TempStr + int_to_str(Min) + ' ';
If (Pm = TRUE) then TempStr := TempStr + 'pm ' ELSE TempStr := TempStr + 'am ';
TempStr := TempStr + DayName[Day] + ' ' + MonthName[Month] + ' ';
If (Date < 10) then TempStr := TempStr + '0' + int_to_str(Date) ELSE TempStr := TempStr + int_to_str(Date);
TempStr := TempStr + ', ' + int_to_str(Year);
ExtendedDate := TempStr;
END;
{******************************************************************************}
FUNCTION SeeWords(St : String): Integer;
VAR
T : String;
I : Integer;
BEGIN
T := St;
I := 1;
REPEAT
If (Pos(' ',T) <> 0) then
BEGIN
Delete(T,1,Pos(' ',T));
Inc(I);
END;
UNTIL (Pos(' ',T) = 0);
SeeWords := I;
END;
{******************************************************************************}
FUNCTION PadRight(St: String; Ch: Char; L: Integer): String;
VAR
I : Integer;
TempStr : String;
BEGIN
TempStr := St;
If (Length(TempStr) > L) then TempStr[0] := chr(L);
If (Length(TempStr) < L) then
BEGIN
For I := Length(TempStr) + 1 to L do TempStr[I] := Ch;
TempStr[0] := chr(L);
END;
PadRight := TempStr;
END;
{****************************************************************************}
FUNCTION PadLeft(St: String; Ch: Char; L: Integer): String;
VAR
TempStr : String;
I : Word;
BEGIN
If Length(St) >= L then PadLeft := Copy(St,1,L) ELSE
BEGIN
For i := 1 to (L - Length(St)) do TempStr[i] := Ch;
TempStr[0] := Chr(L - Length(St));
PadLeft := TempStr + St;
END;
END;
{****************************************************************************}
Function ExtractFileName(Var Line : String;Index : Integer) : String;
Var
Temp : String;
Begin
Delete(Line,Index,1);
While (Index <= Length(Line)) AND (Line[Index] = ' ')
Do Delete(Line,Index,1);
Temp := '';
While (Index <= Length(Line)) AND (Line[Index] <> ' ') Do
Begin
Temp := Temp + Line[Index];
Delete(Line,Index,1);
End;
ExtractFileName := Temp;
End;
Procedure CloseHandle(Handle : Word);
Var
Regs : Registers;
Begin
With Regs Do
Begin
AH := $3E;
BX := Handle;
MsDos(Regs);
End;
End;
Procedure Duplicate(SourceHandle : Word;Var TargetHandle : Word);
Var
Regs : Registers;
Begin
With Regs Do
Begin
AH := $45;
BX := SourceHandle;
MsDos(Regs);
TargetHandle := AX;
End;
End;
Procedure ForceDuplicate(SourceHandle : Word;Var TargetHandle : Word);
Var
Regs : Registers;
Begin
With Regs Do
Begin
AH := $46;
BX := SourceHandle;
CX := TargetHandle;
MsDos(Regs);
TargetHandle := AX;
End;
End;
Procedure Exec(Path,CmdLine : String);
Var
StdIn : Word;
Stdout : Word;
Index : Integer;
FName : String[80];
InFile : Text;
OutFile : Text;
InHandle : Word;
OutHandle : Word;
{ ===============>>>> } { change below for STDERR }
Begin
StdIn := 0;
StdOut := 1; { change to 2 for StdErr }
Duplicate(StdIn,InHandle); { duplicate standard input }
Duplicate(StdOut,OutHandle); { duplicate standard output }
Index := Pos('>',CmdLine);
If Index > 0 Then { check for output redirection }
Begin
FName := ExtractFileName(CmdLine,Index); { get output file name }
Assign(OutFile,FName); { open a text file }
Rewrite(OutFile); { .. for output }
ForceDuplicate(TextRec(OutFile).Handle,StdOut);{ make output same }
End;
Index := Pos('<',CmdLine);
If Index > 0 Then { check for input redirection }
Begin
FName := ExtractFileName(CmdLine,Index); { get input file name }
Assign(InFile,FName); { open a text file }
Reset(InFile); { for input }
ForceDuplicate(TextRec(InFile).Handle,StdIn); { make input same }
End;
DOS.Exec(Path,CmdLine); { run EXEC }
ForceDuplicate(InHandle,StdIn); { put standard input back to keyboard }
ForceDuplicate(OutHandle,StdOut); { put standard output back to screen }
CloseHandle(InHandle); { close the redirected input file }
CloseHandle(OutHandle); { close the redirected output file }
End;
{****************************************************************************}
FUNCTION Value(I : String): LongInt;
VAR
N : LongInt;
N1 : Integer;
BEGIN
Val(I, N, N1);
If (N1 <> 0) then
BEGIN
I := Copy(I, 1, N1 - 1);
Val(I, N, N1)
END;
Value := N;
If (I = '') then Value := 0;
END;
{******************************************************************************}
FUNCTION LeapYear(Yr : Word): Boolean;
BEGIN
LeapYear := ((Yr MOD 4) = 0) AND (((Yr MOD 100) <> 0) or ((Yr MOD 400) = 0));
END;
{******************************************************************************}
FUNCTION Days(Mo, Yr : Word): Word;
VAR
D : Word;
BEGIN
D := MonthDays[Mo];
If (Mo = 2) and LeapYear(Yr) then Inc(D);
Days := d;
END;
{******************************************************************************}
FUNCTION DayCount(Mo, Yr : Word): Word;
VAR
M, T : Word;
BEGIN
T := 0;
For M := 1 to (Mo - 1) do T := T + Days(M, Yr);
DayCount := T;
END;
{******************************************************************************}
FUNCTION ValidMDY(VAR mm, dd, yy : Word; MinYr, MaxYr, DefYr : Word): Boolean;
VAR
Changed : Boolean;
MaxD : Word;
CurYear : ShortInt;
BEGIN
ReadTime;
CurYear := Year - 1900;
Changed := False;
If (Mm < 1) or (Mm > 12) then
BEGIN
Changed := TRUE;
Mm := 1;
END;
If (Yy < 1900) then Yy := Yy + 1900;
If (Yy < MinYr) or (Yy > MaxYr) then
BEGIN
Changed := TRUE;
If DefYr <> 0 THEN Yy := DefYr ELSE Yy := CurYear;
END;
If (Dd < 1) then
BEGIN
Changed := TRUE;
Dd := 1;
END;
If (Dd > 28) then
BEGIN
MaxD := Days(mm, yy);
If (Dd > MaxD) then
BEGIN
Changed := TRUE;
Dd := MaxD;
END;
END;
ValidMDY := NOT Changed;
END;
{******************************************************************************}
FUNCTION DateStToMDY(Dt : String; VAR m, d, Y : Word; MinYr, MaxYr, DefYr : Word): Boolean;
BEGIN
M := Value(Copy(Dt,1,2));
D := Value(Copy(Dt,4,2));
If Copy(Dt,6,1)='²' then Y := 2000 + Value(Copy(Dt, 7, 2)) ELSE
Y := 1900 + Value(Copy(Dt, 7, 2));
DateStToMDY := ValidMDY(m, d, Y, MinYr, MaxYr, DefYr);
END;
{******************************************************************************}
FUNCTION DayNum(Dt : String): Word;
VAR
D, M, Y, T, C : Word;
BEGIN
T := 0;
If DateStToMDY(Dt,m,d,Y,1985,2027,1985) then
BEGIN
For C := 1985 to Y - 1 do
If (LeapYear(C)) then Inc(T,366) ELSE Inc(T,365);
T := T + DayCount(M,Y) + (D - 1);
END;
DayNum := T;
END;
{******************************************************************************}
FUNCTION WordToHex(W : Word): String;
CONST
Hex : ARRAY [0..15] of Char = '0123456789ABCDEF';
VAR
H : String[4];
BEGIN
H[0] := Chr(4);
H[1] := Hex[(W SHR 12) AND $0F];
H[2] := Hex[(W SHR 8) AND $0F];
H[3] := Hex[(W SHR 4) AND $0F];
H[4] := Hex[W AND $0F];
WordToHex := H;
END;
{******************************************************************************}
PROCEDURE TNTExitProc;
VAR
VidSeg : Word;
X, Y : Byte;
C : Char;
S : String[80];
ErrorType, Description : String[128];
Fil : Text;
BEGIN
If (ErrorAddr <> NIL) then
BEGIN
If (ExitCode < 99) then ErrorType := 'DOS error' ELSE
If (ExitCode < 149) then ErrorType := 'I/O error' ELSE
If (ExitCode < 199) then ErrorType := 'Critical error' ELSE
ErrorType := 'Fatal error';
CASE ExitCode of
1 : Description := 'Invalid function number';
2 : Description := 'File not found';
3 : Description := 'Path not found';
4 : Description := 'Too many open files';
5 : Description := 'File access denied';
6 : Description := 'Invalid file handle';
12 : Description := 'Invalid file access code';
15 : Description := 'Invalid drive number';
16 : Description := 'Cannot remove current directory';
17 : Description := 'Cannot rename across drives';
18 : Description := 'No more files';
100 : Description := 'Disk read error';
101 : Description := 'Disk write error';
102 : Description := 'File not assigned';
103 : Description := 'File not open';
104 : Description := 'File not open for input';
105 : Description := 'File not open for output';
106 : Description := 'Invalid numeric format';
150 : Description := 'Disk is write-protected';
151 : Description := 'Unknown unit';
152 : Description := 'Drive not ready';
153 : Description := 'Unknown command';
154 : Description := 'CRC error in data';
155 : Description := 'Bad drive request structure length';
156 : Description := 'Disk seek error';
157 : Description := 'Unknown media type';
158 : Description := 'Sector not found';
159 : Description := 'Printer out of paper';
160 : Description := 'Device write fault';
161 : Description := 'Device read fault';
162 : Description := 'Hardware failure';
200 : Description := 'Division by zero';
201 : Description := 'Range check error';
202 : Description := 'Stack overflow error';
203 : Description := 'Heap overflow error';
204 : Description := 'Invalid printer operation';
205 : Description := 'Floating-point overflow';
206 : Description := 'Floating-point underflow';
207 : Description := 'Invalid floating-point operation';
208 : Description := 'Overlay manager not installed';
209 : Description := 'Overlay file read error';
210 : Description := 'Object not installed';
211 : Description := 'Call to abstract method';
212 : Description := 'Stream registration error';
213 : Description := 'Collection index out of range';
214 : Description := 'Collection overflow error';
215 : Description := 'Arithmetic overflow error';
216 : Description := 'General protection fault';
END;
NL; NL;
CStrLn('|07Runtime error : |15'+int_to_str(ExitCode)+'.');
CStrLn('|07Type of error : |15'+ErrorType+'.');
CStrLn('|07Error description : |15'+Description+'.');
CStrLn('|07Memory address : |15'+WordToHex(Seg(ErrorAddr^))+':'+WordToHex(Ofs(ErrorAddr^))+'.');
Assign(Fil,'RUNERROR.LOG');
{$I-} Append(Fil); {$I+} if (IOResult <> 0) then
BEGIN
Rewrite(Fil);
WriteLn(Fil,'Runtime Error Log');
WriteLn(Fil,'═══════════════════════════════════════════════════════════════════════════════');
WriteLn(Fil);
WriteLn(Fil,'Please notify the author of this software immediately of this problem. Be sure');
WriteLn(Fil,'to attach a copy of this error log file with your message. For information on');
WriteLn(Fil,'contacting the author, please refer to the documentation.');
WriteLn(Fil);
WriteLn(Fil,'A "█" character in the below screen image(s) indicates the current position of');
WriteLn(Fil,'the cursor at the time(s) of error.');
END;
WriteLn(Fil);
WriteLn(Fil,'───────────────────────────────────────────────────────────────────────────────');
WriteLn(Fil,'Time of error : ',CoolTime,' on ',CoolDate,'.');
WriteLn(Fil,'Runtime error : ',ExitCode,'.');
WriteLn(Fil,'Type of error : ',ErrorType,'.');
WriteLn(Fil,'Error description : ',Description,'.');
WriteLn(Fil,'Memory address : '+WordToHex(Seg(ErrorAddr^)),':',WordToHex(Ofs(ErrorAddr^)),'.');
WriteLn(Fil);
WriteLn(Fil,'──────────────────────────[ Start of Screen Capture ]──────────────────────────');
If (Mem[$0000:$0449] = 7) then VidSeg := $B000 ELSE VidSeg := $B800;
For Y := 1 to 25 do
BEGIN
S := '';
For X := 1 to 80 do
BEGIN
C := Chr(Mem[VidSeg:(160*(Y-1)+2*(X-1))]);
If (C = #0) then C := #32;
If (X = WhereX) and (Y = WhereY) then C := #219;
If (X <> 80) or ((X = 80) and (C <> #32)) then S := S + C;
END;
WriteLn(Fil,S);
END;
WriteLn(Fil,'───────────────────────────[ End of Screen Capture ]───────────────────────────');
Flush(Fil);
Close(Fil);
NL;
CStr('|14[> Pausing for five seconds... ');
Delay(5000);
NL;
ExitProc := TNTExitPtr;
ErrorAddr := NIL;
END;
END;
{****************************************************************************}
FUNCTION PakTagDate(S : String): Word;
VAR
Ecode : Integer;
I, M, D, Y : LongInt;
BEGIN
Ecode := 0;
Val(Copy(S,1,2),I,Ecode);
If (Ecode = 0) then M := I ELSE M := 0;
Val(Copy(S,4,2),I,Ecode);
If (Ecode = 0) then D := I ELSE D := 0;
Val(Copy(S,7,2),I,Ecode);
If (Ecode = 0) then Y := I ELSE Y := 0;
PakTagDate := (Y SHL 9) + (M SHL 5) + D;
END;
{****************************************************************************}
FUNCTION PakTagTime(S : String): Word;
VAR
I, Ecode : Integer;
H, M, Se : LongInt;
BEGIN
Ecode := 0;
Val(Copy(S,1,2),I,Ecode);
If (Ecode = 0) then H := I ELSE H := 0;
Val(Copy(S,4,2),I,Ecode);
If (Ecode = 0) then M := I ELSE M := 0;
Val(Copy(S,7,2),I,Ecode);
If (Ecode = 0) then Se := I ELSE Se := 0;
PakTagTime := (H SHL 11) + (M SHL 5) + (Se DIV 2);
END;
{****************************************************************************}
FUNCTION OutDate(KMonth, KDate, KYear : Word): String;
VAR
I : Integer;
TempStr, Temp : String;
BEGIN
I := KYear - 1900;
Str(KMonth,TempStr);
Temp := TempStr + '-';
Str(KDate,TempStr);
If KDate < 10 then Temp := Temp + '0' + TempStr + '-' ELSE Temp := Temp + TempStr + '-';
Str(I,TempStr);
If I < 10 then Temp := Temp + '0' + TempStr ELSE Temp := Temp + TempStr;
OutDate := Temp;
END;
{****************************************************************************}
FUNCTION OutTime(KHour, KMin, KSec : Word): String;
VAR
Temp : String;
Pm : Boolean;
BEGIN
Pm := FALSE;
If (KHour >= 12) then
BEGIN
Pm := TRUE;
Dec(KHour,12);
END;
If (KHour = 0) then Temp := '12:' ELSE Temp := int_to_str(KHour) + ':';
If (KMin < 10) then Temp := Temp + '0' + int_to_str(KMin) ELSE Temp := Temp + int_to_str(KMin);
If (Pm = TRUE) then Temp := Temp + 'p' ELSE Temp := Temp + 'a';
OutTime := Temp;
END;
{****************************************************************************}
FUNCTION StatusBar(Total, Amt : LongInt): String;
CONST
BarLength = 40;
VAR
A, B, C, D : LongInt;
I : Integer;
Percent : Real;
St, TmpSt : String;
BEGIN
If (Total = 0) or (Amt = 0) then
BEGIN
StatusBar := '';
Exit;
END;
If (Amt > Total) then Amt := Total;
Percent := Amt / Total * (BarLength * 10);
A := Trunc(Percent);
B := A DIV 10;
C := 1;
Percent := Amt / Total * 100;
D := Trunc(Percent);
St := ' (' + int_to_str(D) + '%)';
TmpSt := '';
TmpSt := PadRight(TmpSt,'█',B*C) + PadRight(TmpSt,'░',(BarLength-(B*C))) + St;
StatusBar := TmpSt;
END;
{****************************************************************************}
FUNCTION EraseFiles(Path, Mask : String): Integer;
VAR
S : SearchRec;
PROCEDURE KillFile(S : String);
VAR
F : File;
BEGIN
Assign(F,S);
{$I-} Erase(F); {$I+}
END;
BEGIN
FindFirst(Path + Mask, AnyFile - Directory, S);
If (DosError = 18) then Exit;
KillFile(Path + S.Name);
REPEAT
FindNext(S);
If not (DosError = 18) then KillFile(Path + S.Name);
UNTIL DosError = 18;
EraseFiles := IOResult;
END;
{****************************************************************************}
BEGIN
ReadTime;
TNTExitPtr := ExitProc; {* Initalizes the error handler... *}
ExitProc := @TNTExitProc;
VS := VidSeg; {* Initalizes the screen capture routines. *}
END.