home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Boston 2
/
boston-2.iso
/
DOS
/
PROGRAM
/
PASCAL
/
UTIL
/
UTILITY.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-12-01
|
103KB
|
3,741 lines
{$A+,B-,D-,E-,F-,G-,I+,L-,N-,O-,R-,S-,V-,X-}
{
Utility 16.1 (c) Copyright 1990, 1991 by Gemini Systems ALL RIGHTS RESERVED
╒════════════════════════════════════════════════════════════════════════╕
│ │
│ This UNIT was written for TURBO PASCAL 5.0 by: │
│ │
│ GEMINI SYSTEMS │
│ 7748 Lake Ridge Drive │
│ Waterford, MI 48327 │
│ │
│ Comments, Suggestions or Donations welcome. │
│ │
│ To use in your programs, simply state UTILITY in your uses clause. │
│ │
│ example: PROGRAM prog_name; │
│ USES utility; (Programs must be compiled with │
│ the $V- Compiler Directive) │
│ │
╘════════════════════════════════════════════════════════════════════════╛
}
{$I UTILITY.DOC }
IMPLEMENTATION
CONST
HEXCHARS : ARRAY [1..16] OF CHAR =
('0','1','2','3','4','5','6','7','8','9',
'A','B','C','D','E','F');VAR
ExitSave : pointer;
OLDVAL : STRING;
type
EnvArray = array[0..32767] of Char;
EnvArrayPtr = ^EnvArray;
EnvRec =
record
EnvSeg : Word; {Segment of the environment}
EnvLen : Word; {Usable length of the environment}
EnvPtr : Pointer; {Nil except when allocated on heap}
end;
VAR
ENV_REC : ENVREC;
CURRENT_BORDER : INTEGER;
BLINK_IS_ON : BOOLEAN;
FUNCTION GETHEX(DECIMAL_VALUE : WORD) : STRING;
VAR
ADDRESS_DIGIT,
COUNTER,
DIVISOR,
QUOTIENT : INTEGER;
TEMPSTRING : STRING;
BEGIN
GETHEX := '';
TEMPSTRING := '';
FOR ADDRESS_DIGIT := 1 TO 4 DO
BEGIN
DIVISOR := 1;
FOR COUNTER := ADDRESS_DIGIT TO 3 DO
DIVISOR := DIVISOR * 16;
QUOTIENT := DECIMAL_VALUE DIV DIVISOR;
DECIMAL_VALUE := DECIMAL_VALUE MOD DIVISOR;
TEMPSTRING := TEMPSTRING + HEXCHARS[QUOTIENT+1];
END;
GETHEX := TEMPSTRING;
END;
PROCEDURE SET_CURSOR;
VAR
TOPLINE,
BOTLINE : BYTE;
BIOSPARAM : REGISTERS;
BEGIN
CASE CURS OF
BLOCK : BEGIN
TOPLINE := 0;
BOTLINE := 7;
END;
UNDERLINE : BEGIN
TOPLINE := 6;
BOTLINE := 7;
END;
NONE : BEGIN
TOPLINE := 32;
BOTLINE := 0;
END;
HALF : BEGIN
TOPLINE := 4;
BOTLINE := 7;
END;
END;
WITH BIOSPARAM DO
BEGIN
AX := 1 SHL 8 + 0;
CX := TOPLINE SHL 8 + BOTLINE;
END;
INTR($10,BIOSPARAM);
CUR := CURS;
END;
{$F+}
PROCEDURE EXITHANDLER;
VAR
OFFSET,
SEGMENT : STRING;
BEGIN
EXITPROC := EXITSAVE;
IF RESET_CURSOR THEN
SET_CURSOR(UNDERLINE);
IF (EXITCODE <> 0) AND (SHOW_ERROR) THEN
BEGIN
OFFSET := GETHEX(OFS(ERRORADDR^));
SEGMENT := GETHEX(SEG(ERRORADDR^));
WINDOW(1,1,80,25);
WRITELN;
ERRORADDR := NIL;
GOTOXY(1,25);
WRITELN; WRITELN; WRITELN; WRITELN; WRITELN; WRITELN; WRITELN; WRITELN;
FW(1,18,$4E,'╔═══════════════════════════════════════════════════════════════════════════╗');
IF EXITCODE = 255 THEN
BEGIN
FW(1,19,$4E,'║ Program Terminated by Operator ! ║');
FW(1,20,$4E,'║ Press <any key> to Continue ║');
FW(1,21,$4E,'╚═══════════════════════════════════════════════════════════════════════════╝');
GOTOXY(35,20);
END
ELSE
BEGIN
FW(1,19,$4E,'║ Program Terminated by Run-Time Error! ║');
FW(1,20,$4E,'║ Program - ║');
FW(1,21,$4E,'║ Error Code - ║');
FW(1,22,$4E,'║ Error Address - ║');
FW(1,23,$4E,'║ Press <any key> to Continue ║');
FW(1,24,$4E,'╚═══════════════════════════════════════════════════════════════════════════╝');
TEXTATTR := $4F;
GOTOXY(19,20);
WRITE(PARAMSTR(0));
GOTOXY(19,21);
WRITE(EXITCODE);
GOTOXY(19,22);
WRITE(SEGMENT,':',OFFSET);
GOTOXY(52,23);
END;
CH := READKEY;
WRITELN;
END;
TEXTATTR := TEXTATTR_AT_ENTRY;
END;
{$F-}
FUNCTION CGA_INSTALLED : BOOLEAN;
VAR
MONITOR_INFO : BYTE ABSOLUTE $0040:$0010;
BEGIN
CGA_INSTALLED := TRUE;
IF MONITOR_INFO AND 48=48 THEN
BEGIN
CGA_INSTALLED := FALSE;
P := PTR($B000,0000);
END
ELSE
IF MONITOR_INFO AND 32=32 THEN
BEGIN
CGA_INSTALLED := TRUE;
P := PTR($B800,0000);
END;
END;
PROCEDURE SAVE_SCREEN;
BEGIN
MOVE(P^[1],SCREEN[1],4000);
END;
PROCEDURE REBUILD_SCREEN;
BEGIN
MOVE(SCREEN[1],P^[1],4000);
END;
PROCEDURE UP_SOUND;
VAR
I : INTEGER;
BEGIN
FOR I := 2000 TO 4000 DO
SOUND(I);
NOSOUND;
END;
PROCEDURE DOWN_SOUND;
VAR
I : INTEGER;
BEGIN
FOR I := 4000 DOWNTO 2000 DO
SOUND(I);
NOSOUND;
END;
PROCEDURE CAPS_ON;
VAR
KEYBOARD : BYTE ABSOLUTE $0040:$0017;
BEGIN
KEYBOARD:=KEYBOARD OR 64;
END;
FUNCTION CAPS_ARE_ON : BOOLEAN;
VAR
KEYBOARD : BYTE ABSOLUTE $0040:$0017;
BEGIN
CAPS_ARE_ON := KEYBOARD AND 64 = 64;
END;
PROCEDURE CAPS_OFF;
VAR
KEYBOARD : BYTE ABSOLUTE $0040:$0017;
BEGIN
KEYBOARD:=KEYBOARD AND 191;
END;
PROCEDURE NUM_LOCK_ON;
VAR
KEYBOARD : BYTE ABSOLUTE $0040:$0017;
BEGIN
KEYBOARD:=KEYBOARD OR 32;
END;
FUNCTION NUM_LOCK_IS_ON : BOOLEAN;
VAR
KEYBOARD : BYTE ABSOLUTE $0040:$0017;
BEGIN
NUM_LOCK_IS_ON := KEYBOARD AND 32 = 32;
END;
PROCEDURE NUM_LOCK_OFF;
VAR
KEYBOARD : BYTE ABSOLUTE $0040:$0017;
BEGIN
KEYBOARD:=KEYBOARD AND 223;
END;
PROCEDURE SCROLL_LOCK_ON;
VAR
KEYBOARD : BYTE ABSOLUTE $0040:$0017;
BEGIN
KEYBOARD:=KEYBOARD OR 16;
END;
PROCEDURE SCROLL_LOCK_OFF;
VAR
KEYBOARD : BYTE ABSOLUTE $0040:$0017;
BEGIN
KEYBOARD:=KEYBOARD AND 239;
END;
FUNCTION SCROLL_LOCK_IS_ON : BOOLEAN;
VAR
KEYBOARD : BYTE ABSOLUTE $0040:$0017;
BEGIN
SCROLL_LOCK_IS_ON := KEYBOARD AND 16 = 16;
END;
PROCEDURE SHOW_VERSION;
VAR
CH : CHAR;
L : LONGINT;
SCREEN : ARRAY [1..285] OF CHAR;
TEMP : STRING[15];
BEGIN
MOVE(P^[319],SCREEN[1],71);
MOVE(P^[479],SCREEN[72],71);
MOVE(P^[639],SCREEN[143],71);
MOVE(P^[799],SCREEN[214],71);
FW(1,3,$4F,'╒════════════════════════════════╕');
FW(1,4,$4F,'│ │');
IF LENGTH(PARAMSTR(0)) <= 30 THEN
FW(3,4,$4F,PARAMSTR(0))
ELSE
BEGIN
FW(3,4,$4F,CHR(27)+COPY(PARAMSTR(0),LENGTH(PARAMSTR(0))-28,29));
END;
FW(1,5,$4F,'│ U16.1 RELEASE │');
FW(1,6,$4F,'╘════════════════════════════════╛');
IF UT.COMPILED_DATE <> '%%-%%-%%' THEN
BEGIN
FW(18,5,$4F,UT.COMPILED_DATE+' ');
IF UT.COMPILED_TIME <> '%%:%%' THEN
FW(27,5,$4F,UT.COMPILED_TIME);
END
ELSE
FW(18,5,$4F,VERSION);
GOTOXY(16,5);
START_TIMER(L);
REPEAT
UNTIL (ELAP_TIME(L) > 15) OR KEYPRESSED;
IF KEYPRESSED THEN
BEGIN
READCH(CH,FALSE);
IF CH = AF1 THEN
BEGIN
TEMP := 'LJUOUR&\\\VFMY';
UN_ENCRYPT(TEMP,15000);
FW(1,5,$4F,'│ │');
FW(11,5,$4F,TEMP);
READCHT(CH,FALSE,30);
END;
END;
WHILE KEYPRESSED DO
CH := READKEY;
MOVE(SCREEN[1],P^[319],71);
MOVE(SCREEN[72],P^[479],71);
MOVE(SCREEN[143],P^[639],71);
MOVE(SCREEN[214],P^[799],71);
END;
PROCEDURE SPECIAL_KEY(VAR CH : CHAR);
BEGIN
CASE ORD(CH) OF
72 : CH:=#180; { UP ARROW }
80 : CH:=#181; { DOWN ARROW }
77 : CH:=#192; { RIGHT ARROW }
75 : CH:=#191; { LEFT ARROW }
71 : CH:=#196; { HOME KEY } { ESC KEY RETURNS CHR(27) }
73 : CH:=#178; { PGUP KEY }
79 : CH:=#197; { END KEY }
81 : CH:=#179; { PGDN KEY }
82 : CH:=#198; { INSERT KEY }
83 : CH:=#199; { DELETE KEY }
59 : CH:=#127; { F1 }
60 : CH:=#128; { F2 }
61 : CH:=#129; { F3 }
62 : CH:=#130; { F4 }
63 : CH:=#131; { F5 }
64 : CH:=#132; { F6 }
65 : CH:=#133; { F7 }
66 : CH:=#134; { F8 }
67 : CH:=#135; { F9 }
68 : CH:=#136; { F10 }
104 : CH:=#139; { ALT F1 }
105 : CH:=#140; { ALT F2 }
106 : CH:=#141; { ALT F3 }
107 : CH:=#142; { ALT F4 }
108 : CH:=#143; { ALT F5 }
109 : CH:=#144; { ALT F6 }
110 : CH:=#145; { ALT F7 }
111 : CH:=#146; { ALT F8 }
112 : CH:=#147; { ALT F9 }
113 : CH:=#148; { ALT F10}
30 : CH:=#151; { ALT A }
48 : CH:=#152; { ALT B }
46 : CH:=#153; { ALT C }
32 : CH:=#154; { ALT D }
18 : CH:=#155; { ALT E }
33 : CH:=#156; { ALT F }
34 : CH:=#157; { ALT G }
35 : CH:=#158; { ALT H }
23 : CH:=#159; { ALT I }
36 : CH:=#160; { ALT J }
37 : CH:=#161; { ALT K }
38 : CH:=#162; { ALT L }
50 : CH:=#163; { ALT M }
49 : CH:=#164; { ALT N }
24 : CH:=#165; { ALT O }
25 : CH:=#166; { ALT P }
16 : CH:=#167; { ALT Q }
19 : CH:=#168; { ALT R }
31 : CH:=#169; { ALT S }
20 : CH:=#170; { ALT T }
22 : CH:=#171; { ALT U }
47 : CH:=#172; { ALT V }
17 : CH:=#173; { ALT W }
45 : CH:=#174; { ALT X }
21 : CH:=#175; { ALT Y }
44 : CH:=#176; { ALT Z }
94 : CH:=#200; { CNTR F1 }
95 : CH:=#201;
96 : CH:=#202;
97 : CH:=#203;
98 : CH:=#204;
99 : CH:=#205;
100 : CH:=#206;
101 : CH:=#207;
102 : CH:=#208;
103 : CH:=#209;
END;
END;
PROCEDURE READCH;
VAR
I,
ATX, ATY : INTEGER;
LINE25 : BUF160;
HELP : BOOLEAN;
Procedure PROCESS_COMMAND(UserRoutine : Pointer; NA : STRING);
Procedure CallUserRoutine (NA : STRING); INLINE
( $FF / $5E / <UserRoutine );
Begin
CallUserRoutine(NA);
End;
PROCEDURE EVENT_HANDLER(PROCESS_ROUTINE : POINTER; MASK : STRING);
BEGIN
PROCESS_COMMAND(PROCESS_ROUTINE,'');
END;
BEGIN
ATX := WHEREX;
ATY := WHEREY;
SAVE_LINE(25,LINE25);
HELP := FALSE;
REPEAT
I := 300;
REPEAT
IF (SHIFT_KEYS('A')) AND (HELP_LINE <> '') THEN
BEGIN
FW(1,25,HELP_ATTR,PAD(HELP_LINE,80));
GOTOXY(ATX,ATY);
HELP := TRUE;
END
ELSE
IF (SHIFT_KEYS('C')) AND (HELP_LINE2 <> '') THEN
BEGIN
FW(1,25,HELP_ATTR2,PAD(HELP_LINE2,80));
GOTOXY(ATX,ATY);
HELP := TRUE;
END
ELSE
IF HELP THEN
BEGIN
REBUILD_LINE(25,LINE25);
GOTOXY(ATX,ATY);
HELP := FALSE;
END;
IF UT.TIMEX > 0 THEN
BEGIN
I := SUCC(I);
IF I > 200 THEN
BEGIN
WRITE_TIME(UT.TIMEX,UT.TIMEY,CH);
I := 0;
END;
GOTOXY43(ATX,ATY);
END;
UNTIL KEYPRESSED OR (COMMAND_BUFFER <> '');
REBUILD_LINE(25,LINE25);
HELP := FALSE;
IF COMMAND_BUFFER = '' THEN
BEGIN
CH := READKEY;
IF CH = #0 THEN
BEGIN
CH := READKEY;
SPECIAL_KEY(CH);
END;
IF (CH IN [' '..'~']) AND ECHO THEN
WRITE(CH);
END
ELSE
BEGIN
CH := COMMAND_BUFFER[1];
IF (CH IN [' '..'~']) AND ECHO THEN
WRITE(CH);
DELETE(COMMAND_BUFFER,1,1);
END;
IF CH = AF10 THEN SHOW_VERSION;
IF EventHandler <> NIL THEN
EVENT_HANDLER(EventHandler,'');
UNTIL CH <> AF10;
END;
FUNCTION PRINTER_NOT_READY : BOOLEAN;
VAR
REGS : REGISTERS;
BEGIN
PRINTER_NOT_READY := TRUE;
FILLCHAR(REGS,SIZEOF(REGS),00);
WITH REGS DO
BEGIN
AX := $0200;
DX := 0; { LPT1 = 0, LPT2 = 1 }
END;
INTR($17,REGS);
IF REGS.AX AND $4000 = 0 THEN
BEGIN
IF REGS.AX AND $1000 <> 0 THEN PRINTER_NOT_READY := FALSE;
END;
IF REGS.AX AND $8000 = 0 THEN PRINTER_NOT_READY := TRUE;
END;
PROCEDURE SET_ATTR;
VAR
MONITOR_INFO : BYTE ABSOLUTE $0040:$0010;
SCREEN1 : ARRAY [1..4000] OF BYTE ABSOLUTE $B800:$0000;
SCREEN2 : ARRAY [1..4000] OF BYTE ABSOLUTE $B000:$0000;
I,Z : INTEGER;
BEGIN
FOR I := 1 TO 80 DO
IF I IN X THEN
BEGIN
Z := ((Y * 160) - 160) + (I * 2);
IF MONITOR_INFO AND 48=48 THEN
SCREEN2[Z] := ATTRIB
ELSE
IF MONITOR_INFO AND 32=32 THEN
SCREEN1[Z] := ATTRIB;
END;
END;
PROCEDURE SET_ATTR_BUFFER;
VAR
I,Z : INTEGER;
BEGIN
FOR I := 1 TO 80 DO
IF I IN X THEN
BEGIN
Z := ((Y * 160) - 160) + (I * 2);
SC[Z] := CHAR(ATTRIB);
END;
END;
PROCEDURE WRITE_TIME;
VAR
IND,TEMP : STR8;
HR, MIN, SEC, SEC100 : WORD;
C : CURTYPE;
SAVE_ATTR : BYTE;
SX, SY : INTEGER;
BEGIN
GETTIME(HR,MIN,SEC,SEC100);
IND := ' ';
NOW := (HR * 60) + MIN;
IF NOT (MILITARY IN ['M','m']) THEN
BEGIN
IF HR > 12 THEN
BEGIN
HR := HR - 12;
IND := 'pm';
END
ELSE
IF HR = 12 THEN
IND := 'pm'
ELSE
IND := 'am';
END;
STR(HR:2,TIME);
IF (TIME[1] = ' ') AND (MILITARY IN ['M','n']) THEN TIME[1] := '0';
STR(MIN:2,TEMP);
IF TEMP[1] = ' ' THEN TEMP[1] := '0';
TIME := TIME + ':' + TEMP;
IF NOT (MILITARY IN ['M','m']) THEN
TIME := TIME + ' ' + IND;
IF X <> 0 THEN
BEGIN
C := CUR;
SX := WHEREX;
SY := WHEREY;
SET_CURSOR(NONE);
SAVE_ATTR := CRT.TEXTATTR;
CRT.TEXTATTR := SCREEN_ATTR(X,Y);
GOTOXY43(X,Y);
WRITE(COPY(TIME,1,2));
IF BLINK_IS_ON THEN
CRT.TEXTATTR := CRT.TEXTATTR + BLINK;
WRITE(':');
IF BLINK_IS_ON THEN
CRT.TEXTATTR := CRT.TEXTATTR - BLINK;
WRITE(COPY(TIME,4,5));
CRT.TEXTATTR := SAVE_ATTR;
GOTOXY(SX,SY);
SET_CURSOR(C);
END;
END;
PROCEDURE WRITE_DATE;
VAR
TEMP : STRING[9];
YR, MO, DAY : WORD;
BEGIN
GETDATE(YR,MO,DAY,DOW);
IF WORDS IN ['W','w','D','d'] THEN
BEGIN
CASE MO OF
1 : DATE := 'January ';
2 : DATE := 'February ';
3 : DATE := 'March ';
4 : DATE := 'April ';
5 : DATE := 'May ';
6 : DATE := 'June ';
7 : DATE := 'July ';
8 : DATE := 'August ';
9 : DATE := 'September ';
10 : DATE := 'October ';
11 : DATE := 'November ';
12 : DATE := 'December ';
END;
STR(DAY:2,TEMP);
DATE := DATE + TEMP;
STR(YR:4,TEMP);
DATE := DATE + ', '+TEMP;
IF WORDS IN ['D','d'] THEN
BEGIN
CASE DOW OF
0 : TEMP := 'Sunday';
1 : TEMP := 'Monday';
2 : TEMP := 'Tuesday';
3 : TEMP := 'Wednesday';
4 : TEMP := 'Thursday';
5 : TEMP := 'Friday';
6 : TEMP := 'Saturday';
END;
DATE := TEMP + ' ' + DATE;
END;
END
ELSE
BEGIN
IF YR > 2000 THEN
YR := YR - 2000
ELSE
YR := YR - 1900;
STR(MO:2,DATE);
IF DATE[1] = ' ' THEN DATE[1] := '0';
STR(DAY:2,TEMP);
IF TEMP[1] = ' ' THEN TEMP[1] := '0';
DATE := DATE + '-' + TEMP + '-';
STR(YR:2,TEMP);
IF TEMP[1] = ' ' THEN TEMP[1] := '0';
DATE := DATE + TEMP;
END;
IF X <> 0 THEN
FW(X,Y,SCREEN_ATTR(X,Y),DATE);
END;
PROCEDURE FW(X,Y : INTEGER; ATTR : BYTE; LINE : STR80);
VAR
I,J,
Z : INTEGER;
BEGIN
Z := (((Y * 160) - 160) + (X * 2)) - 1;
I := 1;
J := 1;
REPEAT
P^[Z+J-1] := LINE[I];
P^[Z+J] := CHR(ATTR);
I := I + 1;
J := J + 2;
UNTIL I > LENGTH(LINE);
END;
FUNCTION WHOAMI;
BEGIN
WHOAMI := PARAMSTR(0);
END;
PROCEDURE START_TIMER;
VAR
TIME1,
TIME2 : DATETIME;
SEC100,
DAYOFWEEK : WORD;
BEGIN
WITH TIME1 DO
GETDATE(YEAR,MONTH,DAY,DAYOFWEEK);
WITH TIME1 DO
GETTIME(HOUR,MIN,SEC,SEC100);
PACKTIME(TIME1,T);
END;
FUNCTION ELAP_TIME;
VAR
TIME1,
TIME2 : DATETIME;
SEC100,
DAYOFWEEK : WORD;
L,M,N : LONGINT;
R : REAL;
FUNCTION JULIAN(T : DATETIME) : REAL;
VAR
TEMP : REAL;
BEGIN
TEMP := INT((T.MONTH - 14.0) / 12.0);
JULIAN := T.DAY - 32075.0 +
INT(1461.0 * (T.YEAR + 4800.0 + TEMP) / 4.0) +
INT(367.0 * (T.MONTH - 2.0 - TEMP * 12.0) / 12.0) -
INT(3.0 * INT((T.YEAR + 4900.0 + TEMP) / 100.0) / 4.0)
END;
BEGIN
WITH TIME1 DO
GETDATE(YEAR,MONTH,DAY,DAYOFWEEK);
WITH TIME1 DO
GETTIME(HOUR,MIN,SEC,SEC100);
UNPACKTIME(T,TIME2);
R := JULIAN(TIME1)-JULIAN(TIME2);
L := TRUNC(R * 864.0 * 100.0);
M := TIME1.HOUR * 60;
M := (M + TIME1.MIN) * 60;
M := M + TIME1.SEC;
N := TIME2.HOUR * 60;
N := (N + TIME2.MIN) * 60;
N := N + TIME2.SEC;
ELAP_TIME := L + M - N;
END;
FUNCTION ELAP_TIME_STR;
VAR
D,H,M,S : LONGINT;
T : LONGINT;
ST : STRING;
BEGIN
T := ELAP_TIME(TIM);
D := T DIV 86400;
T := T MOD 86400;
H := T DIV 3600;
T := T MOD 3600;
M := T DIV 60;
S := T MOD 60;
IF D > 0 THEN
BEGIN
ST := LONGINT_STR(D,1);
IF D = 1 THEN
ST := ST + ' day, '
ELSE
ST := ST + ' days, ';
END
ELSE
ST := '';
IF (D > 0) OR (H > 0) THEN
BEGIN
ST := ST + LONGINT_STR(H,2);
IF H = 1 THEN
ST := ST + ' hour, '
ELSE
ST := ST + ' hours, ';
END;
IF (D > 0) OR (H > 0) OR (M > 0) THEN
ST := ST + LONGINT_STR(M,2) + ' min, ';
ST := ST + LONGINT_STR(S,2) + ' sec';
ELAP_TIME_STR := PAD(ST,35);
END;
FUNCTION PAD;
VAR
I : INTEGER;
BEGIN
I := 1;
IF LENGTH(S) < LEN THEN
S := S + SPACES(LEN - LENGTH(S));
IF LENGTH(S) > LEN THEN
S[0] := CHR(LEN);
WHILE POS(#0,S) > 0 DO
S[POS(#0,S)] := ' ';
PAD := S;
END;
FUNCTION PAD_LEFT;
VAR
I : INTEGER;
BEGIN
I := 1;
IF LENGTH(S) < LEN THEN
S := SPACES(LEN - LENGTH(S)) + S;
IF LENGTH(S) > LEN THEN
S[0] := CHR(LEN);
PAD_LEFT := S;
END;
FUNCTION PAD_CH;
VAR
I : INTEGER;
BEGIN
I := 1;
IF LENGTH(S) < LEN THEN
S := S + DUP(CH,LEN - LENGTH(S));
IF LENGTH(S) > LEN THEN
S[0] := CHR(LEN);
PAD_CH := S;
END;
FUNCTION SPACES;
VAR
S : STRING;
BEGIN
S[0] := CHR(NUM);
FILLCHAR(S[1], NUM, ' ');
SPACES := S;
END;
FUNCTION UPPERCASE;
VAR
COUNTER : WORD;
BEGIN
FOR COUNTER := 1 TO LENGTH(S) DO
S[COUNTER] := UPCASE(S[COUNTER]);
UPPERCASE := S;
END;
FUNCTION EGA_INSTALLED : BOOLEAN;
VAR
REG : REGISTERS;
BEGIN
REG.AX := $1200;
REG.BX := $0010;
REG.CX := $FFFF;
INTR($10, REG);
EGA_INSTALLED := REG.CX <> $FFFF;
END;
FUNCTION VGA_INSTALLED : BOOLEAN;
VAR
REGS : REGISTERS;
BEGIN
REGS.AX := $1A00;
INTR($10,REGS);
VGA_INSTALLED := (REGS.AL = $1A);
END;
PROCEDURE LINES43;
BEGIN
IF EGA_PRESENT THEN
TEXTMODE(CO80 + FONT8X8);
END;
PROCEDURE GOTOXY43;
VAR
I : INTEGER;
C : CURTYPE;
BEGIN
C := CUR;
IF Y < 26 THEN
GOTOXY(X,Y)
ELSE
IF LASTMODE = 259 THEN
BEGIN
I := 25;
SET_CURSOR(NONE);
GOTOXY(X,25);
WHILE I < Y DO
BEGIN
WRITE(CHR(10));
I := SUCC(I);
END;
SET_CURSOR(C);
END;
END;
PROCEDURE LINES25;
BEGIN
TEXTMODE(CO80);
END;
PROCEDURE READCHTIME;
VAR
I,
ATX, ATY : INTEGER;
HELP : BOOLEAN;
LINE25 : BUF160;
BEGIN
ATX := WHEREX;
ATY := WHEREY;
HELP := FALSE;
SAVE_LINE(25,LINE25);
I := 300;
REPEAT
I := SUCC(I);
IF (SHIFT_KEYS('A')) AND (HELP_LINE <> '') THEN
BEGIN
FW(1,25,HELP_ATTR,PAD(HELP_LINE,80));
GOTOXY(ATX,ATY);
HELP := TRUE;
END
ELSE
IF (SHIFT_KEYS('C')) AND (HELP_LINE2 <> '') THEN
BEGIN
FW(1,25,HELP_ATTR2,PAD(HELP_LINE2,80));
GOTOXY(ATX,ATY);
HELP := TRUE;
END
ELSE
IF HELP THEN
BEGIN
REBUILD_LINE(25,LINE25);
GOTOXY(ATX,ATY);
HELP := FALSE;
END;
IF I > 200 THEN
BEGIN
WRITE_TIME(X,Y,CH);
I := 0;
END;
GOTOXY43(ATX,ATY);
UNTIL KEYPRESSED OR (COMMAND_BUFFER <> '');
REBUILD_LINE(25,LINE25);
READCH(CH,ECHO);
END;
PROCEDURE READSTR;
VAR
I,
START : INTEGER;
CAPIT,
CAPWO,
INSON : BOOLEAN;
SAVECH : CHAR;
FUNCTION EDIT_ALL : BOOLEAN;
VAR
I : INTEGER;
BEGIN
EDIT_ALL := TRUE;
FOR I := 1 TO LEN DO
IF NOT (I IN CANEDIT) THEN
EDIT_ALL := FALSE;
END;
BEGIN
OLDVAL := INSTRING;
INSON := FALSE;
IF YLOC > 199 THEN
BEGIN
CAPIT := TRUE;
YLOC := YLOC - 200;
END
ELSE
BEGIN
CAPIT := FALSE;
IF YLOC > 99 THEN
BEGIN
YLOC := YLOC - 100;
CAPWO := TRUE;
END
ELSE
CAPWO := FALSE;
END;
IF CLEAR IN EXITCH THEN
INSTRING := SPACES(LEN)
ELSE
INSTRING := PAD(INSTRING,LEN);
FW(X,Y,PATTR,PROMPT);
START := X + LENGTH(PROMPT);
X := X_IN;
FW(START,Y,IATTR,INSTRING);
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN + START) DO
X := SUCC(X);
IF XLOC > 99 THEN
BEGIN
X := LEN;
XLOC := XLOC - 100;
END;
WHILE NOT (X IN CANEDIT) DO
X := PRED(X);
SET_CURSOR(UNDERLINE);
IF NOT (DISPLAY IN EXITCH) THEN
REPEAT
GOTOXY(START+X-1,Y);
CH := CH1;
READCHTIME(CH,FALSE,XLOC,YLOC);
SAVECH := CH;
CASE CH OF
HOMEKEY : BEGIN
X := 1;
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN + START) DO
X := SUCC(X);
END;
ENDKEY : BEGIN
X := LEN;
WHILE (X > 2) AND (INSTRING[X-1] = ' ') DO
X := PRED(X);
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN) DO
X := SUCC(X);
WHILE NOT (X IN CANEDIT) DO
X := PRED(X);
IF X < 1 THEN
X := 1
ELSE
IF (X = 2) AND (INSTRING[1] = ' ') AND
(1 IN CANEDIT) THEN
X := 1;
END;
#8 : IF (X > 1) AND EDIT_ALL THEN
BEGIN
DELETE(INSTRING,X-1,1);
INSTRING := INSTRING + ' ';
FW(START,Y,IATTR,INSTRING);
X := PRED(X);
WHILE (NOT (X IN CANEDIT)) AND
(X > 1) DO
X := PRED(X);
WHILE NOT (X IN CANEDIT) DO
X := SUCC(X);
END
ELSE
IF X > 1 THEN
BEGIN
X := PRED(X);
WHILE (NOT (X IN CANEDIT)) AND
(X > 1) DO
X := PRED(X);
WHILE NOT (X IN CANEDIT) DO
X := SUCC(X);
END
ELSE
BEGIN
SAVECH := CH;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := UP;
END;
RIGHT : IF X < LEN THEN
BEGIN
X := SUCC(X);
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN + START) DO
X := SUCC(X);
IF NOT (X IN CANEDIT) THEN
IF NOCONV IN EXITCH THEN
BEGIN
SAVECH := RIGHT;
CH := NOCONV;
END
ELSE
CH := DOWN;
WHILE NOT (X IN CANEDIT) DO
X := PRED(X);
END
ELSE
BEGIN
SAVECH := CH;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := DOWN;
END;
LEFT : IF X > 1 THEN
BEGIN
X := PRED(X);
WHILE (NOT (X IN CANEDIT)) AND
(X > 1) DO
X := PRED(X);
IF NOT (X IN CANEDIT) THEN
IF NOCONV IN EXITCH THEN
BEGIN
SAVECH := LEFT;
CH := NOCONV;
END
ELSE
CH := UP;
WHILE NOT (X IN CANEDIT) DO
X := SUCC(X);
END
ELSE
BEGIN
SAVECH := CH;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := UP;
END;
' '..'~' : IF CH IN VALID THEN
IF INSON THEN
BEGIN
DELETE(INSTRING,LENGTH(INSTRING),1);
IF (CAPWO AND ((X = 1) OR (INSTRING[X-1] = ' '))) OR
CAPIT THEN
CH := UPCASE(CH);
INSERT(CH,INSTRING,X);
X := SUCC(X);
IF X > LEN THEN
CH := DOWN;
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN + START) DO
X := SUCC(X);
WHILE NOT (X IN CANEDIT) DO
X := PRED(X);
FW(START,Y,IATTR,INSTRING);
END
ELSE
BEGIN
IF (CAPWO AND ((X = 1) OR (INSTRING[X-1] = ' '))) OR
CAPIT THEN
CH := UPCASE(CH);
INSTRING[X] := CH;
FW(START+X-1,Y,IATTR,CH);
X := SUCC(X);
IF X > LEN THEN
BEGIN
SAVECH := RIGHT;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := DOWN;
END;
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN + START) DO
X := SUCC(X);
IF NOT (X IN CANEDIT) THEN
IF NOCONV IN EXITCH THEN
BEGIN
SAVECH := RIGHT;
CH := NOCONV;
END
ELSE
CH := DOWN;
WHILE NOT (X IN CANEDIT) DO
X := PRED(X);
END;
INSKEY : BEGIN
INSON := NOT INSON;
IF INSON AND (EDIT_ALL) THEN
SET_CURSOR(BLOCK)
ELSE
BEGIN
SET_CURSOR(UNDERLINE);
INSON := FALSE;
END;
END;
DELKEY : IF EDIT_ALL THEN
BEGIN
DELETE(INSTRING,X,1);
INSTRING := INSTRING + ' ';
GOTOXY(START,Y);
FW(START,Y,IATTR,INSTRING);
END;
ALT_C : BEGIN
FOR I := 1 TO LEN DO
IF I IN CANEDIT THEN
INSTRING[I] := ' ';
X := 1;
FW(START,Y,IATTR,INSTRING);
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN + START) DO
X := SUCC(X);
END;
END;
IF X > LEN THEN X := LEN;
UNTIL (CH = #27) OR (CH IN EXITCH);
IF NOCONV IN EXITCH THEN
CH := SAVECH;
X_OUT := X;
X_IN := 1;
SET_CURSOR(UNDERLINE);
CHANGED := INSTRING <> OLDVAL;
END;
PROCEDURE READ_STR;
VAR
I,
LEN,
START : INTEGER;
CAPWO,
VALID,
EDITALL,
INSON : BOOLEAN;
SAVECH : CHAR;
OLDATTR : BYTE;
OLDCUR : CURTYPE;
FUNCTION CANEDIT(INCHAR : CHAR) : BOOLEAN;
BEGIN
IF ((INCHAR = ' ') OR
(INCHAR = 'c') OR
(INCHAR = 'y') OR
(INCHAR = 'A') OR
(INCHAR = '0') OR
(INCHAR = '1') OR
(INCHAR = '.') OR
(INCHAR = '!') OR
(INCHAR = '+')) THEN
CANEDIT := TRUE
ELSE
CANEDIT := FALSE;
END;
BEGIN
INSTRING := PAD(INSTRING,LENGTH(MASK));
OLDVAL := INSTRING;
INSON := FALSE;
SAVECH := #0;
CAPWO := FALSE;
EDITALL := TRUE;
OLDCUR := CUR;
TEXTATTR := UT.INPUT_ATTR;
LEN := LENGTH(INSTRING);
FOR I := 1 TO LENGTH(INSTRING) DO
BEGIN
IF MASK[I] = 'c' THEN
CAPWO := TRUE
ELSE
IF (NOT CANEDIT(MASK[I])) THEN
BEGIN
IF MASK[I] <> 'x' THEN
INSTRING[I] := MASK[I];
EDITALL := FALSE;
END;
IF EDITALL THEN
BEGIN
IF (POS('y',MASK) > 0) AND (MASK <> DUP('y',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('y',MASK) > 0) AND (MASK <> DUP('y',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('A',MASK) > 0) AND (MASK <> DUP('A',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('0',MASK) > 0) AND (MASK <> DUP('0',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('1',MASK) > 0) AND (MASK <> DUP('1',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('.',MASK) > 0) AND (MASK <> DUP('.',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('!',MASK) > 0) AND (MASK <> DUP('!',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('+',MASK) > 0) AND (MASK <> DUP('+',LENGTH(MASK))) THEN
EDITALL := FALSE;
END;
END;
IF X > 99 THEN
BEGIN
X := X - 100;
START := X;
X := LEN;
WHILE (X > 2) AND (NOT CANEDIT(MASK[X])) DO
X := X - 1;
END
ELSE
BEGIN
START := X;
X := X_IN;
END;
OLDATTR := SCREEN_ATTR(START,Y);
GOTOXY(START,Y);
WRITE(INSTRING);
SET_CURSOR(UNDERLINE);
WHILE (NOT CANEDIT(MASK[X])) AND (X <= LEN) DO
X := X + 1;
REPEAT
GOTOXY(START+X-1,Y);
READCH(CH,FALSE);
CASE CH OF
HOMEKEY : BEGIN
X := 1;
WHILE (NOT CANEDIT(MASK[X])) AND
(X <= LEN + START) DO
X := SUCC(X);
END;
ENDKEY : BEGIN
X := LEN;
WHILE (X > 2) AND (INSTRING[X-1] = ' ') DO
X := PRED(X);
WHILE (NOT CANEDIT(MASK[X])) AND
(X <= LEN) DO
X := SUCC(X);
WHILE NOT CANEDIT(MASK[X]) DO
X := PRED(X);
IF X < 1 THEN
X := 1
ELSE
IF (X = 2) AND (INSTRING[1] = ' ') AND
(CANEDIT(MASK[1])) THEN
X := 1;
END;
#8 : IF (X > 1) AND EDITALL THEN
BEGIN
DELETE(INSTRING,X-1,1);
INSTRING := INSTRING + ' ';
GOTOXY(START,Y);
WRITE(INSTRING);
X := PRED(X);
WHILE (NOT CANEDIT(MASK[X])) AND
(X > 1) DO
X := PRED(X);
WHILE NOT CANEDIT(MASK[X]) DO
X := SUCC(X);
END
ELSE
IF X > 1 THEN
BEGIN
X := PRED(X);
WHILE (NOT CANEDIT(MASK[X])) AND
(X > 1) DO
X := PRED(X);
WHILE NOT CANEDIT(MASK[X]) DO
X := SUCC(X);
END
ELSE
BEGIN
IF UT.NOCONV THEN
SAVECH := LEFT
ELSE
CH := UP;
END;
RIGHT : IF X < LEN THEN
BEGIN
X := SUCC(X);
WHILE (NOT CANEDIT(MASK[X])) AND
(X <= LEN + START) DO
X := SUCC(X);
IF NOT CANEDIT(MASK[X]) THEN
IF UT.NOCONV THEN
SAVECH := RIGHT
ELSE
CH := DOWN;
WHILE NOT CANEDIT(MASK[X]) DO
X := PRED(X);
END
ELSE
BEGIN
IF UT.NOCONV THEN
SAVECH := CH
ELSE
CH := DOWN;
END;
LEFT : IF X > 1 THEN
BEGIN
X := PRED(X);
WHILE (NOT CANEDIT(MASK[X])) AND
(X > 1) DO
X := PRED(X);
IF NOT CANEDIT(MASK[X]) THEN
IF UT.NOCONV THEN
SAVECH := LEFT
ELSE
CH := UP;
WHILE NOT CANEDIT(MASK[X]) DO
X := SUCC(X);
END
ELSE
BEGIN
IF UT.NOCONV THEN
SAVECH := LEFT
ELSE
CH := UP;
END;
' '..'~' : BEGIN
VALID := FALSE;
CASE MASK[X] OF
' ',
'c' : VALID := TRUE;
'A' : BEGIN
VALID := TRUE;
CH := UPCASE(CH);
END;
'y' : BEGIN
CH := UPCASE(CH);
IF CH IN ['Y','N'] THEN
VALID := TRUE;
END;
'0' : IF CH IN ['0'..'9'] THEN
VALID := TRUE;
'1' : IF CH IN ['0'..'9',' '] THEN
VALID := TRUE;
'.' : IF CH IN ['0'..'9','.'] THEN
VALID := TRUE;
'!' : IF CH IN ['0'..'9','.',' '] THEN
VALID := TRUE;
'+' : IF CH IN ['0'..'9','.',' ','+','-'] THEN
VALID := TRUE;
END;
IF VALID THEN
BEGIN
IF (CAPWO) AND ((X = 1) OR
(INSTRING[X-1] = ' ')) THEN
CH := UPCASE(CH);
IF INSON THEN
BEGIN
DELETE(INSTRING,LENGTH(INSTRING),1);
INSERT(CH,INSTRING,X);
GOTOXY(START,Y);
WRITE(INSTRING);
END
ELSE
BEGIN
INSTRING[X] := CH;
GOTOXY(START+X-1,Y);
WRITE(CH);
END;
X := SUCC(X);
IF X > LEN THEN
BEGIN
IF UT.NOCONV THEN
SAVECH := RIGHT
ELSE
CH := DOWN;
END
ELSE
BEGIN
WHILE (NOT CANEDIT(MASK[X])) AND
(X <= LEN + START) DO
X := SUCC(X);
IF NOT CANEDIT(MASK[X]) THEN
IF UT.NOCONV THEN
SAVECH := RIGHT
ELSE
CH := DOWN;
WHILE NOT CANEDIT(MASK[X]) DO
X := PRED(X);
END;
END;
END;
INSKEY : BEGIN
INSON := NOT INSON;
IF INSON AND (EDITALL) THEN
SET_CURSOR(BLOCK)
ELSE
BEGIN
SET_CURSOR(UNDERLINE);
INSON := FALSE;
END;
END;
DELKEY : IF EDITALL THEN
BEGIN
DELETE(INSTRING,X,1);
INSTRING := INSTRING + ' ';
GOTOXY(START,Y);
WRITE(INSTRING);
END;
ALT_C : BEGIN
FOR I := 1 TO LEN DO
IF CANEDIT(MASK[I]) THEN
INSTRING[I] := ' ';
X := 1;
GOTOXY(START,Y);
WRITE(INSTRING);
WHILE (NOT CANEDIT(MASK[X])) AND
(X <= LEN) DO
X := SUCC(X);
END;
END;
IF X > LEN THEN X := LEN;
UNTIL (CH = #27) OR (UT.EXITCH[ORD(CH)]) OR (SAVECH <> #0);
IF SAVECH <> #0 THEN
CH := SAVECH;
X_OUT := X;
X_IN := 1;
SET_CURSOR(UNDERLINE);
TEXTATTR := OLDATTR;
GOTOXY(START,Y);
WRITE(INSTRING);
TEXTATTR := UT.DEFAULT_ATTR;
SET_CURSOR(OLDCUR);
CHANGED := INSTRING <> OLDVAL;
END;
PROCEDURE READ_ONLY(NAME : STRING);
VAR
F : FILE;
ATTR : WORD;
BEGIN
ASSIGN(F,NAME);
GETFATTR(F,ATTR);
ATTR := ATTR OR 1;
SETFATTR(F,ATTR);
END;
PROCEDURE READ_WRITE(NAME : STRING);
VAR
F : FILE;
ATTR : WORD;
BEGIN
ASSIGN(F,NAME);
GETFATTR(F,ATTR);
IF ODD(ATTR) THEN
ATTR := ATTR - 1;
SETFATTR(F,ATTR);
END;
PROCEDURE READ_REAL(X,Y,LEN : INTEGER;
PATTR : INTEGER;
PROMPT : STR80;
IATTR : INTEGER;
VAR R : REAL;
DPLACES : INTEGER;
LOW,HIGH : REAL;
EXITCH : ETYPE;
ICOMA : BOOLEAN;
TX, TY : INTEGER;
CH : CHAR);
VAR
RESULT : INTEGER;
TEMP : STRING[40];
T : ETYPE;
S : BUF160;
SAT : INTEGER;
BEGIN
IF ICOMA THEN
TEMP := COMMA(R,0,DPLACES,RNUM)
ELSE
STR(R:0:DPLACES,TEMP);
IF (R = 0.0) OR (CLEAR IN EXITCH) THEN
BEGIN
TEMP := '0';
TEMP := PAD(TEMP,LEN);
EXITCH := EXITCH - [CLEAR];
END;
T := [' ','0'..'9','-',','];
IF DPLACES > 0 THEN
T := T + ['.'];
REPEAT
WHILE LENGTH(TEMP) < LEN DO
TEMP := TEMP + ' ';
READSTR(X,Y,LEN,PATTR,PROMPT,IATTR,TEMP,T,[1..LEN],EXITCH,TX,TY,CH);
WHILE (TEMP[1] = ' ') AND (LENGTH(TEMP) > 0) DO
DELETE(TEMP,1,1);
WHILE (TEMP[LENGTH(TEMP)] = ' ') AND (LENGTH(TEMP) > 0) DO
DELETE(TEMP,LENGTH(TEMP),1);
IF TEMP[LENGTH(TEMP)] = '.' THEN
DELETE(TEMP,LENGTH(TEMP),1);
WHILE (POS(',',TEMP) > 0) AND (LENGTH(TEMP) > 0) DO
DELETE(TEMP,POS(',',TEMP),1);
IF TEMP[1] = '.' THEN
TEMP := '0' + TEMP;
VAL(TEMP,R,RESULT);
IF (RESULT = 0) AND ((R < LOW) OR (R > HIGH)) THEN
RESULT := 1;
IF RESULT <> 0 THEN
BEGIN
SAT := TEXTATTR;
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',LOW:0:DPLACES,' to ',HIGH:0:DPLACES,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL RESULT = 0;
WHILE LENGTH(TEMP) < LEN DO
TEMP := ' ' + TEMP;
IF ICOMA THEN
FW(X+LENGTH(PROMPT),Y,IATTR,COMMA(R,LEN,DPLACES,RNUM))
ELSE
FW(X+LENGTH(PROMPT),Y,IATTR,TEMP);
END;
PROCEDURE READ_INT(X,Y,LEN : INTEGER;
PATTR : INTEGER;
PROMPT : STR80;
IATTR : INTEGER;
VAR R : INTEGER;
LOW,HIGH : INTEGER;
EXITCH : ETYPE;
ICOMA : BOOLEAN;
TX, TY : INTEGER;
CH : CHAR);
VAR
RESULT : INTEGER;
TEMP : STRING;
T : ETYPE;
S : BUF160;
SAT : INTEGER;
BEGIN
IF (R = 0) OR (CLEAR IN EXITCH) THEN
BEGIN
TEMP := '0';
EXITCH := EXITCH - [CLEAR];
END
ELSE
IF ICOMA THEN
TEMP := COMMA(R,0,0,INUM)
ELSE
STR(R,TEMP);
WHILE LENGTH(TEMP) < LEN DO
TEMP := TEMP + ' ';
T := [' ','0'..'9','-',','];
REPEAT
WHILE LENGTH(TEMP) < LEN DO
TEMP := TEMP + ' ';
READSTR(X,Y,LEN,PATTR,PROMPT,IATTR,TEMP,T,[1..LEN],EXITCH,TX,TY,CH);
WHILE (TEMP[1] = ' ') AND (LENGTH(TEMP) > 0) DO
DELETE(TEMP,1,1);
WHILE (TEMP[LENGTH(TEMP)] = ' ') AND (LENGTH(TEMP) > 0) DO
DELETE(TEMP,LENGTH(TEMP),1);
WHILE (POS(',',TEMP) > 0) AND (LENGTH(TEMP) > 0) DO
DELETE(TEMP,POS(',',TEMP),1);
IF _LONGINT(TEMP) <= 32767 THEN
VAL(TEMP,R,RESULT)
ELSE
RESULT := 1;
IF (RESULT = 0) AND ((R < LOW) OR (R > HIGH)) THEN
RESULT := 1;
IF RESULT <> 0 THEN
BEGIN
SAVE_LINE(Y+1,S);
SAT := TEXTATTR;
TEXTATTR := $4F;
IF X > 39 THEN
GOTOXY(39,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',LOW,' to ',HIGH,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL RESULT = 0;
WHILE LENGTH(TEMP) < LEN DO
TEMP := ' ' + TEMP;
IF ICOMA THEN
FW(X+LENGTH(PROMPT),Y,IATTR,COMMA(R,LEN,0,INUM))
ELSE
FW(X+LENGTH(PROMPT),Y,IATTR,TEMP);
END;
FUNCTION DRIVE_READY(DRIVE : CHAR) : BOOLEAN;
BEGIN
DRIVE_READY := DISKSIZE(ORD(DRIVE)-64) <> -1;
END;
FUNCTION _REAL(INSTRING : STRING) : REAL;
VAR
R : REAL;
RESULT : INTEGER;
BEGIN
WHILE POS(' ',INSTRING) > 0 DO
DELETE(INSTRING,POS(' ',INSTRING),1);
VAL(INSTRING,R,RESULT);
_REAL := R;
END;
FUNCTION _INTEGER(INSTRING : STRING) : INTEGER;
VAR
I,
RESULT : INTEGER;
BEGIN
WHILE POS(' ',INSTRING) > 0 DO
DELETE(INSTRING,POS(' ',INSTRING),1);
IF POS('.',INSTRING) > 0 THEN
INSTRING := COPY(INSTRING,1,POS('.',INSTRING)-1);
IF (LENGTH(INSTRING) >= 5) AND (INSTRING > '32767') THEN
BEGIN
_INTEGER := 0;
EXIT;
END;
VAL(INSTRING,I,RESULT);
_INTEGER := I;
END;
FUNCTION _LONGINT(INSTRING : STRING) : LONGINT;
VAR
SIGN,
LEN,
I : INTEGER;
TENS,
NUMBER : LONGINT;
BEGIN
TENS := 1;
NUMBER := 0;
SIGN := 1;
_LONGINT := 0;
WHILE POS(' ',INSTRING) > 0 DO
DELETE(INSTRING,POS(' ',INSTRING),1);
IF POS('.',INSTRING) > 0 THEN
INSTRING := COPY(INSTRING,1,POS('.',INSTRING)-1);
IF (LENGTH(INSTRING) >= 10) AND (INSTRING > '2147483648') THEN
EXIT;
LEN := LENGTH(INSTRING);
IF INSTRING[1] = '-' THEN
BEGIN
IF LEN = 1 THEN
EXIT;
SIGN := -1;
END;
FOR I := LEN DOWNTO 1 DO
IF (INSTRING[I] < '0') OR (INSTRING[I] > '9') THEN
ELSE
BEGIN
NUMBER := NUMBER + (ORD(INSTRING[I]) - ORD('0')) * TENS;
TENS := TENS * 10;
END;
NUMBER := NUMBER * SIGN;
_LONGINT := NUMBER;
END;
FUNCTION _WORD(INSTRING : STRING) : WORD;
VAR
SIGN,
LEN,
I : INTEGER;
TENS : LONGINT;
NUMBER : WORD;
BEGIN
TENS := 1;
NUMBER := 0;
SIGN := 1;
_WORD := 0;
WHILE POS(' ',INSTRING) > 0 DO
DELETE(INSTRING,POS(' ',INSTRING),1);
IF POS('.',INSTRING) > 0 THEN
INSTRING := COPY(INSTRING,1,POS('.',INSTRING)-1);
IF (LENGTH(INSTRING) >= 5) AND (INSTRING > '65535') THEN
EXIT;
LEN := LENGTH(INSTRING);
IF INSTRING[1] = '-' THEN
BEGIN
IF LEN = 1 THEN
EXIT;
SIGN := -1;
END;
FOR I := LEN DOWNTO 1 DO
IF (INSTRING[I] < '0') OR (INSTRING[I] > '9') THEN
EXIT
ELSE
BEGIN
NUMBER := NUMBER + (ORD(INSTRING[I]) - ORD('0')) * TENS;
TENS := TENS * 10;
END;
NUMBER := NUMBER * SIGN;
_WORD := NUMBER;
END;
FUNCTION GET_FILE_NAME(MASK : STRING; DEL : BOOLEAN) : STRING;
TYPE
STR12 = STRING[12];
VAR
I,J,
FM,
TOP,
SEL,
INDEX : INTEGER;
TEMP : STR12;
DIRINFO : SEARCHREC;
SAVENAME : ARRAY [1..500] OF STRING[12];
F : FILE;
C : CURTYPE;
SAVE_ATTR : INTEGER;
PROCEDURE WRITE_PAGE;
VAR
I : INTEGER;
BEGIN
J := 10;
WINDOW(36,10,50,17);
CLRSCR;
WINDOW(1,1,80,25);
FOR I := TOP TO TOP+7 DO
IF I <= INDEX THEN
BEGIN
FW(38,J,$0E,SAVENAME[I]);
J := SUCC(J);
END;
END;
BEGIN
C := CUR;
SAVE_ATTR := TEXTATTR;
SET_CURSOR(NONE);
TEXTBACKGROUND(BLACK);
FM := FILEMODE;
FILEMODE := 0;
INDEX := 1;
FILLCHAR(SAVENAME,SIZEOF(SAVENAME),0);
FINDFIRST(MASK,READONLY+ARCHIVE,DIRINFO);
WHILE DOSERROR = 0 DO
BEGIN
SAVENAME[INDEX] := DIRINFO.NAME;
INDEX := SUCC(INDEX);
FINDNEXT(DIRINFO);
END;
INDEX := PRED(INDEX);
FOR I := 1 TO INDEX DO
FOR J := I+1 TO INDEX DO
IF SAVENAME[I] > SAVENAME[J] THEN
BEGIN
TEMP := SAVENAME[I];
SAVENAME[I] := SAVENAME[J];
SAVENAME[J] := TEMP;
END;
FW(35, 8,$0E,'╔═ Select File ═╗');
FW(35, 9,$0E,'║ ║');
FW(35,10,$0E,'║ ║');
FW(35,11,$0E,'║ ║');
FW(35,12,$0E,'║ ║');
FW(35,13,$0E,'║ ║');
FW(35,14,$0E,'║ ║');
FW(35,15,$0E,'║ ║');
FW(35,16,$0E,'║ ║');
FW(35,17,$0E,'║ ║');
FW(35,18,$0E,'║ ║');
FW(35,19,$0E,'║ ║');
FW(35,20,$0E,'║ ║');
FW(35,21,$0E,'╚═══════════════╝');
FW(39,19,$0F,CHR(24)+' '+CHR(25)+' '+ENTER_KEY);
FW(38,20,$0F,'PgUp PgDn');
IF DEL THEN
BEGIN
FW(35,21,$0E,'║ <DEL> Delete ║');
FW(35,22,$0E,'╚═══════════════╝');
SET_ATTR([36..49],21,$0F);
END;
SET_CURSOR(NONE);
TOP := 1;
SEL := 1;
FOR I := 1 TO 8 DO
IF I <= INDEX THEN
FW(38,I+9,$0E,SAVENAME[I]);
REPEAT
SET_ATTR([37..49],SEL+9,$70);
READCH(CH,FALSE);
CH := UPCASE(CH);
SET_ATTR([37..49],SEL+9,$0E);
CASE CH OF
'0'..'9',
'A'..'Z' : BEGIN
TOP := 1;
WHILE (TOP < 500) AND (SAVENAME[TOP][1] < CH) DO
TOP := SUCC(TOP);
SEL := 1;
WHILE (TOP > 1) AND (LENGTH(SAVENAME[TOP]) = 0) DO
TOP := PRED(TOP);
WRITE_PAGE;
END;
UP : IF SEL > 1 THEN
SEL := PRED(SEL)
ELSE
IF TOP > 1 THEN
BEGIN
WINDOW(36,10,50,17);
INSLINE;
WINDOW(1,1,80,25);
TOP := PRED(TOP);
FW(38,10,$0E,SAVENAME[TOP]);
END;
DOWN : IF (SEL < 8) AND (TOP+SEL-1 < INDEX) THEN
SEL := SUCC(SEL)
ELSE
IF TOP+SEL < INDEX THEN
BEGIN
WINDOW(36,10,50,17);
GOTOXY(1,8);
WRITELN;
WINDOW(1,1,80,25);
TOP := SUCC(TOP);
FW(38,17,$0E,SAVENAME[TOP+SEL-1]);
END;
PGDN : IF TOP + 8 <= INDEX THEN
BEGIN
SEL := 1;
TOP := TOP + 8;
WRITE_PAGE;
END;
PGUP : IF TOP > 1 THEN
BEGIN
SEL := 1;
TOP := TOP - 8;
IF TOP < 1 THEN TOP := 1;
WRITE_PAGE;
END;
DELKEY : IF DEL THEN
BEGIN
SET_ATTR([37..49],SEL+9,$70);
FW(36,21,$8E,' Are You Sure? ');
SET_CURSOR(UNDERLINE);
REPEAT
GOTOXY(50,21);
READCH(CH,FALSE);
CH := UPCASE(CH);
UNTIL CH IN ['Y','N'];
SET_CURSOR(NONE);
IF CH = 'Y' THEN
BEGIN
ASSIGN(F,SAVENAME[TOP+SEL-1]);
{$I-}
ERASE(F);
{$I+}
IF IORESULT = 0 THEN
BEGIN
FOR I := TOP+SEL-1 TO INDEX-1 DO
SAVENAME[I] := SAVENAME[I+1];
INDEX := PRED(INDEX);
WRITE_PAGE;
END;
END;
FW(37,21,$0F,' <DEL> Delete ');
END;
END;
UNTIL (CH = RETURN) OR (CH = ESCAPE);
IF CH = RETURN THEN
GET_FILE_NAME := SAVENAME[TOP+SEL-1]
ELSE
GET_FILE_NAME := '';
CH := 'X';
SET_CURSOR(CUR);
FILEMODE := FM;
TEXTATTR := SAVE_ATTR;
END;
PROCEDURE PATHEXEC(COMMAND : PATHSTR; PARMS : STRING);
VAR
P,
DIRSTR : STRING;
AllocError: Integer;
Regs : Registers;
{
Procedure ShrinkAllocation;
Begin
If Ofs(FreePtr^)<>0 Then
Begin
AllocError := -1;
Exit;
End;
Regs.AH := $4A;
Regs.ES := Prefixseg;
Regs.BX := Seg(HeapPtr^)-PrefixSeg;
MsDos(Regs);
If (Regs.Flags And Fcarry)=Fcarry Then
AllocError := Regs.AX
Else
AllocError := 0;
End;
Procedure RestoreAllocation;
Begin
If Ofs(FreePtr^)<>0 Then
Begin
AllocError := -1;
Exit;
End;
Regs.AH := $4A;
Regs.ES := Prefixseg;
Regs.BX := Seg(FreePtr^)+$1000-PrefixSeg;
MsDos(Regs);
If (Regs.Flags And Fcarry)=Fcarry Then
AllocError := Regs.AX
Else
AllocError := 0;
End;
}
BEGIN
DIRSTR := GETENV('PATH');
P := FSEARCH(COMMAND,DIRSTR);
IF P <> '' THEN
BEGIN
{
IF DYNAMIC_PATHEXEC THEN
ShrinkAllocation
ELSE
ALLOCERROR := 0;
IF ALLOCERROR = 0 THEN
BEGIN
}
SWAPVECTORS;
EXEC(P,PARMS);
SWAPVECTORS;
{
IF DYNAMIC_PATHEXEC THEN
RestoreAllocation;
END
ELSE
DOSERROR := 8;
}
END
ELSE
DOSERROR := 2;
END;
FUNCTION COMMA(VAR VALUE; FIELDWIDTH, PLACES : INTEGER; NTYPE : TYPEN) : STRING;
VAR
TEMP : STRING;
I,
COMMAPOS,
COMMASINSERTED : INTEGER;
RNUMBER : REAL ABSOLUTE VALUE;
LNUMBER : LONGINT ABSOLUTE VALUE;
INUMBER : INTEGER ABSOLUTE VALUE;
BEGIN
IF FIELDWIDTH < 0 THEN FIELDWIDTH := 0;
IF PLACES < 0 THEN PLACES := 0;
CASE NTYPE OF
RNUM : STR(RNUMBER:FIELDWIDTH:PLACES,TEMP);
LNUM : BEGIN
STR(LNUMBER:FIELDWIDTH,TEMP);
PLACES := 0;
END;
INUM : BEGIN
STR(INUMBER:FIELDWIDTH,TEMP);
PLACES := 0;
END;
END;
IF PLACES = 0 THEN
COMMAPOS := LENGTH(TEMP)-2
ELSE
COMMAPOS := LENGTH(TEMP)-PLACES-3;
COMMASINSERTED := 0;
WHILE (COMMAPOS > 1) AND (TEMP[COMMAPOS-1] IN ['0'..'9']) DO
BEGIN
INSERT(',',TEMP,COMMAPOS);
COMMASINSERTED := SUCC(COMMASINSERTED);
COMMAPOS := COMMAPOS - 3;
END;
FOR I := 1 TO COMMASINSERTED DO
IF TEMP[1] = ' ' THEN
DELETE(TEMP,1,1);
COMMA := TEMP;
END;
FUNCTION READ_SCREEN(X,Y : INTEGER) : CHAR;
VAR
Z : INTEGER;
BEGIN
Z := (((Y * 160) - 160) + (X * 2)) - 1;
READ_SCREEN := P^[Z];
END;
FUNCTION SCREEN_ATTR(X,Y : INTEGER) : BYTE;
VAR
Z : INTEGER;
BEGIN
Z := (((Y * 160) - 160) + (X * 2));
SCREEN_ATTR := ORD(P^[Z]);
END;
PROCEDURE BIN_LED(L : BYTE);
VAR
SHIFTBYTE : BYTE ABSOLUTE $0000:$0417;
BEGIN
IF L IN [0..7] THEN
SHIFTBYTE := L SHL 4;
END;
PROCEDURE READCHT(VAR CH : CHAR; ECHO : BOOLEAN; TOO : LONGINT);
VAR
T : LONGINT;
HELP : BOOLEAN;
ATX,
ATY : INTEGER;
LINE25 : BUF160;
BEGIN
ATX := WHEREX;
ATY := WHEREY;
START_TIMER(T);
HELP := FALSE;
SAVE_LINE(25,LINE25);
REPEAT
IF (SHIFT_KEYS('A')) AND (HELP_LINE <> '') THEN
BEGIN
FW(1,25,HELP_ATTR,PAD(HELP_LINE,80));
GOTOXY(ATX,ATY);
HELP := TRUE;
END
ELSE
IF (SHIFT_KEYS('C')) AND (HELP_LINE2 <> '') THEN
BEGIN
FW(1,25,HELP_ATTR2,PAD(HELP_LINE2,80));
GOTOXY(ATX,ATY);
HELP := TRUE;
END
ELSE
IF HELP THEN
BEGIN
REBUILD_LINE(25,LINE25);
GOTOXY(ATX,ATY);
HELP := FALSE;
END;
UNTIL KEYPRESSED OR (ELAP_TIME(T) >= TOO) OR (COMMAND_BUFFER <> '');
REBUILD_LINE(25,LINE25);
IF KEYPRESSED THEN
READCH(CH,ECHO);
END;
PROCEDURE PRINT_SCREEN(X1,Y1,X2,Y2 : INTEGER; EXT : BOOLEAN);
VAR
CH : CHAR;
I,J : INTEGER;
BEGIN
IF NOT PRINTER_READY THEN EXIT;
FOR I := Y1 TO Y2 DO
BEGIN
FOR J := X1 TO X2 DO
BEGIN
CH := READ_SCREEN(J,I);
IF (CH IN [' '..'~']) OR EXT THEN
WRITE(LST,CH)
ELSE
WRITE(LST,' ');
END;
WRITELN(LST);
END;
END;
FUNCTION PRINTER_READY : BOOLEAN;
VAR
SC : BUFFER;
BEGIN
IF PRINTER_NOT_READY THEN
BEGIN
SAVE_SCREEN(SC);
POP_WINDOW(30,10,57,14,2,$4F);
FW(34,11,$CF,'PRINTER NOT READY !!');
FW(33,13,$4F,'Ready Printer, or <ESC>');
CH := 'X';
GOTOXY(56,13);
WHILE (CH <> ESCAPE) AND PRINTER_NOT_READY DO
IF KEYPRESSED THEN
READCH(CH,FALSE);
IF CH = ESCAPE THEN
PRINTER_READY := FALSE
ELSE
PRINTER_READY := TRUE;
CH := 'X';
REBUILD_SCREEN(SC);
END
ELSE
PRINTER_READY := TRUE;
END;
FUNCTION COMBINE(S1, S2 : STRING;
MAX : INTEGER;
INSERT_COMMA : BOOLEAN) : STRING;
BEGIN
WHILE (S1[LENGTH(S1)] = ' ') AND (LENGTH(S1) > 0) DO
DELETE(S1,LENGTH(S1),1);
IF INSERT_COMMA THEN
S1 := S1 + ', ' + S2
ELSE
S1 := S1 + ' ' + S2;
IF LENGTH(S1) > MAX THEN
S1 := COPY(S1,1,MAX)
ELSE
WHILE LENGTH(S1) < MAX DO
S1 := S1 + ' ';
COMBINE := S1;
END;
PROCEDURE ENCRYPT(VAR LINE : STRING; I : INTEGER);
BEGIN
RANDSEED := I;
FOR I := 1 TO LENGTH(LINE) DO
LINE[I] := CHR(ORD(LINE[I]) + RANDOM(10));
END;
PROCEDURE UN_ENCRYPT(VAR LINE : STRING; I : INTEGER);
BEGIN
RANDSEED := I;
FOR I := 1 TO LENGTH(LINE) DO
LINE[I] := CHR(ORD(LINE[I]) - RANDOM(10));
END;
PROCEDURE CENTER(Y, ATTRIB : INTEGER; LINE : STRING);
VAR
TEMP : STRING;
BEGIN
TEMP := STRIP(LINE,FALSE);
FW(40 - (LENGTH(TEMP) DIV 2),Y,ATTRIB,TEMP);
END;
PROCEDURE SET_ATTR_BOX(X1,Y1,X2,Y2,ATT : INTEGER);
VAR
I : INTEGER;
BEGIN
FOR I := Y1 TO Y2 DO
SET_ATTR([X1..X2],I,ATT);
END;
FUNCTION FILE_OPEN(VAR F) : BOOLEAN;
VAR
FILE_INFO : FILEREC ABSOLUTE F;
BEGIN
FILE_OPEN := FILE_INFO.MODE <> FMCLOSED;
END;
PROCEDURE WRITE_X80_Y25(CH : CHAR; ATTRIB : INTEGER);
BEGIN
FW(80,25,ATTRIB,CH);
END;
PROCEDURE GET_DOS_VER;
VAR
VER : WORD;
TEMP,
TEMP2 : STRING[4];
BEGIN
VER := DOSVERSION;
STR(LO(VER),TEMP);
STR(HI(VER),TEMP2);
DOS_VER := TEMP + '.' + TEMP2;
END;
FUNCTION RANDOM_NUMBER(LOW, HIGH : INTEGER) : INTEGER;
VAR
H,M,S,S100 : WORD;
BEGIN
IF (LOW < 0) OR (HIGH > 99) THEN
BEGIN
RANDOM_NUMBER := 0;
EXIT;
END;
REPEAT
GETTIME(H,M,S,S100);
UNTIL (S100 >= LOW) AND (S100 <= HIGH);
RANDOM_NUMBER := S100;
END;
FUNCTION FILE_EXIST(FILENAME : STRING) : BOOLEAN;
VAR
INF : SEARCHREC;
BEGIN
FINDFIRST(FILENAME,ANYFILE-DIRECTORY,INF);
FILE_EXIST := (DOSERROR = 0);
END;
PROCEDURE BEEP;
BEGIN
SOUND(400);
DELAY(150);
SOUND(300);
DELAY(100);
NOSOUND;
END;
PROCEDURE READSTR_BIG(X,Y,LEN : INTEGER;
PATTR : INTEGER;
PROMPT : STR80;
IATTR : INTEGER;
VAR INSTRING : STRING;
VALID : ETYPE;
CANEDIT : CTYPE;
EXITCH : ETYPE;
XLOC,
YLOC : INTEGER;
CH1 : CHAR;
WIN : INTEGER);
VAR
I,
XX,
START,
OFS : INTEGER;
CAPIT,
CAPWO,
INSON : BOOLEAN;
SAVECH : CHAR;
BEGIN
OLDVAL := INSTRING;
INSON := FALSE;
IF X_IN > LEN THEN
X_IN := LEN;
IF X_IN > WIN THEN
OFS := X_IN
ELSE
OFS := 1;
IF OFS + WIN > LEN THEN
OFS := LEN - WIN + 1;
IF YLOC > 199 THEN
BEGIN
CAPIT := TRUE;
YLOC := YLOC - 200;
END
ELSE
BEGIN
CAPIT := FALSE;
IF YLOC > 99 THEN
BEGIN
YLOC := YLOC - 100;
CAPWO := TRUE;
END
ELSE
CAPWO := FALSE;
END;
IF CLEAR IN EXITCH THEN
INSTRING := SPACES(LEN)
ELSE
INSTRING := PAD(INSTRING,LEN);
FW(X,Y,PATTR,PROMPT);
START := X + LENGTH(PROMPT);
IF X_IN > WIN THEN
X := X_IN - OFS + 1
ELSE
X := X_IN;
FW(START,Y,IATTR,COPY(INSTRING,OFS,WIN));
IF XLOC > 99 THEN
BEGIN
X := LEN;
XLOC := XLOC - 100;
END;
SET_CURSOR(UNDERLINE);
IF NOT (DISPLAY IN EXITCH) THEN
REPEAT
FW(START,Y,IATTR,COPY(INSTRING,OFS,WIN));
GOTOXY(START+X-1,Y);
CH := CH1;
READCHTIME(CH,FALSE,XLOC,YLOC);
SAVECH := CH;
CASE CH OF
HOMEKEY : BEGIN
OFS := 1;
X := 1;
END;
ENDKEY : BEGIN
X := LEN;
WHILE (X > 2) AND (INSTRING[X-1] = ' ') DO
X := PRED(X);
IF (X = 1) AND (INSTRING[1] = ' ') THEN
X := 1;
OFS := X - (WIN - 2);
IF OFS < 1 THEN OFS := 1;
X := WIN;
WHILE (X > 1) AND (INSTRING[X+OFS-2] = ' ') DO
X := PRED(X);
IF X + OFS > LEN THEN
OFS := PRED(OFS);
END;
#8 : IF (X > 1) THEN
BEGIN
DELETE(INSTRING,X-1+OFS-1,1);
INSTRING := INSTRING + ' ';
X := PRED(X);
END
ELSE
IF X > 1 THEN
X := PRED(X)
ELSE
BEGIN
SAVECH := CH;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := UP;
END;
RIGHT : IF X < WIN THEN
X := SUCC(X)
ELSE
IF OFS + WIN <= LEN THEN
OFS := SUCC(OFS)
ELSE
BEGIN
SAVECH := CH;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := DOWN;
END;
LEFT : IF X > 1 THEN
X := PRED(X)
ELSE
IF OFS > 1 THEN
OFS := PRED(OFS)
ELSE
BEGIN
SAVECH := CH;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := UP;
END;
' '..'~' : IF CH IN VALID THEN
IF INSON THEN
BEGIN
IF INSTRING[LEN] = ' ' THEN
BEGIN
DELETE(INSTRING,LENGTH(INSTRING),1);
IF (CAPWO AND ((X = 1) OR (INSTRING[X+OFS-2] = ' '))) OR
CAPIT THEN
CH := UPCASE(CH);
INSERT(CH,INSTRING,X+OFS-1);
IF X < WIN THEN
X := SUCC(X)
ELSE
IF OFS + WIN <= LEN THEN
OFS := SUCC(OFS)
ELSE
BEGIN
SAVECH := RIGHT;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := DOWN;
END;
END
ELSE
BEEP;
END
ELSE
BEGIN
IF (CAPWO AND ((X = 1) OR (INSTRING[X+OFS-2] = ' '))) OR
CAPIT THEN
CH := UPCASE(CH);
INSTRING[X+OFS-1] := CH;
IF X < WIN THEN
X := SUCC(X)
ELSE
IF OFS + WIN <= LEN THEN
OFS := SUCC(OFS)
ELSE
BEGIN
SAVECH := RIGHT;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := DOWN;
END;
END;
INSKEY : BEGIN
INSON := NOT INSON;
IF INSON THEN
SET_CURSOR(BLOCK)
ELSE
BEGIN
SET_CURSOR(UNDERLINE);
INSON := FALSE;
END;
END;
DELKEY : BEGIN
DELETE(INSTRING,X+OFS-1,1);
INSTRING := INSTRING + ' ';
GOTOXY(START,Y);
END;
ALT_C : BEGIN
FOR I := 1 TO LEN DO
INSTRING[I] := ' ';
X := 1;
OFS := 1;
END;
END;
FW(START,Y,IATTR,COPY(INSTRING,OFS,WIN));
IF X > LEN THEN X := LEN;
UNTIL (CH = #27) OR (CH IN EXITCH);
IF NOCONV IN EXITCH THEN
CH := SAVECH;
X_IN := 1;
X_OUT := X+OFS-1;
SET_CURSOR(UNDERLINE);
CHANGED := INSTRING <> OLDVAL;
END;
FUNCTION CHECK_KEYBOARD : CHAR;
VAR
CH : CHAR;
BEGIN
IF KEYPRESSED OR (COMMAND_BUFFER <> '') THEN
BEGIN
READCH(CH,FALSE);
CHECK_KEYBOARD := CH;
END
ELSE
CHECK_KEYBOARD := #0;
END;
PROCEDURE CENTER_PRINT(LINE : STRING;
LEN : INTEGER;
VAR NEXTPOS : INTEGER;
CR : BOOLEAN);
BEGIN
NEXTPOS := ((LEN DIV 2) + (LENGTH(LINE) DIV 2)) + 1;
IF CR THEN
WRITELN(LST,LINE:NEXTPOS-1)
ELSE
WRITE(LST,LINE:NEXTPOS-1);
END;
PROCEDURE DISP_NOPROMPT_MESSAGE(X,Y,LEN,ATTR : INTEGER; MESS : STR80);
BEGIN
FW(X,Y,ATTR,PAD(MESS,LEN));
GOTOXY(X+LEN-1,Y);
END;
PROCEDURE DISP_MESSAGE(X,Y,LEN,ATTR : INTEGER; MESS : STR80);
BEGIN
FW(X,Y,ATTR,PAD(MESS,LEN));
GOTOXY(X+LEN-1,Y);
READCH(CH,FALSE);
END;
PROCEDURE CLEAR_BUFFER(VAR SCREEN : BUFFER;
ATTR : INTEGER);
VAR
I : INTEGER;
BEGIN
I := 1;
REPEAT
SCREEN[I] := ' ';
SCREEN[I+1] := CHAR(ATTR);
I := I + 2;
UNTIL I > 3999;
END;
PROCEDURE FWB(VAR SCREEN : BUFFER;
X,Y,ATTR : INTEGER;
INSTRING : STR80);
VAR
I,Z : INTEGER;
BEGIN
Z := (((Y * 160) - 160) + (X * 2)) - 1;
FOR I := 1 TO LENGTH(INSTRING) DO
IF Z < 4000 THEN
BEGIN
SCREEN[Z] := INSTRING[I];
SCREEN[Z+1] := CHR(ATTR);
Z := Z + 2;
END;
END;
FUNCTION CREATE_NEW_FILE(FILENAME, MESS : STR80) : BOOLEAN;
VAR
CH : CHAR;
SC : BUFFER;
BEGIN
SAVE_SCREEN(SC);
FW(10,15,$04,'╒══════════════════════════════════════════════════╕');
FW(10,16,$04,'│ FILE NOT FOUND !! │');
FW(10,17,$04,'│ │');
FW(10,18,$04,'│ │');
FW(10,19,$04,'│ │');
FW(10,20,$04,'│ Contact: │');
FW(10,21,$04,'│ │');
FW(10,22,$04,'│ Press <any Key> to Abort Program │');
FW(10,23,$04,'╘══════════════════════════════════════════════════╛');
FW(28,18,$0F,FILENAME);
FW(23,20,$0F,MESS);
GOTOXY(52,22);
WHILE KEYPRESSED DO
CH := READKEY;
READCH(CH,FALSE);
CREATE_NEW_FILE := CH = AF1;
REBUILD_SCREEN(SC);
END;
FUNCTION INT_STR(I,LEN : INTEGER) : STR80;
VAR
TEMP : STR80;
BEGIN
STR(I:LEN,TEMP);
INT_STR := TEMP;
END;
FUNCTION REAL_STR(R : REAL; LEN, PLACES : INTEGER) : STR80;
VAR
TEMP : STR80;
BEGIN
STR(R:LEN:PLACES,TEMP);
REAL_STR := TEMP;
END;
FUNCTION LONGINT_STR(I : LONGINT; LEN : INTEGER) : STR80;
VAR
TEMP : STR80;
BEGIN
STR(I:LEN,TEMP);
LONGINT_STR := TEMP;
END;
FUNCTION DATE_TIME_KEY : STR16;
VAR
YEAR, MON, DAY, DOW,
HOUR, MIN, SEC, SEC100 : WORD;
TEMP1,
TEMP2 : STR16;
BEGIN
GETDATE(YEAR,MON,DAY,DOW);
GETTIME(HOUR,MIN,SEC,SEC100);
STR(YEAR:4,TEMP1);
STR(MON:2,TEMP2);
IF TEMP2[1] = ' ' THEN TEMP2[1] := '0';
TEMP1 := TEMP1 + TEMP2;
STR(DAY:2,TEMP2);
IF TEMP2[1] = ' ' THEN TEMP2[1] := '0';
TEMP1 := TEMP1 + TEMP2;
STR(HOUR:2,TEMP2);
IF TEMP2[1] = ' ' THEN TEMP2[1] := '0';
TEMP1 := TEMP1 + TEMP2;
STR(MIN:2,TEMP2);
IF TEMP2[1] = ' ' THEN TEMP2[1] := '0';
TEMP1 := TEMP1 + TEMP2;
STR(SEC:2,TEMP2);
IF TEMP2[1] = ' ' THEN TEMP2[1] := '0';
TEMP1 := TEMP1 + TEMP2;
STR(SEC100:2,TEMP2);
IF TEMP2[1] = ' ' THEN TEMP2[1] := '0';
TEMP1 := TEMP1 + TEMP2;
DATE_TIME_KEY := TEMP1;
END;
FUNCTION STRIP(ST : STRING; IMBED : BOOLEAN) : STRING;
BEGIN
WHILE (LENGTH(ST) > 0) AND (ST[1] = ' ') DO
DELETE(ST,1,1);
WHILE (LENGTH(ST) > 0) AND (ST[LENGTH(ST)] = ' ') DO
DELETE(ST,LENGTH(ST),1);
IF IMBED THEN
WHILE POS(' ',ST) > 0 DO
DELETE(ST,POS(' ',ST),1);
STRIP := ST;
END;
FUNCTION KEY_TO_DATE(ST : STRING) : STRING;
VAR
INT : INTEGER;
IND : STRING[2];
TMP : STRING[2];
BEGIN
INT := _INTEGER(COPY(ST,9,2));
IF INT > 11 THEN
IND := 'pm'
ELSE
IND := 'am';
IF INT > 12 THEN
INT := INT - 12;
TMP := INT_STR(INT,2);
IF TMP[1] = ' ' THEN TMP[1] := '0';
KEY_TO_DATE := COPY(ST,5,2)+'-'+COPY(ST,7,2)+'-'+COPY(ST,1,4)+' '+
TMP+':'+COPY(ST,11,2)+' '+IND;
END;
function Julian(DT : STR8) : longint;
var
Temp, Y, M, D : longint;
Year, Mon, Day : integer;
begin
YEAR := _INTEGER(COPY(DT,7,2));
MON := _INTEGER(COPY(DT,1,2));
DAY := _INTEGER(COPY(DT,4,2));
if (Year < 0) or (Mon < 1) or (Mon > 12) {Mod. #1}
or (Day < 1) or (Day > 31) then
begin
Julian := -1;
exit
end;
Y := Year; M := Mon; D := Day;
if Y < 100 then Y := Y + 1900; {Mod. #1}
Temp := (M - 14) div 12;
Julian := D - 32075 +
(1461 * (Y + 4800 + Temp) div 4) +
(367 * (M - 2 - Temp * 12) div 12) -
(3 * ((Y + 4900 + Temp) div 100) div 4)
end;
FUNCTION JulToMDY(JulianDay: longint) : STR8;
var
TempA, TempB, TempC : longint;
MON, YEAR, DAY : INTEGER;
TEMP : STRING[10];
begin
TempA := JulianDay + 68569;
TempB := 4 * TempA div 146097;
TempA := TempA - (146097 * TempB + 3) div 4;
Year := 4000 * (TempA + 1) div 1461001;
TempC := Year;
TempA := TempA - (1461 * TempC div 4) + 31;
Mon := 80 * TempA div 2447;
TempC := Mon;
Day := TempA - (2447 * TempC div 80);
TempA := Mon div 11;
Mon := Mon + 2 - (12 * TempA);
Year := 100 * (TempB - 49) + Year + TempA;
TEMP := INT_STR(MON,2) + '-' + INT_STR(DAY,2) + '-' + INT_STR(YEAR,4);
IF TEMP[1] = ' ' THEN TEMP[1] := '0';
IF TEMP[4] = ' ' THEN TEMP[4] := '0';
DELETE(TEMP,7,2);
JULTOMDY := TEMP;
end;
procedure DayWeek(DT : STR8; var DayNum: integer;
var DayName: Str3);
VAR
CENTURY,
Tmp : Integer;
YEAR,
MONTH,
DAY : WORD;
Begin
VAL(COPY(DT,7,2),YEAR,TMP);
VAL(COPY(DT,1,2),MONTH,TMP);
VAL(COPY(DT,4,2),DAY,TMP);
If Year < 1900 then
Inc(Year,1900);
If Month < 3 then
Inc(Month, 10)
else
Dec(Month, 2);
If Month > 10 then
Dec(Year);
Century := Year div 100;
Year := Year mod 100;
Tmp := Trunc((2.6 * Month - 0.2) + Day + Year + (Year div 4) +
(Century div 4) - (2 * Century));
DAYNUM := (Tmp + 777) mod 7;
CASE DAYNUM OF
0 : DAYNAME := 'Sun';
1 : DAYNAME := 'Mon';
2 : DAYNAME := 'Tue';
3 : DAYNAME := 'Wed';
4 : DAYNAME := 'Thu';
5 : DAYNAME := 'Fri';
6 : DAYNAME := 'Sat';
END;
End;
FUNCTION DUP(MASK : CHAR; N : INTEGER) : STRING;
VAR
ST : STRING;
BEGIN
FILLCHAR(ST,SIZEOF(ST),MASK);
IF (N < 256) AND (N > 0) THEN
ST[0] := CHR(N)
ELSE
ST[0] := CHR(0);
DUP := ST;
END;
PROCEDURE POP_WINDOW(X1,Y1,X2,Y2 : INTEGER; STYLE : INTEGER; ATTR : BYTE);
VAR
I,
SHADOW : BYTE;
URCORNER,
ULCORNER,
LRCORNER,
LLCORNER,
VERTICAL,
HORIZONTAL : CHAR;
BEGIN
CASE STYLE OF
0,
10 : BEGIN
URCORNER := ' ';
ULCORNER := ' ';
LRCORNER := ' ';
LLCORNER := ' ';
VERTICAL := ' ';
HORIZONTAL := ' ';
END;
1,
11 : BEGIN
URCORNER := '┐';
ULCORNER := '┌';
LRCORNER := '┘';
LLCORNER := '└';
VERTICAL := '│';
HORIZONTAL := '─';
END;
ELSE BEGIN
URCORNER := '╗';
ULCORNER := '╔';
LRCORNER := '╝';
LLCORNER := '╚';
VERTICAL := '║';
HORIZONTAL := '═';
END;
END;
FW(X1,Y1,ATTR,ULCORNER+DUP(HORIZONTAL,X2-X1-1)+URCORNER);
FOR I := Y1 + 1 TO Y2 - 1 DO
FW(X1,I,ATTR,VERTICAL+DUP(' ',X2-X1-1)+VERTICAL);
FW(X1,Y2,ATTR,LLCORNER+DUP(HORIZONTAL,X2-X1-1)+LRCORNER);
IF STYLE < 10 THEN
IF (X2 < 80) AND (Y2 < 25) THEN
BEGIN
SHADOW := $07;
IF Y2 < 25 THEN
SET_ATTR([X1+2..X2+2],Y2+1,SHADOW);
FOR I := Y1 + 1 TO Y2 + 1 DO
IF I <= 25 THEN
SET_ATTR([X2+1,X2+2],I,SHADOW);
END;
END;
FUNCTION GET_FILE_INFO(FILENAME : STRING) : STR80;
VAR
F : FILE OF BYTE;
SAVE_MODE : BYTE;
DT : DATETIME;
DATE,
SIZE : LONGINT;
FUNCTION CONVERT_DATE : STRING;
VAR
IND : CHAR;
TEMP, TEMP2 : STRING;
BEGIN
UNPACKTIME(DATE,DT);
STR(DT.MONTH:2,TEMP2);
STR(DT.DAY:2,TEMP);
IF TEMP[1] = ' ' THEN TEMP[1] := '0';
TEMP2 := TEMP2 + '-' + TEMP;
STR(DT.YEAR:4,TEMP);
TEMP2 := TEMP2 + '-' + COPY(TEMP,3,2);
IF DT.HOUR >= 12 THEN
BEGIN
IND := 'p';
IF DT.HOUR > 12 THEN
DT.HOUR := DT.HOUR - 12;
END
ELSE
IND := 'a';
STR(DT.HOUR:2,TEMP);
TEMP2 := TEMP2 + ' ' + TEMP + ':';
STR(DT.MIN:2,TEMP);
IF TEMP[1] = ' ' THEN TEMP[1] := '0';
TEMP2 := TEMP2 + TEMP + IND;
IF (DT.HOUR=0) AND (DT.MIN=0) AND (DT.SEC=0) THEN
BEGIN
TEMP2 := COPY(TEMP2,1,10);
TEMP2 := TEMP2 + SPACES(5);
END;
CONVERT_DATE := TEMP2;
END;
BEGIN
SAVE_MODE := FILEMODE;
FILEMODE := 0;
ASSIGN(F,FILENAME);
{$I-}
RESET(F);
{$I+}
IF IORESULT = 0 THEN
BEGIN
SIZE := FILESIZE(F);
GETFTIME(F,DATE);
CLOSE(F);
GET_FILE_INFO := LONGINT_STR(SIZE,9)+' '+CONVERT_DATE;
END
ELSE
GET_FILE_INFO := '';
FILEMODE := SAVE_MODE;
END;
PROCEDURE SAVE_LINE(Y : INTEGER; VAR STR : BUF160);
VAR
Z : INTEGER;
BEGIN
Z := (((Y * 160) - 160) + 2) - 1;
MOVE(P^[Z],STR,160);
END;
PROCEDURE REBUILD_LINE(Y : INTEGER; STR : BUF160);
VAR
Z : INTEGER;
BEGIN
Z := (((Y * 160) - 160) + 2) - 1;
MOVE(STR,P^[Z],160);
END;
PROCEDURE FILL_SCREEN(X1,Y1,X2,Y2 : INTEGER; CH : CHAR; ATTR : INTEGER);
VAR
X,Y,
Z : INTEGER;
SC : BUFFER;
BEGIN
SAVE_SCREEN(SC);
FOR Y := Y1 TO Y2 DO
FOR X := X1 TO X2 DO
BEGIN
Z := (((Y * 160) - 160) + (X * 2)) - 1;
SC[Z] := CH;
SC[Z+1] := CHR(ATTR);
END;
REBUILD_SCREEN(SC);
END;
FUNCTION PROGRAM_LOCATION : STRING;
VAR
TEMP,
DIR,
NAME,
EXT : STRING;
BEGIN
TEMP := PARAMSTR(0);
FSPLIT(TEMP,DIR,NAME,EXT);
PROGRAM_LOCATION := DIR;
END;
PROCEDURE REBOOT;
BEGIN
INLINE(
$B8/$40/$00/
$8E/$D8/
$C7/$06/$72/$00/$34/$12/
$EA/$00/$00/$FF/$FF);
END;
procedure SetBlink(On : Boolean);
{-Enable text mode attribute blinking if On is True}
const
PortVal : array[0..4] of Byte = ($0C, $08, $0D, $09, $09);
var
PortNum : Word;
Index : Byte;
PVal : Byte;
begin
IF EGA_PRESENT THEN
begin
inline(
$8A/$5E/<On/ {mov bl,[bp+<On]}
$B8/$03/$10/ {mov ax,$1003}
$CD/$10); {int $10}
Exit;
end
ELSE
IF CGA_PRESENT THEN
begin
PortNum := $3D8;
case LastMode of
0..3 : Index := LastMode;
else Exit;
end;
end
ELSE
begin
PortNum := $3B8;
Index := 4;
end;
PVal := PortVal[Index];
if On then
PVal := PVal or $20;
Port[PortNum] := PVal;
end;
PROCEDURE BLINK_OFF;
BEGIN
SetBlink(False);
BLINK_IS_ON := FALSE;
END;
PROCEDURE BLINK_ON;
BEGIN
SetBlink(True);
BLINK_IS_ON := TRUE;
END;
PROCEDURE SET_BORDER(COLOR : INTEGER);
VAR
REGS : REGISTERS;
MONITOR_INFO : BYTE ABSOLUTE $0040:$0010;
BEGIN
CURRENT_BORDER := COLOR;
IF (EGA_PRESENT) OR (VGA_PRESENT) THEN
BEGIN
REGS.AH := $10;
REGS.AL := 1;
REGS.BH := COLOR;
INTR($10,REGS);
END
ELSE
PORT[$03D9]:=15 AND COLOR;
END;
PROCEDURE SCREEN_ON;
VAR
REGS : REGISTERS;
MONITOR_INFO : BYTE ABSOLUTE $0040:$0010;
BEGIN
IF EGA_PRESENT OR VGA_PRESENT THEN
BEGIN
REGS.AH := $12;
REGS.AL := 0;
REGS.BL := $36;
INTR($10,REGS);
END
ELSE
BEGIN
IF MONITOR_INFO AND 48 = 48 THEN
PORT[952]:=255
ELSE
PORT[984]:=41;
END;
SET_BORDER(CURRENT_BORDER);
END;
PROCEDURE SCREEN_OFF;
VAR
REGS : REGISTERS;
MONITOR_INFO : BYTE ABSOLUTE $0040:$0010;
BEGIN
IF EGA_PRESENT OR VGA_PRESENT THEN
BEGIN
REGS.AH := $12;
REGS.AL := 1;
REGS.BL := $36;
INTR($10,REGS);
END
ELSE
BEGIN
IF MONITOR_INFO AND 48 = 48 THEN
PORT[952]:=1
ELSE
PORT[984]:=1;
END;
IF (EGA_PRESENT) OR (VGA_PRESENT) THEN
BEGIN
REGS.AH := $10;
REGS.AL := 1;
REGS.BH := 0;
INTR($10,REGS);
END
ELSE
PORT[$03D9]:=15 AND 0;
END;
PROCEDURE POP_MESSAGE(X,Y : INTEGER; BORDER, ATTR : BYTE;
MATTR : BYTE; MESSAGE : STR80);
BEGIN
IF X = 0 THEN
X := 40 - ((LENGTH(MESSAGE) + 3) DIV 2);
POP_WINDOW(X,Y,X+LENGTH(MESSAGE)+3,Y+2,BORDER,ATTR);
FW(X+2,Y+1,MATTR,MESSAGE);
GOTOXY(X+LENGTH(MESSAGE)+2,Y+1);
END;
PROCEDURE POP_WINDOW_TITLE( X,Y,X1,Y1 : INTEGER;
BORDER, ATTR : BYTE;
TATTR,
TY : BYTE;
TITLE : STR80);
BEGIN
POP_WINDOW(X,Y,X1,Y1,BORDER,ATTR);
FW((X+((X1-X) DIV 2) - (LENGTH(TITLE) DIV 2)),TY,TATTR,+' '+TITLE+' ');
END;
FUNCTION SHIFT_KEYS(KEY : CHAR) : BOOLEAN;
{ KEY = 'R' for Right, 'L' for Left, 'C' for Control, 'A' for Alt }
VAR
KEYBOARD : BYTE ABSOLUTE $0040:$0017;
BEGIN
CASE UPCASE(KEY) OF
'R' : SHIFT_KEYS := KEYBOARD AND 1 = 1;
'L' : SHIFT_KEYS := KEYBOARD AND 2 = 2;
'C' : SHIFT_KEYS := KEYBOARD AND 4 = 4;
'A' : SHIFT_KEYS := KEYBOARD AND 8 = 8;
END;
END;
procedure MasterEnv;
{-Return master environment record}
var
Owner : Word;
Mcb : Word;
Eseg : Word;
Done : Boolean;
begin
with Env_Rec do begin
FillChar(Env_Rec, SizeOf(Env_Rec), 0);
{Interrupt $2E points into COMMAND.COM}
Owner := MemW[0:(2+4*$2E)];
{Mcb points to memory control block for COMMAND}
Mcb := Owner-1;
if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) then
Exit;
{Read segment of environment from PSP of COMMAND}
Eseg := MemW[Owner:$2C];
{Earlier versions of DOS don't store environment segment there}
if Eseg = 0 then begin
{Master environment is next block past COMMAND}
Mcb := Owner+MemW[Mcb:3];
if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) then
{Not the right memory control block}
Exit;
Eseg := Mcb+1;
end else
Mcb := Eseg-1;
{Return segment and length of environment}
EnvSeg := Eseg;
EnvLen := MemW[Mcb:3] shl 4;
end;
end;
procedure SkipAsciiZ(EPtr : EnvArrayPtr; var EOfs : Word);
{-Skip to end of current AsciiZ string}
begin
while EPtr^[EOfs] <> #0 do
Inc(EOfs);
end;
function EnvNext(EPtr : EnvArrayPtr) : Word;
{-Return the next available location in environment at EPtr^}
var
EOfs : Word;
begin
EOfs := 0;
if EPtr <> nil then begin
while EPtr^[EOfs] <> #0 do begin
SkipAsciiZ(EPtr, EOfs);
Inc(EOfs);
end;
end;
EnvNext := EOfs;
end;
function StUpcase(S : string) : string;
{-Uppercase a string}
var
SLen : byte absolute S;
I : Integer;
begin
for I := 1 to SLen do
S[I] := UpCase(S[I]);
StUpcase := S;
end;
function SearchEnv(EPtr : EnvArrayPtr;
var Search : string) : Word;
{-Return the position of Search in environment, or $FFFF if not found.
Prior to calling SearchEnv, assure that
EPtr is not nil,
Search is not empty
}
var
SLen : Byte absolute Search;
EOfs : Word;
MOfs : Word;
SOfs : Word;
Match : Boolean;
begin
{Force upper case search}
Search := StUpcase(Search);
{Assure search string ends in =}
if Search[SLen] <> '=' then begin
Inc(SLen);
Search[SLen] := '=';
end;
EOfs := 0;
while EPtr^[EOfs] <> #0 do begin
{At the start of a new environment element}
SOfs := 1;
MOfs := EOfs;
repeat
Match := (EPtr^[EOfs] = Search[SOfs]);
if Match then begin
Inc(EOfs);
Inc(SOfs);
end;
until not Match or (SOfs > SLen);
if Match then begin
{Found a match, return index of start of match}
SearchEnv := MOfs;
Exit;
end;
{Skip to end of this environment string}
SkipAsciiZ(EPtr, EOfs);
{Skip to start of next environment string}
Inc(EOfs);
end;
{No match}
SearchEnv := $FFFF;
end;
procedure GetAsciiZ(EPtr : EnvArrayPtr; var EOfs : Word; var EStr : string);
{-Collect AsciiZ string starting at EPtr^[EOfs]}
var
ELen : Byte absolute EStr;
begin
ELen := 0;
while (EPtr^[EOfs] <> #0) and (ELen < 255) do begin
Inc(ELen);
EStr[ELen] := EPtr^[EOfs];
Inc(EOfs);
end;
end;
function SetEnv(Name, Value : string) : Boolean;
{-Set environment string, returning true if successful}
var
SLen : Byte absolute Name;
VLen : Byte absolute Value;
EPtr : EnvArrayPtr;
ENext : Word;
EOfs : Word;
MOfs : Word;
OldLen : Word;
NewLen : Word;
NulLen : Word;
begin
with Env_Rec do begin
SetEnv := False;
if (EnvSeg = 0) or (SLen = 0) then
Exit;
EPtr := Ptr(EnvSeg, 0);
{Find the search string}
EOfs := SearchEnv(EPtr, Name);
{Get the index of the next available environment location}
ENext := EnvNext(EPtr);
{Get total length of new environment string}
NewLen := SLen+VLen;
if EOfs <> $FFFF then begin
{Search string exists}
MOfs := EOfs+SLen;
{Scan to end of string}
SkipAsciiZ(EPtr, MOfs);
OldLen := MOfs-EOfs;
{No extra nulls to add}
NulLen := 0;
end else begin
OldLen := 0;
{One extra null to add}
NulLen := 1;
end;
if VLen <> 0 then
{Not a pure deletion}
if ENext+NewLen+NulLen >= EnvLen+OldLen then
{New string won't fit}
Exit;
if OldLen <> 0 then begin
{Overwrite previous environment string}
Move(EPtr^[MOfs+1], EPtr^[EOfs], ENext-MOfs-1);
{More space free now}
Dec(ENext, OldLen+1);
end;
{Append new string}
if VLen <> 0 then begin
Move(Name[1], EPtr^[ENext], SLen);
Inc(ENext, SLen);
Move(Value[1], EPtr^[ENext], VLen);
Inc(ENext, VLen);
end;
{Clear out the rest of the environment}
FillChar(EPtr^[ENext], EnvLen-ENext, 0);
SetEnv := True;
end;
end;
PROCEDURE READ_R( X,Y : INTEGER;
VAR R : REAL;
MIN,
MAX : REAL;
PLACES : INTEGER;
RIGHT_JUST : INTEGER;
ICOMMA : BOOLEAN);
var
temp : string[80];
len : integer;
SAT : BYTE;
S : BUF160;
begin
str(max:0:places,temp);
LEN := LENGTH(TEMP);
str(r:0:places,temp);
sat := screen_attr(x,y);
textattr := sat;
FW(X,Y,SAT,SPACES(RIGHT_JUST));
IF MIN < 0.0 THEN
BEGIN
len := LEN + 1; { +1 FOR MINUS SIGN }
REPEAT
read_str(x,y,temp,dup('+',len));
IF (_REAL(TEMP) < MIN) OR (_REAL(TEMP) > MAX) THEN
BEGIN
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',MIN:0:PLACES,' to ',MAX:0:PLACES,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL (_REAL(TEMP) >= MIN) AND (_REAL(TEMP) <= MAX);
END
ELSE
REPEAT
READ_STR(X,Y,TEMP,DUP('.',LEN));
IF (_REAL(TEMP) < MIN) OR (_REAL(TEMP) > MAX) THEN
BEGIN
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',MIN:0:PLACES,' to ',MAX:0:PLACES,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL (_REAL(TEMP) >= MIN) AND (_REAL(TEMP) <= MAX);
r := _real(temp);
str(r:0:places,temp); { THIS TRUNCATES ANYTHING }
r := _real(temp); { PAST PLACES }
textattr := screen_attr(x,y);
gotoxy(x,y);
IF ICOMMA THEN
write(comma(r,RIGHT_JUST,places,RNUM))
ELSE
WRITE(R:RIGHT_JUST:PLACES);
end;
PROCEDURE READ_I( X,Y : INTEGER;
VAR R : INTEGER;
MIN,
MAX : INTEGER;
RIGHT_JUST : INTEGER;
ICOMMA : BOOLEAN);
var
temp : string[80];
len : integer;
SAT : BYTE;
S : BUF160;
begin
str(max:0,temp);
LEN := LENGTH(TEMP);
str(r:0,temp);
sat := screen_attr(x,y);
textattr := sat;
GOTOXY(X,Y);
WRITE(' ':RIGHT_JUST);
IF MIN < 0.0 THEN
BEGIN
len := LEN + 1; { +1 FOR MINUS SIGN }
REPEAT
read_str(x,y,temp,dup('+',len));
IF (_INTEGER(TEMP) < MIN) OR (_INTEGER(TEMP) > MAX) THEN
BEGIN
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',MIN:0,' to ',MAX:0,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL (_INTEGER(TEMP) >= MIN) AND (_INTEGER(TEMP) <= MAX);
END
ELSE
REPEAT
READ_STR(X,Y,TEMP,DUP('.',LEN));
IF (_INTEGER(TEMP) < MIN) OR (_INTEGER(TEMP) > MAX) THEN
BEGIN
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',MIN:0,' to ',MAX:0,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL (_INTEGER(TEMP) >= MIN) AND (_INTEGER(TEMP) <= MAX);
r := _INTEGER(temp);
str(r:0,temp); { THIS TRUNCATES ANYTHING }
r := _INTEGER(temp); { PAST PLACES }
textattr := screen_attr(x,y);
gotoxy(x,y);
IF ICOMMA THEN
write(comma(r,RIGHT_JUST,0,INUM))
ELSE
WRITE(R:RIGHT_JUST);
end;
PROCEDURE READ_L( X,Y : INTEGER;
VAR R : LONGINT;
MIN,
MAX : LONGINT;
RIGHT_JUST : LONGINT;
ICOMMA : BOOLEAN);
var
temp : string[80];
len : integer;
SAT : BYTE;
S : BUF160;
begin
str(max:0,temp);
LEN := LENGTH(TEMP);
str(r:0,temp);
sat := screen_attr(x,y);
textattr := sat;
GOTOXY(X,Y);
WRITE(' ':RIGHT_JUST);
IF MIN < 0.0 THEN
BEGIN
len := LEN + 1; { +1 FOR MINUS SIGN }
REPEAT
read_str(x,y,temp,dup('+',len));
IF (_LONGINT(TEMP) < MIN) OR (_LONGINT(TEMP) > MAX) THEN
BEGIN
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',MIN:0,' to ',MAX:0,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL (_LONGINT(TEMP) >= MIN) AND (_LONGINT(TEMP) <= MAX);
END
ELSE
REPEAT
READ_STR(X,Y,TEMP,DUP('.',LEN));
IF (_LONGINT(TEMP) < MIN) OR (_LONGINT(TEMP) > MAX) THEN
BEGIN
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',MIN:0,' to ',MAX:0,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL (_LONGINT(TEMP) >= MIN) AND (_LONGINT(TEMP) <= MAX);
r := _LONGINT(temp);
str(r:0,temp); { THIS TRUNCATES ANYTHING }
r := _LONGINT(temp); { PAST PLACES }
textattr := screen_attr(x,y);
gotoxy(x,y);
IF ICOMMA THEN
write(comma(r,RIGHT_JUST,0,LNUM))
ELSE
WRITE(R:RIGHT_JUST);
end;
PROCEDURE READ_MONEY(X,Y : INTEGER;
VAR R : REAL;
DPLACES : INTEGER;
RIGHT_JUST : INTEGER;
LOW, HIGH : REAL);
VAR
I : INTEGER;
TEMP : STRING[15];
OLDATTR : BYTE;
LEN : INTEGER;
VALID_SET : SET OF CHAR;
FACTOR : REAL;
OLD_CUR : CURTYPE;
BEGIN
OLD_CUR := CUR;
SET_CURSOR(UNDERLINE);
FACTOR := 1;
FOR I := 1 TO DPLACES DO
FACTOR := FACTOR * 10;
VALID_SET := ['0'..'9',#8];
IF R > HIGH THEN R := HIGH;
IF R < LOW THEN R := LOW;
OLDATTR := SCREEN_ATTR(X,Y);
TEXTATTR := UT.INPUT_ATTR;
LEN := LENGTH(COMMA(HIGH,0,DPLACES,RNUM));
IF LOW < 0.0 THEN
BEGIN
VALID_SET := VALID_SET + ['-'];
IF LENGTH(COMMA(LOW,0,DPLACES,RNUM)) > LEN THEN
LEN := LENGTH(COMMA(LOW,0,DPLACES,RNUM));
END;
CHANGED := FALSE;
TEMP := COMMA(R,LEN,DPLACES,RNUM);
GOTOXY(X+RIGHT_JUST-LEN,Y);
WRITE(TEMP);
TEMP := '';
REPEAT
GOTOXY(X+RIGHT_JUST-1,Y);
READCH(CH,FALSE);
IF CH IN VALID_SET THEN
BEGIN
VALID_SET := VALID_SET - ['-'];
CHANGED := TRUE;
IF CH = #8 THEN
DELETE(TEMP,LENGTH(TEMP),1)
ELSE
IF (_REAL(TEMP+CH) > 0.0) THEN
IF (LENGTH(TEMP) < LEN) AND
((_REAL(TEMP+CH) / FACTOR) <= HIGH) THEN
TEMP := TEMP + CH
ELSE
ELSE
IF (LENGTH(TEMP) < LEN) AND
((_REAL(TEMP+CH) / FACTOR) >= LOW) THEN
TEMP := TEMP + CH;
R := _REAL(TEMP) / FACTOR;
GOTOXY(X+RIGHT_JUST-LEN,Y);
WRITE(COMMA(R,LEN,DPLACES,RNUM));
IF CH = '-' THEN
BEGIN
GOTOXY(X+RIGHT_JUST-LEN,Y);
WRITE('-');
END;
END;
UNTIL (CH = #27) OR (UT.EXITCH[ORD(CH)]);
TEXTATTR := OLDATTR;
GOTOXY(X,Y);
WRITE(COMMA(R,RIGHT_JUST,DPLACES,RNUM));
TEXTATTR := UT.DEFAULT_ATTR;
SET_CURSOR(OLD_CUR);
END;
PROCEDURE READ_DIGIT( X,Y : INTEGER;
VAR VALUE;
RIGHT_JUST : INTEGER;
LOW, HIGH : LONGINT;
NTYPE : TYPEN);
VAR
TEMP : STRING[15];
OLDATTR : BYTE;
LNUMBER : LONGINT ABSOLUTE VALUE;
INUMBER : INTEGER ABSOLUTE VALUE;
LEN : INTEGER;
VALID_SET : SET OF CHAR;
OLD_CUR : CURTYPE;
BEGIN
OLD_CUR := CUR;
SET_CURSOR(UNDERLINE);
VALID_SET := ['0'..'9',#8];
LEN := LENGTH(COMMA(HIGH,0,0,LNUM));
IF LOW < 0 THEN
BEGIN
VALID_SET := VALID_SET + ['-'];
IF LENGTH(COMMA(LOW,0,0,LNUM)) > LEN THEN
LEN := LENGTH(COMMA(LOW,0,0,LNUM));
END;
CASE NTYPE OF
LNUM : BEGIN
IF LNUMBER > HIGH THEN LNUMBER := HIGH;
IF LNUMBER < LOW THEN LNUMBER := LOW;
TEMP := COMMA(LNUMBER,LEN,0,LNUM);
END;
INUM : BEGIN
IF INUMBER > HIGH THEN INUMBER := HIGH;
IF INUMBER < LOW THEN INUMBER := LOW;
TEMP := COMMA(INUMBER,LEN,0,INUM);
END;
ELSE EXIT;
END;
OLDATTR := SCREEN_ATTR(X,Y);
TEXTATTR := UT.INPUT_ATTR;
CHANGED := FALSE;
GOTOXY(X+RIGHT_JUST-LEN,Y);
WRITE(TEMP);
TEMP := '';
REPEAT
GOTOXY(X+RIGHT_JUST-1,Y);
READCH(CH,FALSE);
IF CH IN VALID_SET THEN
BEGIN
VALID_SET := VALID_SET - ['-'];
CHANGED := TRUE;
IF CH = #8 THEN
DELETE(TEMP,LENGTH(TEMP),1)
ELSE
CASE NTYPE OF
LNUM : IF _LONGINT(TEMP+CH) > 0 THEN
IF (LENGTH(TEMP) < LEN) AND
((_LONGINT(TEMP+CH) <= HIGH)) THEN
TEMP := TEMP + CH
ELSE
ELSE
IF (LENGTH(TEMP) < LEN) AND
((_LONGINT(TEMP+CH) >= LOW)) THEN
TEMP := TEMP + CH;
INUM : IF _INTEGER(TEMP+CH) > 0 THEN
IF (LENGTH(TEMP) < LEN) AND
((_INTEGER(TEMP+CH) <= HIGH)) THEN
TEMP := TEMP + CH
ELSE
ELSE
IF (LENGTH(TEMP) < LEN) AND
((_INTEGER(TEMP+CH) >= LOW)) THEN
TEMP := TEMP+CH;
END;
GOTOXY(X+RIGHT_JUST-LEN,Y);
CASE NTYPE OF
LNUM : BEGIN
LNUMBER := _LONGINT(TEMP);
WRITE(COMMA(LNUMBER,LEN,0,LNUM));
END;
INUM : BEGIN
INUMBER := _INTEGER(TEMP);
WRITE(COMMA(INUMBER,LEN,0,INUM));
END;
END;
IF CH = '-' THEN
BEGIN
GOTOXY(X+RIGHT_JUST-LEN,Y);
WRITE('-');
END;
END;
UNTIL (CH = #27) OR (UT.EXITCH[ORD(CH)]);
TEXTATTR := OLDATTR;
GOTOXY(X+RIGHT_JUST-LEN,Y);
CASE NTYPE OF
LNUM : BEGIN
IF CHANGED THEN
LNUMBER := _LONGINT(TEMP);
WRITE(COMMA(LNUMBER,LEN,0,LNUM));
END;
INUM : BEGIN
IF CHANGED THEN
INUMBER := _INTEGER(TEMP);
WRITE(COMMA(INUMBER,LEN,0,INUM));
END;
END;
TEXTATTR := UT.DEFAULT_ATTR;
SET_CURSOR(OLD_CUR);
END;
FUNCTION BLANKS(INSTRING : STRING) : BOOLEAN;
BEGIN
BLANKS := PAD(' ',LENGTH(INSTRING)) = INSTRING;
END;
Function PackKey(Dte, Tme : str8) : longint;
var
Dow,
sec100 : word;
dt : DateTime;
Tlong : longint;
begin
if Dte = '' then
begin
GetDate(Dt.Year,Dt.Month,Dt.Day,Dow);
GetTime(Dt.Hour,Dt.Min,Dt.Sec,Sec100);
end
else
begin
if copy(Dte,7,2) < '80' then
Dt.Year := 2000 + _word(copy(Dte,7,2))
else
Dt.Year := 1900 + _word(copy(Dte,7,2));
Dt.Month := _word(copy(Dte,1,2));
Dt.Day := _word(copy(Dte,4,2));
Dt.Hour := _word(copy(Tme,1,2));
Dt.Min := _word(copy(Tme,4,2));
Dt.Sec := _word(copy(Tme,7,2));
end;
PackTime(Dt, Tlong);
PackKey := Tlong;
end;
Function UnPackKey(PK : longint) : str20;
var
Temp : str20;
Dt : DateTime;
begin
UnPackTime(PK, Dt);
temp := longint_str(Dt.Month,2) + '-' +
longint_str(Dt.Day,2) + '-' +
longint_str(Dt.Year,2) + ' ' +
longint_str(Dt.Hour,2) + ':' +
longint_str(Dt.Min,2) + ':' +
longint_str(Dt.Sec,2);
delete(temp,7,2);
if temp[1] = ' ' then temp[1] := '0';
if temp[4] = ' ' then temp[4] := '0';
if temp[7] = ' ' then temp[7] := '0';
if temp[10] = ' ' then temp[10] := '0';
if temp[13] = ' ' then temp[13] := '0';
if temp[16] = ' ' then temp[16] := '0';
UnPackKey := Temp;
end;
PROCEDURE StuffBuffer(S : STR16);
CONST
KbStart = $1E;
VAR
N,MAX : BYTE;
KbHead : WORD ABSOLUTE $40:$1A;
KbTail : WORD ABSOLUTE $40:$1C;
KbBuff : ARRAY [0..15] OF WORD ABSOLUTE $40:KbStart;
BEGIN
MAX := 15;
IF LENGTH(S) < MAX THEN
MAX := LENGTH(S);
ASM CLI END;
KbHead := KbStart;
KbTail := KbStart + 2*MAX;
FOR N := 1 TO MAX DO
KbBuff[PRED(N)] := WORD(S[N]);
ASM STI END;
END;
BEGIN
SHOW_ERROR := TRUE;
EXITSAVE := EXITPROC;
EXITPROC := @EXITHANDLER;
TEXTATTR_AT_ENTRY := TEXTATTR;
GEMINI_SYSTEMS := 'Ngmmwp![~{zkpt';
UN_ENCRYPT(GEMINI_SYSTEMS,69);
UT.TIMEX := 0;
UT.TIMEY := 2;
UT.TIME_TYPE := 'N';
UT.DATEX := 0;
UT.DATEY := 2;
UT.DATE_TYPE := ' '; { D,W,else }
UT.INPUT_ATTR := $70;
UT.DEFAULT_ATTR := $02;
UT.COMPILED_DATE := '%%-%%-%%';
UT.COMPILED_TIME := '%%:%%';
UT.NOCONV := FALSE;
FILLCHAR(UT.EXITCH,SIZEOF(UT.EXITCH),1);
FILLCHAR(UT.EXITCH[32],95,0);
UT.EXITCH[191] := FALSE;
UT.EXITCH[192] := FALSE;
UT.EXITCH[8] := FALSE;
UT.EXITCH[196] := FALSE;
UT.EXITCH[197] := FALSE;
UT.EXITCH[198] := FALSE;
UT.EXITCH[199] := FALSE;
SET_CURSOR(UNDERLINE);
BLINK_ON;
CGA_PRESENT := CGA_INSTALLED;
EGA_PRESENT := EGA_INSTALLED;
VGA_PRESENT := VGA_INSTALLED;
DYNAMIC_PATHEXEC := FALSE;
CURRENT_BORDER := 0;
GET_DOS_VER;
WRITE_TIME(0,1,'N');
WRITE_DATE(0,1,'N');
DISPLAY := #255;
NOCONV := #254;
CLEAR := #253;
X_IN := 1;
X_OUT := 1;
MASTERENV;
START_TIMER(TIM);
END.
