home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / PASCAL / PT03.ZIP / ARCHIVE.AR < prev    next >
Encoding:
Text File  |  1983-09-01  |  10.9 KB  |  475 lines
  1. -h- acopy.arc 267
  2. { acopy -- copy n characters from fdi to fdo }
  3. procedure acopy (fdi, fdo : filedesc; n : integer);
  4. var
  5.  c : character;
  6.  i : integer;
  7. begin
  8.  for i := 1 to n do
  9.   if (getcf(c, fdi) = ENDFILE) then
  10.    error('archive: end of file in acopy')
  11.   else
  12.    putcf(c, fdo)
  13. end;
  14.  
  15. -h- addfile.arc 423
  16. { addfile -- add file "name" to archive }
  17. procedure addfile (var name : string; fd : filedesc);
  18. var
  19.  head : string;
  20.  nfd : filedesc;
  21. {$include:'makehdr.arc'}
  22. begin
  23.  nfd := open(name, IOREAD);
  24.  if (nfd = IOERROR) then begin
  25.   putstr(name, STDERR);
  26.   message(': can''t add');
  27.   errcount := errcount + 1
  28.  end;
  29.  if (errcount = 0) then begin
  30.   makehdr(name, head);
  31.   putstr(head, fd);
  32.   fcopy(nfd, fd);
  33.   xclose(nfd)
  34.  end
  35. end;
  36.  
  37. -h- archive.arc 939
  38. { archive -- file maintainer }
  39. procedure archive;
  40. const
  41.  MAXFILES = 100; { or whatever }
  42. var
  43.  aname : string;  { archive name }
  44.  cmd : string;    { command type }
  45.  fname : array [1..MAXFILES] of string; { filename args }
  46.  fstat : array [1..MAXFILES] of boolean; { true=in archive }
  47.  nfiles : integer; { number of filename arguments }
  48.  errcount : integer; { number of errors }
  49.  archtemp : string; { temp file name 'artemp' }
  50.  archhdr : string; { header string '-h-' }
  51. {$include:'archproc.arc'}
  52. begin
  53.  initarch;
  54.  if (not getarg(1, cmd, MAXSTR))
  55.    or (not getarg(2, aname, MAXSTR)) then
  56.   help;
  57.  getfns;
  58.  if (length(cmd) <> 2) or (cmd[1] <> ord('-')) then
  59.   help
  60.  else if (cmd[2] = ord('c')) or (cmd[2] = ord('u')) then
  61.   update(aname, cmd[2])
  62.  else if (cmd[2] = ord('t')) then
  63.   table(aname)
  64.  else if (cmd[2] = ord('x')) or (cmd[2] = ord('p')) then
  65.   extract(aname, cmd[2])
  66.  else if (cmd[2] = ord('d')) then
  67.   delete(aname)
  68.  else
  69.   help
  70. end;
  71.  
  72. -h- archproc.arc 464
  73. { archproc -- include procedures for archive }
  74. {$include:'getword.arc' }
  75. {$include:'gethdr.arc'  }
  76. {$include:'filearg.arc' }
  77. {$include:'fskip.arc'   }
  78. {$include:'fmove.arc'   }
  79. {$include:'acopy.arc'   }
  80. {$include:'notfound.arc'}
  81. {$include:'addfile.arc' }
  82. {$include:'replace.arc' }
  83. {$include:'help.arc'    }
  84. {$include:'getfns.arc'  }
  85. {$include:'update.arc'  }
  86. {$include:'table.arc'   }
  87. {$include:'extract.arc' }
  88. {$include:'delete.arc'  }
  89. {$include:'initarch.arc'}
  90.  
  91. -h- delete.arc 478
  92. { delete -- delete files from archive }
  93. procedure delete (var aname : string);
  94. var
  95.  afd, tfd : filedesc;
  96. begin
  97.  if (nfiles <= 0) then    { protect innocents }
  98.   error('archive: -d requires explicit file names');
  99.  afd := mustopen(aname, IOREAD);
  100.  tfd := mustcreate(archtemp, IOWRITE);
  101.  replace(afd, tfd, ord('d'));
  102.  notfound;
  103.  xclose(afd);
  104.  xclose(tfd);
  105.  if (errcount = 0) then
  106.   fmove(archtemp, aname)
  107.  else
  108.   message('fatal errors - archive not altered');
  109.  remove(archtemp)
  110. end;
  111.  
  112. -h- extract.arc 724
  113. { extract -- extract files from archive }
  114. procedure extract (var aname: string; cmd : character);
  115. var
  116.  ename, inline : string;
  117.  afd, efd : filedesc;
  118.  size : integer;
  119. begin
  120.  afd := mustopen(aname, IOREAD);
  121.  if (cmd = ord('p')) then
  122.   efd := STDOUT
  123.  else  { cmd is 'x' }
  124.   efd := IOERROR;
  125.  while (gethdr(afd, inline, ename, size)) do
  126.   if (not filearg(ename)) then
  127.    fskip(afd, size)
  128.   else begin
  129.    if (efd <> STDOUT) then
  130.     efd := create(ename, IOWRITE);
  131.    if (efd = IOERROR) then begin
  132.     putstr(ename, STDERR);
  133.     message(': can''t create');
  134.     errcount := errcount + 1;
  135.     fskip(afd, size)
  136.    end
  137.    else begin
  138.     acopy(afd, efd, size);
  139.     if (efd <> STDOUT) then
  140.      xclose(efd)
  141.    end
  142.   end;
  143.  notfound
  144. end;
  145.  
  146. -h- fequal.arc 376
  147. { fequal -- test two filenames for equality, ignoring leading x: if present }
  148. function fequal (var str1, str2 : string) : boolean;
  149. var
  150.  i,j : integer;
  151. begin
  152.  i := 1;
  153.  j := 1;
  154.  if (str1[2] = COLON) then i := 3;
  155.  if (str2[2] = COLON) then j := 3;
  156.  while (str1[i] = str2[j]) and (str1[i] <> ENDSTR) do begin
  157.   i := i + 1;
  158.   j := j + 1;
  159.   end;
  160.  fequal := (str1[i] = str2[j])
  161. end;
  162. -h- filearg.arc 434
  163. { filearg -- check if name matches argument list }
  164. function filearg (var name : string) : boolean;
  165. var
  166.  i : integer;
  167.  found : boolean;
  168. {$include:'fequal.arc'}
  169. begin
  170.  if (nfiles <= 0) then
  171.   filearg := true
  172.  else begin
  173.   found := false;
  174.   i := 1;
  175.   while (not found) and (i <= nfiles) do begin
  176.    if (fequal(name, fname[i])) then begin
  177.     fstat[i] := true;
  178.     found := true
  179.    end;
  180.    i := i + 1
  181.   end;
  182.   filearg := found
  183.  end
  184. end;
  185.  
  186. -h- fmove.arc 235
  187. { fmove -- move file name1 to name2 }
  188. procedure fmove (var name1, name2 : string);
  189. var
  190.  fd1, fd2 : filedesc;
  191. begin
  192.  fd1 := mustopen(name1, IOREAD);
  193.  fd2 := mustcreate(name2, IOWRITE);
  194.  fcopy(fd1, fd2);
  195.  xclose(fd1);
  196.  xclose(fd2)
  197. end;
  198.  
  199. -h- fsize.arc 263
  200. { fsize -- size of file in characters }
  201. function fsize (var name : string) : integer;
  202. var
  203.  c : character;
  204.  fd : filedesc;
  205.  n : integer;
  206. begin
  207.  n := 0;
  208.  fd := mustopen(name, IOREAD);
  209.  while (getcf(c, fd) <> ENDFILE) do
  210.   n := n + 1;
  211.  xclose(fd);
  212.  fsize := n
  213. end;
  214.  
  215. -h- fskip.arc 231
  216. { fskip -- skip n characters on file fd }
  217. procedure fskip (fd : filedesc; n : integer);
  218. var
  219.  c : character;
  220.  i : integer;
  221. begin
  222.  for i := 1 to n do
  223.   if (getcf(c, fd) = ENDFILE) then
  224.    error('archive: end of file in fskip')
  225. end;
  226.  
  227. -h- getfns.arc 524
  228. { getfns -- get filenames into fname, look for duplicates }
  229. procedure getfns;
  230. var
  231.  i, j : integer;
  232.  junk : boolean;
  233. begin
  234.  errcount := 0;
  235.  nfiles := nargs - 2;
  236.  if (nfiles > MAXFILES) then
  237.   error('archive: too many file names');
  238.  for i := 1 to nfiles do
  239.   junk := getarg(i+2, fname[i], MAXSTR);
  240.  for i := 1 to nfiles do
  241.   fstat[i] := false;
  242.  for i := 1 to nfiles - 1 do
  243.   for j := i + 1 to nfiles do
  244.    if (equal(fname[i], fname[j])) then begin
  245.     putstr(fname[i], STDERR);
  246.     error(': duplicate file name')
  247.    end
  248. end;
  249.  
  250. -h- gethdr.arc 432
  251. { gethdr -- get header info from fd }
  252. function gethdr (fd : filedesc; var buf, name : string;
  253.   var size : integer) : boolean;
  254. var
  255.  temp : string;
  256.  i : integer;
  257. begin
  258.  if (getline(buf, fd, MAXSTR) = false) then
  259.   gethdr := false
  260.  else begin
  261.   i := getword(buf, 1, temp);
  262.   if (not equal(temp, archhdr)) then
  263.    error('archive not in proper format');
  264.   i := getword(buf, i, name);
  265.   size := ctoi(buf, i);
  266.   gethdr := true
  267.  end
  268. end;
  269.  
  270. -h- getword.arc 407
  271. { getword -- get word from s[i] into out }
  272. function getword (var s : string; i : integer;
  273.    var out : string) : integer;
  274. var
  275.  j : integer;
  276. begin
  277.  while (s[i] in [BLANK, TAB, NEWLINE]) do
  278.   i := i + 1;
  279.  j := 1;
  280.  while (not (s[i] in [ENDSTR,BLANK,TAB,NEWLINE])) do begin
  281.   out[j] := s[i];
  282.   i := i + 1;
  283.   j := j + 1
  284.  end;
  285.  out[j] := ENDSTR;
  286.  if (s[i] = ENDSTR) then
  287.   getword := 0
  288.  else
  289.   getword := i
  290. end;
  291.  
  292. -h- help.arc 124
  293. { help -- print diagnostic for archive }
  294. procedure help;
  295. begin
  296.  error('usage: archive -[cdptux] archname [files...]')
  297. end;
  298.  
  299. -h- initarch.arc 438
  300. { initarch -- initialize variables for archive }
  301. procedure initarch;
  302. begin
  303.  { setstring(archtemp, 'artemp'); }
  304.   archtemp[1] := ord('a');
  305.   archtemp[2] := ord('r');
  306.   archtemp[3] := ord('t');
  307.   archtemp[4] := ord('e');
  308.   archtemp[5] := ord('m');
  309.   archtemp[6] := ord('p');
  310.   archtemp[7] := ENDSTR;
  311.  { setstring(archhdr, '-h-'); }
  312.   archhdr[1] := ord('-');
  313.   archhdr[2] := ord('h');
  314.   archhdr[3] := ord('-');
  315.   archhdr[4] := ENDSTR;
  316. end;
  317.  
  318. -h- makehdr.arc 417
  319. { makehdr -- make header line for archive member }
  320. procedure makehdr (var name, head : string);
  321. var
  322.  i,j : integer;
  323. {$include:'fsize.arc'}
  324. begin
  325.  scopy(archhdr, 1, head, 1);
  326.  i := length(head) + 1;
  327.  head[i] := BLANK;
  328.  j := 1;
  329.  if (name[2] = COLON) then j := 3;
  330.  scopy(name, j, head, i+1);
  331.  i := length(head) + 1;
  332.  head[i] := BLANK;
  333.  i := itoc(fsize(name), head, i+1);
  334.  head[i] := NEWLINE;
  335.  head[i+1] := ENDSTR
  336. end;
  337.  
  338.  
  339. -h- notfound.arc 247
  340. { notfound -- print "not found" warning }
  341. procedure notfound;
  342. var
  343.  i : integer;
  344. begin
  345.  for i := 1 to nfiles do
  346.   if (fstat[i] = false) then begin
  347.    putstr(fname[i], STDERR);
  348.    message(': not in archive');
  349.    errcount := errcount + 1
  350.   end
  351. end;
  352.  
  353. -h- replace.arc 415
  354. { replace -- replace or delete files }
  355. procedure replace (afd, tfd : filedesc; cmd : integer);
  356. var
  357.  inline, uname : string;
  358.  size : integer;
  359. begin
  360.  while (gethdr(afd, inline, uname, size)) do
  361.   if (filearg(uname)) then begin
  362.    if (cmd = ord('u')) then  { add new one }
  363.     addfile(uname, tfd);
  364.    fskip(afd, size) { discard old one }
  365.   end
  366.   else begin
  367.    putstr(inline, tfd);
  368.    acopy(afd, tfd, size)
  369.   end
  370. end;
  371.  
  372. -h- table.arc 338
  373. { table -- print table of archive contents }
  374. procedure table (var aname : string);
  375. var
  376.  head, name : string;
  377.  size : integer;
  378.  afd : filedesc;
  379. {$include:'tprint.arc'}
  380. begin
  381.  afd := mustopen(aname, IOREAD);
  382.  while (gethdr(afd, head, name, size)) do begin
  383.   if (filearg(name)) then
  384.    tprint(head);
  385.   fskip(afd, size)
  386.  end;
  387.  notfound
  388. end;
  389.  
  390. -h- tprint.arc 445
  391. { tprint -- print table entry for one member }
  392. procedure tprint (var buf : string);
  393. var
  394.  i,j : integer;
  395.  temp : string;
  396. begin
  397.  i := getword(buf, 1, temp); { header }
  398.  i := getword(buf, i, temp); { name }
  399.  putstr(temp, STDOUT);
  400.  for j := 1 to (MAXFN-length(temp)) do putc(BLANK); {trailing blanks}
  401.  i := getword(buf, i, temp); { size }
  402.  for j := 1 to (6-length(temp)) do putc(BLANK);  {leading blanks}
  403.  putstr(temp, STDOUT);
  404.  putc(NEWLINE)
  405. end;
  406.  
  407. -h- update.arc 608
  408. { update -- update existing files, add new ones at end }
  409. procedure update (var aname : string; cmd : character);
  410. var
  411.  i : integer;
  412.  afd, tfd : filedesc;
  413. begin
  414.  tfd := mustcreate(archtemp, IOWRITE);
  415.  if (cmd = ord('u')) then begin
  416.   afd := mustopen(aname, IOREAD);
  417.   replace(afd, tfd, ord('u')); { update existing }
  418.   xclose(afd)
  419.  end;
  420.  for i := 1 to nfiles do  { add new ones }
  421.   if (fstat[i] = false) then begin
  422.    addfile(fname[i], tfd);
  423.    fstat[i] := true
  424.   end;
  425.  xclose(tfd);
  426.  if (errcount = 0) then
  427.   fmove(archtemp, aname)
  428.  else
  429.   message('fatal errors - archive not altered');
  430.  remove(archtemp)
  431. end;
  432. -h- archive.pas 769
  433. {$debug-}
  434. program outer (input,output);
  435.  
  436. {$include:'globcons.inc'}
  437. {$include:'globtyps.inc'}
  438.  
  439. {$include:'initio.dcl'}
  440. {$include:'flush.dcl' }
  441.  
  442. {$include:'getline.dcl' }
  443. {$include:'equal.dcl'   }
  444. {$include:'error.dcl'   }
  445. {$include:'message.dcl' }
  446. {$include:'ctoi.dcl'    }
  447. {$include:'itoc.dcl'    }
  448. {$include:'getcf.dcl'   }
  449. {$include:'putc.dcl'    }
  450. {$include:'putcf.dcl'   }
  451. {$include:'putstr.dcl'  }
  452. {$include:'create.dcl'  }
  453. {$include:'mustopen.dcl'}
  454. {$include:'mustcrea.dcl'}
  455. {$include:'fcopy.dcl'   }
  456. {$include:'length.dcl'  }
  457. {$include:'open.dcl'    }
  458. {$include:'close.dcl'   }
  459. {$include:'nargs.dcl'   }
  460. {$include:'getarg.dcl'  }
  461. {$include:'scopy.dcl'   }
  462. {$include:'remove.dcl'  }
  463.  
  464. {$include:'archive.arc' }
  465. BEGIN
  466.   minitio; initio;
  467.   archive;
  468.   flush(0);
  469. END.
  470. -h- archive.mak 181
  471. archive+initio+getfcb+flush+error+getarg+nargs+length+
  472. getline+equal+ctoi+itoc+getcf+putc+putcf+putstr+fcopy+
  473. mustopen+mustcrea+create+message+close+getc+isdigit+
  474. scopy+remove+open
  475.