home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PIBCAT.ZIP / PIBCATS2.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1987-01-30  |  19.6 KB  |  434 lines
  1. (*--------------------------------------------------------------------------*)
  2. (*     TimeOfDayString --- Return current time of day as string             *)
  3. (*--------------------------------------------------------------------------*)
  4.  
  5. FUNCTION TimeOfDayString : AnyStr;
  6.  
  7. (*--------------------------------------------------------------------------*)
  8. (*                                                                          *)
  9. (*     Function:  TimeOfDayString                                           *)
  10. (*                                                                          *)
  11. (*     Purpose:   Return current time of day as string                      *)
  12. (*                                                                          *)
  13. (*     Calling sequence:                                                    *)
  14. (*                                                                          *)
  15. (*        Tstring := TimeOfDayString : AnyStr;                              *)
  16. (*                                                                          *)
  17. (*           Tstring  --- Resultant 'HH:MM am/pm' form of time              *)
  18. (*                                                                          *)
  19. (*--------------------------------------------------------------------------*)
  20.  
  21. VAR
  22.    Hours : INTEGER;
  23.    SH    : STRING[2];
  24.    SM    : STRING[2];
  25.    AmPm  : STRING[2];
  26.    Regs  : RegPack;
  27.  
  28. BEGIN (* TimeOfDayString *)
  29.                                    (* Time of day interrupt *)
  30.    Regs.Ax := $2C00;
  31.    INTR( $21 , Regs );
  32.  
  33.    Hours   := Regs.Ch;
  34.  
  35.    Adjust_Hour( Hours , AmPm );
  36.  
  37.    STR( Hours  :2, SH );
  38.    STR( Regs.Cl:2, SM );
  39.  
  40.    IF SM[1] = ' ' THEN SM[1] := '0';
  41.  
  42.    TimeOfDayString := SH + ':' + SM + ' ' + AmPm;
  43.  
  44. END   (* TimeOfDayString *);
  45.  
  46. (*--------------------------------------------------------------------------*)
  47. (*             DateString  --- Return current date in string form           *)
  48. (*--------------------------------------------------------------------------*)
  49.  
  50. FUNCTION DateString : AnyStr;
  51.  
  52. (*--------------------------------------------------------------------------*)
  53. (*                                                                          *)
  54. (*     Function:  DateString                                                *)
  55. (*                                                                          *)
  56. (*     Purpose:   Returns current date in string form                       *)
  57. (*                                                                          *)
  58. (*     Calling sequence:                                                    *)
  59. (*                                                                          *)
  60. (*        Dstring := DateString: AnyStr;                                    *)
  61. (*                                                                          *)
  62. (*           Dstring     --- Resultant string form of date                  *)
  63. (*                                                                          *)
  64. (*     Calls:  MsDos                                                        *)
  65. (*                                                                          *)
  66. (*--------------------------------------------------------------------------*)
  67.  
  68. VAR
  69.   RecPack:       RegPack;
  70.   Month:         STRING[3];
  71.   Day:           STRING[2];
  72.   Year:          STRING[2];
  73.  
  74. BEGIN (* DateString *)
  75.                                    (* Date function *)
  76.   RecPack.Ax := $2A00;
  77.                                    (* Get date from DOS *)
  78.   MsDos( RecPack );
  79.                                    (* Convert to MM/DD/YY string *)
  80.   WITH Recpack DO
  81.      BEGIN
  82.         STR( Cx - 1900 :2 , Year  );
  83.         STR( Dx MOD 256:2 , Day   );
  84.         Month := Month_Names[ Dx SHR 8 ];
  85.      END;
  86.  
  87.   DateString := Day + '-' + Month + '-' + Year;
  88.  
  89. END   (* DateString *);
  90.  
  91. (*----------------------------------------------------------------------*)
  92. (*         Long_To_Real --- Convert 32 bit INTEGER to real              *)
  93. (*----------------------------------------------------------------------*)
  94.  
  95. FUNCTION Long_To_Real( Long : LongInt ) : REAL;
  96.  
  97. VAR
  98.    RLow : REAL;
  99.    RHigh: REAL;
  100.  
  101. BEGIN (* Long_To_Real *)
  102.  
  103.    WITH Long DO
  104.      BEGIN
  105.                                    (* Convert low-order 16 bits *)
  106.         IF ( Low < 0 ) THEN
  107.            RLow := 65536.0 + Low
  108.         ELSE
  109.            RLow := Low;
  110.                                    (* Convert high-order 16 bits *)
  111.         IF ( High < 0 ) THEN
  112.            RHigh := 65536.0 + High
  113.         ELSE
  114.            RHigh := High;
  115.  
  116.      END;
  117.                                    (* Put 'em together! *)
  118.  
  119.    Long_To_Real := RHigh * 65536.0 + RLow;
  120.  
  121. END   (* Long_To_Real *);
  122.  
  123. (*----------------------------------------------------------------------*)
  124. (*            Open_File --- Open untyped file for processing            *)
  125. (*----------------------------------------------------------------------*)
  126.  
  127. PROCEDURE Open_File(     FileName : AnyStr;
  128.                      VAR AFile    : FILE;
  129.                      VAR File_Pos : REAL;
  130.                      VAR Error    : INTEGER );
  131.  
  132. (*----------------------------------------------------------------------*)
  133. (*                                                                      *)
  134. (*    Procedure: Open_File                                              *)
  135. (*                                                                      *)
  136. (*    Purpose:   Opens untyped file (of byte) for input                 *)
  137. (*                                                                      *)
  138. (*    Calling sequence:                                                 *)
  139. (*                                                                      *)
  140. (*       Open_File(     FileName : AnyStr;                              *)
  141. (*                  VAR AFile    : FILE;                                *)
  142. (*                  VAR File_Pos : REAL;                                *)
  143. (*                  VAR Error    : INTEGER );                           *)
  144. (*                                                                      *)
  145. (*          FileName --- Name of file to open                           *)
  146. (*          AFile    --- Associated file variable                       *)
  147. (*          File_Pos --- Initial byte offset in file (always set to 0)  *)
  148. (*          Error    --- =  0:  Open went OK.                           *)
  149. (*                       <> 0:  Open failed.                            *)
  150. (*                                                                      *)
  151. (*----------------------------------------------------------------------*)
  152.  
  153. BEGIN (* Open_File *)
  154.                                    (* Try opening file.  Access       *)
  155.                                    (* is essentially as file of byte. *)
  156.      (*$I-*)
  157.   ASSIGN( AFile , FileName );
  158.   RESET ( AFile , 1 );
  159.      (*$I+*)
  160.                                    (* Check if open went OK or not *)
  161.   IF ( IOResult <> 0 ) THEN
  162.      Error := Open_Error
  163.   ELSE
  164.      Error := 0;
  165.                                    (* We are at beginning of file *)
  166.   File_Pos := 0.0;
  167.  
  168. END   (* Open_File *);
  169.  
  170. (*----------------------------------------------------------------------*)
  171. (*              Close_File --- Close an unytped file                    *)
  172. (*----------------------------------------------------------------------*)
  173.  
  174. PROCEDURE Close_File( VAR AFile : FILE );
  175.  
  176. (*----------------------------------------------------------------------*)
  177. (*                                                                      *)
  178. (*    Procedure: Close_File                                             *)
  179. (*                                                                      *)
  180. (*    Purpose:   Closes untyped file                                    *)
  181. (*                                                                      *)
  182. (*    Calling sequence:                                                 *)
  183. (*                                                                      *)
  184. (*       Close_File( VAR AFile : FILE );                                *)
  185. (*                                                                      *)
  186. (*          AFile    --- Associated file variable                       *)
  187. (*                                                                      *)
  188. (*----------------------------------------------------------------------*)
  189.  
  190. BEGIN (* Close_File *)
  191.                                    (* Close the file *)
  192.       (*$I-*)
  193.    CLOSE( AFile );
  194.       (*$I+*)
  195.                                    (* Clear error flag *)
  196.    IF ( IOResult <> 0 ) THEN;
  197.  
  198. END   (* Close_File *);
  199.  
  200. (*----------------------------------------------------------------------*)
  201. (*          Quit_Found --- Check if ^C hit on keyboard                  *)
  202. (*----------------------------------------------------------------------*)
  203.  
  204. FUNCTION QuitFound : BOOLEAN;
  205.  
  206. (*----------------------------------------------------------------------*)
  207. (*                                                                      *)
  208. (*    Function:  Quit_Found                                             *)
  209. (*                                                                      *)
  210. (*    Purpose:   Determines if keyboard input is ^C                     *)
  211. (*                                                                      *)
  212. (*    Calling sequence:                                                 *)
  213. (*                                                                      *)
  214. (*       Quit := Quit_Found : BOOLEAN;                                  *)
  215. (*                                                                      *)
  216. (*          Quit  --- TRUE if ^C typed at keyboard.                     *)
  217. (*                                                                      *)
  218. (*    Remarks:                                                          *)
  219. (*                                                                      *)
  220. (*       The cataloguing process can be halted by hitting ^C at the     *)
  221. (*       keyboard.  This routine is called when Find_Files notices that *)
  222. (*       keyboard input is waiting.  If ^C is found, then cataloguing   *)
  223. (*       stops at the next convenient breakpoint.  The global variable  *)
  224. (*       User_Break indicates that a ^C was found.                      *)
  225. (*                                                                      *)
  226. (*----------------------------------------------------------------------*)
  227.  
  228. VAR
  229.    Ch : CHAR;
  230.  
  231. BEGIN (* QuitFound *)
  232.                                    (* Character was hit -- read it *)
  233.    READ( Kbd, Ch );
  234.                                    (* If it is a ^C, set User_Break *)
  235.                                    (* so we halt at next convenient *)
  236.                                    (* location.                     *)
  237.  
  238.    User_Break := User_Break OR ( Ch = ^C );
  239.    QuitFound  := User_Break;
  240.                                    (* Purge anything else in keyboard *)
  241.                                    (* buffer                          *)
  242.    WHILE( KeyPressed ) DO
  243.       READ( Kbd, Ch );
  244.  
  245. END   (* QuitFound *);
  246.  
  247. (*----------------------------------------------------------------------*)
  248. (*           Check_Entry_Spec --- Check if entry spec is legitimate     *)
  249. (*----------------------------------------------------------------------*)
  250.  
  251. PROCEDURE Check_Entry_Spec(     Entry_Spec     : AnyStr;
  252.                             VAR Entry_Name     : String8;
  253.                             VAR Entry_Ext      : String3;
  254.                             VAR Use_Entry_Spec : BOOLEAN );
  255.  
  256. (*----------------------------------------------------------------------*)
  257. (*                                                                      *)
  258. (*    Procedure: Check_Entry_Spec                                       *)
  259. (*                                                                      *)
  260. (*    Purpose:   Check_Entry_Spec                                       *)
  261. (*                                                                      *)
  262. (*    Calling sequence:                                                 *)
  263. (*                                                                      *)
  264. (*       Check_Entry_Spec(     Entry_Spec     : AnyStr;                 *)
  265. (*                         VAR Entry_Name     : String8;                *)
  266. (*                         VAR Entry_Ext      : String3;                *)
  267. (*                         VAR Use_Entry_Spec : BOOLEAN );              *)
  268. (*                                                                      *)
  269. (*          Entry_Spec     --- The wildcard for .ARC/.LBR contents.     *)
  270. (*          Entry_Name     --- Output 8-char name part of wildcard      *)
  271. (*          Entry_Ext      --- Output 3-char extension part of wildcard *)
  272. (*          Use_Entry_Spec --- TRUE if Entry_Spec legitimate and not    *)
  273. (*                             equivalent to a "get all entries."       *)
  274. (*                                                                      *)
  275. (*    Remarks:                                                          *)
  276. (*                                                                      *)
  277. (*       This routine splits the original wildcard specification into   *)
  278. (*       two parts:  one corresponding to the name portion, and the     *)
  279. (*       other the extension portion.  "*" (match string) characters    *)
  280. (*       are converted to an appropriate series of "?" (match one char) *)
  281. (*       characters.                                                    *)
  282. (*                                                                      *)
  283. (*----------------------------------------------------------------------*)
  284.  
  285. VAR
  286.    ISpec : INTEGER;
  287.    IDot  : INTEGER;
  288.    LSpec : INTEGER;
  289.    IOut  : INTEGER;
  290.    QExt  : BOOLEAN;
  291.  
  292. BEGIN (* Check_Entry_Spec *)
  293.                                    (* Initialize name, extension *)
  294.                                    (* portion of wildcard        *)
  295.    Entry_Name := '????????';
  296.    Entry_Ext  := '???';
  297.                                    (* IOut points to name/ext position *)
  298.    IOut  := 0;
  299.                                    (* ISpec points to wildcard position *)
  300.    ISpec := 0;
  301.                                    (* Get length of wildcard *)
  302.  
  303.    LSpec := Min( LENGTH( Entry_Spec ) , 12 );
  304.  
  305.                                    (* See if '.' appears in Entry_Spec.  *)
  306.                                    (* If not, assume one after name part *)
  307.                                    (* of wildcard.                       *)
  308.  
  309.    IDot := POS( '.' , Entry_Spec );
  310.    IF ( IDot = 0 ) THEN
  311.       IDot := 9;
  312.                                    (* Point to first character in wildcard *)
  313.    ISpec := 1;
  314.                                    (* We start storing in name, not extension *)
  315.    QExt  := FALSE;
  316.                                    (* Loop over characters in wildcard *)
  317.  
  318.    WHILE( ISpec <= LSpec ) DO
  319.       BEGIN
  320.                                    (* Handle '.', '*', '?' specially; copy *)
  321.                                    (* rest directly to either name or      *)
  322.                                    (* extension portion of wildcard.       *)
  323.  
  324.          CASE Entry_Spec[ISpec] OF
  325.  
  326.             '.': BEGIN
  327.                     IOut := 0;
  328.                     QExt := TRUE;
  329.                  END;
  330.             '*': IF QExt THEN
  331.                     ISpec := 12
  332.                  ELSE
  333.                     ISpec := IDot - 1;
  334.             '?': IOut := IOut + 1;
  335.             ELSE BEGIN
  336.                     IOut := IOut + 1;
  337.                     IF QExt THEN
  338.                        Entry_Ext[IOut]  := Entry_Spec[ISpec]
  339.                     ELSE
  340.                        Entry_Name[IOut] := Entry_Spec[ISpec]
  341.                  END;
  342.  
  343.          END;
  344.                                    (* Point to next character in wildcard. *)
  345.          ISpec := ISpec + 1;
  346.  
  347.       END;
  348.                                    (* If wildcard turns out to be a  *)
  349.                                    (* 'match anything' spec, don't   *)
  350.                                    (* bother with any matching later *)
  351.                                    (* on.                            *)
  352.  
  353.    Use_Entry_Spec := ( Entry_Name <> '????????' ) OR
  354.                      ( Entry_Ext  <> '???'      );
  355.  
  356. END   (* Check_Entry_Spec *);
  357.  
  358. (*----------------------------------------------------------------------*)
  359. (*     Entry_Matches --- Check if given file name matches entry spec    *)
  360. (*----------------------------------------------------------------------*)
  361.  
  362. FUNCTION Entry_Matches( FileName : AnyStr ) : BOOLEAN;
  363.  
  364. (*----------------------------------------------------------------------*)
  365. (*                                                                      *)
  366. (*    Function:  Entry_Matches                                          *)
  367. (*                                                                      *)
  368. (*    Purpose:   Entry_Matches                                          *)
  369. (*                                                                      *)
  370. (*    Calling sequence:                                                 *)
  371. (*                                                                      *)
  372. (*       Matches := Entry_Matches( VAR FileName : AnyStr ) : BOOLEAN;   *)
  373. (*                                                                      *)
  374. (*          FileName --- name of file to check against entry spec       *)
  375. (*          Matches  --- set TRUE if FileName matches global            *)
  376. (*                       entry spec contained in 'Entry_Spec'.          *)
  377. (*                                                                      *)
  378. (*----------------------------------------------------------------------*)
  379.  
  380. VAR
  381.    IDot  : INTEGER;
  382.    IPos  : INTEGER;
  383.    Match : BOOLEAN;
  384.    FName : STRING[8];
  385.    FExt  : STRING[3];
  386.    LName : INTEGER;
  387.  
  388. BEGIN (* Entry_Matches *)
  389.                                    (* Assume match found to start. *)
  390.    Match := TRUE;
  391.                                    (* Initialize wildcard form of  *)
  392.                                    (* file name and extension.     *)
  393.    FName := '????????';
  394.    FExt  := '???';
  395.                                    (* Get length of filename *)
  396.    LName := LENGTH( FileName );
  397.                                    (* See if '.' appears in filename.    *)
  398.    IDot := POS( '.' , FileName );
  399.                                    (* Move name field to wildcard pattern *)
  400.    IF ( IDot > 0 ) THEN
  401.       BEGIN
  402.          MOVE( FileName[1],      FName[1], IDot  - 1    );
  403.          MOVE( FileName[IDot+1], FExt [1], LName - IDot )
  404.       END
  405.    ELSE
  406.       MOVE( FileName[1], FName[1], LName );
  407.  
  408.                                    (* IPos has position in name portion *)
  409.    IPos := 0;
  410.                                    (* Try matching name portion of file name *)
  411.                                    (* with wildcard for name portion.        *)
  412.    REPEAT
  413.       IPos  := IPos + 1;
  414.       IF ( Entry_Name[IPos] <> '?' ) THEN
  415.          Match := Match AND ( FName[IPos] = Entry_Name[IPos] );
  416.    UNTIL ( NOT Match ) OR ( IPos = 8 );
  417.  
  418.                                    (* IPos has position in extension portion *)
  419.    IPos := 0;
  420.                                    (* Try matching extension portion of file *)
  421.                                    (* name with wildcard for extension       *)
  422.                                    (* portion.  Unnecessary if name portions *)
  423.                                    (* didn't match.                          *)
  424.    IF Match THEN
  425.       REPEAT
  426.          IPos  := IPos + 1;
  427.          IF ( Entry_Ext[IPos] <> '?' ) THEN
  428.             Match := Match AND ( FExt[IPos] = Entry_Ext[IPos] );
  429.       UNTIL ( NOT Match ) OR ( IPos = 3 );
  430.  
  431.    Entry_Matches := Match;
  432.  
  433. END   (* Entry_Matches *);
  434.