home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 17 / CD_ASCQ_17_101194.iso / vrac / zndel20.zip / ZNDEL.PAS < prev   
Pascal/Delphi Source File  |  1994-08-18  |  15KB  |  556 lines
  1. {
  2.           ZNDEL version 2.0   -  Public Domain / Freeware
  3.  
  4.         Exclusive-Delete utility ( originally 'ZIP-NOT-DEL' ? )
  5.  
  6.    Original:  Written Sept 21, 1991   G. Palmer
  7.  
  8.    Version 2.0  August 17, 1994   E. de Neve   CompuServe ID: 100121,1070
  9.  
  10.    New in version 2.0 :
  11.  
  12.      - recognizes 12 of the most common archive format extensions
  13.      - full DIR-style wildcard support
  14.      - confirmation asked before deleting
  15.      - no confirmation needed in assigned working directories
  16.      - realistic limits & safety checks for maximum number of files
  17.      - switch to override prompting, useful in batch files
  18.  
  19. }
  20.  
  21.  
  22. {$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y-} {* compiler switches *}
  23. Program Zndel2;
  24.  
  25. Uses DOS, Crt;
  26.  
  27. Type
  28.   FullNameStr = String [12];
  29.   
  30. Const
  31.   Assume_Yes: Boolean = False;
  32.   
  33.   Maxdelete   =  2000;
  34.   Maxsave     =  32;
  35.   Maxworkdirs =  32;
  36.   
  37.   MetaBufSize =  4000;  { I/O buffer used when patching .exe file }
  38.   
  39.   ConfigStart: String [5] = '(CFG<'; { mark start of config area }
  40.   Nr_workdirs: Byte =  0;
  41.   Workdirs: Array [1..MaxWorkDirs] Of FullNameStr =
  42.   ('', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '',
  43.   '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '');
  44.   ConfigEnd: String [5] = '>CFG)'; { end of config area }
  45.   
  46.   MaxArchExt  =  12;
  47.   ArchExt: Array [1..MaxArchExt] Of String [3] =
  48.   ( 'ZIP', 'ARJ', 'LZH', 'ARC', 'LIM', 'UC2',
  49.   'PAK', 'SQZ', 'HAP', 'SDN', 'ZOO', 'SIT' );
  50.   
  51.   
  52.   VaLetSet: Set Of Char = [ '#'..')', '!', '@', '^', '~', '_', '{',
  53.   '}', '-', '0'..'9', 'A'..'Z', 'a'..'z'];
  54.   { set of valid letters that make up an unambiguous file/dir name }
  55.   
  56.   
  57. Var
  58.   CH:                     Char;
  59.   I:                      Word;
  60.   Afile:                  File;
  61.   Nr_Names_To_Save:       Word;
  62.   Nr_Files_To_Delete:     Word;
  63.   Nr_Files_Found:         Word;
  64.   Nr_Files_to_Protect:    Word;
  65.   TempStr, UpStr:         FullNameStr;
  66.   Files_To_Delete :       Array [1..maxdelete]   Of FullNameStr;
  67.   Names_To_Save:          Array [1..maxsave]     Of FullNameStr;
  68.   Search_Record:          SearchRec;
  69.   MetaBuffer:             Array [0..MetaBufSize] Of Byte;
  70.   
  71. Procedure Show_Info;
  72. Begin
  73.   WriteLn;
  74.   WriteLn ('Deletes all files in the current directory, except:');
  75.   WriteLn ('        Files listed on the command line, DIR-style wildcards allowed.');
  76.   WriteLn ('        Archived files ( ZIP, LZH, ARC, ARJ, LIM, ZOO etc. )');
  77.   WriteLn ('        Hidden, System and ReadOnly files.');
  78.   WriteLn;
  79.   WriteLn ('Usage:  ZNDEL [/Y] [filespec (filespec) ]  delete all but filespecs & archives');
  80.   WriteLn ('                └──>   assume YES on all prompting');
  81.   WriteLn ('        ZNDEL /S       show current settings');
  82.   WriteLn ('        ZNDEL /?       show this help text');
  83.   WriteLn;
  84.   WriteLn ('        ZNDEL /W  [workdir (workdir) ]   assign working directories ');
  85.   WriteLn;
  86.   WriteLn ('        ZNDEL will always ask for confirmation before deleting files,');
  87.   WriteLn ('        unless the current directory is one of the assigned working dirs.');
  88.   Halt;
  89. End;
  90.  
  91.  
  92. Procedure WildExpand (Var inname: String);
  93.  
  94. Var workname: String [12]; {name}
  95.   Havecard: Boolean;
  96.   S, D, P: Byte;           {counters source,destin,point}
  97.   ic: Char;
  98.   
  99. Procedure PartExpand;
  100. Begin
  101.   If HaveCard Then IC := '?'
  102.   Else
  103.     If (S > Byte (inname [0] ) ) Or (P > 0) Then IC := ' ' Else
  104.     Begin
  105.       IC := UpCase (inname [S] );
  106.       If IC = '*' Then
  107.       Begin Havecard := True; IC := '?'; End
  108.       Else
  109.         If IC = '.' Then
  110.         Begin P := S; IC := ' '; End;
  111.       Inc (S);
  112.     End; {real ic digest}
  113.   
  114.   Workname [D] := IC;
  115.   Inc (D);
  116. End;
  117.  
  118.  
  119. Begin
  120.   
  121.   S := 1; { source }
  122.   D := 1; { destin }
  123.   P := 0; { point-pos }
  124.   
  125.   workname [0] := #12;
  126.   workname [9] := '.';
  127.   
  128.   
  129.   HaveCard := (Inname [0] > #0) And (inname [1] = '.');
  130.   
  131.   While (Byte (inname [0] ) > S) And (Inname [S] = ' ') Do Inc (S);
  132.   { 'remove' front spaces... }
  133.   
  134.   Repeat {copy into name8}
  135.     PartExpand;
  136.   Until D = 9;
  137.   
  138.   S := 1; {FIND any point if it exists..}
  139.   While (P = 0) And (S <= Byte (Inname [0] ) ) Do
  140.   Begin
  141.     If inname [S] = '.' Then P := S Else Inc (S);
  142.   End;
  143.   
  144.   Havecard := ( (P = 0) And (Inname [0] > #0) )  Or (Inname [0] = #1);
  145.   
  146.   S := P; {on point }
  147.   P := 0;
  148.   
  149.   Inc (S); {both get over point}
  150.   Inc (D);
  151.   
  152.   PartExpand; {ext 3 chars}
  153.   PartExpand;
  154.   PartExpand;
  155.   
  156.   Inname := WorkName;
  157. End;
  158.  
  159.  
  160.  
  161. Function MatchWild (Var WW1, SS2: String): Boolean; {count on BOTH being expanded..}
  162. Var CC: Byte;
  163. Begin
  164.   
  165.   {loop both strings, if wild has non-? char that doesnt match SS2 char,
  166.   OR SS2 char has ? that doesn't match SPACE, then exit}
  167.   
  168.   matchwild := False;
  169.   
  170.   For CC := 1 To 12 Do If WW1 [CC] <> SS2 [CC] Then
  171.   Begin
  172.     If ( (ww1 [cc] = ' ') And (ss2 [cc] <> '?') )
  173.        Or
  174.        ( (WW1 [CC] <> '?') )
  175.     Then Exit;
  176.   End;
  177.   
  178.   Matchwild := True;
  179. End;
  180.  
  181.  
  182. Function SameName (Wild, Sample: String): Boolean;
  183. Begin
  184.   { Note: WILD must be an already expanded 13-character wildcard string}
  185.   Wildexpand (Sample);
  186.   Samename := matchwild (Wild, Sample);
  187. End;
  188.  
  189. Procedure Show_Config;
  190. Begin
  191.   Write ('Assigned working directories:   ');
  192.   If Nr_Workdirs = 0 Then WriteLn ('None.');
  193.   For I := 1 To Nr_Workdirs Do Write (Workdirs [I], '  ');
  194.   WriteLn;
  195.   Halt;
  196. End;
  197.  
  198.  
  199. Function ValidDirName (Var Workstring: String): Boolean;
  200. Var I: Byte;
  201.   NumPoints: Byte;
  202.   PointStart: Byte;
  203.   ExtSize: Byte;
  204.   NameSize: Byte;
  205. Begin
  206.   PointStart := 0;
  207.   For I := 1 To Length (WorkString) Do
  208.   Begin
  209.     If (Workstring [i] = '.') And (Pointstart = 0) Then
  210.     Begin {point digest}
  211.       If I > 1 Then PointStart := I
  212.       Else Begin ValidDirName := False; Exit; End;
  213.       {too many points, or starts with point..}
  214.     End
  215.     {no point - then must be valid filename letter}
  216.     Else
  217.       If Not (Workstring [i] In VaLetSet)
  218.       Then Begin ValidDirName := False; Exit; End;
  219.   End;
  220.   
  221.   {finally, check if the extension OR filename are not too big: }
  222.   
  223.   If ( (Pointstart = 0) And (Length (Workstring) > 8) )
  224.      Or ( Pointstart > 9)
  225.      Or ( ( Pointstart > 1) And (Length (WorkString) > (Pointstart + 3) ) )
  226.   Then ValidDirname := False
  227.   Else
  228.     ValidDirName := True;
  229. End;
  230.  
  231.  
  232. Procedure UpcaseString (Var Workstring: String);
  233.   Var I: Byte;
  234.   Begin
  235.     For I := 1 To Length (WorkString) Do WorkString [i] := UpCase (WorkString [i] );
  236.   End;
  237.  
  238.  
  239. Function FindLocation (Var Infile: File;  Sample: String): LongInt;
  240.  
  241.  { universal 'binary file' search routine, works with files }
  242.  { of any length, even if much larger than 64Kb             }
  243.  { searches a file for sample string using the 'Metabuffer' }
  244.  { assumes the file INFILE was already open for reading     }
  245.  
  246. Var I: LongInt;
  247.   J: Word;
  248.   Location: LongInt;
  249.   BytesRead: Word;
  250.   SearchIndex: LongInt;
  251. Begin
  252.   
  253.   SearchIndex := 0;
  254.   FindLocation := 0;
  255.   
  256.   If Length (Sample) = 0 Then Exit;
  257.   
  258.   Repeat
  259.     Seek (InFile, Searchindex);
  260.     
  261.     BlockRead (InFile, Metabuffer, SizeOf (Metabuffer), BytesRead);
  262.     
  263.     If BytesRead < Length (Sample) Then Exit; {file or buffer too small..}
  264.     
  265.     For I := 0 To (BytesRead - Length (Sample) ) Do
  266.       If MetaBuffer [i] = Byte (Sample [1] ) Then
  267.       Begin
  268.         J := 1;
  269.         
  270.         While (J < Length (Sample) ) And
  271.               ( Metabuffer [I + J] = Byte (Sample [J + 1] ) )
  272.         Do Inc (J);
  273.         
  274.         If J = Length (Sample)  Then Begin
  275.           FindLocation := SearchIndex + I;
  276.           Exit;
  277.         End;
  278.         
  279.       End;
  280.     
  281.     If BytesRead < SizeOf (Metabuffer) Then Exit;    { at end of file}
  282.     
  283.     SearchIndex := SearchIndex + BytesRead - Length (Sample) + 1;
  284.     
  285.     { This ensures overlap between consecutive buffer reads; because
  286.     of this overlap, the whole procedure will still work even in
  287.     the extreme case when Sizeof(Metabuffer)=Length(Sample)  !!! }
  288.     
  289.   Until False;
  290.   
  291. End;
  292.  
  293.  
  294.  
  295.  
  296. Procedure Config_Workdirs;
  297.  Var BytesRead, BytesWritten: Word; {dummy args for Blockread/write}
  298.    PatchAddr1, PatchAddr2: Word;
  299.    I, J: Word;
  300.    NewDirs: Word;
  301.    ParamString: String;
  302.  Begin
  303.    { put supplied working dir names into array }
  304.    
  305.    NewDirs := ParamCount;       { First parameter was /W }
  306.    
  307.    Nr_Workdirs := 0;            { disregard old settings }
  308.    
  309.    For i := 2 To NewDirs Do     { expand & add to SAVE specs list }
  310.      If (Nr_workdirs < MaxWorkDirs) Then   { check for max nr of dirs }
  311.      Begin
  312.        ParamString := ParamStr (i);
  313.        UpcaseString (ParamString);
  314.        If ParamString [1] = '/' Then Show_Info; { wrong place for option }
  315.        
  316.        If ValidDirName (ParamString) Then Begin
  317.          Inc (Nr_Workdirs);
  318.          If Paramstring [Byte (Paramstring [0] ) ] = '.' {get rid of ugly points at end}
  319.          Then Dec (Byte (paramstring [0] ) );
  320.          WorkDirs [Nr_Workdirs] := ParamString;
  321.        End;
  322.      End;
  323.    
  324.    { Find 'home' directory, find ZNDEL.EXE (or whatever our name was)
  325.    find out where to insert the new workdirs data structure,
  326.    then copy them to it. }
  327.    
  328.    Assign (Afile, ParamStr (0) ); { it's ME ! }
  329.    FileMode := 2;               { default, read and write possible }
  330.    Reset (Afile, 1);            { open, counting will be done in BYTES }
  331.    
  332.    If IOResult <> 0 Then Begin
  333.      WriteLn ('Configuration failed - file not found.');
  334.      WriteLn;
  335.      Halt;
  336.    End;
  337.    
  338.    PatchAddr1 := FindLocation (Afile, Configstart);
  339.    PatchAddr2 := FindLocation (Afile, ConfigEnd);
  340.    
  341.    If IOResult <> 0 Then Begin
  342.      WriteLn ('Configuration failed - error reading file.');
  343.      WriteLn;
  344.      Halt;
  345.    End;
  346.    
  347.    
  348.    If  (PatchAddr1 = 0) Or (PatchAddr2 = 0)
  349.        Or ( (PatchAddr2 - PatchAddr1) <> (Ofs (ConfigEnd) - Ofs (ConfigStart) ) )
  350.    Then Begin
  351.      WriteLn ('Error - incompatible structure in: ', ParamStr (0) );
  352.      WriteLn;
  353.      Halt;
  354.    End;
  355.    
  356.    { Now seek to config area in file and copy our own data to it.. }
  357.    { The area to patch starts just after 'configstart' at Nr_Workdirs}
  358.    
  359.    Seek (Afile, PatchAddr1 + Length (ConfigStart) );
  360.    
  361.    BlockWrite (Afile, Nr_Workdirs, ( SizeOf (Nr_Workdirs) + SizeOf (Workdirs) ),
  362.    BytesWritten);
  363.    
  364.    Close (Afile);
  365.    
  366.    If IOResult <> 0 Then WriteLn (' Error trying to update options.')
  367.    Else
  368.    Begin
  369.      WriteLn ('New settings written to ', ParamStr (0) );
  370.      Show_Config;
  371.    End;
  372.    
  373.    Halt;
  374.  End;
  375.  
  376.  
  377.  
  378. Procedure Get_Command_Line_Args;
  379. Var
  380.   I:   Word;
  381.   ParamString : String;
  382.   Nr_Params, DigestParam: Byte;
  383.   
  384. Begin
  385.   Nr_Params := ParamCount;
  386.   If Nr_Params = 0  Then Exit;
  387.   
  388.   DigestParam := 1;
  389.   
  390.   ParamString := ParamStr (1);
  391.   UpcaseString (ParamString);
  392.   
  393.   If ParamString = '/W' Then  Config_Workdirs;
  394.   If ParamString = '/S' Then  Show_Config;
  395.   
  396.   If ParamString = '/Y' Then  Begin
  397.     Assume_Yes := True;
  398.     Inc (DigestParam);
  399.   End;
  400.   
  401.   If ParamString = '/?' Then  Show_Info;
  402.   
  403.   
  404.   { no valid options so interpret the rest as filespecs of files to be saved }
  405.   
  406.   Nr_Names_to_save := 0;
  407.   
  408.   For i := DigestParam To Nr_Params Do   { expand & add to SAVE specs list }
  409.     If Nr_Names_to_Save < MaxSave Then         { check for max nr of names }
  410.     Begin
  411.       ParamString := ParamStr (i);
  412.       If ParamString [1] = '/' Then Show_Info;    { wrong place for option }
  413.       WildExpand (ParamString);
  414.       Inc (Nr_Names_to_Save);
  415.       Names_to_Save [Nr_Names_to_save] := ParamString;
  416.     End;
  417.   
  418. End;
  419.  
  420.  
  421.  
  422.  
  423. Procedure Check_If_Protected (Curr_file: String);
  424. Var  I: Integer;
  425. Begin
  426.   Inc (Nr_Files_Found);
  427.   Inc (Nr_Files_to_Protect);  { start and assume it's protected }
  428.   
  429.   If ( (Search_Record. Attr And ReadOnly) = ReadOnly) Then Exit; { Protected }
  430.   
  431.   For I := 1 To MaxArchExt Do              { does it have a known extension? }
  432.     If Pos ('.' + ArchExt [I] , Curr_file) > 1 Then Exit;
  433.   
  434.   For I := 1 To Nr_Names_to_Save Do                 { was it on cmd line? }
  435.     If SameName (Names_to_Save [i], Curr_File)  Then Exit;
  436.   
  437.   Dec (Nr_Files_to_Protect);  { not protected after all }
  438.   Inc (Nr_Files_To_Delete);
  439.   
  440.   Files_To_Delete [ Nr_Files_to_Delete ] := Curr_File;  { add to delete list }
  441.   
  442. End;
  443.  
  444.  
  445. Function InWorkDir: Boolean;
  446. Var ThisDir: String;
  447.   T: Word;
  448. Begin
  449.   
  450.   InWorkDir := True;
  451.   
  452.   { Test if we are in a working dir, or any one of its subdirs.... }
  453.   
  454.   GetDir (0, thisdir);
  455.   Thisdir := Thisdir + '\';
  456.   For T := 1 To Nr_WorkDirs Do
  457.   Begin
  458.     If Pos ('\' + WorkDirs [T] + '\', Thisdir) > 0 Then Exit;
  459.   End;
  460.   
  461.   InWorkDir := False;
  462. End;
  463.  
  464.  
  465. Procedure SayPrott; { ask for confirmation }
  466. Begin
  467.   WriteLn ('! WARNING - this is not a known working directory.');
  468.   Write ('Are you sure (Y/N)? ');
  469.   While KeyPressed Do CH := ReadKey;
  470.   CH := ReadKey;
  471.   WriteLn (CH);
  472.   If UpCase (CH) <> 'Y' Then Halt;
  473. End;
  474.  
  475.  
  476. Procedure Bye;
  477. Begin
  478.   WriteLn;
  479.   WriteLn ('ZNDEL 2.0  aborted.');
  480.   Halt;
  481. End;
  482.  
  483.  
  484. Function Redirected: Boolean;
  485.  { detect if user wants redirectable output }
  486. Assembler;
  487. Asm
  488.   MOV   AX, 04400h  { query device info }
  489.   MOV   BX, 1       { for device STDOUT }
  490.   Int   021h
  491.   XOr   AX, AX
  492.   Test  DL, 02      { bit 1 clear = STDOUT device no longer standard output }
  493.   JNZ   @notredir
  494.   MOV   AL, 1       { true if redirected }
  495.   @notredir:
  496. End;
  497.  
  498.  
  499. Begin
  500.   If  Redirected Then  Begin
  501.     { In Borland/Turbo Pascal, using CRT bypasses DOS so the }
  502.     { output is not redirectable. Here we reroute the output }
  503.     { to the official DOS STDOUT device again, but only when }
  504.     { the user wanted to redirected the output.              }
  505.     Assign (Output, '');  { Put pascal output back on real STDOUT.. }
  506.     Rewrite (Output);     { Open for writing }
  507.   End;
  508.   
  509.   While KeyPressed Do CH := ReadKey;
  510.   
  511.   WriteLn ('ZNDEL 2.0  Exclusive Delete utility by G. Palmer and E. de Neve    Freeware');
  512.   
  513.   Get_Command_Line_Args;
  514.   
  515.   If (Not InWorkDir) Then If (Not Assume_Yes) Then SayPrott;
  516.   
  517.   Nr_Files_Found      := 0;
  518.   Nr_Files_to_Protect := 0;
  519.   Nr_Files_to_Delete  := 0;
  520.   
  521.   
  522.   { Reading directory .. }
  523.   
  524.   FindFirst ('*.*', Archive, Search_Record);
  525.   If (DosError = 0) Then Check_if_protected (Search_Record. Name);
  526.   
  527.   While (DosError = 0) And (Nr_Files_to_Delete < Maxdelete)
  528.   Do Begin
  529.     FindNext (Search_Record);
  530.     If (DosError = 0) Then Check_if_protected (Search_Record. Name);
  531.     If KeyPressed Then bye;       { chance to cancel }
  532.   End;
  533.   
  534.   
  535.   {   Deleting files .. }
  536.   
  537.   If (Nr_Files_to_Delete > 0 ) Then
  538.   Begin
  539.     If KeyPressed Then bye;       { chance to cancel }
  540.     
  541.     For I := 1 To Nr_Files_To_Delete Do
  542.     Begin
  543.       If KeyPressed Then bye;     { chance to cancel }
  544.       Assign (Afile, Files_To_Delete [I] );
  545.       Erase (Afile);
  546.     End;
  547.     
  548.   End;
  549.   
  550.   
  551.   WriteLn;
  552.   WriteLn ('    Files found: ', Nr_Files_found);
  553.   WriteLn ('Protected files: ', Nr_Files_to_Protect);
  554.   WriteLn ('  Files deleted: ', Nr_Files_to_Delete);
  555. End.
  556.