home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 08 / tricks / clear.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-06-01  |  5.0 KB  |  150 lines
  1. (* ------------------------------------------------------ *)
  2. (*                    CLEAR.PAS                           *)
  3. (*        Löschen und Überschreiben von Dateien           *)
  4. (*        (c) 1989  Andreas Kleine  &  TOOLBOX            *)
  5. (* ------------------------------------------------------ *)
  6. PROGRAM Clear;
  7.  
  8. USES Dos, Crt;
  9.  
  10. CONST bufs = $E000;             { Max. 57344 Bytes werden  }
  11.                                 { auf einmal überschrieben }
  12. VAR handl, written,
  13.     count          : WORD;
  14.     pfad, fname, s : STRING;
  15.     sr             : SearchRec;
  16.     ch             : CHAR;
  17.     del            : BOOLEAN;            { Abfrage löschen }
  18.     buffer         : ARRAY [1..bufs] OF BYTE;
  19.  
  20.   PROCEDURE OpenFile(fname : STRING; access : WORD;
  21.                                           VAR handl : WORD);
  22.   VAR r : Registers;
  23.   BEGIN
  24.     r.ax := $3d00 + access;  fname := fname + #0;
  25.     r.ds := Seg(fname);      r.dx := Ofs(fname) + 1;
  26.     MsDos(r);
  27.     IF Odd(r.flags) THEN BEGIN            { Carry gesetzt? }
  28.       Writeln('Datei kann nicht geöffnet werden');
  29.       Halt;
  30.     END ELSE handl := r.ax;
  31.   END;
  32.  
  33.   PROCEDURE CloseFile(handl : INTEGER);
  34.   VAR r: REGISTERS;
  35.   BEGIN
  36.     r.ax := $3e00;         { DOS Funk. 62, Datei schließen }
  37.     r.bx := handl;
  38.     MsDos(r);
  39.     IF Odd(r.flags) THEN BEGIN
  40.       WriteLn('Fehler beim Schließen der Datei');
  41.       Halt;
  42.     END;
  43.   END;
  44.  
  45.   PROCEDURE WriteBuffer(handl, anzbytes : WORD;
  46.                                           VAR transf: WORD);
  47.                   { Schreibt anzbytes u. übergibt die tat- }
  48.                   { sächlich geschriebenen Bytes (transf)  }
  49.   VAR r: Registers;
  50.   BEGIN
  51.     r.bx := handl;
  52.     r.ax := $4000;        { DOS Funk. 67,Datei beschreiben }
  53.     r.cx := anzbytes;
  54.     r.ds := Seg(buffer);  r.dx := Ofs(buffer);
  55.     MsDos(r);
  56.     IF Odd(r.flags) THEN BEGIN
  57.       Writeln(' Datei-Schreibfehler aufgetreten');
  58.       Halt;
  59.     END ELSE transf := r.ax;
  60.     IF transf <> anzbytes THEN BEGIN
  61.       Writeln(' Achtung!! Es konnten nicht alle ',
  62.               'Bytes der Datei überschrieben werden!');
  63.       Halt;
  64.     END;
  65.   END;
  66.  
  67.   PROCEDURE ClearFile;
  68.                      { schreibt leeren Buffer in die Datei }
  69.   VAR rest, anz, time : LONGINT;
  70.       f               : FILE;
  71.   BEGIN
  72.     Assign(f, pfad + sr.name);
  73.     Reset(f, 1);            { Durch "1" ermittelt FileSize }
  74.     rest := FileSize(f);              { die Größe in Bytes }
  75.     IF NOT del THEN GetFTime(f, time);
  76.     OpenFile(pfad + sr.name, 1, handl);
  77.     REPEAT
  78.       IF rest > bufs THEN anz := bufs
  79.                      ELSE anz := rest;
  80.       WriteBuffer(handl, anz , written);
  81.       Dec(rest, written);
  82.     UNTIL rest = 0;
  83.     Closefile(handl);
  84.     IF NOT del THEN SetFTime(f, time)
  85.                ELSE erase(f);
  86.     close(f);
  87.     Inc(count);
  88.   END;
  89.  
  90.   PROCEDURE Parse(param : STRING; VAR pfad, fname : STRING);
  91.                    { teilt Parameter in Pfad und Datei auf }
  92.   VAR i : BYTE;
  93.   BEGIN
  94.     i := Length(param);
  95.     WHILE NOT(param[i] IN ['\', ':']) AND (i > 0) DO Dec(i);
  96.     pfad := Copy(param, 1, i);
  97.     IF i < Length(param) THEN
  98.       fname := Copy(param, i+1, Length(param))
  99.     ELSE fname := '*.*';
  100.   END;
  101.  
  102. BEGIN
  103.   ClrScr;  WriteLn;
  104.   WriteLn(' CLEAR überschreibt und löscht Dateien');
  105.   Write(' ( Sie sind auch mit Undelete, Recover',
  106.         ' usw. nicht mehr zurück zugewinnen! )');
  107.   WriteLn;  WriteLn;
  108.   IF (ParamCount = 0) OR (ParamCount > 2) THEN BEGIN
  109.     Writeln(' Aufruf: CLEAR [Pfad][Datei] [-]');
  110.     Writeln(' - : Dateien werden überschrieben,',
  111.             ' aber nicht gelöscht');
  112.     Halt;
  113.   END;
  114.   FillChar(buffer, bufs, $F6);             { Buffer füllen }
  115.   del := ParamStr(2) <> '-';
  116.   IF del THEN  s := ' und gelöscht' ELSE s := '';
  117.   Parse(Paramstr(1), pfad, fname);
  118.   IF pfad = '' THEN BEGIN
  119.     GetDir(0, pfad);                           { akt. Dir. }
  120.     IF pfad[Length(pfad)] <> '\' THEN pfad := pfad + '\';
  121.   END;
  122.   WriteLn(' Pfad: ', pfad, '   Datei: ', fname);
  123.   WriteLn(' Es wird überschrieben' + s);  WriteLn;
  124.   count := 0;
  125.   FindFirst(pfad + fname, anyfile, sr);
  126.   IF DosError IN [2, 18] THEN
  127.     WriteLn(' Datei nicht gefunden!');
  128.   WHILE DosError = 0 DO BEGIN
  129.     IF sr.attr AND ReadOnly <> 0 THEN
  130.       WriteLn(' ', sr.name, ' ist schreibgeschützt',
  131.                             ' - Zugriff ist nicht möglich!')
  132.     ELSE
  133.       IF (sr.attr AND directory = 0) AND
  134.          (sr.attr AND volumeID= 0) THEN BEGIN
  135.         Write(' Soll ', sr.name:12, ' überschrieben',
  136.                 s + ' werden (J/N/ESC) ? ');
  137.         REPEAT
  138.           ch := UpCase(ReadKey);
  139.         UNTIL ch IN ['J', 'N', #27];
  140.         IF ch = #27 THEN Halt;
  141.         WriteLn(ch);  IF ch = 'J' THEN ClearFile;
  142.       END;
  143.     FindNext(sr);                   { Nächste Datei suchen }
  144.   END;
  145.   IF DosError = 3 THEN WriteLn(' Pfad nicht gefunden!');
  146.   WriteLn;
  147.   WriteLn(count:3, ' Datei(en) überschrieben' + s);
  148. END.
  149. (* ------------------------------------------------------ *)
  150. (*                 Ende von CLEAR.PAS                     *)