Category : Utilities for DOS and Windows Machines
Archive   : MODFILT.ZIP
Filename : FILTER.MOD

 
Output of file : FILTER.MOD contained in archive : MODFILT.ZIP
MODULE filter;

(*
Title: filter.mod

Author: Randall A. Maddox
12209 M Peach Crest Drive
Germantown, MD 20874
(301) 428-9581

System: LOGITECH MODULA-2, MS/PCDOS, Version 3.0, August 1987

Description: This program will accept a byte pattern to look for, a
second byte pattern to replace the first one with, and
a series of file names upon which to perform the search
and replace operations. Invoking the program with no
parameters, or with an invalid parameter, will give a
screen showing the proper calling syntax and the error.
The program is NOT user interactive, all its parameters
are passed to it in the command line tail. The program
may be invoked from .bat files and it returns the following
values in ERRORLEVEL for use in IF tests after return:

ERRORLEVEL = 0 -> no error, normal program termination
ERRORLEVEL = 1 -> program halted by user with ^X
ERRORLEVEL = 2 -> improper command-line syntax
ERRORLEVEL = 3 -> invalid/missing input pattern
ERRORLEVEL = 4 -> invalid/missing output pattern
ERRORLEVEL = 5 -> input file open/read/close error(s)
ERRORLEVEL = 6 -> output file creation/write/close error(s)
ERRORLEVEL = 7 -> both input and output file error(s)

The program employs the Boyer-Moore pattern matching
algorithm. For more details on this and other useful
algorithms see: "Algorithms", R. Sedgewick, 1984,
Addison-Wesley Publishing Company, Inc., Reading, MA.
See also: "Algorithms & Data Structures", N. Wirth, 1986,
Prentice-Hall, Inc., Englewood Cliffs, NJ. I highly
recommend both of these texts, and the Wirth text in
particular for all you Modula-2 programmers.

Update History:
Originally written: 11/28/87 by Randy Maddox
Released: 12/9/87 by Randy Maddox

*)

FROM Break IMPORT
DisableBreak;

FROM ErrorCode IMPORT
SetErrorCode, ExitToOS;

FROM InOut IMPORT
WriteString, WriteLn;

FROM Keyboard IMPORT
Read,KeyPressed;

FROM FileSystem IMPORT
File,Response,Lookup,SetRead,SetWrite,Close,Delete,
ReadNBytes,WriteNBytes;

FROM NumberConversion IMPORT
StringToNum;

IMPORT Strings;

FROM SYSTEM IMPORT
BYTE, WORD, ADDRESS, ADR, CODE, SWI, GETREG, SETREG, AX, BX, ES;


CONST
Null = 000C; (* ASCII Null, string terminator *)
Space = 040C; (* ASCII Space *)
CR = 015C; (* ASCII Carriage Return *)
Delim = '~'; (* string delimiter *)
BufSiz = 30719; (* size of InBuf and OutBuf *)

TYPE
Buffer = ARRAY[0..BufSiz] OF BYTE;

VAR
CTail : ARRAY[0..127] OF CHAR; (* command line tail *)
Tnull : CARDINAL; (* index of Null terminator on CTail *)
Sep1 : CARDINAL; (* index of 1st separator in CTail *)
Sep2 : CARDINAL; (* index of 2nd separator in CTail *)
InPat : ARRAY[0..120] OF BYTE; (* input pattern *)
Lin : INTEGER; (* index of last valid byte of InPat *)
OutPat : ARRAY[0..120] OF BYTE; (* output pattern *)
Lout : INTEGER; (* index of last valid byte of OutPat *)
Skip : ARRAY[0..255] OF CARDINAL; (* mismatch skip length *)
InFile : ARRAY[0..65] OF CHAR; (* input file name *)
Inf : File; (* input file handle structure *)
InFileErr : BOOLEAN; (* true if any InFile is bad *)
OutFile : ARRAY[0..65] OF CHAR; (* output file name *)
Outf : File; (* output file handle structure *)
OutFileErr : BOOLEAN; (* true if any OutFile is bad *)
FileOK : BOOLEAN; (* true if OK to read/write file *)
NoFile : BOOLEAN; (* true when no more left in CTail *)
InBuf : Buffer; (* input buffer *)
OutBuf : Buffer; (* output buffer *)
Abort : BOOLEAN; (* true if user wants to abort *)

(****************************************************************************)

PROCEDURE GetCTail(VAR Tnull : CARDINAL; VAR CTail : ARRAY OF CHAR);

(* This procedure retrieves the command line tail and returns it in
CTail as a Null terminated string. The index of the terminating
Null is returned in Tnull. *)

TYPE
CharPointer = POINTER TO CHAR;

VAR
Cptr : CharPointer;
TmpPtr : ADDRESS;
AXwd : WORD;
I : CARDINAL;

