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