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