Category : Pascal Source Code
Archive   : SOFTOOLS.ZIP
Filename : CHAPTER5.PAS

 
Output of file : CHAPTER5.PAS contained in archive : SOFTOOLS.ZIP
{chapter5.pas}

{
Copyright (c) 1981
By: Bell Telephone Laboratories, Inc. and
Whitesmith's Ltd.,

This software is derived from the book
"Software Tools in Pascal", by
Brian W. Kernighan and P. J. Plauger
Addison-Wesley, 1981
ISBN 0-201-10342-7

Right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}

CONST
MAXPAT=MAXSTR;
CLOSIZE=1;
CLOSURE=STAR;
BOL=PERCENT;
EOL=DOLLAR;
ANY=QUESTION;
CCL=LBRACK;
CCLEND=RBRACK;
NEGATE=CARET;
NCCL=EXCLAM;
LITCHAR=67;

FUNCTION MAKEPAT (VAR ARG:XSTRING; START:INTEGER;
DELIM:CHARACTER; VAR PAT:XSTRING):INTEGER;FORWARD;

FUNCTION AMATCH(VAR LIN:XSTRING;OFFSET:INTEGER;
VAR PAT:XSTRING; J:INTEGER):INTEGER;FORWARD;
FUNCTION MATCH(VAR LIN,PAT:XSTRING):BOOLEAN;FORWARD;

FUNCTION MAKEPAT;
VAR
I,J,LASTJ,LJ:INTEGER;
DONE,JUNK:BOOLEAN;

FUNCTION GETCCL(VAR ARG:XSTRING; VAR I:INTEGER;
VAR PAT:XSTRING; VAR J:INTEGER):BOOLEAN;
VAR
JSTART:INTEGER;
JUNK:BOOLEAN;

PROCEDURE DODASH(DELIM:CHARACTER; VAR SRC:XSTRING;
VAR I:INTEGER; VAR DEST:XSTRING;
VAR J:INTEGER; MAXSET:INTEGER);
CONST ESCAPE=ATSIGN;
VAR K:INTEGER;
JUNK:BOOLEAN;

FUNCTION ESC(VAR S:XSTRING; VAR I:INTEGER):CHARACTER;
BEGIN
IF(S[I]<>ESCAPE) THEN
ESC:=S[I]
ELSE IF (S[I+1]=ENDSTR) THEN
ESC:=ESCAPE
ELSE BEGIN
I:=I+1;
IF (S[I]=ORD('N')) THEN
ESC:=NEWLINE
ELSE IF (S[I]=ORD('T')) THEN
ESC:=TAB
ELSE
ESC:=S[I]
END
END;

BEGIN
WHILE(SRC[I]<>DELIM) AND (SRC[I]<>ENDSTR) DO BEGIN
IF(SRC[I]=ESCAPE)THEN
JUNK:=ADDSTR(ESC(SRC,I),DEST,J,MAXSET)
ELSE IF (SRC[I]<>DASH) THEN
JUNK:=ADDSTR(SRC[I],DEST,J,MAXSET)
ELSE IF (J<=1) OR (SRC[I+1]=ENDSTR) THEN
JUNK:=ADDSTR(DASH,DEST,J,MAXSET)
ELSE IF (ISALPHANUM(SRC[I-1]))
AND (ISALPHANUM(SRC[I+1]))
AND (SRC[I-1]<=SRC[I+1]) THEN BEGIN
FOR K:=SRC[I-1]+1 TO SRC[I+1] DO
JUNK:=ADDSTR(K,DEST,J,MAXSET);
I:=I+1
END
ELSE
JUNK:=ADDSTR(DASH,DEST,J,MAXSET);
I:=I+1
END
END;

BEGIN
I:=I+1;
IF(ARG[I]=NEGATE) THEN BEGIN
JUNK:=ADDSTR(NCCL,PAT,J,MAXPAT);
I:=I+1
END
ELSE
JUNK:=ADDSTR(CCL,PAT,J,MAXPAT);
JSTART:=J;
JUNK:=ADDSTR(0,PAT,J,MAXPAT);
DODASH(CCLEND,ARG,I,PAT,J,MAXPAT);
PAT[JSTART]:=J-JSTART-1;
GETCCL:=(ARG[I]=CCLEND)
END;

PROCEDURE STCLOSE(VAR PAT:XSTRING;VAR J:INTEGER;
LASTJ:INTEGER);
VAR
JP,JT:INTEGER;
JUNK:BOOLEAN;
BEGIN
FOR JP:=J-1 DOWNTO LASTJ DO BEGIN
JT:=JP+CLOSIZE;
JUNK:=ADDSTR(PAT[JP],PAT,JT,MAXPAT)
END;
J:=J+CLOSIZE;
PAT[LASTJ]:=CLOSURE
END;

