PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/dk.pas

Pascal/Delphi Source File | 1990-03-05 | 6.8 KB | 272 lines

PROGRAM DIRKILLPROG;
{ Recursive descent directory/file deletion program. }


(*

 Programmed for Turbo Pascal 5.5 (should work with 4.0 and 5.0).
 Will give a run-time error if you kill the directory that the
 executable resides in, but the error comes after all is finished,
 so it doesn't really matter. }


 This program will remove all files and child directories (and their
 files too) of the specified directory.

 For example, you have the following directory structure on a disk....


 Root --> \SUBDIR1  --> A bunch of files
                    --> \SUBDIR1\SUBDIR1.1 --> A bunch more files
                    --> \SUBDIR1\SUBDIR1.2 --> Yet another bunch of files
      --> \SUBDIR2
      --> \SUBDIR3

 Using the DOS 'RD' commmand, you would not be able to remove \SUBDIR1
 without first erasing all the files in it and the files in SUBDIR1.1
 and the files in SUBDIR1.2 and 'RD'ing SUBDIR1.1 and SUBDIR1.2...

 This can be quite time consuming.   You could instead just type
 'dk \subdir1', answer 'y' to the 'are you sure' prompt and wait
 a few seconds while your computer does the work for you.

 There is one CAVEAT to using this program.  It is quite powerful and
 only asks 'are you sure' once.  If you were to type 'dk c:\' and
 answer 'y', all files and subdirectories on drive C: would be
 erased/removed.

 The 'DIRKILL' procedure can be easily modified to do other useful things.
 For instance, if you wanted to back-up all the pascal source code on a hard
 disk (or in a large set of directories) to a floppy, you could change the
 file mask (*.* for erasing) to  *.pas and instead of erasing files,
 you could put in code to copy files.  You would probably also want to
 take out the line of code that removes a directory (last line in DIRKILL).

 The recursive descent method that is the basis for this program is
 quite useful in the MS-DOS hierarchical file system for performing
 manipulations on sets of files that may be in many directories with
 a common parent directory.

 I hope you find this program useful.  I release this software to the
 public domain, so enjoy it.


 P. S.  If you accidentally wipe out files/directories, they should be
        recoverable by any utility that can recover from errant 'rd'
        and 'erase' commands.

*)


uses
   DOS, CRT;


FUNCTION UPCASESTR(sTempStr : String) : String;
{ Force all alphabetic characters to upper case. }
var
   II : Integer;

begin
for II := 1 to length(sTempStr) do
   sTempStr[II] := upcase(sTempStr[II]);

UPCASESTR := sTempStr;
end; { UPCASESTR }


FUNCTION PROCESSPATH(var sTempStr : String) : Boolean;
{ Verify that SS is a valid path string. }
var
   bRetVal   : Boolean;
   sWorkStr  : String;
   sCurrPath : String;

begin
bRetVal  := False;
sWorkStr := sTempStr;

if (sWorkStr[1] <> '\') then
   begin
   if (sWorkStr[1] in ['A'..'Z']) and (sWorkStr[2] = ':') then
      begin
      if (length(sWorkStr) = 2) then
         sWorkStr := concat(sWorkStr,'\');
      end { if }
   else
      begin
      getdir(0,sCurrPath);
      if (sCurrPath[length(sCurrPath)] = '\') then
         sWorkStr := concat(sCurrPath,sWorkStr)
      else
         sWorkStr := concat(sCurrPath,'\',sWorkStr);
      end; { else }
   end; { if }

chdir(sWorkStr);
if (IOResult = 0) then
   begin
   sTempStr := sWorkStr;
   bRetVal  := True;
   end { if }
else
   begin
   writeln;
   writeln('Directory not found (',sWorkStr,').  Program aborted.');
   end; { else }

PROCESSPATH := bRetVal;
end; { PROCESSPATH }


FUNCTION WARNING(sTempStr : String) : Boolean;
{ Verify user intentions. }
var
   iYY     : Integer;
   sPrompt : String;
   sAnswer : String;
   bRetVal : Boolean;

begin
bRetVal := False;

writeln;
writeln;
writeln;

{ Save y-location. }
iYY := WhereY - 2;

{ Build & display prompt string. }
sPrompt := concat('Deleting directory "',sTempStr,'".  Are you sure (Y/N): ');
gotoxy(1,iYY);
write(sPrompt);

{ Loop until user presses Y/N or breaks out of application. }
repeat
   { Clear answer area. }
   gotoxy(length(sPrompt) + 1, iYY);
   write(' ':80 - (length(sPrompt) + 1));

   { Read user's answer. }
   gotoxy(length(sPrompt) + 1, iYY);
   readln(sAnswer);

   { Judge it. }
   if (sAnswer[1] in ['Y','y']) then
      bRetVal := True;
until (sAnswer[1] in ['Y','y','N','n']);

WARNING := bRetVal;
end; { WARNING }


PROCEDURE DIRKILL(sWorkDir : String);
{ Recursive descent portion of program.  Does the real work. }
var
   srTemp     : SearchRec;
   KillFile   : File;
   sSaveStr   : String;
   sTestStuff : String;

begin
chdir(sWorkDir);
sSaveStr := sWorkDir;

{ Make sure there is a terminating backslash. }
if (sWorkDir[length(sWorkDir)] <> '\') then
   sWorkDir := concat(sWorkDir,'\');

findfirst(sWorkDir + '*.*', AnyFile, srTemp);
while (DosError = 0) do
   begin
   { Ignore the '.' and '..' entries common to all directories. }
   if (srTemp.Name[1] <> '.') then
      begin

      { Is it a directory entry? }
      if ((srTemp.Attr and Directory) <> 0) then
         begin
         DIRKILL(concat(sWorkDir, srTemp.Name));
         end { if }

      { else, it isn't a directory, so delete it. }
      else
         begin
         { THIS IS WHERE THE FILE ERASING HAPPENS. }
         assign(KillFile, srTemp.Name);

         { Make sure we kill hidden, system, and read/only files. }
         setfattr(KillFile, 0);

         {$I-}
         reset(KillFile);
         close(KillFile);
         erase(KillFile);
         {$I+}

         end; { else }
      end; { if }

   findnext(srTemp);
   end; { while }

{ Back out of the directory. }
{$I-}
chdir('..');
getdir(0,sTestStuff);
{$I+}

{ Remove directory we just backed out of. }
writeln('Deleting ',sSaveStr,'...');

{ THIS IS WHERE THE DIRECTORY REMOVING HAPPENS. }
rmdir(sSaveStr);
end; { DIRKILL }



var
   sTempStr : String;
   sOldDir  : String;


begin { MAIN }
writeln;
writeln('Directory killer program.  By Jim Grinsfelder.');
writeln;
if (ParamCount = 1) then
   begin
   { Get current default directory. }
   getdir(0, sOldDir);

   sTempStr := UPCASESTR(ParamStr(1));
   if (PROCESSPATH(sTempStr)) then
      begin
      if (WARNING(sTempStr)) then
         begin
         DIRKILL(sTempStr);

         { Restore to current default directory if possible. }
         {$I-} { Turn off I/O checking in case they killed old directory. }
         chdir(sOldDir);
         {$I+}
         end { if }
      else
         begin
         writeln;
         writeln('DIRKILL aborted.  Nothing deleted.');
         writeln;
         end; { else }
      end; { if }
   end { if }
else
   begin
   writeln;
   writeln('Invalid parameters (or not enough parameters).');
   writeln;
   writeln('Usage:  DIRKILL \PATH.');
   writeln;
   end;
end. { MAIN }