Turbo Toolbox/Turbo_Toolbox.iso/1990/11/bonus/filter.pas

Pascal/Delphi Source File | 1990-10-05 | 5.7 KB | 208 lines

(* ------------------------------------------------------ *)
(*                     FILTER.PAS                         *)
(*         Ersetzen von Zeichenketten in Dateien          *)
(*           (c) 1990 R. Hensmann & TOOLBOX               *)
(* ------------------------------------------------------ *)
{$I-}
PROGRAM Filter2;

USES Dos, LongReplace;

TYPE PReplace = ^TReplace;
       (* Zeiger auf Ersetzungsrecord *)

     TReplace = RECORD
                  OldString, NewString : STRING;
                  Next                 : PReplace;
                END;
       (* Zeigerliste für Ersetzkombinationen *)

     CharKomb = ARRAY [#0..#255] OF SET OF CHAR;
       (* Alle Buchstabenkombinationen der Suchstrings *)

VAR  Wurzel   : PReplace;
     ck       : CharKomb;
     Buf      : BufArray;
       (* Textpuffer *)

PROCEDURE ckString( VAR st : STRING);
VAR i : WORD;
BEGIN
  (* Eintragen aller Buchstabenkombinationen *)
  FOR i := 1 TO Length( st)-1 DO
    ck[st[i]] := ck[st[i]] + [st[i+1]];
END;

PROCEDURE Error( St : STRING);
BEGIN
  WriteLn(St);
  Halt;
END;

PROCEDURE ReadWhitespace(VAR s:STRING;ch:CHAR;VAR i:WORD);
(* überliest Leerzeichen und TAB's *)
CONST TAB = CHR(9);
BEGIN
  WHILE (s[i] <> ch) AND (i<=Length(s)) DO BEGIN
    IF (s[i] <> ' ') AND (s[i] <> TAB) THEN BEGIN
      WriteLn('Fehler : ',s);
      WriteLn('':9-1+i,'^');
      Error( 'Programm abgebrochen');
    END;
    INC( i);
  END;
  IF i<=Length(s) THEN INC(i);
END; (* ReadWhitespace *)

PROCEDURE ReadStr(VAR s:STRING; ch:CHAR; VAR i:WORD;
                  VAR new:STRING);
BEGIN
  new := '';
  REPEAT
    WHILE (i <= Length(s)) AND (s[i] <> ch) DO BEGIN
      new := new+s[i];
      INC( i);
    END;
    (* Wenn Delimiter doppelt angegeben, *)
    (* wird er Pascal-like aufgenommen   *)
    IF (i < Length(s)) AND (s[i+1] = ch) THEN BEGIN
      new := new+ch;
      INC( i,2);
    END;
  UNTIL (i>Length(s)) OR (s[i] = ch);
  IF i<=Length(s) THEN INC( i);
END; (* ReadStr *)

PROCEDURE LoadData( DatName : STRING);
VAR t         : Text;
    h         : PReplace;
    Zeile     : STRING;
    i         : WORD;
BEGIN
  Fillchar( ck, SIZEOF( ck), #0); (* ARRAY leeren *)
  Assign( t, DatName);
  Reset( t);
  IF IOResult <> 0 THEN
    Error('Steuerdatei nicht gefunden.');
  New( Wurzel); (* Dummy-Element *)
  h := Wurzel;  (* Hilfszeiger   *)
  REPEAT
    ReadLn( t, Zeile);
    IF IOResult <> 0 THEN
      Error('Lesefehler beim Lesen der Steuerdatei');
    IF (Zeile <> '') AND (Zeile[1] <> ';') THEN BEGIN
      New( h^.next);
      h := h^.next;
      i := 1; (* Laufzeiger des Strings *)
      ReadWhitespace( Zeile, '"', i);
      ReadStr( Zeile, '"', i, h^.OldString);
      ReadWhiteSpace( Zeile, '=', i);
      ReadWhiteSpace( Zeile, '"', i);
      ReadStr( Zeile, '"', i, h^.NewString);
      ckString( h^.OldString);
      h^.next := NIL;
      IF h^.OldString = '' THEN BEGIN
        WriteLn( Zeile);
        Error('Ein leerer String kann nicht ersetzt werden');
      END;
    END;
  UNTIL EOF( t);
  Wurzel := Wurzel^.Next;
  Close( t);
  IF IOResult <> 0 THEN
    Error('Steuerdatei kann nicht geschlossen werden');
END; (* LoadData *)

PROCEDURE ChangeText( VAR OldText, NewText : STRING);
VAR fold, fnew : File;
    sold       : LONGINT;
    bufsize,
    bufstart   : LONGINT;
    h          : PReplace;

BEGIN
  Assign( fold, OldText);
  Assign( fnew, NewText);
  Reset( fold, 1);
  IF IOResult <> 0 THEN
    Error('Originaldatei nicht gefunden');
  Rewrite( fnew, 1);
  IF IOResult <> 0 THEN
    Error('Neue Datei kann nicht geöffnet werden. Schreibschutz?');
  sold := FileSize( fold);
  bufstart := 0;
  WHILE sold > 0 DO BEGIN
    IF sold > 10000 THEN bufsize := 10000
                    ELSE bufsize := sold;
    BlockRead(fold, Buf, bufsize);
    Write('.');
    IF IOResult <> 0 THEN
      Error('Lesefehler');
    WHILE (bufsize > 0) AND (bufsize <> sold) AND
          (Buf[bufsize] IN ck[Buf[bufsize-1]])
    DO Dec(bufsize);
    IF bufsize = 0 THEN
      Error('Interner Fehler: zu kompliziert');
    Inc(bufstart,bufsize);
    Dec(sold,bufsize);
    Seek( fold, bufstart);

    h := wurzel;
    WHILE h <> NIL DO BEGIN
      LongReplaceAll( h^.OldString,
                      h^.NewString,
                      Buf,
                      bufsize);
      h := h^.next;
      Write('.');
    END;
    BlockWrite(fnew,Buf,bufsize);
    IF IOResult <> 0 THEN
      Error('Schreibfehler');
  END; (* WHILE *)
  Close( fold);
  Close( fnew);
  IF IOResult <> 0 THEN
    Error('Fehler beim Schließen der Dateien');
END; (* ChangeText *)

VAR newtext, oldtext, steuer : STRING;
    t, t2                    : Text;
    same                     : BOOLEAN;
    path, dummy              : STRING;

BEGIN
  WriteLn('FILTER - Textdateifilter ');
  Write('Steuerdatei                           : ');
  ReadLn(steuer);
  LoadData(steuer);
  Write('Alte Datei                            : ');
  ReadLn(oldtext);
  Write('Neue Datei (RETURN für gleichen Namen): ');
  ReadLn(newtext);
  WriteLn;
  same := newtext = '';
  IF same THEN BEGIN
    FSplit( FExpand(oldtext), path, oldtext, dummy);
    oldtext := oldtext+dummy;
    Assign(t, path+oldtext);
    Rename(t, path+'FILTER.)$(');
    IF IOResult <> 0 THEN BEGIN
      Assign(t2, path+'FILTER.)$(');
      Erase(t2);
      IF IOResult <> 0 THEN
        Error(path+'FILTER.)$( kann nicht gelöscht werden');
    END;
    newtext := path+oldtext;
    oldtext := path+'FILTER.)$(';
  END;
  Write('Bin beschäftigt');
  ChangeText( oldtext, newtext);
  Writeln;
  IF same THEN BEGIN
    Erase( t);
    IF IOResult <> 0 THEN
      Error('Filter.)$( kann nicht gelöscht werden');
  END;
END.