Power-Programmierung

home *** CD-ROM | disk | FTP | other *** search

/ Power-Programmierung / CD1.mdf / pascal / library / dos / utility / utility.pas < prev

Wrap

Pascal/Delphi Source File | 1994-04-11 | 100.1 KB | 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.