BEGIN
J:=1;
I:=START;
LASTJ:=1;
DONE:=FALSE;
WHILE(NOT DONE) AND (ARG[I]<>DELIM)
AND (ARG[I]<>ENDSTR) DO BEGIN
LJ:=J;
IF(ARG[I]=ANY) THEN
JUNK:=ADDSTR(ANY,PAT,J,MAXPAT)
ELSE IF (ARG[I]=BOL) AND (I=START) THEN
JUNK:=ADDSTR(BOL,PAT,J,MAXPAT)
ELSE IF (ARG[I]=EOL) AND (ARG[I+1]=DELIM) THEN
JUNK:=ADDSTR(EOL,PAT,J,MAXPAT)
ELSE IF (ARG[I]=CCL) THEN
DONE:=(GETCCL(ARG,I,PAT,J)=FALSE)
ELSE IF (ARG[I]=CLOSURE) AND (I>START) THEN BEGIN
LJ:=LASTJ;
IF(PAT[LJ] IN [BOL,EOL,CLOSURE]) THEN
DONE:=TRUE
ELSE
STCLOSE(PAT,J,LASTJ)
END
ELSE BEGIN
JUNK:=ADDSTR(LITCHAR,PAT,J,MAXPAT);
JUNK:=ADDSTR(ESC(ARG,I),PAT,J,MAXPAT)
END;
LASTJ:=LJ;
IF(NOT DONE) THEN
I:=I+1
END;
IF(DONE) OR (ARG[I]<>DELIM) THEN
MAKEPAT:=0
ELSE IF (NOT ADDSTR(ENDSTR,PAT,J,MAXPAT)) THEN
MAKEPAT:=0
ELSE
MAKEPAT:=I
END;


FUNCTION AMATCH;


VAR I,K:INTEGER;
DONE:BOOLEAN;


FUNCTION OMATCH(VAR LIN:XSTRING; VAR I:INTEGER;
VAR PAT:XSTRING; J:INTEGER):BOOLEAN;
VAR
ADVANCE:-1..1;


