home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 12 / tricks / xera.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1990-09-12  |  10.0 KB  |  335 lines
  1. (* ------------------------------------------------------ *)
  2. (*                       XERA.PAS                         *)
  3. (*             (c) 1990 Günter Rau & TOOLBOX              *)
  4. (* ------------------------------------------------------ *)
  5. PROGRAM CrossErase;
  6.  
  7. {$R-,S-,I-,V-,B-,N-}
  8. {$M 50000,0,0}
  9.  
  10. USES Crt,Dos;
  11.  
  12. TYPE
  13.   str10 = STRING [10];
  14.  
  15. CONST
  16.   Version               = 'X(Cross)ERA(se)';
  17.   DelayTime             = 2000;
  18.   BufLen                = 1024;
  19.   JokerChar   : STRING  = '&';
  20.                     { Joker für ein beliebiges Zeichen }
  21.   JokerStr    : STRING  = '*';
  22.                         { Joker für beliebige Zeichenkette }
  23.   OptionCut   : STRING  = '/';
  24.            { durch dieses Zeichen werden Optionen getrennt }
  25.   ExcludeName : STRING  = '?????????.????';
  26.   forced      : BOOLEAN = FALSE;
  27.   subdir      : BOOLEAN = FALSE;
  28.   cat         : BOOLEAN = FALSE;
  29.   request     : BOOLEAN = FALSE;
  30.   slow        : BOOLEAN = FALSE;
  31.   wipe        : BOOLEAN = FALSE;
  32.  
  33. VAR
  34.   Path        : DirStr;
  35.   FName    : NameStr;
  36.   FExt   : ExtStr;
  37.   Buffer      : ARRAY [1..BufLen] OF BYTE;
  38.  
  39.   PROCEDURE Help;
  40.   BEGIN
  41.     WriteLn;
  42.     WriteLn('Folgende Optionen sind erlaubt:');
  43.     WriteLn('/DIR      löschen eines Unterverzeichnisses');
  44.     WriteLn('/SUB      Dateien werden auch in allen ',
  45.                        'Unterverzeichnissen gelöscht');
  46.     WriteLn('/F        auch Dateien mit den Attributen ',
  47.             'Hidden und ReadOnly werden gelöscht');
  48.     WriteLn('/SL       langsames Löschen');
  49.     WriteLn('/WIPE     Datei wird überschrieben, bevor ',
  50.                        'sie gelöscht wird');
  51.     WriteLn('/R        bei jeder Datei wird gefragt, ',
  52.                        'ob sie gelöscht werden soll');
  53.     WriteLn('/EX=file  diese Dateien werden nicht ',
  54.                        'gelöscht');
  55.     WriteLn;
  56.     WriteLn('Beispiel:');
  57.     WriteLn('DELETE *.*/SUB/WIPE/EX=*.pas');
  58.     WriteLn;
  59.   END;
  60.  
  61.   PROCEDURE ExitProcedure;
  62.   VAR
  63.     c : CHAR;
  64.   BEGIN
  65.     IF KeyPressed THEN BEGIN
  66.       c := ReadKey;
  67.       IF c = #27 THEN Halt(0);
  68.       WriteLn('Press any key to continue, or ESC to Exit');
  69.       c := ReadKey;
  70.       IF c = #27 THEN Halt(0);
  71.     END;
  72.   END;
  73.  
  74.   FUNCTION StrUpCase(s : STRING) : STRING;
  75.   VAR
  76.     i : INTEGER;
  77.   BEGIN
  78.     FOR i := 1 TO Length(s) DO s[i] := UpCase(s[i]);
  79.     StrUpCase := s;
  80.   END;
  81.  
  82.   FUNCTION FileAttr(sr : SearchRec; Attr : BYTE) : BOOLEAN;
  83.   BEGIN
  84.     FileAttr := FALSE;
  85.     IF (sr.Attr AND Attr) = Attr THEN FileAttr := TRUE;
  86.   END;
  87.  
  88.   FUNCTION MinInt(a, b : INTEGER) : INTEGER;
  89.   BEGIN
  90.     IF a < b THEN MinInt := a
  91.              ELSE MinInt := b;
  92.   END;
  93.  
  94.   FUNCTION Jokerposition(s : STRING) : INTEGER;
  95.     { gibt an, an welcher Stelle in "s" ein Joker vorkommt }
  96.   VAR
  97.     Starpos, Andpos : INTEGER;
  98.   BEGIN
  99.     Starpos := Pos(Jokerstr,  s);
  100.     Andpos  := Pos(Jokerchar, s);
  101.     IF Starpos = 0 THEN Jokerposition := Andpos;
  102.     IF Andpos  = 0 THEN Jokerposition := Starpos;
  103.     IF (Starpos > 0) AND (Andpos > 0) THEN
  104.       Jokerposition := MinInt(Starpos, Andpos);
  105.   END;
  106.  
  107.   FUNCTION Match(Jokerstring, name : STRING) : BOOLEAN;
  108.     { prüft, ob Jokerstring und name 'zusammenpassen' }
  109.   VAR
  110.     Matchpos, Jokerpos, NextJokerpos, Starpos,
  111.     Andpos,   NameLen, JokerStringLen             : INTEGER;
  112.   BEGIN
  113.     NameLen := Length(name);
  114.     Jokerstringlen := Length(Jokerstring);
  115.     Jokerpos := Jokerposition(Jokerstring);
  116.     IF Jokerpos > 1 THEN BEGIN
  117.       IF Copy(Jokerstring, 1, Jokerpos-1) =
  118.          Copy(name, 1, Jokerpos-1) THEN BEGIN
  119.         Match := Match(Copy(Jokerstring, Jokerpos,
  120.                             Jokerstringlen),
  121.                        Copy(name, Jokerpos, namelen));
  122.       END ELSE BEGIN
  123.         Match := FALSE;
  124.       END;
  125.     END;
  126.     IF Jokerpos = 1 THEN BEGIN
  127.       nextJokerpos := Jokerposition(Copy(Jokerstring, 2,
  128.                                     Jokerstringlen-1));
  129.       IF Copy(Jokerstring, 1, 1) = Jokerstr THEN BEGIN
  130.                                              { Joker = '*' }
  131.         IF nextJokerpos = 0 THEN BEGIN
  132.           Match := Match(Copy(Jokerstring, 2,
  133.                               Jokerstringlen-1),
  134.                          Copy(name, namelen -
  135.                               (Jokerstringlen-1)+1,
  136.                                Jokerstringlen-1));
  137.         END ELSE BEGIN
  138.           matchpos := Pos(Copy(Jokerstring, 2,
  139.                                nextJokerpos-1), name);
  140.           IF matchpos = 0 THEN BEGIN
  141.             Match := FALSE;
  142.           END ELSE BEGIN
  143.             Match := Match(Copy(Jokerstring, 2,
  144.                                 Jokerstringlen-1),
  145.                            Copy(name, matchpos,
  146.                                 namelen-matchpos+1));
  147.           END;
  148.         END;
  149.       END ELSE BEGIN                         { Joker = '&' }
  150.         IF namelen > 0 THEN BEGIN
  151.           Match := Match(Copy(Jokerstring, 2,
  152.                               Jokerstringlen-1),
  153.                          Copy(name, 2, namelen-1));
  154.         END ELSE BEGIN
  155.           Match := FALSE;
  156.         END;
  157.       END;
  158.     END;
  159.     IF Jokerpos = 0 THEN BEGIN
  160.       Match := (Jokerstring = name);
  161.     END;
  162.   END;
  163.  
  164.   PROCEDURE ParseInput;
  165.   VAR
  166.     Position     : INTEGER;
  167.     option, name : STRING;
  168.  
  169.     PROCEDURE ParseOption(option : STRING);
  170.     BEGIN
  171.       IF Length(option) > 0 THEN BEGIN
  172.         option := option + '/';
  173.         option := StrUpCase(option);
  174.         IF Pos('/HELP/', option) > 0 THEN BEGIN
  175.           help;
  176.           Halt(0);
  177.         END;
  178.         IF Pos('/EX=', option) > 0 THEN BEGIN
  179.           Excludename := option;
  180.           Delete(ExcludeName, 1,
  181.                  Pos('/EX=', ExcludeName) + 3);
  182.           excludename := Copy(excludename, 1,
  183.                               Pos('/', excludename)-1);
  184.         END;
  185.         IF Pos('/SUB/',  option) > 0 THEN subdir  := TRUE;
  186.         IF Pos('/F/',    option) > 0 THEN forced  := TRUE;
  187.         IF Pos('/DIR/',  option) > 0 THEN cat     := TRUE;
  188.         IF Pos('/R/',    option) > 0 THEN request := TRUE;
  189.         IF Pos('/SL/',   option) > 0 THEN slow    := TRUE;
  190.         IF Pos('/WIPE/', option) > 0 THEN wipe    := TRUE;
  191.       END;
  192.     END;
  193.  
  194.   BEGIN
  195.     name   := '';
  196.     option := '';
  197.     IF ParamCount = 1 THEN BEGIN
  198.       Position := Pos(optioncut, ParamStr(1));
  199.       IF Position > 0 THEN BEGIN
  200.         option := Copy(ParamStr(1), Position,
  201.                        Length(ParamStr(1)));
  202.         name   := Copy(ParamStr(1), 1, Position-1);
  203.       END ELSE BEGIN
  204.         name := ParamStr(1);
  205.       END;
  206.     END ELSE Halt(0);
  207.     name := FExpand(name);
  208.     FSplit(name, Path, FName, FExt);
  209.     ParseOption(option);
  210.   END;
  211.  
  212.   PROCEDURE WipeFile(VAR f : FILE);
  213.   VAR
  214.     i, len : LONGINT;
  215.   BEGIN
  216.     Rewrite(f, BufLen);
  217.     len := (FileSize(f) DIV BufLen) + 1;
  218.     FOR i := 1 TO len DO BEGIN
  219.       BlockWrite(f, Buffer, 1);
  220.     END;
  221.     Close(f);
  222.   END;
  223.  
  224.   PROCEDURE DeleteFiles(Path, FName : STRING);
  225.  
  226.     PROCEDURE DelFile(Path,FName : STRING);
  227.     VAR
  228.       sr : SearchRec;
  229.       f  : FILE;
  230.       c  : CHAR;
  231.     BEGIN
  232.       FindFirst(Path + '*.*', anyfile, sr);
  233.       WHILE DosError = 0 DO BEGIN
  234.         IF NOT (FileAttr(sr, Directory) OR
  235.                 FileAttr(sr, volumeid)) THEN BEGIN
  236.           IF Match(FName, sr.name) AND
  237.              (NOT Match(excludename, sr.name)) THEN BEGIN
  238.             Assign(f, Path + sr.name);
  239.             IF forced AND
  240.                (NOT FileAttr(sr, SysFile)) THEN BEGIN
  241.               SetFAttr(f, 0);
  242.               sr.Attr := 0;
  243.             END;
  244.             IF FileAttr(sr, ReadOnly) OR
  245.                FileAttr(sr, Hidden) OR
  246.                FileAttr(sr, SysFile) THEN BEGIN
  247.               Write(Path + sr.name);
  248.               GotoXY(65, WhereY);
  249.               WriteLn('NOT deleted');
  250.             END ELSE BEGIN
  251.               ExitProcedure;
  252.               IF request THEN BEGIN
  253.                 Write(Path + sr.name);
  254.                 GotoXY(60, WhereY);
  255.                 Write('delete ? (Y/N) ');
  256.                 c := ReadKey;
  257.                 IF c = #27 THEN Halt(0);
  258.                 WriteLn(UpCase(c));
  259.                 IF UpCase(c) = 'Y' THEN BEGIN
  260.                   IF wipe THEN WipeFile(f);
  261.                   Erase(f);
  262.                 END;
  263.               END ELSE BEGIN
  264.                 IF slow THEN Delay(delaytime);
  265.                 ExitProcedure;
  266.                 IF wipe THEN WipeFile(f);
  267.                 Erase(f);
  268.                 Write(Path + sr.name);
  269.                 GotoXY(65, WhereY);
  270.                 WriteLn('deleted');
  271.               END;
  272.             END;
  273.           END;
  274.         END;
  275.         FindNext(sr);
  276.       END;
  277.     END;
  278.  
  279.     PROCEDURE DelAllFiles(Path, FName : STRING);
  280.     VAR
  281.       sr : SearchRec;
  282.     BEGIN
  283.       DelFile(Path,FName);
  284.       FindFirst(Path + '*.*', anyfile, sr);
  285.       WHILE DosError = 0 DO BEGIN
  286.         IF FileAttr(sr, Directory) AND
  287.            (sr.name[1] <> '.') THEN
  288.           DelAllFiles(Path + sr.name + '\', FName);
  289.         FindNext(sr);
  290.       END;
  291.     END;
  292.  
  293.     PROCEDURE DelDir(Path : STRING);
  294.     VAR
  295.       sr : SearchRec;
  296.       s  : STRING;
  297.     BEGIN
  298.       DelFile(Path, '*');
  299.       FindFirst(Path + '*.*', anyfile, sr);
  300.       WHILE DosError = 0 DO BEGIN
  301.         IF FileAttr(sr, Directory) AND
  302.            (sr.name[1] <> '.') THEN
  303.           DelDir(Path + sr.name + '\');
  304.         FindNext(sr);
  305.       END;
  306.       s := Path;
  307.       Delete(s, Length(s), 1);
  308.     {$I-}
  309.       RmDir(s);
  310.     {$I+}
  311.       Write('Directory   ', Path, '   ');
  312.       IF IOResult <> 0 THEN
  313.         WriteLn('cannot be removed')
  314.       ELSE
  315.         WriteLn('removed')
  316.     END;
  317.  
  318.   BEGIN
  319.     IF subdir THEN BEGIN
  320.       DelAllFiles(Path, FName);   Exit;
  321.     END;
  322.     IF cat THEN BEGIN
  323.       DelDir(Path + FName+'\');  Exit;
  324.     END;
  325.     DelFile(Path, FName);
  326.   END;
  327.  
  328. BEGIN
  329.   FillChar(Buffer, BufLen, #0);
  330.   ParseInput;
  331.   DeleteFiles(Path, FName + FExt);
  332. END.
  333. (* ------------------------------------------------------ *)
  334. (*                Ende von XERA.PAS                       *)
  335.