home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PRMASTR3.ZIP / SEARCH.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-01-19  |  4.4 KB  |  188 lines
  1. {$f+}
  2. Unit Search;
  3.  
  4. Interface
  5.  
  6. uses dos;
  7.  
  8. type action_type = function(fname:string):byte;
  9.      flistptr    = ^flist;
  10.      flist       = record
  11.                      next : flistptr;
  12.                      fname: string;
  13.                    end;
  14.  
  15. var
  16.   numfilesinlist:integer;
  17.   filelist,
  18.   endoffilelist:flistptr;
  19.  
  20. procedure searchdirectory(fname:string;
  21.                           action:action_type;
  22.                           filespecs:byte;
  23.                           deldir,recurse:boolean;
  24.                           var evar:byte);
  25.  
  26. function match(fileset:string):boolean;
  27.  
  28. procedure deletefilelist;
  29.  
  30. procedure getfilelist(fileset:string;attribs:byte);
  31.  
  32. Implementation
  33.  
  34.  
  35. procedure searchdirectory(fname:string;
  36.                           action:action_type;
  37.                           filespecs:byte;
  38.                           deldir,recurse:boolean;
  39.                           var evar:byte);
  40.  
  41. var
  42.   nextdirectory:string;
  43.   tempdirectory:string;
  44.   newfilename  :string;
  45.   currentdta   :searchrec;
  46.   i,j          :integer;
  47.  
  48. begin
  49.   i:=length(fname);
  50.   while fname[i] <> '\' do
  51.     i:=i-1;
  52.  
  53.   if recurse then
  54.   begin
  55.       tempdirectory:=copy(fname,1,i) + '*.*';
  56.       findfirst(tempdirectory,anyfile,currentdta);
  57.  
  58.       while (doserror <> 18) do
  59.         begin
  60.           if ( ( (currentdta.attr and Directory) = Directory )
  61.           and (currentdta.name[1] <> '.'))
  62.           then
  63.             begin
  64.               nextdirectory:=copy(fname,1,i)+
  65.                              currentdta.name+
  66.                              copy(fname,i+1,length(fname)-i);
  67.               searchdirectory(nextdirectory,
  68.                               action,
  69.                               filespecs,
  70.                               deldir,
  71.                               recurse,
  72.                               evar);
  73.             end;
  74.           if evar > 0 then   {if we had an error then keep bailing out!}
  75.              exit;
  76.           findnext(currentdta);
  77.         end;
  78.   end;
  79.  
  80.   findfirst(fname,filespecs,currentdta);
  81.   if (doserror = 18) then
  82.     begin
  83.      {writeln(fname,' does not exist.');}
  84.      evar:=$FD;
  85.      exit;
  86.     end;
  87.  
  88.   while (doserror = 0) do
  89.     begin
  90.       if (currentdta.name[1] <> '.') then
  91.         begin
  92.           newfilename:='';
  93.           j:=length(fname);
  94.           while fname[j] <> '\' do
  95.             j:=j-1;
  96.           newfilename:=copy(fname,1,j);
  97.           newfilename:=newfilename+currentdta.name;
  98.           evar:=action(newfilename);
  99.           if (evar <> 0) and (evar <> $FF) then   {if error then bail out!}
  100.             exit;
  101.         end;
  102.  
  103.       findnext(currentdta);
  104.     end;
  105.  
  106.    if deldir then
  107.      if length(fname) < 4 then
  108.         writeln('I will not delete the root directory!')
  109.      else
  110.         begin
  111.           {$I-}
  112.           rmdir(copy(fname,1,i-1));
  113.           {$I+}
  114.           if ioresult <> 0 then
  115.              writeln('Unable to remove directory ',copy(fname,1,i-1))
  116.           else
  117.              writeln(copy(fname,1,i-1),' removed');
  118.         end;
  119. end;
  120.  
  121. function match(fileset:string):boolean;
  122. var
  123.    dirinfo:searchrec;
  124. begin
  125.    findfirst(fileset,anyfile,dirinfo);
  126.    if doserror in [2,3,18] then
  127.       match:=false
  128.    else
  129.       match:=true;
  130. end;
  131.  
  132. {add a filename to the filelist}
  133. function look4afile(thefilename:string):byte;
  134. var
  135.    tnode:flistptr;
  136.    tname:namestr;
  137. begin
  138.   new(tnode);
  139.   endoffilelist^.next:=tnode;
  140.   with tnode^ do
  141.     begin
  142.       next:=nil;
  143.       fname:=thefilename;
  144.     end;
  145.   if filelist = nil then   {if start of list point filelist to it}
  146.     filelist:=tnode;
  147.   endoffilelist:=tnode;
  148.   numfilesinlist:=numfilesinlist+1;
  149.   look4afile:=$00;
  150. end;
  151.  
  152. {delete the filelist}
  153. procedure deletefilelist;
  154. var tnode:flistptr;
  155.     tnode2:flistptr;
  156. begin
  157.   tnode:=filelist;
  158.   while tnode <> nil do
  159.     begin
  160.       tnode2:=tnode;
  161.       tnode:=tnode^.next;
  162.       dispose(tnode2);
  163.     end;
  164.   filelist:=nil;
  165.   endoffilelist:=nil;
  166.   numfilesinlist:=0;
  167. end;
  168.  
  169. {create a list of files on disk from a fileset with wildcards}
  170. procedure getfilelist(fileset:string;attribs:byte);
  171. var
  172.   bailout:byte;
  173. begin
  174.   numfilesinlist:=0;
  175.   filelist:=nil;                {start with no files}
  176.   endoffilelist:=nil;
  177.   searchdirectory(fileset,
  178.                   look4afile,
  179.                   attribs,
  180.                   false,
  181.                   false,
  182.                   bailout);
  183. end;
  184.  
  185. begin
  186.   {no initialization code needed}
  187. end.
  188.