home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CP/M
/
CPM_CDROM.iso
/
cpm
/
cpm86
/
trbtol86.lbr
/
CHAPTER5.PQS
/
CHAPTER5.PAS
Wrap
Pascal/Delphi Source File
|
1985-10-23
|
9KB
|
411 lines
{
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;