CP/M/CPM_CDROM.iso/enterprs/cpm/utils/s/tutor.arc/CHAPTER5.PAS

Pascal/Delphi Source File | 1992-11-30 | 8.6 KB | 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;