BEGIN
AXwd := WORD(2F00H);
SETREG(AX,AXwd); (* AH = 2FH, Get Disk Transfer Address *)
CODE(55H); (* PUSH BP *)
SWI(21H); (* call DOS *)
CODE(5DH); (* POP BP *)
GETREG(ES,TmpPtr.SEGMENT); (* DTA, segment *)
GETREG(BX,TmpPtr.OFFSET); (* DTA, offset *)
Cptr := TmpPtr;
Tnull := ORD(Cptr^); (* Tnull = length of command tail *)
IF (Tnull > 0) THEN
FOR I := 0 TO (Tnull - 1) DO
INC(TmpPtr); (* point to next byte in command tail *)
Cptr := TmpPtr;
CTail[I] := Cptr^; (* and get that byte *)
END; (* for *)
END; (* if *)
CTail[Tnull] := 000C; (* Null terminator on string *)
END GetCTail; (* procedure *)

(****************************************************************************)

PROCEDURE Quit(Err : CARDINAL);

(* This procedure displays an error message, sets the DOS ERRORLEVEL,
and then exits to DOS. *)

VAR
ErrMsg : ARRAY[0..60] OF CHAR;

BEGIN
IF (Err = 0) THEN ErrMsg := '** Normal program termination.'
ELSIF (Err = 1) THEN ErrMsg := '** Program aborted by user.'
ELSIF (Err = 2) THEN ErrMsg := '** ERROR: Improper command-line syntax.'
ELSIF (Err = 3) THEN ErrMsg := '** ERROR: Invalid/missing input pattern.'
ELSIF (Err = 4) THEN ErrMsg := '** ERROR: Invalid/missing output pattern.'
ELSIF (Err = 5) THEN ErrMsg := '** ERROR: Input file open/read/close error(s).'
ELSIF (Err = 6) THEN ErrMsg := '** ERROR: Output file creation/write/close error(s).'
ELSIF (Err = 7) THEN ErrMsg := '** ERROR: Both input and output file error(s).'
ELSE ErrMsg := '** ERROR: Unknown error condition.' END;
WriteLn;
WriteString(ErrMsg);
WriteLn;
IF (Err > 1) AND (Err < 5) THEN (* command-line error, give usage *)
WriteLn;
WriteString('Proper calling syntax is:');
WriteLn;WriteLn;
WriteString(' filter [ ...]');
WriteLn;WriteLn;
WriteString('Where: is a series of bytes to be replaced with WriteLn;
WriteString('pattern>. Each pattern may be specified either as a series of characters');
WriteLn;
WriteString('enclosed by ');
WriteString(Delim);WriteString(Delim);
WriteString(', or as a series of hexadecimal byte values separated');
WriteLn;
WriteString('by commas, e.g., ');
WriteString(Delim);
WriteString('aBc');
WriteString(Delim);
WriteString(' and 0D,0A are each valid patterns. The two patterns');
WriteLn;
WriteString('need not be the same length, and may be ');
WriteString(Delim);
WriteString(Delim);
WriteString(' in order to');
WriteLn;
WriteString('delete from the file. Max pattern size is 120 bytes.');
WriteLn;WriteLn;
WriteString(' is the name, optionally including a path, of an EXISTING file');
WriteLn;
WriteString('to be filtered. Output is to file with same , but with the');
WriteLn;
WriteString('extension .FLT. Multiple may be included on the command line');
WriteLn;
WriteString('and each will be filtered in turn. NOTE: This program automatically');
WriteLn;
WriteString('avoids filename collisions and will NOT overwrite an existing file.');
WriteLn;
END;
SetErrorCode(Err);
ExitToOS;
END Quit; (* procedure *)

(****************************************************************************)

PROCEDURE CleanTail(VAR Tnull : CARDINAL; VAR CTail : ARRAY OF CHAR;
VAR Sep1 : CARDINAL; VAR Sep2 : CARDINAL);

(* This procedure removes all excess spaces from CTail, i.e., leading
and trailing spaces are removed and any internal spacings of more
than one space are reduced to a single space. The index of the first
internal separator is returned in Sep1 and the second in Sep2. Both
will be 0 if no internal separators are found. *)

VAR
I : CARDINAL;

BEGIN
Sep1 := 0; (* initialize *)
Sep2 := 0;
WHILE (CTail[0] = Space) DO (* clear any leading blanks *)
Strings.Delete(CTail,0,1);
DEC(Tnull);
END; (* while *)
WHILE (Tnull > 0) AND (CTail[Tnull - 1] = Space) DO (* and trailing blanks *)
Strings.Delete(CTail,(Tnull - 1),1);
DEC(Tnull);
END; (* while *)
IF (Tnull < 4) THEN
Quit(2) (* bad command line *)
ELSE (* trim out any extra internal blanks *)
(* first set point to start looking for spaces *)
I := 1;
IF (CTail[0] = Delim) THEN (* got delimited string to skip over *)
WHILE (CTail[I] <> Delim) AND (I < Tnull) DO
INC(I)
END; (* while *)
IF (I = 1) THEN
Quit(3) (* first string is empty DelimDelim *)
ELSIF ((Tnull - I) < 5) THEN
Quit(2) (* bad command line *)
ELSE
INC(I); (* point to first char after closing delim *)
IF (CTail[I] <> Space) THEN Quit(2) END; (* bad syntax *)
END; (* if*)
END; (* if *)
REPEAT
IF (CTail[I] = Delim) THEN (* got another delimited string to skip *)
INC(I);
WHILE (CTail[I] <> Delim) AND (I < Tnull) DO
INC(I)
END; (* while *)
IF ((Tnull - I) < 3) THEN Quit(2) END; (* bad command line *)
ELSIF (CTail[I] = Space) THEN (* record index of 1st and 2nd blanks *)
IF (Sep1 = 0) THEN
Sep1 := I
ELSIF (Sep2 = 0) THEN
Sep2 := I
END; (* if *)
END; (* if *)
WHILE (CTail[I] = Space) AND (CTail[I + 1] = Space) DO
Strings.Delete(CTail,(I + 1),1);
DEC(Tnull);
END; (* while *)
INC(I);
UNTIL (I > (Tnull - 2)) (* repeat *)
END; (* if *)
END CleanTail; (* procedure *)

(****************************************************************************)

PROCEDURE GetInPat(Sep1 : CARDINAL; CTail : ARRAY OF CHAR;
VAR InPat : ARRAY OF BYTE; VAR Lin : INTEGER);

(* This procedure extracts the input pattern from CTail and checks that
it is a valid pattern. If valid, the pattern is returned in InPat
and the index of the last valid byte in InPat is returned in Lin,
otherwise the program is aborted. *)

VAR
I,J : CARDINAL;
Tmp : ARRAY[0..2] OF CHAR;
Done : BOOLEAN;

BEGIN
Lin := -1; (* set initially to bad value *)
IF (CTail[0] = Delim) AND (CTail[Sep1 - 1] = Delim) THEN
(* got delimited string *)
FOR I := 1 TO (Sep1 - 2) DO
InPat[I - 1] := BYTE(CTail[I])
END; (* for *)
Lin := Sep1 - 3
ELSE (* got hex digits separated by commas *)
(*
I -> index into CTail, initially 0
Lin -> index into InPat, initially -1
J -> gets cardinal value of Tmp
*)
I := 0; (* initialize index *)
Tmp[2] := Null; (* terminate string *)
LOOP
IF (I >= Sep1) THEN EXIT END; (* all done *)
Tmp[0] := CTail[I]; (* assume at least one digit *)
INC(I); (* point to next *)
IF (CTail[I] <> ',') AND (CTail[I] <> ' ') THEN
(* get second digit, if present *)
Tmp[1] := CTail[I];
INC(I) (* point to next *)
ELSE (* only one digit, terminate string *)
Tmp[1] := Null
END;
StringToNum(Tmp,16,J,Done);
IF Done THEN (* got valid byte value *)
INC(Lin);
InPat[Lin] := VAL(BYTE,J)
ELSE (* invalid value *)
Lin := -1;
EXIT
END;
(* I should now be pointing at ',' or ' ', so point to next digit *)
INC(I);
END; (* loop *)
END; (* if *)
IF (Lin < 0) THEN Quit(3) END; (* bad InPat, abort *)
END GetInPat; (* procedure *)

(****************************************************************************)

PROCEDURE GetOutPat(VAR Sep1, Sep2 : CARDINAL; VAR CTail : ARRAY OF CHAR;
VAR OutPat : ARRAY OF BYTE; VAR Lout : INTEGER);

(* This procedure extracts the output pattern from CTail and checks that
it is a valid pattern. If valid, the pattern is returned in OutPat
and the index of the last valid byte in OutPat is returned in Lout,
otherwise the program is aborted. *)

VAR
I,J : CARDINAL;
Tmp : ARRAY[0..2] OF CHAR;
Done : BOOLEAN;
Empty : BOOLEAN;

BEGIN
Lout := -1; (* set initially to bad value *)
Empty := FALSE; (* don't know if empty yet *)
IF (CTail[Sep1 + 1] = Delim) AND (CTail[Sep2 - 1] = Delim) THEN
(* got delimited string *)
IF ((Sep2 - Sep1) > 3) THEN (* got nonempty string *)
J := 0;
FOR I := (Sep1 + 2) TO (Sep2 - 2) DO
OutPat[J] := BYTE(CTail[I]);
INC(J)
END; (* for *)
Lout := J - 1
ELSIF ((Sep2 - Sep1) = 3) THEN (* got empty string *)
Lout := 0; (* set to a good value *)
Empty := TRUE (* now we know *)
ELSE
Quit(2) (* bad syntax *)
END; (* if *)
ELSE (* got hex digits separated by commas *)
(*
I -> index into CTail, initially 0
Lin -> index into OutPat, initially -1
J -> gets cardinal value of Tmp
*)
I := Sep1 + 1; (* initialize index *)
Tmp[2] := Null; (* terminate string *)
LOOP
IF (I >= Sep2) THEN EXIT END; (* all done *)
Tmp[0] := CTail[I]; (* assume at least one digit *)
INC(I); (* point to next *)
IF (CTail[I] <> ',') AND (CTail[I] <> ' ') THEN
(* get second digit, if present *)
Tmp[1] := CTail[I];
INC(I) (* point to next *)
ELSE (* only one digit, terminate string *)
Tmp[1] := Null
END;
StringToNum(Tmp,16,J,Done);
IF Done THEN (* got valid byte value *)
INC(Lout);
OutPat[Lout] := VAL(BYTE,J)
ELSE (* invalid value *)
Lout := -1;
EXIT
END;
(* I should now be pointing at ',' or ' ', so point to next digit *)
INC(I);
END; (* loop *)
END; (* if *)
IF (Lout < 0) THEN Quit(4) END; (* bad OutPat, abort *)
IF Empty THEN Lout := -1 END; (* OK, shows OutPat = nothing *)
Strings.Delete(CTail,0,(Sep2 + 1)); (* strip patterns off of CTail *)
IF (Tnull >= (Sep2 + 1)) THEN (* reset Tnull *)
DEC(Tnull,(Sep2 + 1))
ELSE
Tnull := 0
END;
Sep1 := 0;Sep2 := 0; (* these don't matter anymore, set to safe value *)
END GetOutPat; (* procedure *)

(****************************************************************************)

PROCEDURE SetSkip(InPat : ARRAY OF BYTE; Lin : CARDINAL;
VAR Skip : ARRAY OF CARDINAL);

VAR
I,J : CARDINAL;

BEGIN
FOR I := 0 TO 255 DO (* set all to initial value *)
Skip[I] := 0
END; (* for *)
FOR I := (Lin) TO 0 BY -1 DO (* set for bytes in InPat *)
J := ORD(InPat[I]);
IF (I <> Lin) AND (Skip[J] = 0) THEN
Skip[J] := Lin - I
END
END; (* for *)
J := Lin + 1; (* value for all not yet set *)
FOR I := 0 TO 255 DO (* set bytes not in InPat *)
IF (Skip[I] = 0) THEN Skip[I] := J END
END; (* for *)
END SetSkip; (* procedure *)

(****************************************************************************)

PROCEDURE GetNext(VAR InFile : ARRAY OF CHAR; VAR CTail : ARRAY OF CHAR;
VAR Tnull : CARDINAL; VAR NoFile : BOOLEAN);

(* This procedure peels the next filename off of CTail, i.e., whatever
is there up to the first space or Tnull, and returns it in InFile as
a Null terminated string. If InFile isn't long enough the name just
gets truncated with no error. NoFile gets set true when there is nothing left in CTail. *)

VAR
I,J : CARDINAL;

BEGIN
IF (Tnull = 0) THEN (* nothing left in CTail *)
NoFile := TRUE (* set to bail out *)
ELSE (* got something to peel off into InFile *)
I := 0;J := HIGH(InFile);
IF (CTail[0] <> Space) AND (CTail[0] <> Null) THEN
REPEAT (* copy filename into InFile *)
InFile[I] := CTail[I];
INC(I);
UNTIL (CTail[I] = Space) OR (CTail[I] = Null) OR (I = Tnull) OR (I = J);
InFile[I] := Null; (* terminate it *)
IF (I > 0) THEN (* we put at least one character into InFile *)
Strings.Delete(CTail,0,(I + 1)); (* strip it off of CTail *)
IF (Tnull >= (I + 1)) THEN (* and reset Tnull *)
DEC(Tnull,(I + 1))
ELSE
Tnull := 0
END; (* if *)
NoFile := FALSE (* we do have something *)
ELSE
Tnull := 0;
NoFile := TRUE (* nope, got nothing *)
END (* if *)
ELSE (* CTail[0] is space or null, which should not be *)
InFile[0] := Null; (* set things to bail out *)
Tnull := 0;
NoFile := TRUE
END; (* if *)
END; (* if *)
END GetNext; (* procedure *)

(****************************************************************************)

PROCEDURE CheckAbort(VAR Abort : BOOLEAN);

(* See if user has pressed Abort key *)

CONST
AbortKey = 030C;

VAR
Ch : CHAR;

BEGIN
Read(Ch);
IF (Ch = AbortKey) THEN
WriteLn;
Abort := TRUE
ELSE
Abort := FALSE
END; (* if *)
END CheckAbort; (* procedure *)

(****************************************************************************)

PROCEDURE InPrep(InFile : ARRAY OF CHAR; VAR Inf : File;
VAR FileOK : BOOLEAN);

(* This procedure attempts to open the file named in InFile with the
file handle structure Inf. If open is successful then the file is
set to read mode. FileOK is returned false if either of these tasks
fails. *)

BEGIN
WriteString('File - '); (* let user see some action *)
WriteString(InFile);
Lookup(Inf,InFile,FALSE); (* see if file exists *)
IF (Inf.res = done) THEN (* it does *)
SetRead(Inf); (* set to Read mode *)
IF (Inf.res = done) THEN
FileOK := TRUE (* everything OK *)
ELSE (* tell user bad news *)
FileOK := FALSE;
WriteString(CR); (* should be ASCII Carriage Return *)
WriteString("Can't SetRead - ");
WriteString(InFile);
WriteLn;
Close(Inf); (* and try to close the file *)
IF (Inf.res <> done) THEN (* couldn't close *)
WriteString("Can't close - ");
WriteString(InFile);
WriteLn;
END;
END; (* if *)
ELSE
FileOK := FALSE;
WriteString(CR); (* should be ASCII Carriage Return *)
WriteString("Can't open - ");
WriteString(InFile);
WriteLn
END; (* if *)
IF (KeyPressed() = TRUE) THEN (* see if user wants to abort *)
CheckAbort(Abort);
IF Abort THEN (* clean up and abort *)
IF FileOK THEN (* don't leave file open *)
Close(Inf);
IF (Inf.res <> done) THEN
WriteString("Can't close - ");
WriteString(InFile);
WriteLn
END (* if *)
END; (* if *)
Quit(1) (* and quit this program *)
END (* if *)
END; (* if *)
END InPrep; (* procedure *)

(****************************************************************************)

PROCEDURE OutPrep(InFile : ARRAY OF CHAR; VAR OutFile : ARRAY OF CHAR;
VAR Outf : File; VAR FileOK : BOOLEAN);

(* This procedure attempts to create an output filename in OutFile
based on the value of InFile. If open is successfull then we try to
set the file to Write mode. FileOK is returned false if either of
these tasks fail. *)

VAR
Done : BOOLEAN;

(*----------------------------------------------------------*)

PROCEDURE CreateOutFile(InFile : ARRAY OF CHAR;
VAR OutFile : ARRAY OF CHAR;
VAR Outf : File; VAR Done : BOOLEAN);

(* This local procedure to OutPrep attempts to create a filename in
OutFile that is based on InFile and can be opened as a new file.
If creation and open are OK then Outf references the open file
and Done is returned TRUE. *)

VAR
I,J : CARDINAL;
Unique,Exhausted,Avoided : BOOLEAN;

(*----------------------------------------------------------*)

PROCEDURE Avoid(VAR FileName : ARRAY OF CHAR; VAR Avoided : BOOLEAN);

(* This local procedure to CreateOutFile is called in the event of a
filename collision. The algorithm used will only generate up to
a maximum of 17,576 variations of a given filename. Variations
are created so that version alpha order is same as version
chronological order. If algorithm is exhausted, then Done is
returned FALSE. We assume that filename is complete with .FLT
as last 4 characters. *)

VAR
I,J : CARDINAL;

BEGIN (* procedure Avoid *)
Avoided := TRUE; (* set to initial value *)
J := Strings.Length(FileName); (* J = index of terminating null *)
DEC(J,5); (* J = index of last char before '.' *)
I := J;
WHILE (I > 0) AND (FileName[I - 1] <> '\')
AND (FileName[I - 1] <> ':') DO
DEC(I)
END; (* while *)
(* I = index of first char of filename *)
IF ((J - I) < 7) THEN (* name part of filename isn't 8 characters *)
FOR I := 1 TO (7 + I - J) DO (* just pad name out with '$' *)
INC(J);
Strings.Insert('$',FileName,J)
END (* for *)
ELSE (* otherwise we do the tricky part *)
IF (FileName[J] < 'A') THEN FileName[J] := 'A'
ELSIF (FileName[J] < 'Z') THEN
FileName[J] := CHR(ORD(FileName[J]) + 1)
ELSE (* last character is used up, back up one *)
FileName[J] := 'A'; (* reset last character *)
DEC(J); (* index of next to last character *)
IF (FileName[J] < 'A') THEN FileName[J] := 'A'
ELSIF (FileName[J] < 'Z') THEN
FileName[J] := CHR(ORD(FileName[J]) + 1)
ELSE (* next to last character is used up, back up one more *)
FileName[J] := 'A'; (* reset next to last character *)
DEC(J); (* index of third to last character *)
IF (FileName[J] < 'A') THEN FileName[J] := 'A'
ELSIF (FileName[J] < 'Z') THEN
FileName[J] := CHR(ORD(FileName[J]) + 1)
ELSE (* last layer, algorithm is exhausted *)
Avoided := FALSE
END (* if *)
END (* if *)
END (* if *)
END; (* if *)
END Avoid; (* local procedure *)

(*----------------------------------------------------------*)

BEGIN (* procedure CreateOutFile *)
(* if we get here then we know that InFile is a valid filename *)
J := Strings.Length(InFile); (* J = index of terminating null *)
I := 0;
REPEAT
(* first copy InFile up to but NOT including '.' separating
filename from extension or terminating Null *)
OutFile[I] := CAP(InFile[I]); (* make ours uppercase *)
INC(I)
UNTIL ((InFile[I] = '.') AND ((J - I) <= 4)) OR (I = J);
OutFile[I] := Null; (* terminate the string *)
Strings.Concat(OutFile,'.FLT',OutFile); (* add extension *)
Unique := FALSE; (* we don't know yet *)
Exhausted := FALSE;
REPEAT
Lookup(Outf,OutFile,FALSE); (* see if file exists *)
IF (Outf.res = done) THEN (* it does *)
Close(Outf); (* don't leave file open *)
IF (Outf.res <> done) THEN (* couldn't close *)
WriteString("Can't close - ");
WriteString(OutFile);
WriteLn
END; (* if *)
Avoid(OutFile,Avoided); (* generate next name *)
IF (NOT Avoided) THEN (* algorithm exhausted *)
Exhausted := TRUE
END
ELSE
Unique := TRUE
END (* if *)
UNTIL Unique OR Exhausted;
IF Unique THEN (* have OutFile = unique filename *)
Lookup(Outf,OutFile,TRUE); (* try to create the new file *)
IF (Outf.res = done) THEN (* we did *)
Done := TRUE
ELSE
Done := FALSE
END (* if *)
ELSE
Done := FALSE; (* set return flag *)
WriteString("Can't create unique output file name. Remove file(s) and try again.");
WriteLn;
END; (* if *)
END CreateOutFile; (* local procedure *)

(*----------------------------------------------------------*)

BEGIN (* procedure OutPrep *)
CreateOutFile(InFile,OutFile,Outf,Done); (* see if can create file *)
IF Done THEN (* we did *)
SetWrite(Outf); (* set to write mode *)
IF (Outf.res = done) THEN
FileOK := TRUE (* everything OK *)
ELSE
FileOK := FALSE;
WriteString("Can't SetWrite - ");
WriteString(OutFile);
WriteLn;
Delete(OutFile,Outf);
IF (Outf.res <> done) THEN
WriteString("Can't delete - ");
WriteString(OutFile);
WriteLn;
END;
END (* if *)
ELSE
FileOK := FALSE;
WriteString("Can't create - ");
WriteString(OutFile);
WriteLn
END; (* if *)
IF (KeyPressed() = TRUE) THEN (* see if user wants to abort *)
CheckAbort(Abort);
IF Abort THEN (* clean up and abort *)
Close(Inf); (* close input file *)
IF (Inf.res <> done) THEN
WriteLn;
WriteString("Can't close - ");
WriteString(InFile);
WriteLn
END; (* if *)
IF FileOK THEN (* got Outf to delete too *)
Close(Outf);
Delete(OutFile,Outf);
IF (Outf.res <> done) THEN
WriteLn;
WriteString("Can't delete - ");
WriteString(OutFile);
WriteLn
END (* if *)
END; (* if *)
Quit(1) (* and quit this program *)
END (* if *)
END; (* if *)
END OutPrep; (* procedure *)

(****************************************************************************)

PROCEDURE DoFilter();

(* This procedure does all the actual filtering. When we get here, Inf
is open, at start, and in Read mode; Outf is open, at start, and in
Write mode. In other words, we are ready to rock and roll. The
Boyer-Moore pattern matching algorithm is used (see references in
header of this listing). *)

VAR
InBufPtr,OutBufPtr : ADDRESS; (* buffer pointers *)
InBytes,Bread,OutBytes,Bwritten,I,J : CARDINAL;
CurInBuf,LinBuf,CurOutBuf,LastSkip : CARDINAL;
Err,MisMatch,Done,NoMoreBytes : BOOLEAN;

BEGIN
Err := FALSE; (* no error yet *)
NoMoreBytes := FALSE; (* not out of bytes yet *)
OutBufPtr := ADR(OutBuf[0]); (* pointer for WriteNBytes *)
CurInBuf := 0; (* index of current byte in InBuf *)
LinBuf := 0; (* index of last valid byte in InBuf *)
REPEAT (* loop until input eof, read/write error, or no more bytes *)
(* first read bytes into InBuf *)
IF ((LinBuf - CurInBuf) > 0) THEN (* got valid bytes to move down *)
J := 0;
FOR I := (CurInBuf + 1) TO LinBuf DO
InBuf[J] := InBuf[I]; (* copy valid bytes to start of InBuf *)
INC(J)
END (* for *)
END; (* if *)
IF NOT Inf.eof THEN (* don't read past end of file *)
InBufPtr := ADR(InBuf[(LinBuf - CurInBuf)]); (* set Read pointer *)
InBytes := BufSiz - LinBuf + CurInBuf + 1; (* bytes to get *)
ReadNBytes(Inf,InBufPtr,InBytes,Bread)
ELSE
Bread := 0
END; (* if *)
IF (Inf.res <> done) THEN (* got read error *)
Err := TRUE; (* set flag to bail out of loop *)
WriteLn;
WriteString("Can't read - ");
WriteString(InFile);
WriteLn
ELSIF (Bread = 0) AND ((LinBuf - CurInBuf) = 0) THEN
NoMoreBytes := TRUE (* set flag to bail out of loop *)
ELSE (* we're OK to do some filtering *)
IF (Bread = 0) THEN
NoMoreBytes := TRUE (* set flag to bail out of loop *)
END; (* if *)
LinBuf := Bread + LinBuf - 1 - CurInBuf; (* reset index *)
IF (LinBuf >= ORD(Lin)) THEN (* got enough bytes to make match *)
CurOutBuf := 0; (* set index to start of OutBuf *)
CurInBuf := Lin; (* index of first byte to compare *)
LastSkip := Lin + 1; (* initial value *)
Done := FALSE; (* reset if OutBuf full or InBuf empty *)
REPEAT (* start loop through InBuf *)
IF (KeyPressed() = TRUE) THEN (* see if user wants to abort *)
CheckAbort(Abort);
IF Abort THEN (* clean up and abort *)
Close(Inf); (* try to close input file *)
IF (Inf.res <> done) THEN (* couldn't *)
WriteLn;
WriteString("Can't close - ");
WriteString(InFile);
WriteLn
END; (* if *)
Close(Outf);
Delete(OutFile,Outf);
IF (Outf.res <> done) THEN
WriteLn;
WriteString("Can't delete - ");
WriteString(OutFile);
WriteLn
END; (* if *)
Quit(1) (* and quit this program *)
END (* if *)
END; (* if *)
IF (InBuf[CurInBuf] <> InPat[Lin]) THEN (* mismatch *)
IF ((BufSiz - CurOutBuf) > ORD(Lin)) THEN (* room in OutBuf *)
FOR I := (CurInBuf + 1 - LastSkip) TO CurInBuf DO
OutBuf[CurOutBuf] := InBuf[I];
INC(CurOutBuf)
END; (* for *)
I := Skip[ORD(InBuf[CurInBuf])]; (* bytes to skip *)
IF ((CurInBuf + I) <= LinBuf) THEN (* room in InBuf *)
INC(CurInBuf,I); (* increment InBuf index *)
LastSkip := I (* and save skip value *)
ELSE
Done := TRUE (* bail out of this loop *)
END (* if *)
ELSE (* not enough room in OutBuf *)
DEC(CurInBuf,LastSkip); (* back up *)
Done := TRUE (* bail out of this loop *)
END (* if *)
ELSE (* last byte matches, check others *)
IF (Lout > Lin) THEN (* check max space needed *)
I := Lout
ELSE
I := Lin
END; (* if *)
IF ((BufSiz - CurOutBuf) > I) THEN (* got room in OutBuf *)
MisMatch := FALSE; (* reset if mismatch occurs *)
IF (Lin > 0) THEN (* got other bytes to test *)
I := CurInBuf; (* set indexes *)
J := Lin;
REPEAT (* check other bytes *)
DEC(I);
DEC(J);
IF (InBuf[I] <> InPat[J]) THEN
MisMatch := TRUE
END (* if *)
UNTIL MisMatch OR (J = 0) (* repeat *)
END; (* if *)
IF MisMatch THEN
FOR I := (CurInBuf + 1 - LastSkip) TO CurInBuf DO
OutBuf[CurOutBuf] := InBuf[I];
INC(CurOutBuf)
END (* for *)
ELSE (* got a match *)
IF (CurOutBuf > 0) THEN (* back up to pattern start *)
CurOutBuf := CurOutBuf + LastSkip - ORD(Lin) - 1
END;
IF (Lout >= 0) THEN (* got an OutPat *)
FOR I := 0 TO Lout DO (* copy OutPat to OutBuf *)
OutBuf[CurOutBuf] := OutPat[I];
INC(CurOutBuf)
END (* for *)

END (* if *)
END; (* if *)
I := Skip[ORD(InBuf[CurInBuf])]; (* bytes to skip *)
IF ((CurInBuf + I) <= LinBuf) THEN (* room in InBuf *)
INC(CurInBuf,I); (* increment InBuf index *)
LastSkip := I (* and save skip value *)
ELSE
Done := TRUE (* bail out of this loop *)
END (* if *)
ELSE (* not enough room in OutBuf *)
DEC(CurInBuf,LastSkip); (* back up a bit *)
Done := TRUE (* and bail out of this loop *)
END (* if *)
END (* if *)
UNTIL Done; (* repeat *)
WriteNBytes(Outf,OutBufPtr,CurOutBuf,Bwritten);
IF (Outf.res <> done) THEN (* got error writing Outf *)
Err := TRUE; (* set flag to bail out of loop *)
WriteLn;
WriteString("Can't write - "); (* tell user *)
WriteString(OutFile);
WriteLn;
OutFileErr := TRUE (* set global error flag *)
END (* if *)
ELSE (* not enough bytes read to make a match, assume Inf.eof *)
NoMoreBytes := TRUE; (* set flag to bail out of loop *)
OutBufPtr := ADR(InBuf[0]); (* pointer for WriteNBytes *)
OutBytes := LinBuf + 1; (* number of bytes to Write *)
WriteNBytes(Outf,OutBufPtr,OutBytes,Bwritten);
IF (Outf.res <> done) THEN (* got error writing Outf *)
Err := TRUE; (* set error flag *)
WriteLn;
WriteString("Can't write - "); (* tell user *)
WriteString(OutFile);
WriteLn;
OutFileErr := TRUE (* set global error flag *)
END (* if *)
END (* if *)
END; (* if *)
UNTIL Err OR NoMoreBytes; (* repeat *)
IF NOT Err THEN WriteLn END;
Close(Inf); (* all done, close our files if we can *)
IF (Inf.res <> done) THEN
WriteString("Can't close - ");
WriteString(InFile);
WriteLn;
InFileErr := TRUE
END;
Close(Outf);
IF (Outf.res <> done) THEN
WriteString("Can't close - ");
WriteString(OutFile);
WriteLn;
OutFileErr := TRUE;
Err := TRUE (* ensure this flag set *)
END;
IF Err THEN (* get rid of bad file *)
Delete(OutFile,Outf);
IF (Outf.res <> done) THEN
WriteString("Can't delete - ");
WriteString(OutFile);
WriteLn;
OutFileErr := TRUE;
END
END;
END DoFilter; (* procedure *)

(****************************************************************************)

BEGIN (* main program filter *)
DisableBreak; (* no ^Break allowed *)
WriteLn;WriteLn;
WriteString('FILTER 1.0 12/8/87 by: Randy Maddox (301) 428-9581');
WriteLn;
WriteString('Developed with Logitech Modula-2 compiler, Version 3.0');
WriteLn;
GetCTail(Tnull,CTail); (* get command tail *)
IF (Tnull < 5) THEN Quit(2) END; (* abort, bad command line *)
CleanTail(Tnull,CTail,Sep1,Sep2);
IF (Tnull < 5) OR (Sep1 < 1) OR (Sep2 < 3) THEN
Quit(2) (* abort, bad calling syntax *)
END;
GetInPat(Sep1,CTail,InPat,Lin); (* only returns if InPat good *)
GetOutPat(Sep1,Sep2,CTail,OutPat,Lout); (* only returns if OutPat good *)
WriteLn;
WriteString('Control-X aborts program.');
WriteLn;WriteLn;
SetSkip(InPat,Lin,Skip); (* set values for skip array *)
(* initialize some flags *)
InFileErr := FALSE; (* haven't had any problems yet!!! *)
OutFileErr := FALSE;
NoFile := FALSE;
LOOP (* start loop through filenames *)
GetNext(InFile,CTail,Tnull,NoFile); (* get next filename *)
IF NoFile THEN (* no file, bail out *)
EXIT
ELSE (* got something, maybe it's a file name *)
InPrep(InFile,Inf,FileOK); (* try to open *)
IF FileOK THEN (* Inf is open, at start, in Read mode *)
OutPrep(InFile,OutFile,Outf,FileOK); (* try to open *)
IF FileOK THEN (* Outf is open, at start in Write mode *)
DoFilter() (* finally do the actual filtering *)
ELSE
OutFileErr := TRUE (* couldn't create/SetWrite *)
END (* if *)
ELSE
InFileErr := TRUE (* couldn't open/SetRead *)
END (* if *)
END (* if *)
END; (* loop *)
IF InFileErr AND OutFileErr THEN Quit(7) (* input and output error *)
ELSIF InFileErr THEN Quit(5) (* input file open/read/close error *)
ELSIF OutFileErr THEN Quit(6) (* output file creation/write/close error *)
ELSE Quit(0) END; (* normal program termination *)
END filter.

(* end of this file *)


  3 Responses to “Category : Utilities for DOS and Windows Machines
Archive   : MODFILT.ZIP
Filename : FILTER.MOD

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/