[Back to DIRS SWAG index] [Back to Main SWAG index] [Original]

    uses crt,dos;

    { GERA.PAS  - Global search utility to find and delete files.      }
    {- drive not specified - uses the current                          }
    {- always starts at the root directory and searches every          }
    {  directory below it.                                             }
    { C.V. Rutherford }
    { Public domain 12/28/93 }

    type
      PathRecPTR = ^PathRecord;
      PathRecord = record
                     RDir: PathStr;
                     Next: PathRecPTR;
                   end;

    var
      CurTop,
      TempPTR: PathRecPTR;         { Pointer to path references }
      FilesFound : Boolean;        { end of utility display     }

    procedure CheckAborted( ch : char );
    begin
      if ch in [#27,^C] then
         begin
           writeln(#08,'... User abort !');
           HALT(0);
         end;
    end;

    { PushDir/PopDir/ClearDir }
    { are used to save and restore directories during search }

    procedure PushDir( Rdir : PathStr );
    begin
      New( TempPTR );
      TempPTR^.RDir:= RDir;
      TempPTR^.Next:= NIL;
      if CurTop = Nil then
         CurTop := TempPTR
      else
         begin
           TempPTR^.Next := CurTop;
           CurTop := TempPTR;
         end;
    end;

    procedure PopDir(Var RDir : string );
    begin
      if CurTop <> NIL then
         begin
           TempPTR := CurTop;
           CurTop := CurTop^.Next;
           RDir := TempPTR^.RDir;
           Dispose( TempPTR );
           TempPTR := NIL;
         end;
    end;

    procedure ClearDir;
    begin
      while CurTop <> NIL do
        begin
          TempPTR := CurTop;
          CurTop := CurTop^.Next;
          FreeMem( TempPTR, sizeof(PathRecord ));
          TempPTR := NIL;
       end;
    end;

    procedure GetDir( PathN : string );
    var
      f : searchrec;

    begin
      findfirst(PathN+'*.*', directory,f);
      while doserror = 0 do
        begin
          if (f.attr and directory) = directory then
             begin
               if (f.name <> '.') and (f.name <> '..') then
                  pushdir( PathN +f.name+'\');
             end;
          findnext(f);
         end;
    end;

    procedure EraseFile( Source : string );
    var
     F:  file;
     ErrorCode : word;
     ch : char;

    begin
      write('Delete: ', Source+' [N]',#08+#08 );
      ch := Upcase( Readkey );
      if ch = 'Y' then
         begin
           write('Y');
           Assign(F, Source);
           {$I-} Reset(F); {$I+}
           ErrorCode := IOResult;
           if errorCode = 0 then
              begin
                Close(F);
                {$I-} Erase(F); {$I+}
                ErrorCode := IOResult
              end;
           if ErrorCode <> 0 then
              write(']    ', '... File Access denied');
         end
      else
         CheckAborted( ch );
      writeln;
    end;

    procedure GetFiles( PathN, FName : string );
    var
      f : searchrec;

    begin
      findfirst(PathN+FName, anyfile,f);

      while keypressed do CheckAborted( Readkey );   { check for user abort }

      { 18 the only error we should get since we read the directory once before }
      { indicating no more file found }

      while doserror <> 18 do
        begin
          if (F.attr and directory) <> Directory then
             begin
               erasefile(PathN+f.name);        (* ERASE REFERENCE *)
    (*         writeln(PathN+F.Name);           FIND REFERENCE  *)
               FilesFound := TRUE;
             end;
          findnext(f);
         end;
    end;

    procedure GlobalErase(Pname, mask : string );
    begin
      pushdir(Pname);                { Push the root directory }
      while curtop <> NIL do
        begin
          popdir( pname );           { get directory from list }
          getdir( pname );           { get its subdirectories  }
          write('*',#13);            {* provide an indicator   }
          getfiles(pname, mask);     { get directory files     }
          write('-',#13);            {* provide an indicator   }
        end;
      write(' ',#13);                {* clear the indicator    }
    end;

    var
     Dir: DirStr;
     Name: NameStr;
     Ext: ExtStr;

    begin
      CheckBreak := FALSE;           { use our abort }
      FilesFound := FALSE;
      if paramcount > 0 then
         begin
           FSplit(Paramstr(1), Dir, Name, Ext);
           Dir := fexpand(Dir);               { Expand to get drive if not }
                                              { specified }
           Dir := Copy(Dir,1,1)+':\';         { Get drive or default drive }

           writeln;
           writeln('Global Erase..  '+Dir+name+Ext);

           if ( Name='') or (Ext='') or (Ext='.') then
              writeln('Invalid filename.. ?' )
           else
              begin
                GlobalErase( Dir, Name+Ext );
                if not FilesFound then
                   writeln(Name+Ext+' not found ?');
              end;
         end
      else
         writeln('Filename Not Specified.. ?');
      cleardir;
    end.

[Back to DIRS SWAG index] [Back to Main SWAG index] [Original]