ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/MISCPAS.ZIP/WHERE.PAS

Pascal/Delphi Source File | 1992-06-23 | 16.5 KB | 395 lines

 Program WHERE - is a program to locate files on the IBM PC/XT or PC/AT
    hard disks. The search begins at the starting directory (root directory
    by default (\)) and traverses the tree for all files that match the
    search string. This search string may contain wildcards * and ?.

    Output: For each file found:

    nnnnn mm-dd-yy hh:mm pm pathname

        giving the file size, creation date and time, and complete pathname.

    The program is written in Pascal to be built with IBM Pascal 2.0.
    If anyone ports it to other Pascal compilers, please let me know.

    Mike Johnson
    MIT Project Athena
    [e-mail]

--------------
...and here is the source file:
--------------

{$include:'c:\usr\src\pascal\ibmintrp.int'}

{****************************************************************************}
{                                         }
{ Program WHERE - is a program to locate files on the IBM PC/XT or PC/AT     }
{    hard disks. The search begins at the starting directory (root directory }
{    by default (\)) and traverses the tree for all files that match the     }
{    search string. This search string may contain wildcards * and ?.         }
{                                         }
{    Output: For each file found:                                            }
{                                         }
{    nnnnn mm-dd-yy hh:mm pm pathname                                     }
{                                         }
{        giving the file size, creation date and time, and complete pathname. }
{                                         }
{    Syntax:  where [starting_directory]filename.ext                 }
{                                         }
{          starting_directory - the sub-tree of the directory heirarchy   }
{                   for the program to search             }
{          filename.ext     - standard DOS file description that may    }
{                   include wildcards * and ?.             }
{                                         }
{    To build:   using IBM Pascal Compiler, release 2.0:                     }
{                                         }
{          PAS1 where.pas,where.obj;                                      }
{          PAS2                                                           }
{          LINK where,where,NUL.MAP,\lib\ibmpas.lib+\lib\pascal.lib       }
{                                         }
{                                         }
{    Copyright:  1985  by the Massachusetts Institute of Technology         }
{                                         }
{         Permission to use, copy, modify, and distribute this         }
{         program for any purpose and without fee is hereby granted,  }
{         provided that this copyright and permission notice appear on}
{         all copies and supporting documentation, the name of M.I.T. }
{         not be used in advertising or publicity pertaining to         }
{         distribution of the program without specific prior         }
{         permission, and notice be given in supporting documentation }
{         that copying and distribution is by permission of M.I.T.    }
{         M.I.T. makes no representations about the suitability of    }
{         this software for any purpose. It is provided "as is"       }
{         without express or implied warranty.                 }
{                                         }
{         1984, 1985  by Mark S. Ackerman.                 }
{         Permission is granted for unlimited copies if not sold      }
{         or otherwise exchanged for gain.                 }
{                                         }
{    Status   :  Version 1.00                             }
{                                         }
{    Author   :  Michael G. Johnson, MIT Project Athena              }
{                                         }
{         This code is a port of Mark S. Ackerman's WHERE.C program   }
{         written for the Mark Williams C Compiler to the IBM Pascal  }
{         Compiler Version 2.00 . The C code and algorithm appear in  }
{         the October 1985 issue of the PC Tech Journal vol. 3 no. 10 }
{         page 85.                             }
{                                         }
{    Creation Date :   10/30/85                          }
{                                         }
{    Revisions       :   none                             }
{                                         }
{    Parameters passed     :                             }
{                                         }
{    incoming_string - the arguement line containing the starting         }
{              directory and the search string             }
{                                         }
{    Parameters returned : none                          }
{                                         }
{    Entry Conditions     : none                          }
{                                         }
{    Exit Conditions     :                             }
{                                         }
{      Normal  - Normal Pascal return sequence                 }
{      Special - None.                             }
{                                         }
{    External Calls     :                             }
{                                         }
{     intrp(intno, inregs, outregs) - performs a software interrupte,     }
{                     found in library IBMPAS.LIB         }
{          intno   : byte    ! interrupt number             }
{         Vars inregs  : reglist    ! register settings before interrupt }
{         Vars outregs : reglist    ! register settings after interrupt  }
{                                         }
{    External Data Areas ( Global Constants, Types, & Variables ) :         }
{                                         }
{      adsmem   - pointer structure to access data in memory          }
{             ADSMEM : ADS OF ARRAY [0..32766] OF BYTE             }
{                                         }
{      reglist  - record structure used to set and save system registers  }
{             REGLIST : RECORD                         }
{                   AX, BX, CX, DX, SI, DI, DS, ES, FLAGS : WORD  }
{                   END;                         }
{                                         }
{    Compiler  : IBM Personal Computer Pascal Compiler Version 2.00         }
{                                         }
{****************************************************************************}

Program WHERE (input, output, incoming_string);

   Uses ibmintrp;

   Const
     size_where_string = 255;               ! maximum string size
     backslash       = chr(#5C);               ! '\' character
     end_of_string       = chr(#00);               ! DOS ASCIIZ end of string char

   Type
     where_string  = string(size_where_string);    ! fixed length string
     where_lstring = lstring(size_where_string);   ! variable length string

   Var
     incoming_string  : where_string;           ! input command line
     directory_string : where_lstring;           ! starting directory
     check_string      : where_lstring;           ! search string
     time_ampm      : array [0..1] of string(2); ! AM/PM time indicator

   Value
     time_ampm[0] := 'am';
     time_ampm[1] := 'pm';

   {------------------------------------------------------------------------}
   {  Function INIT_STRINGS                            }
   {------------------------------------------------------------------------}
   Function init_strings : boolean;
     { Initialze the starting directory string and the search string,        }
     { DIRECTORY_STRING and CHECK_STRING respectively. This is done by        }
     { by parsing the command line (INCOMING_STRING) at the last backslash. }
     { If a backslask does not exist, the strating directory is by default  }
     { the root (\) and the search string in the command line            }

      Const
        space     = chr(#20);

      Var
        inc_size, dir_size, chk_size : integer;
        i : integer;

      Begin { function init_strings   }
     inc_size := ord(sizeof(incoming_string)) - 1;
     inc_size := inc_size +
             scanne(-inc_size, space, incoming_string, inc_size);
     dir_size := inc_size +
             scaneq(-inc_size, backslash, incoming_string, inc_size);
     chk_size := inc_size - dir_size;
     directory_string.len := wrd(dir_size);
     check_string.len     := wrd(chk_size);

     If dir_size = 0
        Then directory_string := '\'
        Else For i := 1 to dir_size
           Do directory_string[i] := incoming_string[i];
     If chk_size > 0
        Then For i := 1 to chk_size
          Do check_string[i] := incoming_string[i+dir_size];
     If inc_size > 0
        Then init_strings := true
        Else init_strings := false;
      End;  { function init_strings   }


   {------------------------------------------------------------------------}
   {  Procedure LOOKUP - is a recursive call that traverses the DOS tree    }
   {     heirarchy for files matching the the search string. Lookup is        }
   {     called once for each subdirectory and uses a post-order or suffix  }
   {     tree search.                                }
   {------------------------------------------------------------------------}
   Procedure lookup (Const directory_string : string);

      Const
        carry_flag_mask = #01;     ! carry flag mask for error checking
        no_type        = #00;     ! file attrib.- normal file, no archive
        directory_type  = #10;     ! file attrib.- directory
        no_more_files   = #12;     ! error code indicating no more files

      Type
        { DOS Disk Tranfer Area, see page 5-132 of DOS Tech Ref 3.0     }
        dta = record
           dta_data       : string(43);    ! DOS DTA, first 21 used by DOS
           dta_attr       : byte;           ! file attribute
           dta_time       : word;           ! file creation time
           dta_date       : word;           ! file creation date
           dta_size       : integer4;      ! file size
           dta_filename   : lstring(13);   ! ASCIIZ filename
        end;

      Var
        regs    : reglist;
        current_dta : dta;
        current_string    : where_lstring;
        newdirectory_string : where_lstring;

      {---------------------------------------------------------------------}
      {  Procedure SET_DTA - define the memory area where the DOS disk        }
      {     transfer area will be stored. This routine sets the         }
      {     DTA to be current_dta.dta_data. It does so by using DOS        }
      {     interrupt 21h, function 1Ah Set Disk Transfer Address.        }
      {---------------------------------------------------------------------}
      Procedure set_dta (Var current_dta : dta);

     Begin { procedure set_dta   }
        regs.ax := byword(#1A, #00);
        regs.ds := (ADS current_dta.dta_data[1]).s;
        regs.dx := (ADS current_dta.dta_data[1]).r;
        intrp(#21, regs, regs);
     End;  { procedure set_dta   }


      {---------------------------------------------------------------------}
      {  Procedure SET_DTA_VALUES - takes values in the Disk Transfer Area, }
      {     CURRENT_DTA.DTA_DATA and sets the remainder of the the data     }
      {     structure CURRENT_DTA. When the DTA gets set by DOS, it loads   }
      {     the memory in 43 consecutive bytes. Pascal 2.00 forces elements }
      {     in a record structure to predetermined alignments. This is the  }
      {     why the disk transfer area was not define as a RECORD with        }
      {     separate elments for time, data, size, etc. but as a string of  }
      {     43 bytes, then after being set transfered to record elments of  }
      {     the correct size.
      {---------------------------------------------------------------------}
      Procedure set_dta_values (Var current_dta : dta);

     Var
           i       : word;
           ads_mem : adsmem;

     Begin { procedure set_dta_values   }

        current_dta.dta_attr := wrd(current_dta.dta_data[22]);
        ads_mem := ads current_dta.dta_time;
        For i := 0 to 1 Do
          ads_mem^[i] := wrd(current_dta.dta_data[i+23]);
        ads_mem := ads current_dta.dta_date;
        For i := 0 to 1 Do
          ads_mem^[i] := wrd(current_dta.dta_data[i+25]);
        ads_mem := ads current_dta.dta_size;
        For i := 0 to 3 Do
          ads_mem^[i] := wrd(current_dta.dta_data[i+27]);
        i := 0;
        Repeat
          i := i + 1;
          current_dta.dta_filename[i] := current_dta.dta_data[i+31-1];
        Until (i >= 13) Or (current_dta.dta_filename[i] = end_of_string);
        current_dta.dta_filename[0] := chr(i-1);

     End;  { procedure set_dta_values   }

      {---------------------------------------------------------------------}
      {  Procedure GET_FIRST - find the first file having the file        }
      {     attribute FILETYPE, and matching the SEARCH_STRING. If a        }
      {     match is found, the DTA record CURRENT_DTA is updated.        }
      {     The DOS interrupt 21h, function 4Eh Find First Matching file    }
      {     is used achieve this.                        }
      {---------------------------------------------------------------------}
      Procedure get_first (Var search_string : string;
               Const filetype : integer;
               Var current_dta : dta);
     Begin { procedure get_first   }
        regs.ax := byword(#4E, #00);
        regs.cx := wrd(filetype);
        regs.ds := (ADS search_string).s;
        regs.dx := (ADS search_string).r;
        intrp(#21, regs, regs);
        set_dta_values(current_dta);
     End;  { procedure get_first   }

      {---------------------------------------------------------------------}
      {  Procedure GET_NEXT  - find the next file having the file attribute }
      {     and matches the search string as set in the GET_FIRST procedure.}
      {     The criteria for the search was saved in the DTA record element }
      {     CURRENT_DTA.DTA_DATA. The DOS interrupt 21h, function 4Eh        }
      {     Find Next Matching file is used to achieve this.            }
      {---------------------------------------------------------------------}
      Procedure get_next (Var current_dta : dta);
     Begin { procedure get_next   }
        regs.ax := byword(#4F, #00);
        intrp(#21, regs, regs);
        set_dta_values(current_dta);
     End;  { procedure get_next   }

      {---------------------------------------------------------------------}
      {  Procedure GET_FILES - is called once per subdirectory to look        }
      {     for all files matching the search string, and having a file     }
      {     attribute byte indicating a normal file with the archive bit    }
      {     not set.                                }
      {---------------------------------------------------------------------}
      Procedure get_files (Const directory_string : string;
               Var current_dta : dta);

     Const
           hrs_mask = 2#1111100000000000;    ! hour mask for time
           min_mask = 2#0000011111100000;    ! minute mask for time
           yrs_mask = 2#1111111000000000;    ! year mask for date
           mon_mask = 2#0000000111100000;    ! month mask for date
           day_mask = 2#0000000000011111;    ! day mask for date

     Var
           current_string : where_lstring;

     {------------------------------------------------------------------}
     {  Function HOUR - convert hour miltary time to AM/PM time        }
     {------------------------------------------------------------------}
     Function hour(Const military_hour : word) : word;
     Begin    { function hour }
        If (military_hour = 12) OR (military_hour = 0)
           then hour := 12
           else hour := military_hour MOD 12;
     End;    { function hour }

     Begin { procedure get_files   }
        copylst(directory_string, current_string);
        concat(current_string, check_string);
        concat(current_string, end_of_string);
        get_first(current_string, no_type, current_dta);
        While (regs.flags And carry_flag_mask) <> carry_flag_mask
           Do Begin   { write the file information out to OUTPUT }
          Writeln(current_dta.dta_size:10, ' ',
            ((current_dta.dta_date And mon_mask) DIV 32):2, '-',
            chr(((current_dta.dta_date And day_mask)) DIV 10 + #30),
            chr(((current_dta.dta_date And day_mask)) MOD 10 + #30), '-',
               (((current_dta.dta_date And yrs_mask) DIV 512) + 80):2, ' ',
           (hour((current_dta.dta_time And hrs_mask) DIV 2048)):2, ':',
            chr(((current_dta.dta_time And min_mask) DIV 32) DIV 10 + #30),
            chr(((current_dta.dta_time And min_mask) DIV 32) MOD 10 + #30), ' ',
              time_ampm[ord(((current_dta.dta_time And hrs_mask) DIV 2048) DIV 12)], ' ',
              directory_string,
              current_dta.dta_filename);
          get_next(current_dta);
           End;     { write the file information out to OUTPUT }
        If (regs.ax <> no_more_files)
           Then Writeln('problem with looking for ', current_string);
     End;  { procedure get_files   }

   Begin { procedure lookup   }
      copylst(directory_string, current_string);
      concat(current_string, '*.*');
      concat(current_string, end_of_string);
      set_dta(current_dta);
      get_first(current_string, directory_type, current_dta);
      While (regs.flags And carry_flag_mask) <> carry_flag_mask
     Do Begin
        If (current_dta.dta_attr = directory_type) And
           (current_dta.dta_filename[1] <> '.')
           Then Begin
          copylst(directory_string, newdirectory_string);
          concat(newdirectory_string, current_dta.dta_filename);
          concat(newdirectory_string, backslash);
          lookup(newdirectory_string);
          set_dta(current_dta);
           End;
        get_next(current_dta);
     End;
      If (regs.ax = no_more_files)
     Then get_files(directory_string, current_dta)
     Else Writeln('problem with looking thru ', directory_string);
   End;  { procedure lookup   }


{---------------------------------------------------------------------------}
{  Main Program WHERE                                }
{---------------------------------------------------------------------------}
Begin { main program where   }
   If init_strings
      Then lookup(directory_string)
      Else Begin
     writeln('Syntax:  where [starting_directory]filename.ext');
     writeln;
     writeln(' ':9,  'starting_directory - the sub-tree of the directory heirarchy');
     writeln(' ':30, 'for the program to search');
     writeln(' ':9,  'filename.ext       - standard DOS file description that may');
     writeln(' ':30, 'include wildcards * and ?.');
     writeln;
      End;
End.  { main program where   }