home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 14 / CD_ASCQ_14_0694.iso / news / 4547 / pgx122 / bbutil.pas < prev    next >
Pascal/Delphi Source File  |  1994-02-16  |  13KB  |  116 lines
  1. (* This file was mangled by Mangler 1.14 (c) Copyright 1993 by Berend de Boer *)
  2.  {$IFDEF DPMI} {$F+,X+,R-,I-,S-,X+,D+} {$ELSE} {$F+,X+,O+,R-,I-,S-,D+} {$ENDIF} UNIT BBUTIL ;INTERFACE USES OBJECTS ;
  3. CONST PRNLINEFEED =#10;PRNFORMFEED =#12;PRNCR =#13;PRNNL =#13#10;PRNLARGEON =#27+ 'W'+ #1;PRNSMALLON =#15;
  4. PRNSMALLOFF =#18;PRNLARGEOFF =#27+ 'W'+ #0;PRNCAN =#24;PRNUNDON =#27+ '-1';PRNUNDOFF =#27+ '-0';PRNBOLDON =#27+ 'E';
  5. PRNBOLDOFF =#27+ 'F';PRNDOUBLEON =#27+ 'G';PRNDOUBLEOFF =#27+ 'H';CONST MAANDEN :ARRAY [ 1 .. 12 ]  OF STRING [ 9 ]
  6. =('januari', 'februari', 'maart', 'april', 'mei', 'juni', 'juli', 'augustus', 'september', 'oktober', 'november',
  7. 'december');CONST MAXWORD =$FFFF ;TYPE PSLINK =^TSLINK ;TSLINK =RECORD VALUE :PSTRING ;NEXT :PSLINK ;END ;
  8. VAR VALCODE :WORD ;FUNCTION STRS (N :SHORTINT ):STRING ;FUNCTION STRB (N :BYTE ):STRING ;FUNCTION STRI
  9. (N :INTEGER ):STRING ;FUNCTION STRW (N :WORD ):STRING ;FUNCTION STRL (N :LONGINT ):STRING ;FUNCTION STRR (N :REAL ;
  10. WIDTH ,DECIMALS:WORD ):STRING ;FUNCTION LEADINGZERO (VALUE :WORD ):STRING ;FUNCTION HEXSTR (W :WORD ):STRING ;
  11. FUNCTION VALB (CONST S :STRING ):BYTE ;FUNCTION VALI (CONST S :STRING ):INTEGER ;FUNCTION VALW (CONST S :STRING ):WORD ;
  12. FUNCTION VALL (CONST S :STRING ):LONGINT ;FUNCTION VALR (CONST S :STRING ):REAL ;FUNCTION LOWCASE (C :CHAR ):CHAR ;
  13. FUNCTION LOWSTR (CONST S :STRING ):STRING ;FUNCTION UPSTR (CONST S :STRING ):STRING ;FUNCTION FANCYSTR (S :STRING
  14. ):STRING ;FUNCTION CPOS (C :CHAR ;CONST S :STRING ):BYTE ;FUNCTION EMPTY (CONST S :STRING ):BOOLEAN ;FUNCTION EXTRACTSTR
  15. (CONST FROM ,STARTSTR,ENDSTR:STRING ):STRING ;PROCEDURE FORMATSTR (VAR RESULT :STRING ;CONST FORMAT :STRING ;
  16. VAR PARAMS );FUNCTION FTCOPY (CONST S :STRING ;F ,T:WORD ):STRING ;FUNCTION GETDATESTR :STRING ;FUNCTION GETTIMESTR
  17. :STRING ;FUNCTION LEFTJUSTIFY (CONST S :STRING ;F_LEN :WORD ):STRING ;FUNCTION REPCHAR (C :CHAR ;COUNT :INTEGER ):STRING
  18. ;FUNCTION RIGHTJUSTIFY (CONST S :STRING ;F_LEN :WORD ):STRING ;FUNCTION SPC (COUNT :INTEGER ):STRING ;FUNCTION SPOILED
  19. (CONST S :STRING ):BOOLEAN ;FUNCTION STRIPSPC (CONST S :STRING ):STRING ;FUNCTION ZERORIGHTJUSTIFY (CONST S :STRING ;
  20. F_LEN :WORD ):STRING ;PROCEDURE FREESTR (P :PSTRING );FUNCTION GETSTR (P :PSTRING ):STRING ;PROCEDURE REPLACESTR
  21. (VAR P :PSTRING ;S :STRING );FUNCTION CMPB (CONST PTR1 ,PTR2;SIZE :WORD ):INTEGER ;FUNCTION CMPW (CONST PTR1 ,PTR2;
  22. SIZE :WORD ):INTEGER ;PROCEDURE COMPARE (VAR PTR1 ,PTR2;RSIZE :WORD ;VAR FLAG :BYTE );FUNCTION DATEVALID (CONST S :STRING
  23. ):BOOLEAN ;PROCEDURE DISCARD (VAR P );PROCEDURE DISPOSESLINK (PS :PSLINK );FUNCTION MIN (L1 ,L2:LONGINT ):LONGINT ;
  24. FUNCTION NEWSLINK (CONST STR :STRING ;ANEXT :PSLINK ):PSLINK ;PROCEDURE PRNWRITEDATE (YEAR ,MONTH,DAY:WORD );
  25. FUNCTION RND (R :REAL ):REAL ;FUNCTION SCANB (AREA :POINTER ;SIZE :WORD ;VALUE :BYTE ):WORD ;FUNCTION SCANW
  26. (AREA :POINTER ;SIZE :WORD ;VALUE :WORD ):WORD ;IMPLEMENTATION USES PRINTER , DOS ;FUNCTION STRS (N:SHORTINT):STRING ;
  27. VAR OO10:PSTRING;BEGIN ASM {} LES DI , @Result {} MOV WORD PTR OO10, DI {} MOV WORD PTR OO10+ 2 , ES {} END;STR (N , OO10
  28. ^);END ;FUNCTION STRB (N:BYTE):STRING ;VAR OO1O:STRING ;BEGIN STR (N , OO1O );STRB := OO1O ;END ;FUNCTION STRL
  29. (N:LONGINT):STRING ;VAR OO10:PSTRING;BEGIN ASM {} LES DI , @Result {} MOV WORD PTR OO10, DI {}
  30. MOV WORD PTR OO10+ 2 , ES {} END;STR (N , OO10 ^);END ;FUNCTION STRW (N:WORD):STRING ;VAR OO1O:STRING ;BEGIN STR (N ,
  31. OO1O );STRW := OO1O ;END ;FUNCTION STRI (N:INTEGER):STRING ;VAR OO1O:STRING ;BEGIN STR (N , OO1O );STRI := OO1O ;END ;
  32. FUNCTION STRR (N:REAL;WIDTH,DECIMALS:WORD):STRING ;VAR OO1O:STRING ;BEGIN STR (N :WIDTH :DECIMALS , OO1O );STRR := OO1O ;
  33. END ;FUNCTION LEADINGZERO (VALUE:WORD):STRING ;VAR OO1O:STRING ;BEGIN STR (VALUE , OO1O );IF LENGTH (OO1O )=1 THEN OO1O
  34. := '0'+ OO1O ;LEADINGZERO := OO1O ;END ;FUNCTION HEXSTR (W:WORD):STRING ;CONST OOIOOOI11OI1:ARRAY [ 0 .. 15 ]
  35.  OF CHAR='0123456789ABCDEF';BEGIN HEXSTR := OOIOOOI11OI1 [ (W SHR 12 )MOD 16 ] + OOIOOOI11OI1 [ (W SHR 8 )MOD 16 ] +
  36. OOIOOOI11OI1 [ (W SHR 4 )MOD 16 ] + OOIOOOI11OI1 [ W MOD 16 ] ;END ;FUNCTION VALB (CONST S:STRING ):BYTE ;VAR OIOO:WORD;
  37. BEGIN VAL (S , OIOO , VALCODE );VALB := LO (OIOO );END ;FUNCTION VALI (CONST S:STRING ):INTEGER ;VAR OIOO:INTEGER;
  38. BEGIN VAL (S , OIOO , VALCODE );VALI := OIOO ;END ;FUNCTION VALW (CONST S:STRING ):WORD ;VAR OIOO:WORD;BEGIN VAL (S ,
  39. OIOO , VALCODE );VALW := OIOO ;END ;FUNCTION VALL (CONST S:STRING ):LONGINT ;VAR OIOO:LONGINT;BEGIN VAL (S , OIOO ,
  40. VALCODE );VALL := OIOO ;END ;FUNCTION VALR (CONST S:STRING ):REAL ;VAR OO1I:REAL;BEGIN VAL (S , OO1I , VALCODE );VALR :=
  41. OO1I ;END ;FUNCTION LOWCASE (C:CHAR):CHAR ;BEGIN IF C IN [ 'A'.. 'Z'] THEN LOWCASE := CHR (ORD (C )+ (97 - 65 ))ELSE
  42. LOWCASE := C ;END ;FUNCTION LOWSTR (CONST S:STRING ):STRING ;ASSEMBLER;ASM {} PUSH DS {} CLD {} LDS SI , S{}
  43. LES DI , @Result {} LODSB {} STOSB {} XOR AH , AH {} XCHG AX , CX {} JCXZ @3 {} @1 : {} LODSB {} CMP AL , 'A' {} JB @2 {}
  44. CMP AL , 'Z' {} JA @2 {} ADD AL , 20H {} @2 : {} STOSB {} LOOP @1 {} @3 : {} POP DS {} END;FUNCTION UPSTR (CONST S:STRING
  45. ):STRING ;ASSEMBLER;ASM {} PUSH DS {} CLD {} LDS SI , S{} LES DI , @Result {} LODSB {} STOSB {} XOR AH , AH {}
  46. XCHG AX , CX {} JCXZ @3 {} @1 : {} LODSB {} CMP AL , 'a' {} JB @2 {} CMP AL , 'z' {} JA @2 {} SUB AL , 20H {} @2 : {}
  47. STOSB {} LOOP @1 {} @3 : {} POP DS {} END;FUNCTION FANCYSTR (S:STRING ):STRING ;VAR OIlO:WORD;BEGIN S [ 1 ] := UPCASE (S
  48. [ 1 ] );FOR OIlO := 2 TO LENGTH (S ) DO IF S [ OIlO - 1 ] <> ' 'THEN S [ OIlO ] := LOWCASE (S [ OIlO ] );FANCYSTR := S ;
  49. END ;FUNCTION CPOS (C:CHAR;CONST S:STRING ):BYTE ;ASSEMBLER;ASM {} MOV AL , C{} CLD {} LES DI , S{}
  50. MOV CL , ES : [ DI ] {} MOV AH , CL {} XOR CH , CH {} JCXZ @end {} INC DI {} REPNE SCASB {} JNZ @end {} NEG CL {}
  51. ADD CL , AH {} @end : {} MOV AL , CL {} END;FUNCTION EMPTY (CONST S:STRING ):BOOLEAN ;ASSEMBLER;ASM {} LES DI , S{}
  52. MOV CL , [ ES : DI ] {} XOR CH , CH {} JCXZ @Empty {} MOV AL , ' ' {} INC DI {} CLD {} REPE SCASB {} JZ @Empty {}
  53. MOV AX , 0 {} POP BP {} RET 4 {} @Empty : {} MOV AX , 1 {} END;FUNCTION EXTRACTSTR (CONST FROM,STARTSTR,ENDSTR:STRING
  54. ):STRING ;VAR OIlO,OIll:WORD;BEGIN IF STARTSTR =''THEN OIlO := 1 ELSE OIlO := POS (STARTSTR , FROM )+ LENGTH (STARTSTR );
  55. IF ENDSTR =''THEN OIll := LENGTH (FROM )ELSE OIll := POS (ENDSTR , FROM )- 1 ;IF (OIll < OIlO )AND (LENGTH (ENDSTR )=1
  56. )THEN BEGIN OIll := OIlO ;WHILE FROM [ OIll ] <> ENDSTR [ 1 ]  DO INC (OIll );DEC (OIll );END ;EXTRACTSTR := FTCOPY (FROM
  57. , OIlO , OIll );END ;{$L FORMAT.OBJ} PROCEDURE FORMATSTR (VAR RESULT:STRING ;CONST FORMAT:STRING ;VAR PARAMS);EXTERNAL;
  58. FUNCTION FTCOPY (CONST S:STRING ;F,T:WORD):STRING ;BEGIN {$IFOPT Q+} {$Q-} FTCOPY := COPY (S , F , T - F + 1 );{$Q+}
  59. {$ELSE} FTCOPY := COPY (S , F , T - F + 1 );{$ENDIF} END ;FUNCTION GETDATESTR :STRING ;
  60. VAR OOIl,OO0I,OIOO,OIlO11001ll:WORD;BEGIN GETDATE (OOIl , OO0I , OIOO , OIlO11001ll );GETDATESTR := STRW (OOIl )+ '-'+
  61. LEADINGZERO (OO0I )+ '-'+ LEADINGZERO (OIOO );END ;FUNCTION GETTIMESTR :STRING ;VAR OIlI,OO0I,OO1O,O11l0Il0:WORD;
  62. BEGIN GETTIME (OIlI , OO0I , OO1O , O11l0Il0 );GETTIMESTR := LEADINGZERO (OIlI )+ ':'+ LEADINGZERO (OO0I )+ ':'+
  63. LEADINGZERO (OO1O );END ;FUNCTION LEFTJUSTIFY (CONST S:STRING ;F_LEN:WORD):STRING ;BEGIN LEFTJUSTIFY := COPY (S + SPC
  64. (ABS (F_LEN - LENGTH (S ))), 1 , F_LEN );END ;FUNCTION REPCHAR (C:CHAR;COUNT:INTEGER):STRING ;VAR OO1O:STRING ;BEGIN IF
  65. COUNT <= 0 THEN REPCHAR := ''ELSE BEGIN FILLCHAR (OO1O [ 1 ] , COUNT , C );OO1O [ 0 ] := CHR (COUNT );REPCHAR := OO1O ;
  66. END ;END ;FUNCTION RIGHTJUSTIFY (CONST S:STRING ;F_LEN:WORD):STRING ;VAR OIOO:STRING ;BEGIN OIOO := SPC (ABS (F_LEN -
  67. LENGTH (S )))+ S ;RIGHTJUSTIFY := COPY (OIOO , LENGTH (OIOO )- F_LEN + 1 , F_LEN );END ;FUNCTION SPC
  68. (COUNT:INTEGER):STRING ;VAR OO1O:STRING ;BEGIN IF COUNT <= 0 THEN SPC := ''ELSE BEGIN FILLCHAR (OO1O [ 1 ] , ABS (COUNT
  69. ), ' ');OO1O [ 0 ] := CHR (ABS (COUNT ));SPC := OO1O ;END ;END ;FUNCTION SPOILED (CONST S:STRING ):BOOLEAN ;ASSEMBLER;
  70. ASM {} CLD {} LES SI , S{} MOV CL , [ ES : SI ] {} XOR CH , CH {} JCXZ @end {} INC SI {} @next : SEGES LODSB {}
  71. CMP AL , 32 {} JB @stop {} CMP AL , 163 {} JA @stop {} LOOP @next {} @end : MOV AL , 0 {} POP BP {} RET 4 {}
  72. @stop : MOV AL , 1 {} END;FUNCTION STRIPSPC (CONST S:STRING ):STRING ;ASSEMBLER;ASM {} LES DI , S{}
  73. MOV CL , [ ES : DI ] {} MOV CH , 0 {} JCXZ @end {} MOV AL , ' ' {} ADD DI , CX {} STD {} REPE SCASB {} JNZ @@1 {}
  74. JCXZ @end {} @@1 : {} INC CL {} CLD {} LES DI , S{} INC DI {} REPE SCASB {} DEC DI {} MOV SI , DI {} MOV DX , DS {}
  75. MOV AX , ES {} MOV DS , AX {} LES DI , @Result {} INC CL {} MOV [ ES : DI ] , CL {} INC DI {} REP MOVSB {} MOV DS , DX {}
  76. POP BP {} RET 4 {} @end : {} LES DI , @Result {} MOV [ ES : DI ] , CL {} END;FUNCTION ZERORIGHTJUSTIFY (CONST S:STRING ;
  77. F_LEN:WORD):STRING ;VAR OIOO:STRING ;BEGIN OIOO := REPCHAR ('0', ABS (F_LEN - LENGTH (S )))+ S ;ZERORIGHTJUSTIFY := COPY
  78. (OIOO , LENGTH (OIOO )- F_LEN + 1 , F_LEN );END ;FUNCTION GETSTR (P:PSTRING):STRING ;ASSEMBLER;ASM {} PUSH DS {}
  79. LDS SI , P{} MOV AX , DS {} CMP AX , 0 {} JE @nilptr {} LES DI , @Result {} CLD {} MOV CL , [ SI ] {} MOV CH , 0 {}
  80. INC CX {} REP MOVSB {} POP DS {} POP BP {} RET 4 {} @nilptr : {} POP DS {} LES BX , @Result {} XOR AX , AX {}
  81. MOV [ ES : BX ] , AX {} END;PROCEDURE FREESTR (P:PSTRING);BEGIN IF P <> NIL THEN DISPOSESTR (P );END ;
  82. PROCEDURE REPLACESTR (VAR P:PSTRING;S:STRING );BEGIN DISPOSESTR (P );P := NEWSTR (S );END ;PROCEDURE PRNWRITEDATE
  83. (YEAR,MONTH,DAY:WORD);BEGIN {$I-} WRITE (LST , LEADINGZERO (DAY ), '-');WRITE (LST , LEADINGZERO (MONTH ), '-'#39, YEAR
  84. MOD 100 );{$I+} END ;PROCEDURE COMPARE (VAR PTR1,PTR2;RSIZE:WORD;VAR FLAG:BYTE);ASSEMBLER;ASM {} MOV DX , DS {}
  85. LDS SI , PTR2{} LES DI , PTR1{} CLD {} MOV CX , RSIZE{} REPE CMPSW {} LDS BX , FLAG{} JAE @@1 {}
  86. MOV BYTE PTR [ BX ] , 01h {} MOV DS , DX {} POP BP {} RET 12 {} @@1 : JNE @@2 {} MOV BYTE PTR [ BX ] , 0h {}
  87. MOV DS , DX {} POP BP {} RET 12 {} @@2 : MOV BYTE PTR [ BX ] , 0FFh {} MOV DS , DX {} END;FUNCTION CMPB (CONST PTR1,PTR2;
  88. SIZE:WORD):INTEGER ;ASSEMBLER;ASM {} MOV DX , DS {} LDS SI , PTR2{} LES DI , PTR1{} CLD {} MOV CX , SIZE{} REPE CMPSB {}
  89. JAE @@AboveOrEqual {} MOV AX , 01h {} MOV DS , DX {} POP BP {} RET @Params {} @@AboveOrEqual : {} JNE @@Above {}
  90. MOV AX , 0h {} MOV DS , DX {} POP BP {} RET @Params {} @@Above : {} MOV AX , 0ffffh {} MOV DS , DX {} END;FUNCTION CMPW
  91. (CONST PTR1,PTR2;SIZE:WORD):INTEGER ;ASSEMBLER;ASM {} MOV DX , DS {} LDS SI , PTR2{} LES DI , PTR1{} CLD {}
  92. MOV CX , SIZE{} REPE CMPSW {} JAE @@AboveOrEqual {} MOV AX , 01h {} MOV DS , DX {} POP BP {} RET @Params {}
  93. @@AboveOrEqual : {} JNE @@Above {} MOV AX , 0h {} MOV DS , DX {} POP BP {} RET @Params {} @@Above : {} MOV AX , 0ffffh {}
  94. MOV DS , DX {} END;FUNCTION DATEVALID (CONST S:STRING ):BOOLEAN ;VAR OOIl,OO0I,OIOO:WORD;BEGIN DATEVALID := FALSE ;IF
  95. LENGTH (S )<> 8 THEN EXIT ;OOIl := 1900 + VALW (COPY (S , 1 , 2 ));IF VALCODE <> 0 THEN EXIT ;OO0I := VALW (COPY (S , 5 ,
  96. 2 ));IF VALCODE <> 0 THEN EXIT ;OIOO := VALW (COPY (S , 7 , 2 ));IF VALCODE <> 0 THEN EXIT ;IF OIOO < 1 THEN EXIT ;
  97. CASE OO0I  OF 1 , 3 , 5 , 7 , 8 , 10 , 12 :IF OIOO > 31 THEN EXIT ;4 , 6 , 9 , 11 :IF OIOO > 30 THEN EXIT ;2 :BEGIN IF
  98. OIOO > 29 THEN EXIT ;IF (OO0I MOD 4 <> 0 )AND (OIOO =29 )THEN EXIT ;END ;ELSE EXIT ;END ;DATEVALID := TRUE ;END ;
  99. PROCEDURE DISCARD (VAR P);VAR O11III0l:POBJECT ABSOLUTE P;BEGIN IF O11III0l <> NIL THEN BEGIN DISPOSE (O11III0l , DONE );
  100. O11III0l := NIL ;END ;END ;PROCEDURE DISPOSESLINK (PS:PSLINK);BEGIN IF PS <> NIL THEN BEGIN DISPOSESLINK (PS ^. NEXT );
  101. DISPOSESTR (PS ^. VALUE );DISPOSE (PS );END ;END ;FUNCTION MIN (L1,L2:LONGINT):LONGINT ;BEGIN IF L1 < L2 THEN MIN := L1
  102. ELSE MIN := L2 ;END ;FUNCTION NEWSLINK (CONST STR:STRING ;ANEXT:PSLINK):PSLINK ;VAR OI1000l1II00:PSLINK;BEGIN NEW
  103. (OI1000l1II00 );OI1000l1II00 ^. VALUE := NEWSTR (STR );OI1000l1II00 ^. NEXT := ANEXT ;NEWSLINK := OI1000l1II00 ;END ;
  104. FUNCTION RND (R:REAL):REAL ;VAR OO1O:STRING ;OI0ll01lOOOl:WORD;O11IlIIO:INTEGER;BEGIN STR (R :20 :3 , OO1O );IF OO1O [
  105. LENGTH (OO1O )- 2 ] ='-'THEN BEGIN O11IlIIO := POS ('.', OO1O )+ 2 ;IF OO1O [ O11IlIIO + 1 ] >= '5'THEN BEGIN INC (BYTE
  106. (OO1O [ O11IlIIO ] ));WHILE OO1O [ O11IlIIO ] =':' DO BEGIN OO1O [ O11IlIIO ] := '0';DEC (O11IlIIO );IF OO1O [ O11IlIIO ]
  107. ='.'THEN DEC (O11IlIIO );INC (OO1O [ O11IlIIO ] );END ;END ;VAL (COPY (OO1O , 1 , O11IlIIO ), R , OI0ll01lOOOl );
  108. END ELSE BEGIN O11IlIIO := POS ('.', OO1O )+ 2 ;IF OO1O [ O11IlIIO + 1 ] >= '5'THEN BEGIN INC (BYTE (OO1O [ O11IlIIO ]
  109. ));WHILE OO1O [ O11IlIIO ] =':' DO BEGIN OO1O [ O11IlIIO ] := '0';DEC (O11IlIIO );IF OO1O [ O11IlIIO ] ='.'THEN DEC
  110. (O11IlIIO );INC (OO1O [ O11IlIIO ] );END ;END ;VAL (COPY (OO1O , 1 , O11IlIIO ), R , OI0ll01lOOOl );END ;RND := R ;END ;
  111. FUNCTION SCANB (AREA:POINTER;SIZE:WORD;VALUE:BYTE):WORD ;ASSEMBLER;ASM {} MOV AL , VALUE{} CLD {} LES DI , AREA{}
  112. MOV CX , SIZE{} MOV BX , CX {} JCXZ @end {} REPNE SCASB {} JNZ @end {} NEG CX {} ADD CX , BX {} @end : {} MOV AX , CX {}
  113. END;FUNCTION SCANW (AREA:POINTER;SIZE:WORD;VALUE:WORD):WORD ;ASSEMBLER;ASM {} MOV AX , VALUE{} CLD {} LES DI , AREA{}
  114. MOV CX , SIZE{} MOV BX , CX {} JCXZ @end {} REPNE SCASW {} JNZ @end {} NEG CX {} ADD CX , BX {} @end : {} MOV AX , CX {}
  115. END;END .
  116.