home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
ENTERPRS
/
CPM
/
UTILS
/
S
/
TUTOR.ARC
/
CHAPTER5.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-11-30
|
9KB
|
411 lines
{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;