⟦3ab1dccf7⟧

TextFile

(mode list.yes
extract=algol  connect.no blocks.yes
if warning.no
extract list.no
mode list.no)
1980-10-27
begin
boolean list,search,all,convert,from,test;
integer lb,ub,segm,i,j,char,result,area;
integer array field rec;
long array field doc,name,lo;
array field r;
integer array bases(1:8),t,pt,ct(1:10);
array pname,cname,inp(1:3),sname(1:25,1:2);
boolean array sfound(1:25);

boolean procedure disccopy(infile,fsegm,outfile,tail);
value fsegm; integer fsegm;
string infile,outfile;
integer array tail;
begin
integer result,i,free,
  blocklength,s;
integer array todesc,fromdesc(1:20),t(1:10);
array inname,outname(1:3);

free:=((system(2,i,inname)-1536)//512)+1;
blocklength:=free*512;
disccopy:=true;

cleararray(inname);
movestring(inname,1,infile);

cleararray(outname);
movestring(outname,1,outfile);
for i:=1 step 1 until 10 do t(i):=tail(i);
result:=createentry(outname,t);
if result>0 then
begin
  i:=1;
  write(out,<:<10>**:>,string outname(increase(i)),
    <: create entry result :>,result,t(1));
disccopy:=false;
end outfile improper
else
begin
permentry(outname,2);
i:=setenbase(outname,bases(5),bases(6));
if i<>0 then write(out,"nl",1,"*",2,true,12,outname.lo,<: set entry base:>);
if i<>0 and test then write(out,bases(5),bases(6));
end;
if result=0 then
begin
zone z(free*128,1,stderror);

procedure flip;
begin
  getzone6(z,fromdesc);
  setzone6(z,todesc);
end;

procedure flop;
begin
  getzone6(z,todesc);
  setzone6(z,fromdesc);
end;

getzone6(z,todesc);
i:=1;
open(z,4,string inname(increase(i)),0);
setposition(z,0,fsegm); flip;
i:=1;
open(z,4,string outname(increase(i)),0);
s:=tail(1);
if test then write(out,"nl",1,"*",1,outname.lo,<: free :>,free,
   <: first :>,fsegm,<: segments :>,s);;
for i:=1 step free until s do
begin
  flop;
  inrec6(z,free*512); flip;
  outrec6(z,free*512);
  outrec6(z,0);
  if test then write(out,"nl",1,<:free moved :>,free*512);
end;
flop;
i:=(tail(1) mod free)*512;
if test then write(out,"nl",1,<:rest :>,i);
inrec6(z,i); flip;
outrec6(z,i); close(z,true); flop;
close(z,true); flip;
close(z,true); flop;
end zone;
end disccopy;

boolean procedure extractfile(lib,list,search,all,name);
boolean list,search,all;
long array lib;
array name;
begin
integer field segm,w;
array field sn,r;
long array field n,doc;
boolean field firstbyte;
integer array field t;
integer i,j,k,l,entry,entries;
zone cat(128,1,stderror);

extractfile:=all;
open(cat,4,lib,0);
w:=512;
inrec6(cat,512);
entries:=cat.w;
sn:=n:=6; doc:=16; segm:=16;
firstbyte:=1;
r:=0;
t:=14;
setposition(cat,0,0);
for entry:=1 step 1 until entries do
begin
  inrec6(cat,34);
  i:=1;
  if list or all then
   begin
     write(out,"nl",1,"sp",4,true,12,cat.n,
                <<ddddd>,cat.segm);
     outshortcl(out,cat.t(6));
     i:=j:=k:=l:=1;
     if all then
     begin
       if disccopy(string lib.r(increase(i)),cat.firstbyte extract 12,
          string cat.n.r(increase(j)),cat.t) and convert then
       convert:=printfile(string pname(increase(k)),
              string cat.n.r(increase(l)))>0;
    end all;
   end else
  if search or from then
  begin
    if cat.sn(1)=name(1) then
    begin
      if cat.sn(2)=name(2) then
      begin
        extractfile:=true;
        write(out,"nl",1,true,12,cat.n,
                 <<ddddd>,cat.segm);
       outshortcl(out,cat.t(6));
       write(out,<:  on  :>,true,12,lib);
      i:=j:=k:=l:=1;
      if disccopy(string lib(increase(i)),cat.firstbyte extract 12,
                  string cat.n.r(increase(j)),cat.t) and
      convert then printfile(string pname(increase(k)),
              string cat.n.r(increase(l)));
      end name part 2;
    end name part 1;
  end search;
end entry;
close(cat,true);
end  extractfile;


rec:=0;
lo:=r:=0;
name:=6;
doc:=16;
for i:=1 step 1 until 25 do sfound(i):=false;
cleararray(sname);
lookup_tail(<:catalog:>,t);
segm:=t(1);
system(11,0,bases);
readbfp(<:test:>,test,false);
all:=readsfp(<:all:>,cname,<::>);
from:=false;
if -,all then from:=readsfp(<:from:>,cname,<::>);
if from then
begin
  result:=lookuptail(cname,t);
  if result<>0 then alarm("nl",1,cname.lo,<: does not exist:>);
  if t(1)<0 or t(9) shift (-12) extract 12 <>10 then
    alarm("nl",1,"*",3,cname.lo,<: not a contract file:>);
end;
readbfp(<:list:>,list,false);
search:=fpinareas>0;
connectcuri(<:catalog:>);
convert:=readlsfp(pname);
if convert then
begin
result:=lookuptail(pname,pt);
i:=1;
if result>0 or pt(1) <>(-1) shift 23+14 then
  alarm("nl",1,"*",3,<:extractfile printer error :>,
        string pname(increase(i)));
end convert;
if all or from then
begin
  result:=lookuptail(cname,ct);
  if result>0 or ct(9) shift (-12) extract 12<>10 then
  alarm("nl",1,"*",3,string cname(increase(i)),
   if result>0 then <: does not exist:> else <: is not a contract file:>);
   if from then
   begin
    for area:=1 step 1 until fpinareas do
    begin
     readinfp(inp,area);
     i:=1;
     if -,extractfile(cname.lo,list,true,false,inp) then
        write(out,"nl",1,"*",2,string inp(increase(i)),
           <: not found:>);
    end;
  end else
   extractfile(cname.lo,list,true,all,cname);
end all or from else
if search or list then
begin
  for area:=1 step 1 until fpinareas do
  begin
    readinfp(inp,area);
    for j:=1,2 do sname(area,j):=inp(j);
  end;
setposition(in,0,0);
lb:=bases(5); ub:=bases(6);
for segm:=segm step -1 until 1 do
begin
  inrec6(in,512);
  for rec:=0 step 34 until 512-34 do
  begin
    if in.rec(1)<>-1 then
    begin
      if lb=in.rec(2) and ub=in.rec(3) then
      begin
        if in.rec(16)shift (-12) extract 12=10 and
           in.rec(1) extract 3>2 then
        begin
          if -,search then
          begin
            write(out,"nl",1,true,13,in.rec.name,true,6,in.rec(8),
              true,12,in.rec.doc);
            outshortcl(out,in.rec(6+7));
          end;
          if list  then extractfile(in.rec.name,list,false,false,inp) else
          for area:=1 step 1 until fpinareas do
          begin
            for j:=1,2 do inp(j):=sname(area,j);
            if -,sfound(area) then sfound(area):=
               extractfile(in.rec.name,list,true,false,inp);
          end;
        end content;
      end user base;
    end entry;
  end record;
end segments;
if search then
begin
  for area:=1 step 1 until fpinareas do
  begin
    for j:=1,2 do inp(j):=sname(area,j);
    j:=1;
    if -,sfound(area) then write(out,"nl",1,"*",2,true,12,
         string inp(increase(j)),<: not found:>);
  end;
end;
end;
end;
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦3ab1dccf7⟧ TextFile

Derivation

TextFile
