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 / A / ARC20.ARC / ARCEXT.INC < prev    next >
Text File  |  1989-11-10  |  1KB  |  43 lines
  1. (* ARCEXT.INC  TR 101189 *)
  2.  
  3. (* angegebene Datei(en) aus Archive extrahieren *)
  4.  
  5. procedure extarc;
  6. var paths : array[1..10] of char;
  7.     i,n   : byte;
  8.  
  9.   procedure extfile(path:char);
  10.   var nam  : filenam;
  11.   begin
  12.     nam:=pstring(header.name);
  13.     if path<>#0 then nam:=path+':'+nam;
  14.     if note then writeln('Extracting File: ',nam);
  15.     fopen_write(nam,orgfile);
  16.     unpack(oldarc,orgfile,header);
  17.     fclose(orgfile);
  18.     end;
  19.  
  20. begin  { extarc }
  21.   for n:=1 to pcount do begin
  22.     did[n]:=false;
  23.     i:=pos(':',arg[n]);
  24.     if i=0 then paths[n]:=#0 else begin
  25.       paths[n]:=arg[n][1]; delete(arg[n],1,i); end;
  26.     end;
  27.   if openarc(false) then begin
  28.     if pcount=0 then while readhdr(header,oldarc) do extfile(#0)
  29.     else while readhdr(header,oldarc) do begin
  30.       found:=false; n:=0;
  31.       repeat
  32.         n:=succ(n);
  33.         if match(pstring(header.name),arg[n]) then begin
  34.           found:=true; did[n]:=true; end;
  35.       until found or (n>=pcount);
  36.       if found then extfile(paths[n]) else fskip(oldarc,header.size);
  37.       end;
  38.     note_notfound;
  39.     closearc;
  40.     end
  41.   else writeln(empty);
  42.   end;
  43.