home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / dirs.swg / 0040_Deletes Subdirs and files.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-02-28  |  17.1 KB  |  509 lines
  1. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  2.  *  NUKE.PAS by Shane Kerr                                               *
  3.  *        Deletes a subdirectory and everything it contains.             *
  4.  *        Nuke for DOS written Turbo Pascal 5.5                          *
  5.  *        Nuke for Windows written using Turbo Pascal for Windows 1.0    *
  6.  *  Version 1.95    November 23, 1991                                    *
  7.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  8.  
  9. program Nuke;
  10.  
  11. uses
  12. {$IFDEF MsDos}
  13.     DOS;
  14. {$ENDIF}
  15. {$IFDEF Windows}
  16.     WinCRT, WinDOS, Strings;
  17. {$ENDIF}
  18.  
  19. const
  20.     MajorVer = '1';                     { Current major version number }
  21.     MinorVer = '95';                    { Current minor version number }
  22.     Year     = 1991;                    { Release year }
  23.  
  24. {$IFDEF MsDos}
  25.     fsDirectory = 64;                   { Set directory length }
  26.     faReadOnly = ReadOnly;              { Set directory flags }
  27.     faHidden = Hidden;
  28.     faSysFile = SysFile;
  29.     faVolumeID = VolumeID;
  30.     faDirectory = Directory;
  31.     faArchive = Archive;
  32.     faAnyFile = AnyFile;
  33. {$ENDIF}
  34.  
  35. {$IFDEF MsDos}
  36. type
  37.     TRegisters = Registers;                { Used for DOS calls }
  38.     TSearchRec = SearchRec;             { Used for search record }
  39. {$ENDIF}
  40.  
  41. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  42.  *  procedure FCBDeleteFile (FileSpec : string);
  43.  *        Deletes files using the MS-DOS FCB function (from Version 1.0).
  44.  *  parameters:  filespec, file(s) to be deleted
  45.  *  notes:  Can only delete files in the current directory.
  46.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  47.  
  48. procedure FCBDeleteFile (filespec : string);
  49. type
  50.     TFCB = record
  51.         drive : char;                      { 0 = default, 1 = A, 2 = B }
  52.         name : array[0..7] of char;     { File name }
  53.         ext : array[0..2] of char;      { File extension }
  54.         curblk : word;                  { Current block number }
  55.         recsize : word;                 { Logical record size in bytes }
  56.         filsize : longint;              { File size in bytes }
  57.         date : word;                    { Date file was last written }
  58.         resv : array[0..10] of byte;    { Reserved for DOS }
  59.         currec : byte;                  { Current record in block }
  60.         random : longint;               { Random record number }
  61.     end;
  62. var
  63.     FCB : TFCB;
  64.     Regs : TRegisters;
  65.     TempStr : string;
  66.     NameSeg, NameOfs : word;
  67.     FCBSeg, FCBOfs : word;
  68. begin
  69.   { Get segment and offset of the filespec }
  70.     TempStr := filespec + chr(0);
  71.     NameSeg := seg(TempStr);
  72.     NameOfs := ofs(TempStr) + 1;
  73.     FCBSeg := seg(FCB);
  74.     FCBOfs := ofs(FCB);
  75.   { Do the actual DOS calls }
  76.     Regs.AX := $2900;
  77.     Regs.DS := NameSeg;
  78.     Regs.SI := NameOfs;
  79.     Regs.ES := FCBSeg;
  80.     Regs.DI := FCBOfs;
  81.     MsDos(Regs);                        { Parse file to FCB }
  82.     Regs.DS := FCBSeg;
  83.     Regs.DX := FCBOfs;
  84.     Regs.AH := $13;
  85.     MsDos(Regs);                        { Delete file (FCB) }
  86. end; { FCBDeleteFile }
  87.  
  88. {$IFDEF MsDos}
  89. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  90.  *  procedure ClearKb
  91.  *        Clears the keyboard buffer
  92.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  93.  
  94. procedure ClearKb;
  95. var
  96.     Regs : TRegisters;
  97. begin
  98.     Regs.AH := $01;
  99.     Intr($16, Regs);
  100.     while ((Regs.Flags and FZero) = 0) do
  101.       begin
  102.         Regs.AH := $00;
  103.         Intr($16, Regs);
  104.         Regs.AH := $01;
  105.         Intr($16, Regs);
  106.       end;
  107. end; { procedure ClearKb }
  108. {$ENDIF}
  109.  
  110. {$IFDEF MsDos}
  111. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  112.  *  procedure WaitKey
  113.  *        Waits for a key press
  114.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  115.  
  116. procedure WaitKey;
  117. var
  118.     Regs : TRegisters;
  119. begin
  120.     Regs.AH := $00;
  121.     Intr($16, Regs);
  122. end; { procedure WaitKey }
  123. {$ENDIF}
  124.  
  125. {$IFDEF MsDos}
  126. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  127.  *  function IsRedirected : boolean;
  128.  *        Determines whether a program's input or output is redirected
  129.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  130.  
  131. function IsRedirected : boolean;
  132. var
  133.     Regs : Registers;                { Register values }
  134.     StdIn : ^Byte;                    { Standard input }
  135.     StdOut : ^Byte;                    { Standard output }
  136. begin
  137.     Regs.AH := $62;                    { Get segment address of PSP }
  138.     MsDos(Regs);
  139.     StdIn := Ptr(Regs.BX, $18);        { Point to StdIn value }
  140.     StdOut := Ptr(Regs.BX, $19);     { Point to StdOut value }
  141.  
  142.   { Return TRUE if StdIn is the same as StdOut }
  143.     IsRedirected := (StdIn^ <> StdOut^);
  144. end;
  145. {$ENDIF}
  146.  
  147. {$IFDEF MsDos}
  148. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  149.  *  function NumRows : byte;
  150.  *        Returns the number of rows on the screen
  151.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  152.  
  153. function NumRows : byte;
  154. var
  155.     ScreenWidth : word absolute $0040:$004A;
  156.     ScreenSize : word absolute $0040:$004C;
  157. begin
  158.     NumRows := (((ScreenSize div 1000) * 1000) div 2) div ScreenWidth;
  159. end;
  160. {$ENDIF}
  161.  
  162. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  163.  *  function NukeDir (directory : string) : boolean;                     *
  164.  *      Destroys the specified directory and all it contains recursively *
  165.  *  parameters:  directory, path of the directory to be destroyed        *
  166.  *               remove, TRUE to remove directory                        *
  167.  *                 display, TRUE to display files as they are deleted      *
  168.  *                 pause, TRUE to pause after each screen                  *
  169.  *               attr, file search attributes to delete                  *
  170.  *                 lines, number of lines displayed so far                  *
  171.  *  returns:  TRUE if directory is removed, FALSE otherwise              *
  172.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  173. function NukeDir (directory : string; remove, display, pause : boolean;
  174.                     attrib : word; var lines : word) : boolean;
  175. var
  176.     OrgDir : string[fsDirectory];       { Saved original directory }
  177.     SrchRec : TSearchRec;                { For file searches }
  178.     Dummy : boolean;
  179.     Handle : file;                      { File handle (for attrib change) }
  180. begin
  181.     GetDir(0, OrgDir);                   { Get original directory }
  182.  
  183.     ChDir(directory);                   { Change to target directory }
  184.   { If display isn't on, just delete everything (grumble) }
  185.     if (not display) then
  186.         FCBDeleteFile('????????.???');  { Delete all files }
  187.  
  188.   { Find first file present }
  189.     FindFirst('*.*', faDirectory or attrib, SrchRec);
  190.  
  191.   { Loop and nuke any subdirectories found }
  192.     repeat
  193.         if (((SrchRec.Attr and faDirectory) <> 0) and (DosError = 0) and
  194. {$IFDEF MsDos}
  195.                     (SrchRec.Name[1] <> '.')) then
  196. {$ENDIF}
  197. {$IFDEF Windows}
  198.                     (SrchRec.Name[0] <> '.')) then
  199. {$ENDIF}
  200.           begin
  201.             Assign(Handle, SrchRec.Name);
  202.             SetFAttr(Handle, faDirectory);
  203.             Dummy := NukeDir(SrchRec.Name, TRUE, Display, Pause, Attrib, Lines);
  204.           end
  205.         else if ((DosError = 0) and
  206. {$IFDEF MsDos}
  207.                     (SrchRec.Name[1] <> '.') and
  208. {$ENDIF}
  209. {$IFDEF Windows}
  210.                     (SrchRec.Name[0] <> '.') and
  211. {$ENDIF}
  212.             (((SrchRec.Attr and Attrib) <> 0) or (Attrib = 0))) then
  213.           begin
  214.             Assign(Handle, SrchRec.Name);
  215.             SetFAttr(Handle, 0);
  216.             Erase(Handle);
  217.           { If displaying, then show name and increase line count }
  218.             if (Display) then
  219.               begin
  220.                 WriteLn('     Deleting  ', Directory, '\', SrchRec.Name);
  221.                 Inc(Lines);
  222.               end;
  223.           { If pausing, check line count }
  224.             if (Pause and ((Lines mod (NumRows - 2)) = 0)) then
  225.               begin
  226.                 Write('Press any key to continue...');
  227.                 WaitKey;
  228.                 WriteLn;
  229.               end;
  230.           end; { if block }
  231.         FindNext(SrchRec);
  232.     until (DosError <> 0);
  233.  
  234.   { If original directory is current, change to parent }
  235.     if (OrgDir = Directory) then
  236.         ChDir('..')
  237.     else if (pos(Directory, OrgDir) = 1) then
  238.       begin
  239.         ChDir(Directory);
  240.         ChDir('..');
  241.       end
  242.     else
  243.         ChDir(OrgDir);                  { Restore directory }
  244.     NukeDir := FALSE;
  245.     if (Remove) then
  246.       begin
  247.         {$I-}
  248.         RmDir(Directory);                { Kill target directory }
  249.         if (IOResult = 0) then
  250.             NukeDir := TRUE;
  251.         {$I+}
  252.       end;
  253. end; { function NukeDir }
  254.  
  255. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  256.  *  function ToUpper (Str : string) : string;                            *
  257.  *      Convert string to upper case                                     *
  258.  *  parameters:  Str, any string                                         *
  259.  *  returns:  uppercase value of the string                              *
  260.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  261.  
  262. function ToUpper (Str : string) : string;
  263. var
  264.     i : integer;
  265.     Temp : string;
  266. begin
  267.     Temp := str;
  268.     for i := 1 to length(Str) do
  269.         Temp[i] := UpCase(Temp[i]);
  270.     ToUpper := Temp;
  271. end;
  272.  
  273.  
  274. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  275.  *  function ListFiles (directory : string) : integer                    *
  276.  *      Lists files and attributes in the specified directory below      *
  277.  *  parameters:  directory, directory to start listing at                *
  278.  *  returns:  number of files listed                                     *
  279.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  280.  
  281. function ListFiles (directory : string) : integer;
  282. var
  283.     OrgDir : string;                    { Original directory }
  284.     CurDir : string;                    { Current directory }
  285.     SearchRec : TSearchRec;             { Used to find filespecs }
  286.     NumListed : Integer;                { Number of files listed }
  287.     Attr: word;                         { Attributes to remove }
  288. begin
  289.     NumListed := 0;                     { Number of files listed }
  290.     GetDir(0, OrgDir);                    { Get original directory }
  291.  
  292.     ChDir(directory);                   { Change to target directory }
  293.     GetDir(0, CurDir);                    { Get current directory }
  294.  
  295.   { Find first directory present }
  296.     FindFirst('*.*', faDirectory or faReadOnly or faHidden or faSysFile,
  297.         SearchRec);
  298.     FindNext(SearchRec);
  299.     FindNext(SearchRec);
  300.  
  301.   { Loop and list any files found }
  302.     repeat
  303.         if ((DosError = 0) and ((SearchRec.Attr and faDirectory) <> 0)) then
  304.           begin
  305.             NumListed := NumListed + ListFiles(SearchRec.Name);
  306.           end;
  307.         if (DosError = 0) then
  308.           begin
  309.             NumListed := NumListed + 1;
  310.             Write('     ', CurDir, '\', SearchRec.Name);
  311.             if ((SearchRec.Attr and faDirectory) <> 0) then
  312.                 Write(', directory');
  313.             if ((SearchRec.Attr and faReadOnly) <> 0) then
  314.                 Write(', read-only');
  315.             if ((SearchRec.Attr and faHidden) <> 0) then
  316.                 Write(', hidden');
  317.             if ((SearchRec.Attr and faSysFile) <> 0) then
  318.                 Write(', system');
  319.             WriteLn;
  320.           end; { if }
  321.         FindNext(SearchRec);
  322.     until (DosError <> 0);
  323.  
  324.     ChDir(OrgDir);                      { Restore directory }
  325.     ListFiles := NumListed;             { Return number of files listed }
  326. end;  { procedure ListFiles }
  327.  
  328.  
  329. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  330.  *  function HasSwitch (switch : string) : boolean                       *
  331.  *      Checks the command-line arguements for the specified switch      *
  332.  *  parameters:  switch, the switch to search for                        *
  333.  *  returns:  TRUE if found, else FALSE                                  *
  334.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  335.  
  336. function HasSwitch (switch : char) : boolean;
  337. var
  338.     i : integer;                        { Index variable }
  339. begin
  340.     HasSwitch := FALSE;
  341.     for i := 1 to ParamCount-1 do
  342.       begin
  343.         if (Pos(UpCase(switch), ToUpper(ParamStr(i))) <> 0) then
  344.           begin
  345.             HasSwitch := TRUE;
  346.             Exit;
  347.           end; { if }
  348.       end; { for }
  349. end; { function HasSwitch }
  350.  
  351. var { main variables }
  352.     UserInput : string[fsDirectory];    { user response }
  353.     Answer : string;                      { user response }
  354.     OrgDir : string[fsDirectory];       { Original directory }
  355.     Target : string[fsDirectory];       { Directory to nuke }
  356.     Remove : boolean;                   { If directory actually removed }
  357.     Result : boolean;                   { Result of nuking }
  358.     LinesShown : word;                    { Number of lines shown so far }
  359.     Attrib : word;                      { File attributes to delete }
  360.  
  361. begin { main program }
  362.   { Print greeting }
  363.     WriteLn('NUKE Directory  ', MajorVer, '.', MinorVer);
  364.     WriteLn('    (C)', Year, ' by Kerr');
  365.     WriteLn;
  366.  
  367.   { Check for DOS help command }
  368.     if ((ParamCount < 1) or HasSwitch('?') or (Pos('?', ParamStr(1)) <> 0)) then
  369.       begin
  370.         Write('Removes a subdirectory, along with the files and ');
  371.         WriteLn('subdirectories is contains');
  372.         WriteLn;
  373.         WriteLn('NUKE [options] [directory]');
  374.         WriteLn;
  375.         WriteLn('Options are as follows:');
  376.         WriteLn('  K      Keeps the subdirectory after clearing out files.');
  377.         WriteLn('  H      Deletes hidden files.');
  378.         WriteLn('  R      Deletes read-only files.');
  379.         WriteLn('  S      Deletes system files.');
  380.         WriteLn('  A      Deletes files of all attributes.');
  381.         WriteLn('  Y      No verification before NUKEing - dangerous!');
  382.         Write  ('  V      Verbose, displays files and subdirectories they ');
  383.         WriteLn('are removed - SLOW!');
  384.         WriteLn('  P      Pause after each screen.');
  385.         WriteLn;
  386.         WriteLn('You cannot nuke the root directory.');
  387.         WriteLn('Nuke will not Pause if you redirect the input or output.');
  388.         Exit;
  389.       end;
  390.  
  391.   { Set number of lines displayed }
  392.     LinesShown := 0;
  393.  
  394.   { Check for /K switch }
  395.     Remove := not HasSwitch('K');
  396.  
  397.     Attrib := 0;
  398.  
  399.   { Check for /H switch }
  400.     if (HasSwitch('H')) then
  401.         Attrib := Attrib or faHidden;
  402.   { Check for /R switch }
  403.     if (HasSwitch('R')) then
  404.         Attrib := Attrib or faReadOnly;
  405.   { Check for /S switch }
  406.     if (HasSwitch('S')) then
  407.         Attrib := Attrib or faSysFile;
  408.   { Check for /A switch }
  409.     if (HasSwitch('A')) then
  410.         if (Attrib <> 0) then
  411.           begin
  412.             WriteLn('Cannot use the /A switch with other attribute switches.');
  413.             Exit;
  414.           end
  415.         else
  416.             Attrib := faAnyFile;
  417.  
  418. {$IFDEF MsDos}
  419.     UserInput := ParamStr(ParamCount);
  420. {$ENDIF}
  421. {$IFDEF Windows}
  422.     Write('Input directory to remove:  ');
  423.     ReadLn(UserInput);
  424. {$ENDIF}
  425.  
  426.   { Save directory and drive and try to change to new directory }
  427.     GetDir(0, OrgDir);
  428.  
  429.     {$I-}
  430.     ChDir(UserInput);
  431.     if (IOResult <> 0) then
  432.       begin
  433.         WriteLn('   Specified directory not found!');
  434.         ChDir(OrgDir);
  435.         Exit;
  436.       end;
  437.     {$I+}
  438.  
  439.     GetDir(0, Target);                    { Get new directory }
  440.  
  441.   { Display target directory and change back from it }
  442.     WriteLn(' Target is ', Target);
  443.     WriteLn;
  444.  
  445.     ChDir(OrgDir);                      { Restore directory }
  446.  
  447.   { Exit if root directory being nuked }
  448.     if (length(Target) = 3) then
  449.       begin
  450.         WriteLn('You cannot NUKE the root directory!');
  451.         WriteLn('  (Try FORMAT...)');
  452.         Exit;
  453.       end;
  454.  
  455.  
  456.   { Double check before DECIMATING directory }
  457.     if (not HasSwitch('Y')) then
  458.       begin
  459.         WriteLn(' Are you SURE you want to OBLITERATE this directory and');
  460.         Write('  everything in or under it?!?!? (Y/N) ');
  461. {$IFDEF MsDos}
  462.         ClearKb;
  463. {$ENDIF}
  464.         ReadLn(Answer);
  465.         Answer := ToUpper(Answer);
  466.       end;
  467.  
  468.   { If 'yes' or 'y' entered, or 'Y' SWITCH set, nuke that puppy }
  469.     if ((answer = 'YES') or (answer = 'Y') or HasSwitch('Y'))  then
  470.       begin
  471.         WriteLn(' Beginning now...');
  472.         Result := NukeDir(Target, Remove, HasSwitch('V'),
  473.                 HasSwitch('P') and (not IsRedirected), Attrib, LinesShown);
  474.         WriteLn('  ...may the diety of your choice have mercy on your soul.');
  475.       end { if }
  476.     else
  477.       begin
  478.         Result := FALSE;
  479.         WriteLn(' Nothing done.');
  480.         Exit;
  481.       end; { else }
  482.  
  483.   { List files not deleted }
  484.     if (not Result) then
  485.       begin
  486.         WriteLn;
  487.       { Display a message if the directory was SUPPOSED to be removed }
  488.         if (Remove) then
  489.           begin
  490.             WriteLn('  NUKE failed to remove the directory.');
  491.           end
  492.         else
  493.           begin
  494.             WriteLn('  NUKE has kept the directory.');
  495.           end;
  496.         WriteLn(' The following files or directories remain in it:');
  497.         if (ListFiles(Target) = 0) then
  498.             WriteLn('    None');
  499.       { Display helpful hint if the directory was SUPPOSED to be removed }
  500.         if (Remove) then
  501.           begin
  502.             WriteLn;
  503.             Write('If you wish to remove these files, try the ');
  504.             WriteLn('/H, /R, and /S options,');
  505.             WriteLn('  or the /A option.');
  506.           end;
  507.       end; { if }
  508. end. { main }
  509.