home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PIBCAT.ZIP / PIBCATS1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-01-30  |  43.5 KB  |  875 lines
  1. (*--------------------------------------------------------------------------*)
  2. (*               Trim --- Trim trailing blanks from a string                *)
  3. (*--------------------------------------------------------------------------*)
  4.  
  5. FUNCTION Trim( S : AnyStr ) : AnyStr;
  6.  
  7. (*--------------------------------------------------------------------------*)
  8. (*                                                                          *)
  9. (*     Function:   Trim                                                     *)
  10. (*                                                                          *)
  11. (*     Purpose:    Trims trailing blanks from a string                      *)
  12. (*                                                                          *)
  13. (*     Calling sequence:                                                    *)
  14. (*                                                                          *)
  15. (*         Trimmed_S := TRIM( S );                                          *)
  16. (*                                                                          *)
  17. (*            S          --- the string to be trimmed                       *)
  18. (*            Trimmed_S  --- the trimmed version of S                       *)
  19. (*                                                                          *)
  20. (*     Calls:  None                                                         *)
  21. (*                                                                          *)
  22. (*     Remarks:                                                             *)
  23. (*                                                                          *)
  24. (*        Note that the original string itself is left untrimmed.           *)
  25. (*                                                                          *)
  26. (*--------------------------------------------------------------------------*)
  27.  
  28. VAR
  29.    I:       INTEGER;
  30.  
  31. BEGIN (* Trim *)
  32.  
  33.    I       := ORD( S[0] );
  34.  
  35.    WHILE ( I > 0 ) AND ( S[I] = ' ' ) DO
  36.       I := I - 1;
  37.  
  38.    S[0] := CHR( I );
  39.    Trim := S;
  40.  
  41. END   (* Trim *);
  42.  
  43. (*--------------------------------------------------------------------------*)
  44. (*                     Dupl -- Duplicate a character n times                *)
  45. (*--------------------------------------------------------------------------*)
  46.  
  47. FUNCTION Dupl( Dup_char : Char; Dup_Count: INTEGER ) : AnyStr;
  48.  
  49. (*--------------------------------------------------------------------------*)
  50. (*                                                                          *)
  51. (*    Function: Dupl                                                        *)
  52. (*                                                                          *)
  53. (*    Purpose:  Duplicate a character n times                               *)
  54. (*                                                                          *)
  55. (*    Calling Sequence:                                                     *)
  56. (*                                                                          *)
  57. (*       Dup_String := Dupl( Dup_Char: Char; Dup_Count: INTEGER ): AnyStr;  *)
  58. (*                                                                          *)
  59. (*          Dup_Char   --- Character to be duplicated                       *)
  60. (*          Dup_Count  --- Number of times to duplicate character           *)
  61. (*          Dup_String --- Resultant duplicated string                      *)
  62. (*                                                                          *)
  63. (*          Note:  If Dup_Count <= 0, a null string is returned.            *)
  64. (*                                                                          *)
  65. (*    Calls:  None                                                          *)
  66. (*                                                                          *)
  67. (*                                                                          *)
  68. (*    Remarks:                                                              *)
  69. (*                                                                          *)
  70. (*       This routine could be programmed directly in Turbo as:             *)
  71. (*                                                                          *)
  72. (*          VAR                                                             *)
  73. (*             S    : AnyStr;                                               *)
  74. (*                                                                          *)
  75. (*          BEGIN                                                           *)
  76. (*                                                                          *)
  77. (*             FillChar( S[1], Dup_Count, Dup_Char );                       *)
  78. (*             S[0] := CHR( Dup_Count );                                    *)
  79. (*                                                                          *)
  80. (*             Dupl := S;                                                   *)
  81. (*                                                                          *)
  82. (*          END;                                                            *)
  83. (*                                                                          *)
  84. (*--------------------------------------------------------------------------*)
  85.  
  86. BEGIN (* Dupl *)
  87.  
  88.    INLINE(  $16/                   (* PUSH      SS         ; Push stack ptr        *)
  89.             $07/                   (* POP       ES         ; For result addressing *)
  90.             $8B/$4E/$04/           (* MOV       CX,[BP+4]  ; Pick up dup count     *)
  91.             $88/$4E/$08/           (* MOV       [BP+8],CL  ; Store result length   *)
  92.             $8B/$46/$06/           (* MOV       AX,[BP+6]  ; Get char to duplicate *)
  93.             $8D/$7E/$09/           (* LEA       DI,[BP+9]  ; Result address        *)
  94.             $FC/                   (* CLD                  ; Set direction flag    *)
  95.             $F3/$AA                (* REPLSTOSB            ; Perform duplication   *)
  96.          );
  97.  
  98. END   (* Dupl *);
  99.  
  100. (*----------------------------------------------------------------------*)
  101. (*               Min --- Find minimum of two integers                   *)
  102. (*----------------------------------------------------------------------*)
  103.  
  104. FUNCTION Min( A, B: INTEGER ) : INTEGER;
  105.  
  106. (*----------------------------------------------------------------------*)
  107. (*                                                                      *)
  108. (*   Function: Min                                                      *)
  109. (*                                                                      *)
  110. (*   Purpose:  Returns smaller of two numbers                           *)
  111. (*                                                                      *)
  112. (*   Calling sequence:                                                  *)
  113. (*                                                                      *)
  114. (*      Smaller := MIN( A , B ) : INTEGER;                              *)
  115. (*                                                                      *)
  116. (*         A       --- 1st input integer number                         *)
  117. (*         B       --- 2nd input integer number                         *)
  118. (*         Smaller --- smaller of A, B returned                         *)
  119. (*                                                                      *)
  120. (*                                                                      *)
  121. (*   Calls:  None                                                       *)
  122. (*                                                                      *)
  123. (*                                                                      *)
  124. (*----------------------------------------------------------------------*)
  125.  
  126. BEGIN (* Min *)
  127.  
  128.    IF A < B Then
  129.       Min := A
  130.    Else
  131.       Min := B;
  132.  
  133. END   (* Min *);
  134.  
  135. (*----------------------------------------------------------------------*)
  136. (*               Max --- Find maximum of two integers                   *)
  137. (*----------------------------------------------------------------------*)
  138.  
  139. FUNCTION Max( A, B: INTEGER ) : INTEGER;
  140.  
  141. (*----------------------------------------------------------------------*)
  142. (*                                                                      *)
  143. (*   Function:  Max                                                     *)
  144. (*                                                                      *)
  145. (*   Purpose:  Returns larger of two numbers                            *)
  146. (*                                                                      *)
  147. (*   Calling sequence:                                                  *)
  148. (*                                                                      *)
  149. (*      Larger := MAX( A , B ) : INTEGER;                               *)
  150. (*                                                                      *)
  151. (*         A       --- 1st input integer number                         *)
  152. (*         B       --- 2nd input integer number                         *)
  153. (*         Larger  --- Larger of A, B returned                          *)
  154. (*                                                                      *)
  155. (*                                                                      *)
  156. (*   Calls:  None                                                       *)
  157. (*                                                                      *)
  158. (*----------------------------------------------------------------------*)
  159.  
  160. BEGIN (* Max *)
  161.  
  162.    IF A > B Then
  163.       Max := A
  164.    Else
  165.       Max := B;
  166.  
  167. END   (* Max *);
  168.  
  169. (*--------------------------------------------------------------------------*)
  170. (*                 Substr -- Get substring of a string                      *)
  171. (*--------------------------------------------------------------------------*)
  172.  
  173. FUNCTION Substr( S : AnyStr; IS : INTEGER; NS: INTEGER ) : AnyStr;
  174.  
  175. (*--------------------------------------------------------------------------*)
  176. (*                                                                          *)
  177. (*    Function: Substr                                                      *)
  178. (*                                                                          *)
  179. (*    Purpose:  Takes substring of a string                                 *)
  180. (*                                                                          *)
  181. (*    Calling Sequence:                                                     *)
  182. (*                                                                          *)
  183. (*       Sub_String := Substr(  S: Anystr;                                  *)
  184. (*                             IS: INTEGER;                                 *)
  185. (*                             NS: INTEGER ): AnyStr;                       *)
  186. (*                                                                          *)
  187. (*          S   --- String to get substring from                            *)
  188. (*          IS  --- Starting character in S of substring to extract         *)
  189. (*          NS  --- Number of characters to extract                         *)
  190. (*                                                                          *)
  191. (*    Calls:  Copy                                                          *)
  192. (*                                                                          *)
  193. (*    Remarks:                                                              *)
  194. (*                                                                          *)
  195. (*       This routine handles null strings which COPY doesn't like.         *)
  196. (*                                                                          *)
  197. (*--------------------------------------------------------------------------*)
  198.  
  199. VAR
  200.    L : INTEGER;
  201.    L0: INTEGER;
  202.  
  203. BEGIN (* Substr *)
  204.                                    (* Keep all strings in proper range *)
  205.    L0 := ORD( S[0] );
  206.    L  := L0 - IS + 1;
  207.  
  208.    IF( L < NS ) THEN
  209.       NS := L;
  210.                                    (* Extract substring or return null string *)
  211.  
  212.    IF ( NS <= 0 ) OR ( IS < 1 ) OR ( IS > L0 ) THEN
  213.       Substr := ''
  214.    ELSE
  215.       Substr := COPY( S, IS, NS );
  216.  
  217. END   (* Substr *);
  218.  
  219. (*--------------------------------------------------------------------------*)
  220. (*               UpperCase --- Convert string to upper case                 *)
  221. (*--------------------------------------------------------------------------*)
  222.  
  223. FUNCTION UpperCase( S: AnyStr ): AnyStr;
  224.  
  225. (*--------------------------------------------------------------------------*)
  226. (*                                                                          *)
  227. (*    Function: UpperCase                                                   *)
  228. (*                                                                          *)
  229. (*    Purpose:  Convert string to upper case                                *)
  230. (*                                                                          *)
  231. (*    Calling Sequence:                                                     *)
  232. (*                                                                          *)
  233. (*       Upper_String := UpperCase( S : AnyStr ): AnyStr;                   *)
  234. (*                                                                          *)
  235. (*          S            --- String to be converted to upper case           *)
  236. (*          Upper_String --- Resultant uppercase string                     *)
  237. (*                                                                          *)
  238. (*    Calls:  UpCase                                                        *)
  239. (*                                                                          *)
  240. (*    Remarks:                                                              *)
  241. (*                                                                          *)
  242. (*       This routine could be coded directly in Turbo as:                  *)
  243. (*                                                                          *)
  244. (*          VAR                                                             *)
  245. (*              I    : INTEGER;                                             *)
  246. (*              L    : INTEGER;                                             *)
  247. (*              T    : AnyStr;                                              *)
  248. (*                                                                          *)
  249. (*          BEGIN                                                           *)
  250. (*                                                                          *)
  251. (*             L := ORD( S[0] );                                            *)
  252. (*                                                                          *)
  253. (*             FOR I := 1 TO L DO                                           *)
  254. (*                T[I] := UpCase( S[I] );                                   *)
  255. (*                                                                          *)
  256. (*             T[0]      := CHR( L );                                       *)
  257. (*             UpperCase := T;                                              *)
  258. (*                                                                          *)
  259. (*         END;                                                             *)
  260. (*                                                                          *)
  261. (*--------------------------------------------------------------------------*)
  262.  
  263. BEGIN (* UpperCase *)
  264.  
  265.    INLINE(  $1E/                   (*      PUSH      DS          ; Save DS           *)
  266.             $8A/$4E/$04/           (*      MOV       CL,[BP+4]   ; Get length of S   *)
  267.             $30/$ED/               (*      XOR       CH,CH       ; Clear CH          *)
  268.             $8D/$76/$05/           (*      LEA       SI,[BP+5]   ; First source char *)
  269.             $8D/$BE/$04/$01/       (*      LEA       DI,[BP+260] ; Result length     *)
  270.             $36/$88/$0D/           (*      MOV       SS[DI],CL   ; Store length      *)
  271.             $80/$F9/$00/           (*      CMP       CL,0        ; Check for null    *)
  272.             $76/$18/               (*      JLE       L3          ; Quit if null      *)
  273.             $47/                   (*      INC       DI          ; First char result *)
  274.             $8C/$D0/               (*      MOV       AX,SS       ; Save stack addr   *)
  275.             $8E/$D8/               (*      MOV       DS,AX       ; For source        *)
  276.             $8E/$C0/               (*      MOV       ES,AX       ; For result        *)
  277.             $FC/                   (*      CLD                   ; Forward direction *)
  278.             $8A/$04/               (* L1:  MOV       AL,[SI]     ; Next source char  *)
  279.             $3C/$61/               (*      CMP       AL,'a'      ; Compare with 'a'  *)
  280.             $72/$06/               (*      JL        L2          ; Below  -- skip    *)
  281.             $3C/$7A/               (*      CMP       AL,'z'      ; Compare with 'z'  *)
  282.             $77/$02/               (*      JH        L2          ; Above  -- skip    *)
  283.             $2C/$20/               (*      SUB       AL,32       ; Uppercase letter  *)
  284.             $AA/                   (* L2:  STOSB                 ; Store in result   *)
  285.             $46/                   (*      INC       SI          ; Next char         *)
  286.             $E2/$F0/               (*      LOOP      L1          ;                   *)
  287.             $1F                    (* L3:  POP       DS          ; Restore DS        *)
  288.          );
  289.  
  290. END   (* UpperCase *);
  291.  
  292. (*--------------------------------------------------------------------------*)
  293. (*             Get_Dos_Version  --- Get MS DOS version number               *)
  294. (*--------------------------------------------------------------------------*)
  295.  
  296. FUNCTION Get_Dos_Version : INTEGER;
  297.  
  298. (*--------------------------------------------------------------------------*)
  299. (*                                                                          *)
  300. (*     Function:  Get_Dos_Version                                           *)
  301. (*                                                                          *)
  302. (*     Purpose:   Returns current date in string form                       *)
  303. (*                                                                          *)
  304. (*     Calling sequence:                                                    *)
  305. (*                                                                          *)
  306. (*        Dos_Version := Get_Dos_Version: INTEGER;                          *)
  307. (*                                                                          *)
  308. (*           Dos_Version --- Returns MS DOS version in packed form          *)
  309. (*                           LO( Dos_Version ) = Major version number       *)
  310. (*                           HI( Dos_Version ) = Minor version number       *)
  311. (*                                                                          *)
  312. (*     Calls:  MsDos                                                        *)
  313. (*                                                                          *)
  314. (*--------------------------------------------------------------------------*)
  315.  
  316. VAR
  317.   Regs: RegPack;
  318.  
  319. BEGIN (* Get_Dos_Version *)
  320.                                    (* Get version number function *)
  321.   Regs.AX := $3000;
  322.   MsDos( Regs );
  323.  
  324.   Get_Dos_Version := Regs.AX;
  325.  
  326. END   (* Get_Dos_Version *);
  327.  
  328. (*--------------------------------------------------------------------------*)
  329. (*        Adjust_Hour --- Convert 24 hour time to 12 hour am/pm             *)
  330. (*--------------------------------------------------------------------------*)
  331.  
  332. PROCEDURE Adjust_Hour( VAR Hour : INTEGER;
  333.                        VAR AmPm : STRING2 );
  334.  
  335. (*----------------------------------------------------------------------*)
  336. (*                                                                      *)
  337. (*    Procedure: Adjust_Hour                                            *)
  338. (*                                                                      *)
  339. (*    Purpose:   Converts 24 hour time to 12 hour am/pm time            *)
  340. (*                                                                      *)
  341. (*    Calling sequence:                                                 *)
  342. (*                                                                      *)
  343. (*       Adjust_Hour( VAR Hour : INTEGER; AmPm : String2 );             *)
  344. (*                                                                      *)
  345. (*          Hour --- Input = Hours in 24 hour form;                     *)
  346. (*                   Output = Hours in 12 hour form.                    *)
  347. (*          AmPm --- Output 'am' or 'pm' indicator                      *)
  348. (*                                                                      *)
  349. (*----------------------------------------------------------------------*)
  350.  
  351. BEGIN (* Adjust_Hour *)
  352.  
  353.    IF ( Hour < 12 ) THEN
  354.       BEGIN
  355.          AmPm := 'am';
  356.          IF ( Hour = 0 ) THEN
  357.             Hour := 12;
  358.       END
  359.    ELSE
  360.       BEGIN
  361.          AmPm := 'pm';
  362.          IF ( Hour <> 12 ) THEN
  363.             Hour := Hour - 12;
  364.       END;
  365.  
  366. END   (* Adjust_Hour *);
  367.  
  368. (*----------------------------------------------------------------------*)
  369. (*   Convert_String_To_AsciiZ -- Convert Turbo string to Ascii Z String *)
  370. (*----------------------------------------------------------------------*)
  371.  
  372. PROCEDURE Convert_String_To_AsciiZ( VAR S: AnyStr );
  373.  
  374. (*----------------------------------------------------------------------*)
  375. (*                                                                      *)
  376. (*     Procedure:  Convert_String_To_AsciiZ                             *)
  377. (*                                                                      *)
  378. (*     Purpose:    Convert Turbo string to ascii Z string               *)
  379. (*                                                                      *)
  380. (*     Calling Sequence:                                                *)
  381. (*                                                                      *)
  382. (*        Convert_String_To_AsciiZ( VAR S: AnyStr );                    *)
  383. (*                                                                      *)
  384. (*           S --- Turbo string to be turned into Ascii Z string        *)
  385. (*                                                                      *)
  386. (*     Calls:                                                           *)
  387. (*                                                                      *)
  388. (*        None                                                          *)
  389. (*                                                                      *)
  390. (*----------------------------------------------------------------------*)
  391.  
  392. BEGIN (* Convert_String_To_AsciiZ *)
  393.  
  394.    S := S + CHR( 0 );
  395.  
  396. END   (* Convert_String_To_AsciiZ *);
  397.  
  398. (*----------------------------------------------------------------------*)
  399. (*     Dir_Set_Disk_Transfer_Address --- Set DMA address for disk I/O   *)
  400. (*----------------------------------------------------------------------*)
  401.  
  402. PROCEDURE Dir_Set_Disk_Transfer_Address( VAR DMA_Buffer );
  403.  
  404. (*----------------------------------------------------------------------*)
  405. (*                                                                      *)
  406. (*     Procedure:  Dir_Set_Disk_Transfer_Address                        *)
  407. (*                                                                      *)
  408. (*     Purpose:    Sets DMA address for disk transfers                  *)
  409. (*                                                                      *)
  410. (*     Calling Sequence:                                                *)
  411. (*                                                                      *)
  412. (*        Dir_Set_Disk_Transfer_Address( VAR DMA_Buffer );              *)
  413. (*                                                                      *)
  414. (*           DMA_Buffer --- direct memory access buffer                 *)
  415. (*                                                                      *)
  416. (*     Calls:                                                           *)
  417. (*                                                                      *)
  418. (*        MsDos                                                         *)
  419. (*                                                                      *)
  420. (*----------------------------------------------------------------------*)
  421.  
  422. VAR
  423.    Dir_Reg: RegPack;
  424.  
  425. BEGIN (* Dir_Set_Disk_Transfer_Address *)
  426.  
  427.    Dir_Reg.Ax := $1A00;
  428.    Dir_Reg.Ds := SEG( DMA_Buffer );
  429.    Dir_Reg.Dx := OFS( DMA_Buffer );
  430.  
  431.    MsDos( Dir_Reg );
  432.  
  433. END   (* Dir_Set_Disk_Transfer_Address *);
  434.  
  435. (*----------------------------------------------------------------------*)
  436. (*            Dir_Get_Default_Drive --- Get Default Drive               *)
  437. (*----------------------------------------------------------------------*)
  438.  
  439. FUNCTION Dir_Get_Default_Drive: CHAR;
  440.  
  441. (*----------------------------------------------------------------------*)
  442. (*                                                                      *)
  443. (*     Function:  Dir_Get_Default_Drive                                 *)
  444. (*                                                                      *)
  445. (*     Purpose:   Gets default drive for disk I/O                       *)
  446. (*                                                                      *)
  447. (*     Calling Sequence:                                                *)
  448. (*                                                                      *)
  449. (*        Def_Drive := Dir_Get_Default_Drive : CHAR;                    *)
  450. (*                                                                      *)
  451. (*           Def_Drive --- Letter of default drive                      *)
  452. (*                                                                      *)
  453. (*     Calls:                                                           *)
  454. (*                                                                      *)
  455. (*        MsDos                                                         *)
  456. (*                                                                      *)
  457. (*----------------------------------------------------------------------*)
  458.  
  459. VAR
  460.    Dir_Reg: RegPack;
  461.  
  462. BEGIN  (* Dir_Get_Default_Drive *)
  463.  
  464.    Dir_Reg.Ah := $19;
  465.  
  466.    MsDos( Dir_Reg );
  467.  
  468.    Dir_Get_Default_Drive := CHR( Dir_Reg.Al + ORD( 'A' ) );
  469.  
  470. END   (* Dir_Get_Default_Drive *);
  471.  
  472. (*----------------------------------------------------------------------*)
  473. (*   Dir_Find_First_File --- Find First File Matching Given Specs       *)
  474. (*----------------------------------------------------------------------*)
  475.  
  476. FUNCTION Dir_Find_First_File(     File_Pattern: AnyStr;
  477.                               VAR First_File  : Directory_Record  ):
  478.                               INTEGER;
  479.  
  480. (*----------------------------------------------------------------------*)
  481. (*                                                                      *)
  482. (*     Function:   Dir_Find_First_File                                  *)
  483. (*                                                                      *)
  484. (*     Purpose:    Find first file in directory matching specs          *)
  485. (*                                                                      *)
  486. (*     Calling Sequence:                                                *)
  487. (*                                                                      *)
  488. (*        Iok := Dir_Find_First_File(     File_Pattern: AnyStr;         *)
  489. (*                                    VAR First_File  :                 *)
  490. (*                                        Directory_Record ): INTEGER;  *)
  491. (*                                                                      *)
  492. (*           File_Pattern --- File pattern to look for.                 *)
  493. (*           First_File   --- First file matching specs.                *)
  494. (*           Iok          --- 0 if file found, else MsDos return code.  *)
  495. (*                                                                      *)
  496. (*     Calls:                                                           *)
  497. (*                                                                      *)
  498. (*        Dir_Set_Disk_Transfer_Address                                 *)
  499. (*        MsDos                                                         *)
  500. (*                                                                      *)
  501. (*     Remarks:                                                         *)
  502. (*                                                                      *)
  503. (*        The file pattern can be any standard MSDOS file pattern,      *)
  504. (*        including wildcards.  For a complete directory list, enter    *)
  505. (*        '*.*' as the pattern.   Use routine 'Dir_Find_Next_File'      *)
  506. (*        to get the remaining files.                                   *)
  507. (*                                                                      *)
  508. (*----------------------------------------------------------------------*)
  509.  
  510. VAR
  511.    Dir_Reg: RegPack;
  512.  
  513. BEGIN (* Find_First_File *)
  514.  
  515.    Dir_Set_Disk_Transfer_Address( First_File );
  516.  
  517.    Convert_String_To_AsciiZ( File_Pattern );
  518.  
  519.    Dir_Reg.Ds := SEG( File_Pattern[1] );
  520.    Dir_Reg.Dx := OFS( File_Pattern[1] );
  521.    Dir_Reg.Ax := $4E00;
  522.    Dir_Reg.Cx := $FF;
  523.  
  524.    MsDos( Dir_Reg );
  525.  
  526.    IF ( Carry_Flag AND Dir_Reg.Flags ) = 0 THEN
  527.       Dir_Find_First_File := 0
  528.    ELSE
  529.       Dir_Find_First_File := Dir_Reg.Ax;
  530.  
  531. END   (* Find_First_File *);
  532.  
  533. (*----------------------------------------------------------------------*)
  534. (*     Dir_Find_Next_File  --- Find Next File Matching Given Specs      *)
  535. (*----------------------------------------------------------------------*)
  536.  
  537. FUNCTION Dir_Find_Next_File ( VAR Next_File : Directory_Record ) : INTEGER;
  538.  
  539. (*----------------------------------------------------------------------*)
  540. (*                                                                      *)
  541. (*     Function:   Dir_Find_Next_File                                   *)
  542. (*                                                                      *)
  543. (*     Purpose:    Finds next file in directory matching specs          *)
  544. (*                                                                      *)
  545. (*     Calling Sequence:                                                *)
  546. (*                                                                      *)
  547. (*        Iok := Dir_Find_Next_File ( VAR Next_File :                   *)
  548. (*                                        Directory_Record ) : INTEGER; *)
  549. (*                                                                      *)
  550. (*           Next_File    --- Next file matching specs.                 *)
  551. (*           Iok          --- Returned as 0 if file found, else MsDos   *)
  552. (*                            return code indicating error.             *)
  553. (*                                                                      *)
  554. (*     Calls:                                                           *)
  555. (*                                                                      *)
  556. (*        MsDos                                                         *)
  557. (*        Dir_Set_Disk_Transfer_Address                                 *)
  558. (*                                                                      *)
  559. (*----------------------------------------------------------------------*)
  560.  
  561. VAR
  562.    Dir_Reg : RegPack;
  563.  
  564. BEGIN (* Find_Next_File  *)
  565.  
  566.    Dir_Set_Disk_Transfer_Address( Next_File );
  567.  
  568.    Dir_Reg.Ax := $4F00;
  569.  
  570.    MsDos( Dir_Reg );
  571.  
  572.    IF ( Carry_Flag AND Dir_Reg.Flags ) = 0 THEN
  573.       Dir_Find_Next_File := 0
  574.    ELSE
  575.       Dir_Find_Next_File := Dir_Reg.Ax;
  576.  
  577. END   (* Find_Next_File  *);
  578.  
  579. (*----------------------------------------------------------------------*)
  580. (*     Dir_Get_Free_Space  --- Get free space in bytes on disk          *)
  581. (*----------------------------------------------------------------------*)
  582.  
  583. FUNCTION Dir_Get_Free_Space ( Drive : CHAR ) : REAL;
  584.  
  585. (*----------------------------------------------------------------------*)
  586. (*                                                                      *)
  587. (*     Function:   Dir_Get_Free_Space                                   *)
  588. (*                                                                      *)
  589. (*     Purpose:    Gets amount of available space on a drive            *)
  590. (*                                                                      *)
  591. (*     Calling Sequence:                                                *)
  592. (*                                                                      *)
  593. (*        FSpace := Dir_Get_Free_Space ( Drive : CHAR ) : REAL;         *)
  594. (*                                                                      *)
  595. (*           Drive        --- Drive letter for which to get free space  *)
  596. (*           Fspace       --- Returned number of bytes of free space    *)
  597. (*                                                                      *)
  598. (*     Calls:                                                           *)
  599. (*                                                                      *)
  600. (*        MsDos                                                         *)
  601. (*                                                                      *)
  602. (*     Remarks:                                                         *)
  603. (*                                                                      *)
  604. (*         If the free space can't be found, -1 is returned.            *)
  605. (*         This is most likely to happen if an unformatted or wrongly   *)
  606. (*         formatted disk is to be checked.                             *)
  607. (*                                                                      *)
  608. (*----------------------------------------------------------------------*)
  609.  
  610. VAR
  611.    Dir_Reg  : RegPack;
  612.    Clusters : REAL;
  613.    Sectors  : REAL;
  614.    Bytes    : REAL;
  615.  
  616. BEGIN (* Dir_Get_Free_Space  *)
  617.  
  618.                                    (* Request drive information *)
  619.  
  620.    Dir_Reg.DL := ORD(UpCase( Drive )) - ORD('A') + 1;
  621.    Dir_Reg.AH := $36;
  622.  
  623.    MsDos( Dir_Reg );
  624.  
  625.                                    (* Compute free space *)
  626.  
  627.    WITH Dir_Reg DO
  628.       BEGIN
  629.  
  630.          Sectors  := AX;
  631.          Clusters := BX;
  632.          Bytes    := CX;
  633.  
  634.          IF AX = $FFFF THEN
  635.             Dir_Get_Free_Space := -1.0
  636.          ELSE
  637.             Dir_Get_Free_Space := Clusters * Bytes * Sectors;
  638.  
  639.       END;
  640.  
  641. END   (* Dir_Get_Free_Space  *);
  642.  
  643. (*----------------------------------------------------------------------*)
  644. (*            Dir_Convert_Date --- Convert directory creation date      *)
  645. (*----------------------------------------------------------------------*)
  646.  
  647. PROCEDURE Dir_Convert_Date ( Date : INTEGER; VAR S_Date : AnyStr );
  648.  
  649. (*----------------------------------------------------------------------*)
  650. (*                                                                      *)
  651. (*     Procedure: Dir_Convert_Date                                      *)
  652. (*                                                                      *)
  653. (*     Purpose:   Convert creation date from directory to characters.   *)
  654. (*                                                                      *)
  655. (*     Calling Sequence:                                                *)
  656. (*                                                                      *)
  657. (*        Dir_Convert_Date( Date       : INTEGER;                       *)
  658. (*                          VAR S_Date : AnyStr ) : INTEGER;            *)
  659. (*                                                                      *)
  660. (*           Date   --- date as read from directory                     *)
  661. (*           S_Date --- converted date in dd-mon-yy format              *)
  662. (*                                                                      *)
  663. (*     Calls:                                                           *)
  664. (*                                                                      *)
  665. (*        STR                                                           *)
  666. (*                                                                      *)
  667. (*----------------------------------------------------------------------*)
  668.  
  669. VAR
  670.    YY : String[2];
  671.    MM : String[3];
  672.    DD : String[2];
  673.  
  674. BEGIN (* Dir_Convert_Date *)
  675.  
  676.    IF ( Date = 0 ) THEN
  677.       S_Date := '         '
  678.    ELSE
  679.       BEGIN
  680.  
  681.          STR( ( 80 + ( Date SHR 9 ) ) : 2 , YY );
  682.  
  683.          MM := Month_Names[ ( Date AND $01E0 ) SHR 5 ];
  684.  
  685.          STR( ( Date AND $001F ):2 , DD );
  686.  
  687.          S_Date := DD + '-' + MM + '-' + YY;
  688.  
  689.       END;
  690.  
  691. END  (* Dir_Convert_Date *);
  692.  
  693. (*----------------------------------------------------------------------*)
  694. (*            Dir_Convert_Time --- Convert directory creation time      *)
  695. (*----------------------------------------------------------------------*)
  696.  
  697. PROCEDURE Dir_Convert_Time ( Time : INTEGER; VAR S_Time : AnyStr );
  698.  
  699. (*----------------------------------------------------------------------*)
  700. (*                                                                      *)
  701. (*     Procedure: Dir_Convert_Time                                      *)
  702. (*                                                                      *)
  703. (*     Purpose:   Convert creation time from directory to characters.   *)
  704. (*                                                                      *)
  705. (*     Calling Sequence:                                                *)
  706. (*                                                                      *)
  707. (*        Dir_Convert_Time( Time       : INTEGER;                       *)
  708. (*                          VAR S_Time : AnyStr ) : INTEGER;            *)
  709. (*                                                                      *)
  710. (*           Time   --- time as read from directory                     *)
  711. (*           S_Time --- converted time in hh:mm am/pm                   *)
  712. (*                                                                      *)
  713. (*     Calls:                                                           *)
  714. (*                                                                      *)
  715. (*        STR                                                           *)
  716. (*                                                                      *)
  717. (*----------------------------------------------------------------------*)
  718.  
  719. VAR
  720.    HH   : String[2];
  721.    MM   : String[2];
  722.    AmPm : String[2];
  723.    Hour : INTEGER;
  724.  
  725. BEGIN (* Dir_Convert_Time *)
  726.  
  727.    IF ( Time = 0 ) THEN
  728.  
  729.       S_Time := '        '
  730.  
  731.    ELSE
  732.       BEGIN
  733.  
  734.          Hour := ( Time SHR 11 );
  735.  
  736.          Adjust_Hour( Hour , AmPm );
  737.  
  738.          STR( Hour:2 , HH );
  739.  
  740.          STR( ( ( Time AND $07E0 ) SHR 5 ):2 , MM );
  741.          IF MM[1] = ' ' THEN MM[1] := '0';
  742.  
  743.          S_Time := HH + ':' + MM + ' ' + AmPm;
  744.  
  745.       END;
  746.  
  747. END  (* Dir_Convert_Time *);
  748.  
  749. (*----------------------------------------------------------------------*)
  750. (*     Dir_Get_Volume_Label   ---  Get volume label of a disk           *)
  751. (*----------------------------------------------------------------------*)
  752.  
  753. PROCEDURE Dir_Get_Volume_Label(     Volume       : CHAR;
  754.                                 VAR Volume_Label : AnyStr;
  755.                                 VAR Date         : INTEGER;
  756.                                 VAR Time         : INTEGER );
  757.  
  758. (*----------------------------------------------------------------------*)
  759. (*                                                                      *)
  760. (*    Procedure: Dir_Get_Volume_Label                                   *)
  761. (*                                                                      *)
  762. (*    Purpose:   Gets volume label for specified disk                   *)
  763. (*                                                                      *)
  764. (*    Calling sequence:                                                 *)
  765. (*                                                                      *)
  766. (*       Dir_Get_Volume_Label(     Volume       : CHAR;                 *)
  767. (*                             VAR Volume_Label : AnyStr;               *)
  768. (*                             VAR Date         : INTEGER;              *)
  769. (*                             VAR Time         : INTEGER );            *)
  770. (*                                                                      *)
  771. (*          Volume       --- Disk letter for which to get label         *)
  772. (*          Volume_Label --- Actual label itself                        *)
  773. (*          Date         --- Creation date of volume label              *)
  774. (*          Time         --- Creation time of volume label              *)
  775. (*                                                                      *)
  776. (*    Remarks:                                                          *)
  777. (*                                                                      *)
  778. (*       Because of various bugs in the MS DOS 2.x file searching       *)
  779. (*       facilities, this routine will not return a volume date or time *)
  780. (*       for DOS 2.x.                                                   *)
  781. (*                                                                      *)
  782. (*----------------------------------------------------------------------*)
  783.  
  784. VAR
  785.    Volume_Data  : Directory_Record;
  786.    Regs         : RegPack;
  787.    Volume_Pat   : STRING[15];
  788.    OVolume_Data : Extended_FCB;
  789.    Volume_FCB   : Extended_FCB;
  790.  
  791. BEGIN (* Dir_Get_Volume_Label *)
  792.                                    (* Use FCB code for DOS 2.x *)
  793.  
  794.    IF ( LO( Get_Dos_Version ) = 2 ) THEN
  795.       WITH Regs DO
  796.          BEGIN (* Dos 2.x *)
  797.                                    (* Clear out FCBs *)
  798.  
  799.             FillChar( Volume_FCB  , 64, 0 );
  800.             FillChar( OVolume_Data, 64, 0 );
  801.  
  802.                                    (* Set up extended FCB for volume *)
  803.                                    (* label search.                  *)
  804.  
  805.             Volume_FCB.FCB_Flag    := $FF;
  806.             Volume_FCB.FCB_Attr    := Attribute_Volume_Label;
  807.             Volume_FCB.FCB_Drive   := ORD( Volume ) - ORD('A') + 1;
  808.  
  809.             FillChar( Volume_FCB.FCB_FileName, 11, '?' );
  810.  
  811.                                    (* Set address to receive volume label *)
  812.  
  813.             Dir_Set_Disk_Transfer_Address( OVolume_Data );
  814.  
  815.                                    (* Call DOS to search for volume label *)
  816.  
  817.             Regs.Ds := SEG( Volume_FCB );
  818.             Regs.Dx := OFS( Volume_FCB );
  819.             Regs.Ax := $1100;
  820.             MsDos( Regs );
  821.                                    (* Check if we got label.  If so,      *)
  822.                                    (* get it.  Date and time will most    *)
  823.                                    (* likely be garbage, so set them to   *)
  824.                                    (* zero so they won't be listed later. *)
  825.  
  826.             IF ( Regs.Al = $FF ) THEN
  827.                Volume_Label := ''
  828.             ELSE
  829.                Volume_Label := OVolume_Data.FCB_FileName;
  830.  
  831.             Date := 0;
  832.             Time := 0;
  833.  
  834.          END   (* Dos 2.x *)
  835.    ELSE
  836.       WITH Regs DO
  837.          BEGIN  (* Dos 3.x and higher *)
  838.  
  839.                                    (* Set up DMA address for volume info *)
  840.  
  841.             Dir_Set_Disk_Transfer_Address( Volume_Data );
  842.  
  843.                                    (* Search root directory for label *)
  844.  
  845.             Volume_Pat := Volume + ':*.*';
  846.  
  847.             Convert_String_To_AsciiZ( Volume_Pat );
  848.  
  849.             Regs.Ds := SEG( Volume_Pat[1] );
  850.             Regs.Dx := OFS( Volume_Pat[1] );
  851.             Regs.Ax := $4E00;
  852.             Regs.Cx := Attribute_Volume_Label;
  853.  
  854.                                    (* Find volume label *)
  855.             MsDos( Regs );
  856.  
  857.             IF ( Carry_Flag AND Regs.Flags ) <> 0 THEN
  858.                BEGIN                  (* No volume label found *)
  859.                   Volume_Label := '';
  860.                   Date         := 0;
  861.                   Time         := 0;
  862.                END
  863.             ELSE
  864.                WITH Volume_Data DO
  865.                   BEGIN               (* Extract volume label *)
  866.                      Volume_Label := TRIM( COPY( File_Name, 1, POS( #0 , File_Name ) - 1 ) );
  867.                      Date         := File_Date;
  868.                      Time         := File_Time;
  869.                   END;
  870.  
  871.          END (* Dos 3.x and higher *);
  872.  
  873. END   (* Dir_Get_Volume_Label *);
  874.  
  875.