home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / DIR_SRCH.ZIP / DIRSEARC.PAS
Encoding:
Pascal/Delphi Source File  |  1987-09-07  |  17.5 KB  |  650 lines
  1. {$G512,P512}
  2. {  The above compiler directives allow the I/O redirection, I use this
  3.    to be able to type control P to direct the output to the printer
  4.    as well as the screen when using this program from command.com.
  5.    These directives WILL NOT WORK unless you have version 3. To disable
  6.    these directives change the '$' to '*' to allow reversal of the
  7.    procedure later.
  8.  
  9. }
  10. {$V-}
  11. {  Simple whole disk catalog program.
  12.  
  13.    This program will search the entire disk for a file and print out the
  14.    directory information found.  The entries follow the following rules.
  15.  
  16.    for Dir:
  17.           leave blank for current directory,
  18.           if you want the entire disk searched enter just a back slash,
  19.           if you wanta search started at a particular directory then
  20.           completely specify that directory( for example C:\turbo\irs\)
  21.           the trailing backslash is required.
  22.  
  23.    for File Mask:
  24.           use the rules for wild card specification spelled out in the
  25.           DOS manual. ( for example: *.* , att*.* , ??.* and so on )
  26.  
  27.  
  28.     Search Sub Directories:
  29.           if you enter 'Y' or 'y' to this responce the program will
  30.           search for any subdirectories encountered when starting at
  31.           the specified input.
  32.  
  33.     This program will also check the command line buffer for input
  34.     to allow the program to be used from the command.com with a
  35.     command line.  If you enter just one entry on the command line
  36.     then it will be assumed to be the file mask and the current
  37.     directory will be searched but not sub directories.  If you
  38.     enter two entries on the command line the first one will be assumed
  39.     to be the file mask and the 2nd whether to search sub directories.
  40.     If you enter three entries the first is the Dir to start at, the
  41.     2nd the File mask, and the third whether sub directories should be
  42.     searched.
  43.  
  44.     examples:
  45.  
  46.  
  47.       catalog *.bak    -   look for all *.bak's in the current dir.
  48.  
  49.      catalog *.bak y   -   look for all *.bak's from the current dir
  50.                            to the last sub dir on this path.
  51.  
  52.      catalog  \turbo\ *.bak y   - look for all the *.bak's starting at
  53.                                   the \turbo point in the path to the
  54.                                   last sub dir on this path.
  55.  
  56.      catalog  \  *.bak y  -  search the disk stating at the root for all
  57.                              *.bak's .
  58.  
  59.  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  60.  
  61.    This program travels through the directory using a method called
  62.    pre-order traversal.  That means as you look at each entry in a dir
  63.    for a match, if the entry is another dir then that dir will be checked
  64.    before looking at the next entry in the current dir.  This also means that
  65.    when the end of the start director is hit the program is done.
  66.  
  67.    Because of the search method used the order of the print out can be
  68.    confusing, I could fix it but this program works for what I use it for.
  69.  
  70. }
  71. program Catalog;
  72. type
  73.    AnyString =   String[255];
  74.    Str80     =   String[80];
  75.    CommandLine = string[128];
  76.    CmdArray    = Array[1..20] of CommandLine;
  77.  
  78. Var
  79.    FileMask,
  80.    DirMask   :   String[80];
  81.    SubDir    :   boolean;
  82.    Error,
  83.    No,
  84.    I         :   integer;
  85.    Subs,
  86.    Continue  :   Char;
  87.    Sline     :   CommandLine;
  88.    Entries   :   CmdArray;
  89.  
  90. {*I bios.pas    }
  91. type
  92.    Bios     =    Record
  93.                  AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags:Integer;
  94.                  end;
  95.  
  96.    BiosB    =    Record
  97.                  AL,AH,BL,BH,CL,CH,DL,DH:Byte;
  98.                  end;
  99.    DTA      =    String[80];
  100.  
  101.  
  102. procedure GetDate(var Year,Month,Day:Integer);
  103. var
  104.    Reg      :    Bios;
  105.    RegB     :    BiosB absolute Reg;
  106.  
  107. begin
  108.    RegB.AH:=$2A;
  109.    MsDos(Reg);
  110.    Year:=Reg.CX;
  111.    Month:=RegB.DH;
  112.    Day:=RegB.DL;
  113. end;
  114.  
  115. Procedure GetTime(var Hrs,Min,Sec,HSec:Integer);
  116. var
  117.    Reg      :    Bios;
  118.    RegB     :    BiosB absolute Reg;
  119.  
  120. begin
  121.    RegB.AH:=$2C;
  122.    MsDos(Reg);
  123.    Hrs:=RegB.CH;
  124.    Min:=RegB.CL;
  125.    Sec:=RegB.DH;
  126.    HSec:=RegB.DL;
  127. end;
  128.  
  129. Procedure GetIntr(IntrNumber:integer;var CodeSegment,Offset,Error:Integer);
  130. var
  131.    Reg      :    Bios;
  132.    RegB     :    BiosB absolute Reg;
  133.  
  134. begin
  135.    Error:=0;
  136.    RegB.AH:=$35;
  137.    RegB.AL:=IntrNumber;
  138.    MsDos(Reg);
  139.    CodeSegment:=Reg.ES;
  140.    Offset:=Reg.BX;
  141.    If (Reg.Flags And 1)=1 then Error:=RegB.AL;
  142. end;
  143.  
  144. Procedure MakeDir(DataSegment,Offset:Integer;var Error:integer);
  145. var
  146.    Reg      :    Bios;
  147.    RegB     :    BiosB absolute Reg;
  148.  
  149. Begin
  150.    Error:=0;
  151.    RegB.AH:=$39;
  152.    Reg.DS:=DataSegment;
  153.    Reg.DX:=Offset;
  154.    MsDos(Reg);
  155.    If (Reg.Flags And 1)=1 then Error:=RegB.AL;
  156. end;
  157.  
  158. Procedure RemoveDir(DataSegment,Offset:Integer;var Error:integer);
  159. var
  160.    Reg      :    Bios;
  161.    RegB     :    BiosB absolute Reg;
  162.  
  163. Begin
  164.    Error:=0;
  165.    RegB.AH:=$3A;
  166.    Reg.DS:=DataSegment;
  167.    Reg.DX:=Offset;
  168.    MsDos(Reg);
  169.    If (Reg.Flags And 1)=1 then Error:=RegB.AL;
  170. end;
  171.  
  172. Procedure GetCurrentDir(var Name:DTA;var Error:integer);
  173. var
  174.    Reg      :    Bios;
  175.    RegB     :    BiosB absolute Reg;
  176.    I        :    Integer;
  177. Begin
  178.    Error:=0;
  179.    Name[0]:=Chr(0);
  180.    RegB.AH:=$47;
  181.    Reg.DS:=Seg(Name);
  182.    Reg.SI:=Ofs(Name)+1;
  183.    RegB.DL:=0;
  184.    MsDos(Reg);
  185.    If (Reg.Flags And 1)=1 then Error:=RegB.AL;
  186.    If Error=0 then
  187.      begin
  188.         I:=0;
  189.         repeat
  190.          I:=I+1;
  191.         Until (I=64) or (Name[I]=Chr(0));
  192.         Name[0]:=Chr(I);
  193.      end;
  194. end;
  195.  
  196. {*I bios2.pas   }
  197. type
  198.   Registers= Record Case Integer Of
  199.                  1: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer);
  200.                  2: (al,ah,bl,bh,cl,ch,dl,dh: Byte);
  201.                End;
  202.  
  203.   String80      = string[80];
  204.  
  205. procedure SetDTA(MEMSeg,MEMOff:Integer;var Err:Integer );
  206. var
  207.    DOSRegs   :   Registers;
  208. begin
  209.   With DOSRegs do
  210.     begin
  211.       Err   := 0;               { Assume No Error }
  212.       ah := $1A;                { Function used to set the DTA }
  213.       DS := MEMSeg;             { store the parameter Segment in DS }
  214.       DX := MEMOff;             {   "    "      "     Offset in DX }
  215.       MSDos( DOSRegs );
  216.       If (Flags And 1) = 1 then
  217.         Err := al;
  218.      end;
  219. end;
  220.  
  221. procedure GetDTA(var MEMSeg,MEMOff:Integer;
  222.                          var Err : Integer );
  223. var
  224.    DOSRegs   :   Registers;
  225. begin
  226.   With DOSRegs do
  227.     begin
  228.       ah := $2F;      { Function used to get current DTA address }
  229.       MSDos( DOSRegs );
  230.       MEMSeg := ES;   { Segment of DTA returned by DOS }
  231.       MEMOff := BX;   { Offset of DTA returned }
  232.       If (Flags and 1)=1 then
  233.         Err := al;
  234.     end;
  235. end;
  236.  
  237.  
  238. procedure GetFirstFile( Mask : String80; var NamR : String80;
  239.                     MEMSeg, MEMOff : Integer; Option : Integer;
  240.                     var Err : Integer );
  241. var
  242.    DOSRegs   :   Registers;
  243.    I : Integer;
  244. begin
  245.   With DOSRegs do
  246.     begin
  247.       Err := 0;
  248.       ah := $4E;            { Get first directory entry }
  249.       DS := Seg( Mask );    { Point to the file Mask }
  250.       DX := Ofs( Mask )+1;
  251.       CX := Option;         { Store the Option }
  252.       MSDos( DOSRegs );
  253.       If (Flags and 1)=1 then
  254.         Err := al;
  255.     end;
  256.   I := 1;
  257.   repeat
  258.     NamR[ I ] := Chr( mem[ MEMSeg : MEMOff + 29 + I ] );
  259.     I := I + 1;
  260.   until ( not ( NamR[ I - 1 ] in [ ' '..'~' ] ));
  261.   NamR[ 0 ] := Chr( I - 1 );
  262. end;
  263.  
  264. procedure GetNextFile( var NamR : String80; MEMSeg, MEMOff : Integer;
  265.                         Option : Integer; var Err : Integer );
  266. var
  267.    DOSRegs   :   Registers;
  268.    I : Integer;
  269. begin
  270.   With DOSRegs do
  271.   begin
  272.     Err := 0;
  273.     ah := $4F;             { Function used to get the next }
  274.                            { directory entry }
  275.     CX := Option;          { Set the file option }
  276.     MSDos( DOSRegs );
  277.     If (Flags and 1)=1 then
  278.       Err := al;
  279.   end;
  280.   I := 1;
  281.   repeat
  282.     NamR[ I ] := Chr( mem[ MEMSeg : MEMOff + 29 + I ] );
  283.     I := I + 1;
  284.   until ( not ( NamR[ I - 1 ] in [ ' '..'~' ] ));
  285.   NamR[ 0 ] := Chr( I - 1 );
  286. end;
  287. {*I hexout.pas  }
  288.  
  289. type
  290.  
  291.      hex_string  =   string[4];
  292.  
  293.  
  294. function hexout(i:integer):hex_string;
  295. { take integer return hex for it in a string }
  296. var
  297.    dummy:string[4];
  298.    j,k:integer;
  299.  
  300. begin
  301.    for j:=1 to 4 do
  302.       begin
  303.          k:= i and $000F;
  304.          if k > 9 then k:=k+7;
  305.          dummy[5-j]:=chr(k+48);
  306.          i:= i shr 4
  307.       end;
  308.    dummy[0]:=chr(4);
  309.    hexout:=dummy
  310. end;
  311.  
  312. {*I parse.pas   }
  313. procedure parse(S:CommandLine;var No:integer;Var E:CmdArray);
  314. var
  315.   k                :         integer;
  316.   D                :         CommandLine;
  317.  
  318. begin
  319.   No:=ParamCount;
  320.   for k:=1 to No do
  321.     E[k]:=ParamStr(k);
  322. end;
  323. {*I fcb.inc     }
  324. type
  325.   FCB_Layout            =    record
  326.                                Drive             :    byte;
  327.                                FileName          :    Array[1..8] of char;
  328.                                FileExt           :    Array[1..3] of char;
  329.                                CurBlock          :    integer;
  330.                                RecSize           :    integer;
  331.                                FSizeLow          :    integer;
  332.                                FSizeHigh         :    integer;
  333.                                CreateDate        :    integer;
  334.                                CreateTime        :    integer;
  335.                                Flags             :    byte;
  336.                                DiskAddr1st       :    integer;
  337.                                DiskAddrLst       :    integer;
  338.                                LastAccess        :    Array [1..3] of byte;
  339.                                NextRecord        :    byte;
  340.                                RelRecLow         :    integer;
  341.                                RelRecHigh        :    integer;
  342.                              end;
  343.  
  344.  
  345. {*I filecomp.pas}
  346. function WildStrComp(S,A:Str80):boolean;
  347. { this function compares two strings, string A can contain '?' }
  348. { which match anything.                                        }
  349. Var
  350.    I,J    :   Integer;
  351.    Done,
  352.    Match  :   boolean;
  353.  
  354. begin
  355.    Match:=true;
  356.    I:=1;
  357.    J:=Length(A);
  358.    Done:=false;
  359.    If Length(A)<>Length(S) then
  360.      Match:=false
  361.    Else
  362.      begin
  363.         While Match and not Done do
  364.           begin
  365.             If ( I > J ) then Done:=true
  366.             Else
  367.             If A[I]<>'?' then
  368.                If UpCase(A[I])<>UpCase(S[I]) then
  369.                  Match:=false;
  370.             If Match then
  371.               I:=I+1;
  372.           end;
  373.      end;
  374.    WildStrComp:=Match;
  375. end;
  376.  
  377. function FileNameScan(S:Str80):Str80;
  378. var
  379.   T                     :    FCB_Layout;
  380.   i                     :    integer;
  381.   Regs                  :    Registers;
  382.  
  383. begin
  384.   S:=S+Chr(0);
  385.   with Regs do
  386.     begin
  387.       ah:=$29;
  388.       al:=0;
  389.       DS:=Seg(S);
  390.       SI:=Ofs(S)+1;
  391.       ES:=Seg(T);
  392.       DI:=Ofs(T);
  393.     end;
  394.   with T do
  395.     begin
  396.       for i:=1 to 8 do
  397.         FileName[i]:=' ';
  398.       for i:=1 to 3 do
  399.         FileExt[i]:=' ';
  400.     end;
  401.   MsDos(Regs);
  402.   with T do
  403.     begin
  404.       for i:=1 to 8 do
  405.         S[i]:=FileName[i];
  406.       S[9]:='.';
  407.       for i:=1 to 3 do
  408.         S[9+i]:=FileExt[i];
  409.       S[0]:=Chr(12);
  410.     end;
  411.   FileNameScan:=S;
  412. end;
  413.  
  414. procedure FileMaskScan(var S:Str80);
  415. begin
  416.    S:=FileNameScan(S);
  417. end;
  418.  
  419. {*I fillzero.pas}
  420. procedure FillZero(var S:AnyString);
  421. var
  422.   I                :         integer;
  423. begin
  424.   for I:=1 to Length(S) do
  425.     If S[I]=' ' then
  426.       S[I]:='0';
  427. end;
  428. {*I dirutil.pas }
  429. type
  430.    BiosString = String[80];
  431.    DateStr    = String[8];
  432.    TimeStr    = String[8];
  433.  
  434. function DecodeDiskDate(I:integer):DateStr;
  435. var
  436.   D                :         DateStr;
  437.   K                :         integer;
  438.   S                :         String[2];
  439. begin
  440.   D:='';
  441.   If I<>0 then
  442.     begin
  443.       K:=(I shr 5) and $0F;
  444.       Str(K:2,S);
  445.       D:=S;
  446.       K:=I and $1F;
  447.       Str(K:2,S);
  448.       D:=D+'/'+S+'/';
  449.       K:=(I shr 9);
  450.       Str(K+80:2,S);
  451.       D:=D+S;
  452.       FillZero(D);
  453.     end;
  454.   DecodeDiskDate:=D;
  455. end;
  456.  
  457. function DecodeDiskTime(I:integer):TimeStr;
  458. var
  459.   D                :         TimeStr;
  460.   K                :         integer;
  461.   S                :         String[2];
  462. begin
  463.   K:=(I shr 11);
  464.   If K>12 then
  465.     K:=K-12
  466.   else
  467.   If K=0 then
  468.     K:=12;
  469.   Str(K:2,S);
  470.   D:=S+':';
  471.   K:=(I shr 5) and $3F;
  472.   Str(K:2,S);
  473.   D:=D+S;
  474.   FillZero(D);
  475.   K:=(I shr 11);
  476.   If K>12 then D:=D+' pm'
  477.   else If K=12 then D:=D+'  m'
  478.   else D:=D+' am';
  479.   DecodeDiskTime:=D;
  480. end;
  481.  
  482. procedure ExtractFileInfo(var DTABuffer:BiosString;var DirFlag:boolean;
  483.                       var FileSize:Real;var Attr:integer;
  484.                       var Day:DateStr; var Tme:TimeStr);
  485. Var
  486.    Tmp       :   Real;
  487. Begin
  488.    DirFlag:=false;
  489.    FileSize:=0.0;
  490.    Attr:=Ord(DTABuffer[21]);
  491.    Day:=DecodeDiskDate(Ord(DTABuffer[24])+swap(Ord(DTABuffer[25])));
  492.    Tme:=DecodeDiskTime(Ord(DTABuffer[22])+swap(Ord(DTABuffer[23])));
  493.    If (Attr and $10)<>0 then
  494.           DirFlag:=true
  495.    else
  496.      begin
  497.         FileSize:=Ord(DTABuffer[26])+(Ord(DTABuffer[27])*256.0);
  498.         Tmp:=Ord(DTABuffer[28])+(Ord(DTABuffer[29])*256.0);
  499.         if Tmp<>0 then
  500.           FileSize:=(Tmp*65535.0)+FileSize;
  501.      end;
  502. end;
  503.  
  504.  
  505. procedure SearchDir(DirMask:BiosString;var FileMask:BiosString;
  506.                     var Option:Integer;var SubDir:boolean);
  507.  
  508. Var
  509.    SaveDTASeg,
  510.    SaveDTAOfs,
  511.    FileCount,
  512.    Attr,
  513.    Error     :   Integer;
  514.    FirstTime,
  515.    PrintFlag,
  516.    Dir       :   boolean;
  517.    DirCur,
  518.    DTABuffer,
  519.    FileName  :   BiosString;
  520.    FileSize,
  521.    Total     :   Real;
  522.    Date      :   DateStr;
  523.    Time      :   TimeStr;
  524. begin
  525.    FirstTime:=true;
  526.    DirCur:=DirMask+'*.*'+Chr(0);
  527.    GetDTA(SaveDTASeg,SaveDTAOfs,Error);
  528.    SetDTA(Seg(DTABuffer),Ofs(DTABuffer),Error);
  529.    GetFirstFile(DirCur,FileName,Seg(DTABuffer),Ofs(DTABuffer),Option,Error);
  530.    Total:=0.0;
  531.    FileCount:=0;
  532.    If Error=0 then
  533.      begin
  534.         PrintFlag:=WildStrComp(FileNameScan(Copy(FileName,1,Length(FileName)-1)),
  535.                                FileMask);
  536.         If PrintFlag and FirstTime then
  537.           begin
  538.              FirstTime:=False;
  539.              Writeln('Directory : ',DirMask,FileMask);
  540.           end;
  541.         ExtractFileInfo(DTABuffer,Dir,FileSize,Attr,Date,Time);
  542.         If PrintFlag then
  543.           begin
  544.              write(FileName,'':(14-length(FileName)),'<',Copy(Hexout(Attr),3,2),'>');
  545.              If Not Dir then
  546.                write('':3,FileSize:8:0,' ',Date:8,' ',Time)
  547.              else
  548.                write('':3,'<DIR>    ',Date:8,' ',Time);
  549.              writeln;
  550.              Total:=Total+FileSize;
  551.              FileCount:=FileCount+1;
  552.           end;
  553.         If Dir and SubDir and (FileName[1]<>'.') then
  554.           begin
  555.              FileName:=Copy(FileName,1,Length(FileName)-1);
  556.              SearchDir(DirMask+FileName+'\',FileMask,Option,SubDir);
  557.           end
  558.      end;
  559.    While Error=0 do
  560.      begin
  561.         GetNextFile(FileName,Seg(DTABuffer),Ofs(DTABuffer),Option,Error);
  562.         If Error=0 then
  563.           begin
  564.              PrintFlag:=WildStrComp(FileNameScan(Copy(FileName,1,Length(FileName)-1)),
  565.                                     FileMask);
  566.              If PrintFlag and FirstTime then
  567.                begin
  568.                   FirstTime:=False;
  569.                   Writeln('Directory : ',DirMask,FileMask);
  570.                end;
  571.              ExtractFileInfo(DTABuffer,Dir,FileSize,Attr,Date,Time);
  572.              If PrintFlag then
  573.                begin
  574.                  write(FileName,'':(14-length(FileName)),'<',Copy(Hexout(Attr),3,2),'>');
  575.                  If Not Dir then
  576.                    write('':3,FileSize:8:0,' ',Date:8,' ',Time)
  577.                  else
  578.                    write('':3,'<DIR>    ',Date:8,' ',Time);
  579.                  writeln;
  580.                  Total:=Total+FileSize;
  581.                  FileCount:=FileCount+1;
  582.                end;
  583.              If Dir and SubDir and (FileName[1]<>'.') then
  584.                begin
  585.                   FileName:=Copy(FileName,1,Length(FileName)-1);
  586.                   SearchDir(DirMask+FileName+'\',FileMask,Option,SubDir);
  587.                end;
  588.          end;
  589.      end;
  590.    SetDTA(SaveDTASeg,SaveDTAOfs,Error);
  591.    If Not FirstTime then
  592.      begin
  593.         Writeln('Total for : ',DirMask,FileMask);
  594.         Writeln(FileCount,' File(s) with ',Total:10:0,' Byte(s)');
  595.      end;
  596. end;
  597. begin
  598.   No:=ParamCount;
  599.   If No>0 then
  600.     begin
  601.       Parse(Sline,No,Entries);
  602.       If No=3 then
  603.         begin
  604.           DirMask:=Entries[1];
  605.           FileMask:=Entries[2];
  606.           Subs:=Entries[3];
  607.         end
  608.       else
  609.       If No=2 then
  610.         begin
  611.           DirMask:=Entries[1];
  612.           FileMask:=Entries[2];
  613.           Subs:='N';
  614.         end
  615.       else
  616.       If No=1 then
  617.         begin
  618.           GetCurrentDir(DirMask,Error);
  619.           DirMask:=Copy(DirMask,1,Length(DirMask)-1);
  620.           If DirMask='' then DirMask:='\' else
  621.           DirMask:='\'+DirMask+'\';
  622.           FileMask:=Entries[1];
  623.           Subs:='N';
  624.         end
  625.       else
  626.         No:=0;
  627.     end;
  628.   Repeat
  629.    If No=0 then
  630.      begin
  631.        Writeln(Con);
  632.        Write(Con,'Dir : ');
  633.        Readln(Con,DirMask);
  634.        Write(Con,'File Mask : ');
  635.        Readln(Con,FileMask);
  636.        Write(Con,'Search Sub-Directories (Y/N) :');
  637.        Readln(Con,Subs);
  638.      end;
  639.    I:=16;
  640.    SubDir:=(UpCase(Subs)='Y');
  641.    FileMaskScan(FileMask);
  642.    SearchDir(DirMask,FileMask,I,SubDir);
  643.    If No=0 then
  644.      begin
  645.        Write(Con,'Continue Y/N:');
  646.        Readln(Con,Continue);
  647.      end;
  648.   Until (UpCase(Continue)='N') or (No<>0);
  649. end.