{$A+,B+,D-,E+,F+,I+,L-,N-,O+,R-,S+,V-}

unit archive2;

interface

uses

crt, dos,

{rcg11172000 no overlay under Linux.}

{overlay,}

myio,

archive1, file0, file1, file4, file9, file11,

execbat,

common;

procedure doarccommand(cc:char);

implementation

const

maxdoschrline=127;

procedure doarccommand(cc:char);

const maxfiles=100;

var fl:array[1..maxfiles] of astr;

fn,s,s1,s2,os1:astr;

atype,numfl,rn,pl,savflistopt:integer;

i,j,x:integer;

c:char;

abort,next,done,ok,ok1:boolean;

fnx:boolean; {* whether fn points to file out of Telegard .DIR list *}

fil1,fil2:boolean; {* whether listed/unlisted files in list *}

wenttosysop,delbad,savpause:boolean;

f,f1:ulfrec;

rfpts:real;

fi:file of byte;

v:verbrec;

dstr,nstr,estr:astr;

bb:byte;

c_files,c_oldsiz,c_newsiz,oldsiz,newsiz:longint;

function stripname(i:astr):astr;

var i1:astr; n:integer;

function nextn:integer;

var n:integer;

begin

n:=pos(':',i1);

if (n=0) then n:=pos('\',i1);

if (n=0) then n:=pos('/',i1);

nextn:=n;

end;

begin

i1:=i;

while nextn<>0 do i1:=copy(i1,nextn+1,80);

stripname:=i1;

end;

procedure addfl(fn:astr; b:boolean);

var pl,rn,oldnumfl:integer;

f:ulfrec;

s,dstr,nstr,estr:astr;

dirinfo:searchrec;

begin

if (not b) then begin

oldnumfl:=numfl;

recno(fn,pl,rn);

if (fn<>'') and (pos('.',fn)<>0) and (rn<>0) then

while (fn<>'') and (rn<>0) and (numfl<maxfiles) do begin

seek(ulff,rn); read(ulff,f);

inc(numfl);

fl[numfl]:=f.filename;

nrecno(fn,pl,rn);

end;

if (numfl=oldnumfl) then print('No matching files.');

if (numfl>=maxfiles) then print('File records filled.');

end else begin

oldnumfl:=numfl;

fsplit(fn,dstr,nstr,estr); s:=dstr;

while (copy(s,length(s),1)='\') do s:=copy(s,1,length(s)-1);

{$I-} chdir(s); {$I+}

if ioresult<>0 then print('Path not found.')

else begin

findfirst(fn,AnyFile-Directory-VolumeID,dirinfo);

while (doserror=0) and (numfl<maxfiles) do begin

inc(numfl);

fl[numfl]:=fexpand(dstr+dirinfo.name);

findnext(dirinfo);

end;

if (numfl>=maxfiles) then print('File records filled.');

if (numfl=oldnumfl) then print('No matching files.');

end;

chdir(start_dir);

end;

end;

procedure testfiles(b:integer; fn:astr; delbad:boolean; var abort,next:boolean);

var fi:file of byte;

f:ulfrec;

oldboard,pl,rn,atype:integer;

ok:boolean;

begin

oldboard:=fileboard;

if (fileboard<>b) then changefileboard(b);

if (fileboard=b) then begin

recno(fn,pl,rn); { loads in memuboard }

abort:=FALSE; next:=FALSE;

while (fn<>'') and (rn<>0) and (not abort) and (not hangup) do begin

seek(ulff,rn); read(ulff,f);

fn:=memuboard.dlpath+f.filename;

atype:=arctype(fn);

if (atype<>0) then begin

pbn(abort,next); nl;

star('Testing "'+sqoutsp(fn)+'"');

ok:=TRUE;

if (not exist(fn)) then begin

star('File "'+sqoutsp(fn)+'" doesn''t exist.');

ok:=FALSE;

end else begin

arcintegritytest(ok,atype,sqoutsp(fn));

if (not ok) then begin

star('File "'+sqoutsp(fn)+'" didn''t pass integrity test.');

if (delbad) then begin

deleteff(rn,pl,TRUE);

assign(fi,fn);

{$I-} erase(fi); {$I+}

if (ioresult<>0) then star('Error erasing "'+sqoutsp(fn)+'"!');

end;

end;

end;

end;

nrecno(fn,pl,rn);

wkey(abort,next);

end;

close(ulff);

end;

fileboard:=oldboard;

end;

procedure cmtfiles(b:integer; fn:astr; var abort,next:boolean);

var fi:file of byte;

f:ulfrec;

oldboard,pl,rn,atype:integer;

ok:boolean;

begin

oldboard:=fileboard;

if (fileboard<>b) then changefileboard(b);

if (fileboard=b) then begin

recno(fn,pl,rn); { loads in memuboard }

abort:=FALSE; next:=FALSE;

while (fn<>'') and (rn<>0) and (not abort) and (not hangup) do begin

seek(ulff,rn); read(ulff,f);

fn:=memuboard.dlpath+f.filename;

atype:=arctype(fn);

if (atype<>0) then begin

pbn(abort,next); nl;

star('Commenting "'+sqoutsp(fn)+'"');

ok:=TRUE;

if (not exist(fn)) then begin

star('File "'+sqoutsp(fn)+'" doesn''t exist.');

ok:=FALSE;

end

else arccomment(ok,atype,memuboard.cmttype,sqoutsp(fn));

end;

nrecno(fn,pl,rn);

wkey(abort,next);

end;

close(ulff);

end;

fileboard:=oldboard;

end;

procedure cvtfiles(b:integer; fn:astr; toa:integer;

var c_files,c_oldsiz,c_newsiz:longint;

var abort,next:boolean);

var fi:file of byte;

f:ulfrec;

s:astr;

oldboard,pl,rn,atype:integer;

ok:boolean;

begin

oldboard:=fileboard;

if (fileboard<>b) then changefileboard(b);

if (fileboard=b) then begin

recno(fn,pl,rn); { loads in memuboard }

abort:=FALSE; next:=FALSE;

while (fn<>'') and (rn<>0) and (not abort) and (not hangup) do begin

seek(ulff,rn); read(ulff,f);

fn:=memuboard.dlpath+f.filename;

atype:=arctype(fn);

if (atype<>0) and (atype<>toa) then begin

pbn(abort,next); nl;

star('Converting "'+sqoutsp(fn)+'"');

ok:=FALSE;

if (not exist(fn)) then

star('File "'+sqoutsp(fn)+'" doesn''t exist.')

else begin

ok:=TRUE;

s:=copy(fn,1,pos('.',fn))+systat.filearcinfo[toa].ext;

conva(ok,atype,bb,systat.temppath+'1\',sqoutsp(fn),sqoutsp(s));

if (ok) then begin

assign(fi,sqoutsp(fn));

{$I-} reset(fi); {$I+}

ok:=(ioresult=0);

if (ok) then begin

oldsiz:=trunc(filesize(fi));

close(fi);

end else

star('Unable to access "'+sqoutsp(fn)+'"');

if (ok) then

if (not exist(sqoutsp(s))) then begin

star('Unable to access "'+sqoutsp(s)+'"');

sysoplog('Unable to access "'+sqoutsp(s)+'"');

ok:=FALSE;

end;

end;

if (ok) then begin

f.filename:=align(stripname(sqoutsp(s)));

seek(ulff,rn); write(ulff,f);

{$I-} erase(fi); {$I+}

if (ioresult<>0) then begin

star('Unable to erase "'+sqoutsp(fn)+'"');

sysoplog('Unable to erase "'+sqoutsp(fn)+'"');

end;

assign(fi,sqoutsp(s));

{$I-} reset(fi); {$I+}

ok:=(ioresult=0);

if (not ok) then begin

star('Unable to access "'+sqoutsp(s)+'"');

sysoplog('Unable to access "'+sqoutsp(s)+'"');

end else begin

newsiz:=trunc(filesize(fi));

f.blocks:=trunc((filesize(fi)+127.0)/128.0);

close(fi);

seek(ulff,rn); write(ulff,f);

end;

if (ok) then begin

inc(c_oldsiz,oldsiz);

inc(c_newsiz,newsiz);

inc(c_files);

star('Old total space took up : '+cstrl(oldsiz)+' bytes');

star('New total space taken up : '+cstrl(newsiz)+' bytes');

if (oldsiz-newsiz>0) then

star('Space saved : '+cstrl(oldsiz-newsiz)+' bytes')

else

star('Space wasted : '+cstrl(newsiz-oldsiz)+' bytes');

end;

end else begin

sysoplog('Unable to convert "'+sqoutsp(fn)+'"');

star('Unable to convert "'+sqoutsp(fn)+'"');

end;

end;

end;

nrecno(fn,pl,rn);

wkey(abort,next);

end;

close(ulff);

end;

fileboard:=oldboard;

end;

begin

savpause:=(pause in thisuser.ac);

if (savpause) then thisuser.ac:=thisuser.ac-[pause];

savflistopt:=thisuser.flistopt; thisuser.flistopt:=0;

numfl:=0;

fiscan(pl); { loads in memuboard }

case cc of

'A':begin

nl;

print('Add file(s) to archive (up to '+cstr(maxfiles)+') -');

nl;

print('Archive filename: ');

prt(':'); mpl(78); input(fn,78);

if (fn<>'') then begin

if (pos('.',fn)=0) and (memuboard.arctype<>0) then

fn:=fn+'.'+systat.filearcinfo[memuboard.arctype].ext;

fnx:=isul(fn);

if (not fnx) then fn:=memuboard.dlpath+fn;

fn:=fexpand(fn); atype:=arctype(fn);

if (atype=0) then begin

print('Archive format not supported.');

listarctypes;

end else begin

done:=FALSE; c:='A';

repeat

if (c='A') then

repeat

nl;

print('Add files to list - <CR> to end');

prt(cstr(numfl)+':'); mpl(70); input(s,70);

if s<>'' then begin

if pos('.',s)=0 then s:=s+'*.*';

addfl(s,isul(s));

end;

until (s='') or (numfl>=maxfiles) or (hangup);

nl;

prt('Add files to list (?=help) : '); onek(c,'QADLR?');

nl;

case c of

'?':begin

lcmds(19,3,'Add more to list','Do it!');

lcmds(19,3,'List files in list','Remove files from list');

lcmds(19,3,'Quit','');

end;

'D':begin

i:=0;

repeat

inc(i); j:=1;

s2:=sqoutsp(fl[i]);

if not isul(s2) then

s2:=memuboard.dlpath+s2;

s1:=arcmci(systat.filearcinfo[atype].arcline,fn,s2);

os1:=s1;

while (length(s1)<=maxdoschrline) and (i<numfl) do begin

inc(i); inc(j);

s2:=sqoutsp(fl[i]);

if (not isul(s2)) then

s2:=memuboard.dlpath+s2;

os1:=s1;

s1:=s1+' '+s2;

end;

if (length(s1)>maxdoschrline) then begin

dec(i); dec(j);

s1:=os1;

end;

ok:=TRUE;

star('Adding '+cstr(j)+' files to archive...');

shel1;

execbatch(ok,TRUE,'tgtemp1.bat','tgtemp1.$$$',

systat.temppath+'1\',s1,

systat.filearcinfo[atype].succlevel);

shel2;

if (not ok) then begin

star('Errors in adding files');

ok:=pynq('Continue anyway? ');

if (hangup) then ok:=FALSE;

end;

until (i>=numfl) or (not ok);

arccomment(ok,atype,memuboard.cmttype,fn);

nl;

if (not fnx) then begin

s2:=stripname(fn);

recno(s2,pl,rn);

if (rn<>0) then

sprint(#3#5+'NOTE: File already exists in listing!');

if pynq('Add archive to listing? ') then begin

assign(fi,fn);

{$I-} reset(fi); {$I+}

if ioresult=0 then begin

f.blocks:=trunc((filesize(fi)+127.0)/128.0);

close(fi);

end;

f.filename:=s2;

ok1:=TRUE;

if pynq('Use stats of file in directory? ') then begin

repeat

nl;

prt('Enter filename: '); mpl(12); input(s2,12);

recno(s2,pl,rn);

if rn=0 then print('File not found!');

if s2='' then print('Aborted!');

until (rn<>0) or (s2='') or (hangup);

if s2<>'' then begin

seek(ulff,rn); read(ulff,f1);

with f do begin

description:=f1.description;

vpointer:=f1.vpointer;

nacc:=f1.nacc;

ft:=f1.ft;

owner:=f1.owner;

stowner:=f1.stowner;

date:=f1.date;

daten:=f1.daten;

end;

f1.vpointer:=-1;

seek(ulff,rn); write(ulff,f1);

end else

ok1:=FALSE;

end else

ok1:=FALSE;

if (not ok1) then begin

wenttosysop:=FALSE;

dodescrs(f,v,pl,wenttosysop);

f.nacc:=0;

f.ft:=255;

f.owner:=usernum;

f.stowner:=allcaps(thisuser.name);

f.date:=date;

f.daten:=daynum(date);

end;

f.filestat:=[];

if (not fso) and (not systat.validateallfiles) then

f.filestat:=f.filestat+[notval];

if (not systat.fileptratio) then f.filepoints:=0

else begin

rfpts:=(f.blocks/8)/systat.fileptcompbasesize;

f.filepoints:=round(rfpts);

end;

if (rn=0) then newff(f,v) else writefv(rn,f,v);

end;

end;

if pynq('Delete original files? ') then

for i:=1 to numfl do begin

s2:=sqoutsp(fl[i]);

if not isul(fl[i]) then begin

recno(s2,pl,rn);

if rn<>0 then deleteff(rn,pl,TRUE);

s2:=memuboard.dlpath+s2;

end;

assign(fi,s2);

{$I-} erase(fi); {$I+}

if (ioresult<>0) then

print('"'+s2+'": Could not delete');

end;

if ok then done:=TRUE;

end;

'L':if (numfl=0) then print('No files in list!')

else begin

abort:=FALSE; next:=FALSE;

s:=''; j:=0;

i:=0;

repeat

inc(i);

if isul(fl[i]) then s:=s+#3#3 else s:=s+#3#1;

s:=s+align(stripname(fl[i]));

inc(j);

if j<5 then s:=s+' '

else begin

printacr(s,abort,next);

s:=''; j:=0;

end;

until (i=numfl) or (abort) or (hangup);

if (j in [1..4]) and (not abort) then

printacr(s,abort,next);

end;

'R':begin

prt('Remove filename: '); mpl(12); input(s,12);

i:=0;

repeat

inc(i);

if align(stripname(fl[i]))=align(s) then begin

s1:=sqoutsp(fl[i]); sprompt(#3#3+s1);

if pynq(' Remove it? ') then begin

for j:=i to numfl-1 do fl[j]:=fl[j+1];

dec(numfl); dec(i);

end;

end;

until (i>=numfl);

end;

'Q':done:=TRUE;

end;

until (done) or (hangup);

end;

end;

end;

'C':begin

nl;

print('Convert archive formats -');

nl;

print('Filespec:');

prt(':'); mpl(78); input(fn,78);

c_files:=0; c_oldsiz:=0; c_newsiz:=0;

if (fn<>'') then begin

nl;

abort:=FALSE; next:=FALSE;

repeat

prt('Archive type to use? (?=List) : '); input(s,3);

if (s='?') then begin nl; listarctypes; nl; end;

until (s<>'?');

if (value(s)<>0) then bb:=value(s)

else bb:=arctype(s+'FILENAME.'+s);

if (bb<>0) then begin

sysoplog('Conversion process began at '+date+' '+time+'.');

if (isul(fn)) then begin

fsplit(fn,dstr,nstr,estr); s:=dstr;

findfirst(fn,AnyFile-Directory-VolumeID,dirinfo);

abort:=FALSE; next:=FALSE;

while (doserror=0) and (not abort) and (not hangup) do begin

fn:=fexpand(sqoutsp(dstr+dirinfo.name));

atype:=arctype(fn);

if (atype<>0) and (atype<>bb) then begin

star('Converting "'+fn+'"');

ok:=TRUE;

s:=copy(fn,1,pos('.',s))+systat.filearcinfo[bb].ext;

conva(ok,atype,bb,systat.temppath+'1\',fn,s);

if (ok) then begin

assign(fi,sqoutsp(fn));

{$I-} reset(fi); {$I+}

ok:=(ioresult=0);

if (ok) then begin

oldsiz:=trunc(filesize(fi));

close(fi);

end else

star('Unable to access "'+sqoutsp(fn)+'"');

if (ok) then

if (not exist(sqoutsp(s))) then begin

star('Unable to access "'+sqoutsp(s)+'"');

sysoplog('Unable to access "'+sqoutsp(s)+'"');

ok:=FALSE;

end;

end;

if (ok) then begin

{$I-} erase(fi); {$I+}

if (ioresult<>0) then

star('Unable to erase "'+sqoutsp(fn)+'"');

assign(fi,sqoutsp(s));

{$I-} reset(fi); {$I+}

ok:=(ioresult=0);

if (ok) then begin

newsiz:=trunc(filesize(fi));

close(fi);

end else

star('Unable to access "'+sqoutsp(s)+'"');

if (ok) then begin

inc(c_oldsiz,oldsiz);

inc(c_newsiz,newsiz);

inc(c_files);

star('Old total space took up : '+cstrl(oldsiz)+' bytes');

star('New total space taken up : '+cstrl(newsiz)+' bytes');

if (oldsiz-newsiz>0) then

star('Space saved : '+cstrl(oldsiz-newsiz)+' bytes')

else

star('Space wasted : '+cstrl(newsiz-oldsiz)+' bytes');

end;

end else begin

sysoplog('Unable to convert "'+sqoutsp(fn)+'"');

star('Unable to convert "'+sqoutsp(fn)+'"');

end;

end;

findnext(dirinfo);

wkey(abort,next);

end;

{ if (abort) then sprint('@M'+#3#7+'Conversion aborted.');}

end else begin

ok1:=pynq('Search all directories? ');

nl;

if (ok1) then begin

i:=0; abort:=FALSE; next:=FALSE;

while (not abort) and (i<=maxulb) and (not hangup) do begin

if (fbaseac(i)) then

cvtfiles(i,fn,bb,c_files,c_oldsiz,c_newsiz,abort,next);

inc(i);

wkey(abort,next);

if (next) then abort:=FALSE;

end;

end else

cvtfiles(fileboard,fn,bb,c_files,c_oldsiz,c_newsiz,

abort,next);

reset(ulff);

end;

sysoplog('Conversion process ended at '+date+' '+time+'.');

nl;

nl;

star('Total archives converted : '+cstr(c_files));

star('Old total space took up : '+cstrl(c_oldsiz)+' bytes');

star('New total space taken up : '+cstrl(c_newsiz)+' bytes');

if (c_oldsiz-c_newsiz>0) then

star('Space saved : '+cstrl(c_oldsiz-c_newsiz)+' bytes')

else

star('Space wasted : '+cstrl(c_newsiz-c_oldsiz)+' bytes');

sysoplog('Converted '+cstr(c_files)+' archives; old size='+

cstrl(c_oldsiz)+' bytes, new size='+cstrl(c_newsiz)+' bytes');

end;

end;

end;

'M':begin

nl;

print('Comment field update -');

nl;

print('Filespec:');

prt(':'); mpl(78); input(fn,78);

if (fn<>'') then begin

nl;

abort:=FALSE; next:=FALSE;

if (isul(fn)) then begin

prt('Comment type to use? (1-3,0=None) [1] : ');

ini(bb);

if (badini) then bb:=1;

if (bb<0) or (bb>3) then bb:=1;

fsplit(fn,dstr,nstr,estr); s:=dstr;

findfirst(fn,AnyFile-Directory-VolumeID,dirinfo);

abort:=FALSE; next:=FALSE;

while (doserror=0) and (not abort) and (not hangup) do begin

fn:=fexpand(sqoutsp(dstr+dirinfo.name));

atype:=arctype(fn);

if (atype<>0) then begin

star('Commenting "'+fn+'"');

ok:=TRUE;

arccomment(ok,atype,bb,fn);

end;

findnext(dirinfo);

wkey(abort,next);

end;

{ if (abort) then sprint('@M'+#3#7+'Comment update aborted.');}

end else begin

ok1:=pynq('Search all directories? ');

nl;

if (ok1) then begin

i:=0; abort:=FALSE; next:=FALSE;

while (not abort) and (i<=maxulb) and (not hangup) do begin

if (fbaseac(i)) then cmtfiles(i,fn,abort,next);

inc(i);

wkey(abort,next);

if (next) then abort:=FALSE;

end;

end else

cmtfiles(fileboard,fn,abort,next);

reset(ulff);

end;

end;

end;

'T':begin

nl;

print('File integrity testing -');

nl;

print('Filespec:');

prt(':'); mpl(78); input(fn,78);

if (fn<>'') then begin

nl;

delbad:=pynq('Delete files that don''t pass the test? ');

nl;

abort:=FALSE; next:=FALSE;

if (isul(fn)) then begin

fsplit(fn,dstr,nstr,estr); s:=dstr;

findfirst(fn,AnyFile-Directory-VolumeID,dirinfo);

abort:=FALSE; next:=FALSE;

while (doserror=0) and (not abort) and (not hangup) do begin

fn:=fexpand(sqoutsp(dstr+dirinfo.name));

atype:=arctype(fn);

if (atype<>0) then begin

star('Testing "'+fn+'"');

ok:=TRUE;

arcintegritytest(ok,atype,fn);

if (not ok) then begin

star('File "'+fn+'" didn''t pass integrity test.');

if (delbad) then begin

assign(fi,fn);

{$I-} erase(fi); {$I+}

if (ioresult<>0) then star('Error erasing "'+fn+'"!');

end;

end;

end;

findnext(dirinfo);

wkey(abort,next);

end;

{ if (abort) then sprint('@M'+#3#7+'Integrity testing aborted.');}

end else begin

ok1:=pynq('Search all directories? ');

nl;

if (ok1) then begin

i:=0; abort:=FALSE; next:=FALSE;

while (not abort) and (i<=maxulb) and (not hangup) do begin

if (fbaseac(i)) then testfiles(i,fn,delbad,abort,next);

inc(i);

wkey(abort,next);

if (next) then abort:=FALSE;

end;

end else

testfiles(fileboard,fn,delbad,abort,next);

reset(ulff);

end;

end;

end;

'X':begin {* extract *}

end;

end;

close(ulff);

thisuser.flistopt:=savflistopt;

if (savpause) then thisuser.ac:=thisuser.ac+[pause];

end;

end.