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 / TURBTOOL.ARC / CHAPTER5.PAS < prev    next >
Pascal/Delphi Source File  |  1989-09-27  |  9KB  |  411 lines
  1.  
  2. {chapter5.pas}
  3.  
  4. {
  5.         copyright (c) 1981
  6.         by:     bell telephone laboratories, inc. and
  7.                 whitesmith's ltd.,
  8.  
  9.         this software is derived from the book
  10.                 "software tools in pascal", by
  11.                 brian w. kernighan and p. j. plauger
  12.                 addison-wesley, 1981
  13.                 isbn 0-201-10342-7
  14.  
  15.         right is hereby granted to freely distribute or duplicate this
  16.         software, providing distribution or duplication is not for profit
  17.         or other commercial gain and that this copyright notice remains
  18.         intact.
  19. }
  20.  
  21. const
  22.   maxpat=maxstr;
  23.   closize=1;
  24.   closure=star;
  25.   bol=percent;
  26.   eol=dollar;
  27.   any=question;
  28.   ccl=lbrack;
  29.   cclend=rbrack;
  30.   negate=caret;
  31.   nccl=exclam;
  32.   litchar=67;
  33.  
  34. function makepat (var arg:xstring; start:integer;
  35.   delim:character; var pat:xstring):integer;forward;
  36.   
  37. function amatch(var lin:xstring;offset:integer;
  38.   var pat:xstring; j:integer):integer;forward;
  39. function match(var lin,pat:xstring):boolean;forward;
  40.  
  41. function makepat;
  42. var
  43.   i,j,lastj,lj:integer;
  44.   done,junk:boolean;
  45.  
  46. function getccl(var arg:xstring; var i:integer;
  47.   var pat:xstring; var j:integer):boolean;
  48. var
  49.   jstart:integer;
  50.   junk:boolean;
  51.  
  52. procedure dodash(delim:character; var src:xstring;
  53.   var i:integer; var dest:xstring;
  54.   var j:integer; maxset:integer);
  55. const escape=atsign;
  56. var k:integer;
  57. junk:boolean;
  58.  
  59. function esc(var s:xstring; var i:integer):character;
  60. begin
  61.   if(s[i]<>escape) then
  62.     esc:=s[i]
  63.   else if (s[i+1]=endstr) then
  64.     esc:=escape
  65.   else begin
  66.     i:=i+1;
  67.     if (s[i]=ord('n')) then
  68.       esc:=newline
  69.     else if (s[i]=ord('t')) then
  70.       esc:=tab
  71.     else
  72.       esc:=s[i]
  73.     end
  74. end;
  75.  
  76. begin
  77.   while(src[i]<>delim) and (src[i]<>endstr) do begin
  78.     if(src[i]=escape)then
  79.       junk:=addstr(esc(src,i),dest,j,maxset)
  80.     else if (src[i]<>dash) then
  81.       junk:=addstr(src[i],dest,j,maxset)
  82.     else if (j<=1) or (src[i+1]=endstr) then
  83.       junk:=addstr(dash,dest,j,maxset)
  84.     else if (isalphanum(src[i-1]))
  85.       and (isalphanum(src[i+1]))
  86.       and (src[i-1]<=src[i+1]) then begin
  87.         for k:=src[i-1]+1 to src[i+1] do
  88.           junk:=addstr(k,dest,j,maxset);
  89.             i:=i+1
  90.     end
  91.     else
  92.       junk:=addstr(dash,dest,j,maxset);
  93.     i:=i+1
  94.   end
  95. end;
  96.  
  97. begin
  98.   i:=i+1;
  99.   if(arg[i]=negate) then begin
  100.     junk:=addstr(nccl,pat,j,maxpat);
  101.     i:=i+1
  102.   end
  103.   else
  104.     junk:=addstr(ccl,pat,j,maxpat);
  105.   jstart:=j;
  106.   junk:=addstr(0,pat,j,maxpat);
  107.   dodash(cclend,arg,i,pat,j,maxpat);
  108.   pat[jstart]:=j-jstart-1;
  109.   getccl:=(arg[i]=cclend)
  110. end;
  111.  
  112. procedure stclose(var pat:xstring;var j:integer;
  113.   lastj:integer);
  114. var
  115.   jp,jt:integer;
  116.   junk:boolean;
  117. begin
  118.   for jp:=j-1 downto lastj do begin
  119.     jt:=jp+closize;
  120.     junk:=addstr(pat[jp],pat,jt,maxpat)
  121.   end;
  122.   j:=j+closize;
  123.   pat[lastj]:=closure
  124. end;
  125.  
  126. begin
  127.   j:=1;
  128.   i:=start;
  129.   lastj:=1;
  130.   done:=false;
  131.   while(not done) and (arg[i]<>delim)
  132.     and (arg[i]<>endstr) do begin
  133.       lj:=j;
  134.       if(arg[i]=any) then
  135.         junk:=addstr(any,pat,j,maxpat)
  136.       else if (arg[i]=bol) and (i=start) then
  137.         junk:=addstr(bol,pat,j,maxpat)
  138.       else if (arg[i]=eol) and (arg[i+1]=delim) then
  139.         junk:=addstr(eol,pat,j,maxpat)
  140.       else if (arg[i]=ccl) then
  141.         done:=(getccl(arg,i,pat,j)=false)
  142.       else if (arg[i]=closure) and (i>start) then begin
  143.         lj:=lastj;
  144.         if(pat[lj] in [bol,eol,closure]) then
  145.           done:=true
  146.         else
  147.           stclose(pat,j,lastj)
  148.       end
  149.       else begin
  150.         junk:=addstr(litchar,pat,j,maxpat);
  151.         junk:=addstr(esc(arg,i),pat,j,maxpat)
  152.       end;
  153.       lastj:=lj;
  154.       if(not done) then
  155.         i:=i+1
  156.     end;
  157.     if(done) or (arg[i]<>delim) then
  158.       makepat:=0
  159.     else if (not addstr(endstr,pat,j,maxpat)) then
  160.       makepat:=0
  161.     else
  162.       makepat:=i
  163.   end;
  164.   
  165.  
  166. function amatch;
  167.  
  168.  
  169. var i,k:integer;
  170.    done:boolean;
  171.  
  172.  
  173. function omatch(var lin:xstring; var i:integer;
  174.   var pat:xstring; j:integer):boolean;
  175. var
  176.   advance:-1..1;
  177.  
  178.  
  179. function locate (c:character; var pat: xstring;
  180.   offset:integer):boolean;
  181. var
  182.   i:integer;
  183. begin
  184.   locate:=false;
  185.   i:=offset+pat[offset];
  186.   while(i>offset) do
  187.     if(c=pat[i]) then begin
  188.       locate :=true;
  189.       i:=offset
  190.     end
  191.     else
  192.       i:=i-1
  193. end;begin
  194.   advance:=-1;
  195.   if(lin[i]=endstr) then
  196.     omatch:=false
  197.   else if (not( pat[j] in
  198.    [litchar,bol,eol,any,ccl,nccl,closure])) then
  199.      error('in omatch:can''t happen')
  200.   else
  201.     case pat[j] of
  202.     litchar:
  203.       if (lin[i]=pat[j+1]) then
  204.         advance:=1;
  205.     bol:
  206.       if (i=1) then
  207.         advance:=0;
  208.     any:
  209.       if (lin[i]<>newline) then
  210.         advance:=1;
  211.     eol:
  212.       if(lin[i]=newline) then
  213.         advance:=0;
  214.     ccl:
  215.       if(locate(lin[i],pat,j+1)) then
  216.         advance:=1;
  217.     nccl:
  218.       if(lin[i]<>newline)
  219.         and (not locate (lin[i],pat,j+1)) then
  220.           advance:=1
  221.         end;
  222.     if(advance>=0) then begin
  223.       i:=i+advance;
  224.       omatch:=true
  225.     end
  226.     else
  227.       omatch:=false
  228.   end;
  229.   
  230. function patsize(var pat:xstring;n:integer):integer;
  231. begin
  232.   if(not (pat[n] in
  233.    [litchar,bol,eol,any,ccl,nccl,closure])) then
  234.     error('in patsize:can''t happen')
  235.   else
  236.     case pat[n] of
  237.       litchar:patsize:=2;
  238.       bol,eol,any:patsize:=1;
  239.       ccl,nccl:patsize:=pat[n+1]+2;
  240.       closure:patsize:=closize
  241.     end
  242. end;
  243.  
  244. begin
  245.   done:=false;
  246.   while(not done) and (pat[j]<>endstr) do
  247.     if(pat[j]=closure) then begin
  248.       j:=j+patsize(pat,j);
  249.       i:=offset;
  250.       while(not done) and (lin[i]<>endstr) do
  251.         if (not omatch(lin,i,pat,j)) then
  252.           done:=true;
  253.       done:=false;
  254.       while (not done) and (i>=offset) do begin
  255.         k:=amatch(lin,i,pat,j+patsize(pat,j));
  256.         if(k>0) then
  257.           done:=true
  258.         else
  259.           i:=i-1
  260.       end;
  261.       offset:=k;
  262.       done:=true
  263.     end
  264.     else if (not omatch(lin,offset,pat,j))
  265.       then begin
  266.       offset :=0;
  267.       done:=true
  268.     end
  269.     else
  270.       j:=j+patsize(pat,j);
  271.   amatch:=offset
  272. end;
  273. function match;
  274.  
  275. var
  276.   i,pos:integer;
  277.  
  278.   
  279.                                                                                
  280. begin
  281.   pos:=0;
  282.   i:=1;
  283.   while(lin[i]<>endstr) and (pos=0) do begin
  284.     pos:=amatch(lin,i,pat,1);
  285.     i:=i+1
  286.   end;
  287.   match:=(pos>0)
  288. end;
  289.  
  290.  
  291.  
  292.  
  293. procedure find;
  294.   
  295. var
  296.   arg,lin,pat:xstring;
  297.  
  298. function getpat(var arg,pat:xstring):boolean;
  299.  
  300.   
  301.  
  302. begin
  303.   getpat:=(makepat(arg,1,endstr,pat)>0)
  304. end;
  305.  
  306.  
  307. begin
  308.   if(not getarg(2,arg,maxstr))then
  309.     error('usage:find pattern');
  310.   if (not getpat(arg,pat)) then
  311.     error('find:illegal pattern');
  312.   while(getline(lin,stdin,maxstr))do
  313.     if (match(lin,pat))then
  314.       putstr(lin,stdout)
  315. end;
  316.  
  317. procedure change;
  318. const
  319.   ditto=255;
  320. var
  321.   lin,pat,sub,arg:xstring;
  322.  
  323. function getpat(var arg,pat:xstring):boolean;
  324.  
  325.   
  326.  
  327. begin
  328.   getpat:=(makepat(arg,1,endstr,pat)>0)
  329. end;
  330. function getsub(var arg,sub:xstring):boolean;
  331.  
  332. function makesub(var arg:xstring; from:integer;
  333.   delim:character; var sub:xstring):integer;
  334. var i,j:integer;
  335.    junk:boolean;
  336. begin
  337.   j:=1;
  338.   i:=from;
  339.   while (arg[i]<>delim) and (arg[i]<>endstr) do begin
  340.     if(arg[i]=ord('&')) then
  341.       junk:=addstr(ditto,sub,j,maxpat)
  342.     else
  343.       junk:=addstr(esc(arg,i),sub,j,maxpat);
  344.     i:=i+1
  345.   end;
  346.   if (arg[i]<>delim) then
  347.     makesub:=0
  348.   else if (not addstr(endstr,sub,j,maxpat)) then
  349.     makesub:=0
  350.   else
  351.     makesub:=i
  352. end;
  353.  
  354. begin
  355.   getsub:=(makesub(arg,1,endstr,sub)>0)
  356. end;
  357.  
  358. procedure subline(var lin,pat,sub:xstring);
  359. var
  360.   i, lastm, m:integer;
  361.   junk:boolean;
  362.  
  363.  
  364. procedure putsub(var lin:xstring; s1,s2:integer;
  365.   var sub:xstring);
  366. var
  367.   i,j:integer;
  368.   junk:boolean;
  369. begin
  370.   i:=1;
  371.   while (sub[i]<>endstr) do begin
  372.     if(sub[i]=ditto) then
  373.       for j:=s1 to s2-1 do
  374.         putc(lin[j])
  375.       else
  376.         putc(sub[i]);
  377.       i:=i+1
  378.   end
  379. end;
  380.  
  381. begin
  382.   lastm:=0;
  383.   i:=1;
  384.   while(lin[i]<>endstr) do begin
  385.     m:=amatch(lin,i,pat,1);
  386.     if (m>0) and (lastm<>m) then begin
  387.       putsub(lin,i,m,sub);
  388.       lastm:=m
  389.     end;
  390.     if (m=0) or (m=i) then begin
  391.       putc(lin[i]);
  392.       i:=i+1
  393.     end
  394.     else
  395.       i:=m
  396.     end
  397. end;
  398.  
  399. begin
  400.   if(not getarg(2,arg,maxstr)) then
  401.     error('usage:change from [to]');
  402.   if (not getpat(arg,pat)) then
  403.     error('change:illegal "from" pattern');
  404.   if (not getarg(3,arg,maxstr)) then
  405.     arg[1]:=endstr;
  406.   if(not getsub(arg,sub)) then
  407.     error('change:illegal "to" string');
  408.   while (getline(lin,stdin,maxstr)) do
  409.     subline(lin,pat,sub)
  410. end;
  411.