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 / CHAPTER3.PAS < prev    next >
Pascal/Delphi Source File  |  1992-11-30  |  12KB  |  586 lines
  1.  
  2. {chapter3.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. procedure compare;forward;
  22. procedure include;forward;
  23. procedure concat;forward;
  24.  
  25. procedure makecopy;
  26. var
  27.   inname,outname:xstring;
  28.   fin,fout:filedesc;
  29. begin
  30.   if(not getarg(2,inname,maxstr))
  31.     or (not getarg(3,outname,maxstr))then
  32.       error('usage:makecopy old new');
  33.   fin:=mustopen(inname,ioread);
  34.   fout:=mustcreate(outname,iowrite);
  35.   fcopy(fin,fout);
  36.   xclose(fin);
  37.   xclose(fout)
  38. end;
  39.  
  40. procedure print;
  41. var
  42.   name:xstring;
  43.   null:xstring;
  44.   i:integer;
  45.   fin:filedesc;
  46.   junk:boolean;
  47.  
  48. procedure fprint(var name:xstring;fin:filedesc);
  49. const
  50.   margin1=2;
  51.   margin2=2;
  52.   bottom=64;
  53.   pagelen=66;
  54. var
  55.   line:xstring;
  56.   lineno,pageno:integer;
  57.  
  58. procedure skip(n:integer);
  59. var
  60.   i:integer;
  61. begin
  62.   for i:=1 to n do
  63.     putc(newline)
  64. end;
  65.  
  66. procedure head(var name:xstring;pageno:integer);
  67. var
  68.   page:xstring;
  69. begin
  70.   page[1]:=ord(' ');
  71.   page[2]:=ord('p');
  72.   page[3]:=ord('a');
  73.   page[4]:=ord('g');
  74.   page[5]:=ord('e');
  75.   page[6]:=ord(' ');
  76.   page[7]:=endstr;
  77.   putstr(name,stdout);
  78.   putstr(page,stdout);
  79.   putdec(pageno,1);
  80.   putc(newline)
  81. end;
  82.  
  83. begin(*fprint*)
  84.   pageno:=1;
  85.   skip(margin1);
  86.   head(name,pageno);
  87.   skip(margin2);
  88.   lineno:=margin1+margin2+1;
  89.   while(getline(line,fin,maxstr))do begin
  90.     if(lineno=0)then begin
  91.       skip(margin1);;
  92.       pageno:=pageno+1;
  93.       head(name,pageno);
  94.       skip(margin2);
  95.       lineno:=margin1+margin2+1
  96.     end;
  97.     putstr(line,stdout);
  98.     lineno:=lineno+1;
  99.     if(lineno>=bottom)then begin
  100.       skip(pagelen-lineno);
  101.       lineno:=0
  102.     end
  103.   end;
  104.   if(lineno>0)then
  105.     skip(pagelen-lineno)
  106. end;
  107.   
  108. begin(*print*)
  109.   null[1]:=endstr;
  110.   if(nargs=1)then
  111.     fprint(null,stdin)
  112.   else
  113.     for i:=2 to nargs do begin
  114.       junk:=getarg(i,name,maxstr);
  115.       fin:=mustopen(name,ioread);
  116.       fprint(name,fin);
  117.       xclose(fin)
  118.     end
  119. end;
  120.  
  121. procedure compare;
  122. var
  123.   line1,line2:xstring;
  124.   arg1,arg2:xstring;
  125.   lineno:integer;
  126.   infile1,infile2:filedesc;
  127.   f1,f2:boolean;
  128.   
  129. procedure diffmsg (n:integer; var line1,line2:xstring);
  130. begin
  131.   putdec(n,1);
  132.   putc(colon);
  133.   putc(newline);
  134.   putstr(line1,stdout);
  135.   putstr(line2,stdout)
  136. end;
  137.  
  138. begin(*compare*)
  139.   if (not getarg(2,arg1,maxstr))
  140.    or (not getarg(3,arg2,maxstr)) then
  141.      error('usage:compare file1 file2');
  142.   infile1:=mustopen(arg1,ioread);
  143.   infile2:=mustopen(arg2,ioread);
  144.   lineno:=0;
  145.   repeat
  146.     lineno:=lineno+1;
  147.     f1:=getline(line1,infile1,maxstr);
  148.     f2:=getline(line2,infile2,maxstr);
  149.     if (f1 and f2) then
  150.       if (not equal(line1,line2)) then
  151.         diffmsg(lineno,line1,line2)
  152.   until (f1=false) or (f2=false);
  153.   if(f2 and not f1) then
  154.   writeln('compare:end of file on file 1')
  155.   else if (f1 and not f2) then
  156.     writeln('compare:end of file on file2')
  157. end;
  158.  
  159.  
  160. procedure include;
  161. var
  162.   incl:xstring;
  163.  
  164. procedure finclude(f:filedesc);
  165. var
  166.   line,str:xstring;
  167.   loc,i:integer;
  168.   f1:filedesc;
  169. function getword(var s:xstring;i:integer;
  170.   var out:xstring):integer;
  171.  
  172. var
  173.   j:integer;
  174. begin
  175.   while(s[i] in [blank,tab,newline]) do
  176.     i:=i+1;
  177.   j:=1;
  178.   while(not (s[i] in [endstr,blank,tab,newline])) do begin
  179.     out[j]:=s[i];
  180.     i:=i+1;
  181.     j:=j+1
  182.   end;
  183.   out[j]:=endstr;
  184.   if(s[i]=endstr) then
  185.     getword:=0
  186.   else
  187.     getword:=i
  188. end;
  189.  
  190. begin
  191.   while (getline(line,f,maxstr))do begin
  192.     loc:=getword(line,1,str);
  193.     if (not equal(str,incl)) then
  194.       putstr(line,stdout)
  195.     else begin
  196.       loc:=getword(line,loc,str);
  197.       str[xlength(str)]:=endstr;
  198.       for i:= 1 to xlength(str)do
  199.         str[i]:=str[i+1];
  200.       f1:=mustopen(str,ioread);
  201.       finclude(f1);
  202.       xclose(f1)
  203.     end
  204.   end
  205. end;
  206.  
  207. begin
  208.   incl[1]:=ord('#');
  209.   incl[2]:=ord('i');
  210.   incl[3]:=ord('n');
  211.   incl[4]:=ord('c');
  212.   incl[5]:=ord('l');
  213.   incl[6]:=ord('u');
  214.   incl[7]:=ord('d');
  215.   incl[8]:=ord('e');
  216.   incl[9]:=endstr;
  217.   finclude(stdin)
  218. end;
  219.   
  220. procedure concat;
  221. var
  222.   i:integer;
  223.   junk:boolean;
  224.   fd:filedesc;
  225.   s:xstring;
  226. begin
  227.   for i:=2 to nargs do begin
  228.     junk:=getarg(i,s,maxstr);
  229.     fd:=mustopen(s,ioread);
  230.     fcopy(fd,stdout);
  231.     xclose(fd)
  232.   end
  233. end;
  234.  
  235. procedure archive;
  236. const
  237.   maxfiles=10;
  238. var
  239.   aname:xstring;
  240.   cmd:xstring;
  241.   fname:array[1..maxfiles]of xstring;
  242.   fstat:array[1..maxfiles] of boolean;
  243.   nfiles:integer;
  244.   errcount:integer;
  245.   archtemp:xstring;
  246.   archhdr:xstring;
  247. function getword(var s:xstring;i:integer;var out:xstring):integer;
  248. var
  249.   j:integer;
  250. begin
  251.   while (s[i] in [blank,tab,newline]) do
  252.     i:=i+1;
  253.   j:=1;
  254.   while(not (s[i] in [endstr,blank,tab,newline])) do begin
  255.     out[j]:=s[i];
  256.     i:=i+1;
  257.     j:=j+1
  258.   end;
  259.   out[j]:=endstr;
  260.   if(s[i]=endstr) then
  261.     getword:=0
  262.   else
  263.     getword:=i
  264. end;
  265.  
  266.  
  267. function gethdr(fd:filedesc;var buf,name:xstring;
  268.   var size:integer):boolean;
  269. var
  270.   temp:xstring;
  271.   i:integer;
  272. begin
  273.   if(getline(buf,fd,maxstr)=false)then
  274.     gethdr:=false
  275.   else begin
  276.     i:=getword(buf,1,temp);
  277.     if(not equal(temp,archhdr))then
  278.       error('archive not in proper format');
  279.     i:=getword(buf,i,name);
  280.     size:=ctoi(buf,i);
  281.     gethdr:=true
  282.   end
  283. end;
  284.  
  285. function filearg (var name:xstring):boolean;
  286. var
  287.   i:integer;
  288.   found:boolean;
  289. begin
  290.   if(nfiles<=0)then
  291.     filearg:=true
  292.   else begin
  293.     found:=false;
  294.     i:=1;
  295.     while(not found) and (i<=nfiles)do begin
  296.       if(equal(name,fname[i])) then begin
  297.         fstat[i]:=true;
  298.         found:=true
  299.       end;
  300.       i:=i+1
  301.     end;
  302.     filearg:=found
  303.   end
  304. end;
  305.  
  306. procedure fskip(fd:filedesc;n:integer);
  307. var
  308.   c:character;
  309.   i:integer;
  310. begin
  311.   for i:=1 to n do
  312.     if(getcf(c,fd)=endfile)then
  313.       error('archive:end of file in fskip')
  314. end;
  315.  
  316. procedure fmove(var name1,name2:xstring);
  317. var
  318.   fd1,fd2:filedesc;
  319. begin
  320.   fd1:=mustopen(name1,ioread);
  321.   fd2:=mustcreate(name2,iowrite);
  322.   fcopy(fd1,fd2);
  323.   xclose(fd1);
  324.   xclose(fd2)
  325. end;
  326.  
  327.  
  328. procedure acopy(fdi,fdo:filedesc;n:integer);
  329. var
  330.   c:character;
  331.   i:integer;
  332. begin
  333.   for i:=1 to n do
  334.     if (getcf(c,fdi)=endfile)then
  335.       error('archive: end of file in acopy')
  336.     else
  337.       putcf(c,fdo)
  338. end;
  339.  
  340. procedure notfound;
  341. var
  342.   i:integer;
  343. begin
  344.   for i := 1 to nfiles do
  345.     if(fstat[i]=false)then begin
  346.       putstr(fname[i],stderr);
  347.       writeln(':not in archive');
  348.       errcount:=errcount + 1
  349.     end
  350. end;
  351.  
  352. procedure addfile(var name:xstring;fd:filedesc);
  353. var
  354.   head:xstring;
  355.   nfd:filedesc;
  356. procedure makehdr(var name,head:xstring);
  357. var
  358.   i:integer;
  359. function fsize(var name:xstring):integer;
  360. var
  361.   c:character;
  362.   fd:filedesc;
  363.   n:integer;
  364. begin
  365.   n:=0;
  366.   fd:=mustopen(name,ioread);
  367.   while(getcf(c,fd)<>endfile)do
  368.     n:=n+1;
  369.   xclose(fd);
  370.   fsize:=n
  371. end;
  372.  
  373. begin
  374.   scopy(archhdr,1,head,1);
  375.   i:=xlength(head)+1;
  376.   head[i]:=blank;
  377.   scopy(name,1,head,i+1);
  378.   i:=xlength(head)+1;
  379.   head[i]:=blank;
  380.   i:=itoc(fsize(name),head,i+1);
  381.   head[i]:=newline;
  382.   head[i+1]:=endstr
  383. end;
  384.  
  385. begin
  386.   nfd:=open(name,ioread);
  387.   if(nfd=ioerror)then begin
  388.     putstr(name,stderr);
  389.     writeln(':can''t add');
  390.     errcount:=errcount+1
  391.   end;
  392.   if(errcount=0)then begin
  393.     makehdr(name,head);
  394.     putstr(head,fd);
  395.     fcopy(nfd,fd);
  396.     xclose(nfd)
  397.   end
  398. end;
  399.  
  400.  
  401. procedure replace(afd,tfd:filedesc;cmd:integer);
  402. var
  403.   pinline,uname:xstring;
  404.   size:integer;
  405. begin
  406.   while(gethdr(afd,pinline,uname,size))do
  407.     if(filearg(uname))then begin
  408.       if(cmd=ord('u'))then
  409.         addfile(uname,tfd);
  410.       fskip(afd,size)
  411.     end
  412.     else begin
  413.       putstr(pinline,tfd);
  414.       acopy(afd,tfd,size)
  415.     end
  416. end;
  417.  
  418. procedure help;
  419. begin
  420.   error('usage:archive -[cdptux] archname [files...]')
  421. end;
  422.  
  423.  
  424. procedure getfns;
  425. var
  426.   i,j:integer;
  427.   junk:boolean;
  428. begin
  429.   errcount:=0;
  430.   nfiles:=nargs-3;
  431.   if(nfiles>maxfiles)then
  432.     error('archive:to many file names');
  433.   for i:=1 to nfiles do
  434.     junk:=getarg(i+3,fname[i],maxstr);
  435.   for i:=1 to nfiles do
  436.    fstat[i]:=false;
  437.   for i:=1 to nfiles-1 do
  438.     for j:=i+1 to nfiles do
  439.       if(equal(fname[i],fname[j]))then begin
  440.         putstr(fname[i],stderr);
  441.         error(':duplicate filename')
  442.       end
  443. end;
  444.  
  445.  
  446. procedure update(var aname:xstring;cmd:character);
  447. var
  448.   i:integer;
  449.   afd,tfd:filedesc;
  450. begin
  451.   tfd:=mustcreate(archtemp,iowrite);
  452.   if(cmd=ord('u')) then begin
  453.    afd:=mustopen(aname,ioread);
  454.    replace(afd,tfd,ord('u'));(*update existing*)
  455.    xclose(afd)
  456.  end;
  457.  for i:=1 to nfiles do
  458.    if(fstat[i]=false)then begin
  459.       addfile(fname[i],tfd);
  460.       fstat[i]:=true
  461.     end;
  462.     xclose(tfd);
  463.     if(errcount=0)then
  464.       fmove(archtemp,aname)
  465.     else
  466.       writeln('fatal errors - archive not altered');
  467.     remove (archtemp)
  468.   end;
  469. procedure table(var aname:xstring);
  470. var
  471.   head,name:xstring;
  472.   size:integer;
  473.   afd:filedesc;
  474. procedure tprint(var buf:xstring);
  475. var
  476.   i:integer;
  477.   temp:xstring;
  478. begin
  479.   i:=getword(buf,1,temp);
  480.   i:=getword(buf,i,temp);
  481.   putstr(temp,stdout);
  482.   putc(blank);
  483.   i:=getword(buf,i,temp);(*size*)
  484.   putstr(temp,stdout);
  485.   putc(newline)
  486. end;
  487.  
  488. begin
  489.   afd:=mustopen(aname,ioread);
  490.   while(gethdr(afd,head,name,size))do begin
  491.     if(filearg(name))then
  492.       tprint(head);
  493.     fskip(afd,size)
  494.   end;
  495.   notfound
  496. end;
  497.  
  498. procedure extract (var aname:xstring;cmd:character);
  499. var
  500.   ename,pinline:xstring;
  501.   afd,efd:filedesc;
  502.   size : integer;
  503. begin
  504.   afd:=mustopen(aname,ioread);
  505.   if (cmd=ord('p')) then
  506.     efd:=stdout
  507.   else
  508.     efd:=ioerror;
  509.   while (gethdr(afd,pinline,ename,size)) do
  510.     if (not filearg(ename))then
  511.       fskip(afd,size)
  512.     else
  513.       begin
  514.       if (efd<> stdout) then
  515.         efd:=create(ename,iowrite);
  516.       if(efd=ioerror) then begin
  517.         putstr(ename,stderr);
  518.         writeln(': cant''t create');
  519.         errcount:=errcount+1;
  520.         fskip(afd,size)
  521.       end
  522.       else begin
  523.         acopy(afd,efd,size);
  524.         if(efd<>stdout)then
  525.         xclose(efd)
  526.       end
  527.     end;
  528.     notfound
  529.   end;
  530.  
  531. procedure delete(var aname:xstring);
  532. var
  533.   afd,tfd:filedesc;
  534. begin
  535.   if(nfiles<=0)then(*protect innocent*)
  536.     error('archive:-d requires explicit file names');
  537.   afd:=mustopen(aname,ioread);
  538.   tfd:=mustcreate(archtemp,iowrite);
  539.   replace(afd,tfd,ord('d'));
  540.   notfound;
  541.   xclose(afd);
  542.   xclose(tfd);
  543.   if(errcount=0)then
  544.     fmove(archtemp,aname)
  545.   else
  546.     writeln('fatal errors - archive not altered');
  547.   remove(archtemp)
  548. end;
  549.  
  550.  
  551. procedure initarch;
  552. begin
  553.   archtemp[1]:=ord('a');
  554.   archtemp[2]:=ord('r');
  555.   archtemp[3]:=ord('t');
  556.   archtemp[4]:=ord('e');
  557.   archtemp[5]:=ord('m');
  558.   archtemp[6]:=ord('p');
  559.   archtemp[7]:=endstr;
  560.   archhdr[1]:=ord('-');
  561.   archhdr[2]:=ord('h');
  562.   archhdr[3]:=ord('-');
  563.   archhdr[4]:=endstr;
  564. end;
  565.  
  566.  
  567. begin
  568.   initarch;
  569.   if (not getarg(2,cmd,maxstr))
  570.     or(not getarg(3,aname,maxstr)) then
  571.       help;
  572.   getfns;
  573.   if(xlength(cmd)<>2) or(cmd[1]<>ord('-')) then
  574.     help
  575.   else if (cmd[2]=ord('c'))or(cmd[2]=ord('u'))then
  576.     update(aname,cmd[2])
  577.   else if (cmd[2]=ord('t'))then
  578.     table(aname)
  579.   else if (cmd[2]=ord('x'))or(cmd[2]=ord('p'))then
  580.     extract(aname,cmd[2])
  581.   else if (cmd[2]=ord('d'))then
  582.     delete(aname)
  583.   else
  584.     help
  585. end;
  586.