FUNCTION LOCATE (C:CHARACTER; VAR PAT: XSTRING;
OFFSET:INTEGER):BOOLEAN;
VAR
I:INTEGER;
BEGIN
LOCATE:=FALSE;
I:=OFFSET+PAT[OFFSET];
WHILE(I>OFFSET) DO
IF(C=PAT[I]) THEN BEGIN
LOCATE :=TRUE;
I:=OFFSET
END
ELSE
I:=I-1
END;BEGIN
ADVANCE:=-1;
IF(LIN[I]=ENDSTR) THEN
OMATCH:=FALSE
ELSE IF (NOT( PAT[J] IN
[LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
ERROR('IN OMATCH:CAN''T HAPPEN')
ELSE
CASE PAT[J] OF
LITCHAR:
IF (LIN[I]=PAT[J+1]) THEN
ADVANCE:=1;
BOL:
IF (I=1) THEN
ADVANCE:=0;
ANY:
IF (LIN[I]<>NEWLINE) THEN
ADVANCE:=1;
EOL:
IF(LIN[I]=NEWLINE) THEN
ADVANCE:=0;
CCL:
IF(LOCATE(LIN[I],PAT,J+1)) THEN
ADVANCE:=1;
NCCL:
IF(LIN[I]<>NEWLINE)
AND (NOT LOCATE (LIN[I],PAT,J+1)) THEN
ADVANCE:=1
END;
IF(ADVANCE>=0) THEN BEGIN
I:=I+ADVANCE;
OMATCH:=TRUE
END
ELSE
OMATCH:=FALSE
END;

FUNCTION PATSIZE(VAR PAT:XSTRING;N:INTEGER):INTEGER;
BEGIN
IF(NOT (PAT[N] IN
[LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
ERROR('IN PATSIZE:CAN''T HAPPEN')
ELSE
CASE PAT[N] OF
LITCHAR:PATSIZE:=2;
BOL,EOL,ANY:PATSIZE:=1;
CCL,NCCL:PATSIZE:=PAT[N+1]+2;
CLOSURE:PATSIZE:=CLOSIZE
END
END;

BEGIN
DONE:=FALSE;
WHILE(NOT DONE) AND (PAT[J]<>ENDSTR) DO
IF(PAT[J]=CLOSURE) THEN BEGIN
J:=J+PATSIZE(PAT,J);
I:=OFFSET;
WHILE(NOT DONE) AND (LIN[I]<>ENDSTR) DO
IF (NOT OMATCH(LIN,I,PAT,J)) THEN
DONE:=TRUE;
DONE:=FALSE;
WHILE (NOT DONE) AND (I>=OFFSET) DO BEGIN
K:=AMATCH(LIN,I,PAT,J+PATSIZE(PAT,J));
IF(K>0) THEN
DONE:=TRUE
ELSE
I:=I-1
END;
OFFSET:=K;
DONE:=TRUE
END
ELSE IF (NOT OMATCH(LIN,OFFSET,PAT,J))
THEN BEGIN
OFFSET :=0;
DONE:=TRUE
END
ELSE
J:=J+PATSIZE(PAT,J);
AMATCH:=OFFSET
END;
FUNCTION MATCH;

VAR
I,POS:INTEGER;



BEGIN
POS:=0;
I:=1;
WHILE(LIN[I]<>ENDSTR) AND (POS=0) DO BEGIN
POS:=AMATCH(LIN,I,PAT,1);
I:=I+1
END;
MATCH:=(POS>0)
END;




PROCEDURE FIND;

VAR
ARG,LIN,PAT:XSTRING;

FUNCTION GETPAT(VAR ARG,PAT:XSTRING):BOOLEAN;



BEGIN
GETPAT:=(MAKEPAT(ARG,1,ENDSTR,PAT)>0)
END;


BEGIN
IF(NOT GETARG(2,ARG,MAXSTR))THEN
ERROR('USAGE:FIND PATTERN');
IF (NOT GETPAT(ARG,PAT)) THEN
ERROR('FIND:ILLEGAL PATTERN');
WHILE(GETLINE(LIN,STDIN,MAXSTR))DO
IF (MATCH(LIN,PAT))THEN
PUTSTR(LIN,STDOUT)
END;

PROCEDURE CHANGE;
CONST
DITTO=255;
VAR
LIN,PAT,SUB,ARG:XSTRING;

FUNCTION GETPAT(VAR ARG,PAT:XSTRING):BOOLEAN;



BEGIN
GETPAT:=(MAKEPAT(ARG,1,ENDSTR,PAT)>0)
END;
FUNCTION GETSUB(VAR ARG,SUB:XSTRING):BOOLEAN;

FUNCTION MAKESUB(VAR ARG:XSTRING; FROM:INTEGER;
DELIM:CHARACTER; VAR SUB:XSTRING):INTEGER;
VAR I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
J:=1;
I:=FROM;
WHILE (ARG[I]<>DELIM) AND (ARG[I]<>ENDSTR) DO BEGIN
IF(ARG[I]=ORD('&')) THEN
JUNK:=ADDSTR(DITTO,SUB,J,MAXPAT)
ELSE
JUNK:=ADDSTR(ESC(ARG,I),SUB,J,MAXPAT);
I:=I+1
END;
IF (ARG[I]<>DELIM) THEN
MAKESUB:=0
ELSE IF (NOT ADDSTR(ENDSTR,SUB,J,MAXPAT)) THEN
MAKESUB:=0
ELSE
MAKESUB:=I
END;

BEGIN
GETSUB:=(MAKESUB(ARG,1,ENDSTR,SUB)>0)
END;

PROCEDURE SUBLINE(VAR LIN,PAT,SUB:XSTRING);
VAR
I, LASTM, M:INTEGER;
JUNK:BOOLEAN;


PROCEDURE PUTSUB(VAR LIN:XSTRING; S1,S2:INTEGER;
VAR SUB:XSTRING);
VAR
I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
I:=1;
WHILE (SUB[I]<>ENDSTR) DO BEGIN
IF(SUB[I]=DITTO) THEN
FOR J:=S1 TO S2-1 DO
PUTC(LIN[J])
ELSE
PUTC(SUB[I]);
I:=I+1
END
END;

BEGIN
LASTM:=0;
I:=1;
WHILE(LIN[I]<>ENDSTR) DO BEGIN
M:=AMATCH(LIN,I,PAT,1);
IF (M>0) AND (LASTM<>M) THEN BEGIN
PUTSUB(LIN,I,M,SUB);
LASTM:=M
END;
IF (M=0) OR (M=I) THEN BEGIN
PUTC(LIN[I]);
I:=I+1
END
ELSE
I:=M
END
END;

BEGIN
IF(NOT GETARG(2,ARG,MAXSTR)) THEN
ERROR('USAGE:CHANGE FROM [TO]');
IF (NOT GETPAT(ARG,PAT)) THEN
ERROR('CHANGE:ILLEGAL "FROM" PATTERN');
IF (NOT GETARG(3,ARG,MAXSTR)) THEN
ARG[1]:=ENDSTR;
IF(NOT GETSUB(ARG,SUB)) THEN
ERROR('CHANGE:ILLEGAL "TO" STRING');
WHILE (GETLINE(LIN,STDIN,MAXSTR)) DO
SUBLINE(LIN,PAT,SUB)
END;





  3 Responses to “Category : Pascal Source Code
Archive   : SOFTOOLS.ZIP
Filename : CHAPTER5.PAS

  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/