Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FINDF.ZIP/FINDF.PAS

Pascal/Delphi Source File | 1988-10-16 | 6.0 KB | 259 lines

{****************************************************************************

                                    FINDF

                           written by: Richard Simon

  SYSTEM: IBM PC/XT and AT compatibles running MS-DOS 3.xx
LANGUAGE: Turbo PASCAL 5.0

LAST MODIFIED: October 15, 1988

COPYRIGHT

                  (C)copyright 1988 by Simon Say's Database Inc.
                               all rights reserved

FINDF may not be sold in part or whole, it is strictly for example.  FINDF.EXE
and the source code be be given away as long as it is not sold.

DESCRIPTION

FINDF is used to find ALL the files on the disk that match the search
specification given to it from the command line and then report the findings
back to the user.  FINDF also has the option of prompting the user to erase
the files it finds, making it very useful for deleting all the files with
the same name on your hard disk regardless of the subdirectory it is in.

*****************************************************************************}

{$R-,S+,I+,F-,O-,A+,V-,B+,D-,E-,L-}

PROGRAM Findf;

USES Crt,
     Dos;

TYPE DirPtr = ^DirRec;
     DirRec = record
                Name : pointer;
                Next : DirPtr;
              end;

VAR Tree      : DirPtr;
    CurBranch : DirPtr;
    Delete    : boolean;
    BeginHeap : pointer;


PROCEDURE Introduction;

begin
  writeln;
  writeln('FINDF  (C)copyright 1988, Simon Say''s "Database" Inc.');
  writeln;
end;


PROCEDURE Usage;

begin
  writeln('USAGE: FINDF <search spec> </e>');
  writeln;
  writeln('   /e - User Prompted ERASE of files');
  writeln;
  Halt;
end;


PROCEDURE Abort;

begin
  writeln;
  writeln('Program Aborted by user...');
  writeln;
  Release(BeginHeap);
  Halt;
end;


PROCEDURE AddToTree(Name : string);

  { Add each new Directory Name to the Tree }

var NewBranch : DirPtr;

begin
  if Tree = nil then Mark(BeginHeap);

  new(NewBranch);
  NewBranch^.Next := nil;

  GetMem(NewBranch^.Name,length(Name)+1);
  Move(Name,NewBranch^.Name^,length(Name)+1);

  if Tree = nil then
    begin
      CurBranch := NewBranch;
      Tree := NewBranch;
    end
  else
    begin
      CurBranch^.Next := NewBranch;
      CurBranch := NewBranch;
    end;
end;


PROCEDURE SearchTree(FileSpec : string);

  { SearchTree looks through ALL the directories found using the procedure
    DIRECTORIES for the filespec given by the user and then reports the
    findings back to the user.  If the Erase option was defined then the
    user is also prompted for an OK to delete each file found. }

var DirName : string;
    DirInfo : SearchRec;
    Len     : byte;
    WPtr    : DirPtr;
    AnyFound: boolean;
    Lines   : byte;


    procedure More;
    var Scan : char;
    begin
      writeln;
      write('Press any key to continue..');
      scan := ReadKey;

      if (scan = ^[) and (NOT Keypressed) then Abort;

      Lines := 0;
      clrscr;
      writeln('Files on Directory .. ',DirName,':'); inc(Lines);
    end;

    procedure PromptDelete;
    var Ans     : char;
        DelFile : file;
    begin
      write('':13-length(DirInfo.Name),'Are you sure you want to erase (y/n)? ');
      repeat
        Ans := ReadKey;
        if (Ans = ^[) and (NOT KeyPressed) then Abort;
      until upcase(Ans) in['Y','N'];
      if upcase(Ans) = 'Y' then
      begin
        assign(DelFile,DirName+'\'+DirInfo.Name);
        {$I-} erase(DelFile); {$I+}
        if IOresult <> 0 then
          writeln('  Could NOT Erased!')
        else writeln('   Erased');
      end
      else writeln('  NOT Erased!');
    end;

begin
  WPtr  := Tree;
  Lines := 0;

  while WPtr <> nil do
  begin
    Move(WPtr^.Name^,Len,1);
    Move(WPtr^.Name^,DirName,Len+1);

    AnyFound := FALSE;
    chdir(DirName);

    findfirst(FileSpec,ARCHIVE,DirInfo);
    while DosError = 0 do
    begin
      if Lines in[21,22] then More;
      if NOT AnyFound then
      begin
        writeln('Files on Directory .. ',DirName,':'); inc(Lines);
        AnyFound := TRUE;
      end;
      if Delete then
        begin
          write('    ',DirInfo.Name);
          PromptDelete;
        end
      else
        writeln('    ',DirInfo.Name);
      inc(Lines);
      findnext(DirInfo);
    end;

    WPtr := WPtr^.Next;
  end;
end;


PROCEDURE Directories(BeginPath : string);

   { Directoies is a recursive procedure that searches for ALL the directory
     names on the current disk and adds them to a Tree in Memory for later
     reference }

var DirInfo   : SearchRec;

begin
  chdir(BeginPath);

  if BeginPath = '\' then BeginPath := '';

  findfirst('*.',DIRECTORY,DirInfo);
  while DosError = 0 do
  begin
    if (DirInfo.Attr and Directory <> 0) and
       (DirInfo.Name <> '.') and (DirInfo.Name <> '..') then
    begin
      AddToTree(BeginPath+'\'+DirInfo.Name);
      Directories(BeginPath+'\'+DirInfo.Name);
    end;
    findnext(DirInfo);
  end;
end;


PROCEDURE SearchDirectories;

var DefDir : string;
    Options: string[2];

begin
  if ParamCount < 1 then Usage;  { if no search paramater then show usage }

  Tree := nil;                   { Initialize tree }

  if ParamCount = 2 then         { Check for erase option }
  begin
    Options := ParamStr(2);
    case Upcase(Options[2]) of
      'E' : Delete := TRUE;
    end;
  end;

  GetDir(0,DefDir);              { Get Current working Directory }

  AddToTree('\');                { Add Root Directory to Tree }
  Directories('\');              { Traverse Directory tree starting at Root }

  SearchTree(ParamStr(1));       { Search the Directory tree for ParamStr(1) }

  chdir(DefDir);                 { Change directory back to work directory }

  Release(BeginHeap);            { Release all memory allocated by FINDF }
end;


BEGIN

  CheckBreak := FALSE;     { Turn Ctrl-Break off }
  Delete := FALSE;
  Introduction;            { Show Logo }
  SearchDirectories;

END.