{$A+,B+,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) then print('File records filled.'); end else begin oldnumfl:=numfl; fsplit(fn,dstr,nstr,estr); s:=dstr; {rcg11242000 DOSism.} {while (copy(s,length(s),1)='\') do s:=copy(s,1,length(s)-1);} 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) 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; {rcg11242000 DOSism} {conva(ok,atype,bb,systat.temppath+'1\',sqoutsp(fn),sqoutsp(s));} 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 - 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 (imaxdoschrline) then begin dec(i); dec(j); s1:=os1; end; ok:=TRUE; star('Adding '+cstr(j)+' files to archive...'); shel1; {rcg11242000 DOSism} { execbatch(ok,TRUE,'tgtemp1.bat','tgtemp1.$$$', systat.temppath+'1\',s1, systat.filearcinfo[atype].succlevel); } 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; {rcg11242000 DOSism.} {conva(ok,atype,bb,systat.temppath+'1\',fn,s);} 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.