home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
f
/
faq-s.zip
/
FILEXFER.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-05-04
|
68KB
|
2,379 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,O+ }
{$M 65520,0,4096 }
unit filexfer;
interface
uses crt,dos,overlay,configur,
gentypes,configrt,modem,statret,gensubs,subs1,subs2,windows,
userret,mainr1,mainr2,overret1,protocol,mainmenu,subs3,textret;
procedure udsection;
var cn:byte;
implementation
procedure filemenu;
begin
filemenu;
end;
procedure udsection;
{$I file2}
procedure listfile (n:integer; extended:boolean); forward;
procedure listfiles (extended:boolean); forward;
function capfir(inString:STRING):STRING; forward;
function findprot(rors,prot:char):boolean;
var bonzo:file of protorec; sod:boolean;
begin
sod:=false;
assign(bonzo,bbsdatadir+'PROT'+upcase(rors)+'.CFG');
reset(bonzo);
while not(eof(bonzo)) and not(sod) do
begin
read(bonzo,protrec);
if protrec.letter=upcase(prot) then sod:=true;
end;
findprot:=sod;
prprog:=protrec.progname;
prcomm:=protrec.commfmt;
prdesc:=protrec.desc;
close(bonzo);
end;
procedure xtendedlist;
var num:integer;
ud:udrec;
begin
writestr ('[Enter File Number to List Extended Descrip]: *');
num:=valu(input);
if num>numuds then exit;
if num<1 then exit;
seekudfile (num);
read (udfile,ud);
writeln (^U'═════════════════════════════════════════════════════════════════════════════');
writeln (^S,ud.extdesc);
writeln (^U'═════════════════════════════════════════════════════════════════════════════');
end;
procedure whoup;
procedure toplinewho;
begin
if asciigraphics in urec.config then begin
writeln('┌───┬───────────────┬──────────────────────────────┬────────┬────────────┐');
writeln('│ '^S'#'^R' │ '^S'Filename'^R' │ '^S'Uploaded by'^R' │ '^S'Cost '^R' │ '+
^S'Downloaded'^R' │');
writeln('├───┼───────────────┼──────────────────────────────┼────────┼────────────┤') end else begin
writeln('+---+---------------+------------------------------+--------+------------+');
writeln('| '^S'#'^R' | '^S'Filename'^R' | '^S'Uploaded by'^R' | '^S'Cost '^R' | '+
^S'Downloaded'^R' |');
writeln('|---|---------------|------------------------------|--------|------------|');
end;
end;
procedure botlinewho;
begin
if asciigraphics in urec.config then
writeln(^R'└───┴───────────────┴──────────────────────────────┴────────┴────────────┘') else
writeln(^R'+---+---------------+------------------------------+--------+------------+');
end;
var ud :udrec;
cnt:integer;
begin
toplinewho;
for cnt:=1 to numuds do
begin
seekudfile (cnt);
read (udfile,ud);
if asciigraphics in urec.config then begin
write (^R'│ '^S,strr(cnt));
spacelen(2-length(strr(cnt)));
write (^R'│ '^S,ud.filename);
spacelen(14-length(ud.filename));
write (^R'│ '^S,ud.sentby);
spacelen(29-length(ud.sentby));
write (^R'│ '^S,ud.points);
spacelen(7-length(strr(ud.points)));
write (^R'│ '^S,ud.downloaded);
spacelen(11-length(strr(ud.downloaded)));
writeln (^R'│');
end else begin
write (^R'| '^S,strr(cnt));
spacelen(2-length(strr(cnt)));
write (^R'| '^S,ud.filename);
spacelen(14-length(ud.filename));
write (^R'| '^S,ud.sentby);
spacelen(29-length(ud.sentby));
write (^R'| '^S,ud.points);
spacelen(7-length(strr(ud.points)));
write (^R'| '^S,ud.downloaded);
spacelen(11-length(strr(ud.downloaded)));
writeln (^R'|');
end;
end;
botlinewho;
end;
function searchforfile (f:sstr):integer;
var ud:udrec;
cnt:integer;
begin
for cnt:=1 to numuds do begin
seekudfile (cnt);
read (udfile,ud);
if match(ud.filename,f) then begin
searchforfile:=cnt;
exit
end
end;
searchforfile:=0
end;
function getfilenum (t:mstr):integer;
var n,s:integer;
begin
getfilenum:=0;
if length(input)>1 then input:=copy(input,2,255) else
repeat
writestr ('File Name/Number to '+t+' [?/List]:');
if hungupon or (length(input)=0) then exit;
if input='?' then begin
listfiles (false);
input:=''
end
until input<>'';
val (input,n,s);
if s<>0 then begin
n:=searchforfile(input);
if n=0 then begin
writeln ('File not found.');
exit
end
end;
if (n<1) or (n>numuds)
then writeln ('File number out of range!')
else getfilenum:=n
end;
const beenaborted:boolean=false;
function aborted:boolean;
begin
if beenaborted then begin
aborted:=true;
exit
end;
aborted:=xpressed or hungupon;
if xpressed then begin
beenaborted:=true;
writeln (^B'File newscan aborted!')
end
end;
procedure getstring (t:lstr; var m);
var q:lstr absolute m;
mm:lstr;
begin
writeln ('Old ',t,': ',q);
writestr ('Enter new '+t+' [CR/no change]: &');
mm:=input;
if length(mm)<>0 then q:=mm;
writeln
end;
procedure getstringgg (t:lstr; var m);
var q:lstr absolute m;
mm:lstr;
begin
writeln ('Old ',t,': ',q);
writestr ('Enter new '+t+' [CR/no change, "!" for null]:');
mm:=input;
if length(mm)<>0 then q:=mm;
if mm='!' then q:='';
writeln
end;
procedure getint (t:lstr; var i:integer);
var s:sstr;
begin
s:=strr(i);
getstring (t,s);
i:=valu(s)
end;
procedure getboo (t:lstr; var b:boolean);
var s:sstr;
begin
s:=yesno (b);
getstring (t,s);
b:=upcase(s[1])='Y'
end;
procedure removefile (n:integer);
var cnt:integer;
begin
for cnt:=n to numuds-1 do begin
seekudfile (cnt+1);
read (udfile,ud);
seekudfile (cnt);
write (udfile,ud)
end;
seekudfile (numuds);
truncate (udfile)
end;
procedure displayfile (var ffinfo:searchrec);
var a:integer;
begin
a:=ffinfo.attr;
if (a and 8)=8 then exit;
tab (^S+ffinfo.name,13);
if (a and 16)=16
then write (^S'Directory')
else write (^S,ffinfo.size);
if (a and 1)=1 then write (^P' [',^S,'read-only',^P,']'^R);
if (a and 2)=2 then write (^P' [',^S,'hidden',^P,']'^R);
if (a and 4)=4 then write (^P' [',^S,'system',^P,']'^R);
writeln
end;
function defaultdrive:byte;
var r:registers;
begin
r.ah:=$19;
intr ($21,r);
defaultdrive:=r.al+1
end;
procedure directory;
var r:registers;
ffinfo:searchrec;
tpath:anystr;
b:byte;
cnt:integer;
begin
{ getdir (defaultdrive,tpath); }
tpath:=area.xmodemdir;
if tpath[length(tpath)]<>'\' then tpath:=tpath+'\';
tpath:=tpath+'*.*';
writestr ('Path/Wildcard [CR/'+tpath+']:');
writeln (^M);
if length(input)<>0 then tpath:=input;
writelog (16,10,tpath);
findfirst (chr(defaultdrive+64)+':\*.*',8,ffinfo);
if doserror<>0
then writeln ('No volume label'^M)
else writeln ('Volume label: ',ffinfo.name,^M);
findfirst (tpath,$17,ffinfo);
if doserror<>0 then writeln ('No files found.') else begin
cnt:=0;
while doserror=0 do begin
cnt:=cnt+1;
if not break then displayfile (ffinfo);
findnext (ffinfo)
end;
writeln (^B^M'Total Files: ',cnt)
end;
write ('Free Disk Space: ');
writefreespace (tpath)
end;
procedure listarchive (int:integer);
var n:integer;
ud:udrec;
f:file of byte;
fname:lstr;
b,p:byte;
sg:boolean;
size:longint;
sussuh:sstr;
ock:char;
function getsize:longint;
var x:longint;
b:array [1..4] of byte absolute x;
cnt:integer;
begin
for cnt:=1 to 4 do read (f,b[cnt]);
getsize:=x
end;
procedure badarchive;
begin
writeln (^M'That file isn''t an archive!');
close (f);
exit
end;
begin
if nofiles then exit;
if int<1 then begin
n:=getfilenum('List');
if n=0 then exit;
end else n:=int;
seekudfile (n);
read (udfile,ud);
fname:=getfname(ud.path,ud.filename);
assign (f,fname);
reset (f);
iocode:=ioresult;
if iocode<>0 then begin
fileerror ('LISTARCHIVE',fname);
exit
end;
if filesize(f)<32 then begin
badarchive;
exit
end;
p:=pos ('.',ud.filename);
sussuh:=copy (ud.filename,p+1,3);
sussuh:=upstring(sussuh);
close (f);
writehdr ('ARC/PAK/ZIP File List');
writeln;
write (^R'Archive Type: '^S);
if sussuh='ARC' then writeln ('PKARC/PKPAK') else
if sussuh='PAK' then writeln ('PAK') else
if sussuh='ZIP' then writeln ('PKZIP') else
if sussuh='LZH' then writeln ('LHARC') else
if (sussuh<>'ARC') and (sussuh<>'PAK') and (sussuh<>'ZIP') and
(sussuh<>'LZH') then begin
writeln ('Unknown!');
writeln;
writeln (^R'This file does not seem to be an archive of the ARC, PAK, or ZIP type.');
writestr ('Would you care to manually select the archive type [y/n]: *');
if yes then repeat
writeln (^R'[1]: PKARC/PKPAK');
writeln (^R'[2]: PAK');
writeln (^R'[3]: PKZIP');
writeln (^R'[4]: LHARC');
writeln (^R'[Q]: Quit');
writeln;
writestr ('Selection:');
ock:=upcase(input[1]);
if ock='1' then sussuh:='ARC' else
if ock='2' then sussuh:='PAK' else
if ock='3' then sussuh:='ZIP' else
if ock='4' then sussuh:='LZH';
until ock in ['Q','1','2','3'];
end;
writeln;
writeln ('Please hold.');
writeln;
if sussuh='ARC' then arcview (fname) else
if sussuh='PAK' then pakview (fname) else
if sussuh='ZIP' then zipview (fname) else
if sussuh='LZH' then lharcview (fname);
end;
procedure requestfile;
var t:text;
me:message;
m:mailrec;
begin
if hungupon then exit;
writestr (^M^J+'Filename to Request: *');
if length(input)=0 then exit;
input:=upstring(input);
writeln (^M^J+'Enter a Message regarding the File Request:');
delay (1000);
titlestr:='File Request: '+input;
sendstr:='Sysop';
m.line:=editor (me,false,'File Request: '+input);
sendstr:='';
if m.line<0 then exit;
m.anon:=false;
m.title:=titlestr;
m.sentby:=unam;
m.when:=now;
addfeedback (m);
end;
procedure download (autoselect:integer; checktheok:boolean);
var totaltime:sstr;
num,fsize,actualsize,mins,secs,i,b,dsziactualsize,realtime:integer;
ud:udrec;
fname,faqrulez,protop,byteblok:lstr;
ymodem,okselect:boolean;
f:file;
m:sstr;
extrnproto:char; resp:char; byewhendone:boolean;
n:text;
ok:boolean;
begin
if not allowxfer then exit;
if nofiles then exit;
if percent (urec.uploads,urec.downloads)<udratio then begin
writeln ('Your Upload/Download ratio is too low! Upload some files!');
exit;
end;
if useqr then begin
calcqr;
if (qr<qrlimit) and (ulvl<qrexempt) then begin
writeln ('Your Quality Rating is '^S+strr(qr)+^R'.');
writeln ('That exceeds the limit of '^S+strr(qrlimit)+^R'!');
writeln ('You must get a better QR before you can download.');
exit;
end;
end;
if checktheok then begin
if (area.download=false) then begin
writeln;
writeln ('Sorry, downloading is not allowed from this area!');
writeln;
exit;
end;
end;
if autoselect=0
then num:=getfilenum('download')
else num:=autoselect;
if num=0 then exit;
writeln;
seekudfile (num);
read (udfile,ud);
ok:=checkok (ud);
if not ok then exit;
ymodem:=false;
extrnproto:=' ';
listprotocols(0);
if hungupon then exit;
writestr(^R+'Protocol '^P'['^R'CR'^P'/'+^S+urec.defproto+^S' Q'^R'uit'^P']'^R' &');
if hungupon then exit;
if length(input)=0 then extrnproto:=urec.defproto else extrnproto:=upcase(input[1]);
if upstring (input)='Q' then exit;
okselect:=findprot('S',extrnproto);
if not okselect then exit;
fname:=getfname(ud.path,ud.filename);
assign (f,fname);
reset (f);
iocode:=ioresult;
if iocode<>0 then
begin
writeln; writeln('ERROR: Unable to locate file ',fname);
fileerror ('DOWNLOAD',fname);
exit
end;
fsize:=filesize(f);
actualsize:=fsize;
close (f);
totaltime:=minstr(fsize);
mins:=valu(copy(totaltime,1,pos(':',totaltime)-1));
secs:=valu(copy(totaltime,pos(':',totaltime)+1,2));
realtime:=mins;
if secs<>0 then realtime:=mins+(secs div 60);
if mins=0 then mins:=1;
if ((mins>timeleft) and (not sponsoron)) then begin
writestr ('Sorry, you don''t have enough time left!');
mins:=-5;
exit
end;
if (mins-5>timetillevent) then begin
writestr ('Sorry, the timed event is coming up too soon!');
mins:=-5;
exit
end;
writeln;
askaboutbye;
if answer='A' then exit;
wipedszlog;
if (ansigraphics in urec.config) then write (#27+'[2J') else write (^L);
if asciigraphics in urec.config then begin
writeln (^B);
writeln (^R'┌─────────────────────────────────────────┐');
write (^R'│ '^S'Filename: '^S);
tab (ud.filename,24);
writeln (^R'│');
write (^R'│ '^S'Uploaded by: '^S);
tab (ud.sentby,24);
writeln (^R'│');
write (^R'│ '^S'Downloaded: '^S);
faqrulez:='';
faqrulez:=strr(ud.downloaded)+' time';
if (ud.downloaded<>1) then faqrulez:=faqrulez+'s';
tab (faqrulez,24);
writeln (^R'│');
if ymodem then fsize:=(fsize+7) div 8;
if fsize=0 then fsize:=1;
write (^R'│ '^S'Bytes to send: '^S);
byteblok:=^S+strlong(ud.filesize)+^R+' bytes';
tab (byteblok,26);
writeln (^R'│');
write (^R'│ '^S'Transfer Time: '^S);
tab (totaltime,24);
writeln (^R'│');
writeln (^R'├─────────────────────────────────────────┤');
writeln (^R'│ Hit ['^S'Ctrl X'^R'] a few times to Abort │');
writeln (^R'└─────────────────────────────────────────┘');
writeln;
end else begin
writeln (^B);
writeln (^R'+-----------------------------------------+');
write (^R'| '^S'Filename: '^S);
tab (ud.filename,24);
writeln (^R'|');
write (^R'| '^S'Uploaded by: '^S);
tab (ud.sentby,24);
writeln (^R'|');
write (^R'| '^S'Downloaded: '^S);
faqrulez:='';
faqrulez:=strr(ud.downloaded)+' time';
if (ud.downloaded<>1) then faqrulez:=faqrulez+'s';
tab (faqrulez,24);
writeln (^R'|');
if ymodem then fsize:=(fsize+7) div 8;
if fsize=0 then fsize:=1;
write (^R'| '^S'Bytes to send: '^S);
byteblok:=^S+strlong(ud.filesize)+^R+' bytes';
tab (byteblok,26);
writeln (^R'|');
write (^R'| '^S'Transfer Time: '^S);
tab (totaltime,24);
writeln (^R'|');
writeln (^R'|-----------------------------------------|');
writeln (^R'| Hit ['^S'Ctrl X'^R'] a few times to Abort |');
writeln (^R'+-----------------------------------------+');
writeln;
end;
b:=doext ('S',extrnproto,ud.path,ud.filename,baudrate,usecom);
if b<>0 then b:=2;
modeminlock:=false;
beepbeep (b);
xtype:=checkdszlog (ud.filename);
if (upcase(xtype)='Q') then
begin
possiblelzm (ud.points);
b:=2;
end;
if (b=0) or (b=1) then begin
writelog (15,1,fname);
writeln;
clrscr;
ud.downloaded:=ud.downloaded+1;
urec.downloads:=urec.downloads+1;
urec.udpoints:=urec.udpoints-ud.points;
urec.downk:=urec.downk+ud.filesize;
seekudfile (num);
write (udfile,ud);
showhisstats;
writeurec;
if answer='H' then laterdays
end;
end;
procedure typefile;
var num:integer;
ud:udrec;
fname:lstr;
f:text;
k:char;
begin
if nofiles then exit;
num:=getfilenum('type');
if num=0 then exit;
writeln;
seekudfile (num);
read (udfile,ud);
if (not sponsoron) and (ud.points>urec.udpoints) then begin
writeln ('Sorry, that file requires ',ud.points,' points.');
exit
end;
if (ud.newfile) and (not sponsoron) then begin
writeln ('Sorry, that is a new file and must be validated.');
exit
end;
if (ud.specialfile) and (not sponsoron) then begin
writeln ('Sorry, downloading that file requires special permission.');
exit
end;
if (length(ud.dlpw)>0) and (filepw) then begin
writeln;
writestr ('File Password:');
if length(input)=0 then exit else
if not match(input,ud.dlpw) then exit;
end;
if tempsysop then begin
ulvl:=regularlevel;
tempsysop:=false;
writeurec;
bottomline
end;
fname:=getfname(ud.path,ud.filename);
assign (f,fname);
reset (f);
iocode:=ioresult;
if iocode<>0 then
begin
fileerror ('TYPEFILE',fname);
exit
end;
writeln (^B^M'Filename: '^S,ud.filename);
writeln ('Uploaded by: '^S,ud.sentby);
if (ud.points>0) and (not sponsoron) then begin
write (^B^M'NOTE: When the transfer begins, you ',
^M' will be charged ',ud.points,' point');
if ud.points<>1 then write ('s');
writeln ('!')
end;
writeln (^B^M'Press any key to begin the transfer,',
^M'or [Ctrl-X] to abort.'^M);
k:=waitforchar;
if (k=^X) or (upcase(k)='X') then begin
textclose (f);
writeln (^B^M'Aborted!');
exit
end;
while not (eof(f) or break) do begin
read (f,k);
if k=^M then writeln else if k<>^J then write (k)
end;
textclose (f);
if (ud.points>0) and (not sponsoron) then begin
urec.udpoints:=urec.udpoints-ud.points;
writeln (^B'You now have ',
numthings (urec.udpoints,'point','points'),'.')
end;
writeurec
end;
procedure processfile(fn,todir:lstr);
var fn1:lstr; util:integer;
begin
write(^P' - Processing. ');
util:=pos('.',fn);
if util=0 then fn1:=fn else fn1:=copy(fn,1,util-1);
if exist ('PROCESS.BAT') then
exec(getenv('COMSPEC'),' /C PROCESS.BAT '+fn+' '+todir+' '+fn1);
end;
procedure upload;
var ud:udrec;
ok,crcmode,ymodem,extdone,cool:boolean;
i,b,granted,ultime:integer;
dah:real;
fn,protop:lstr;
extrnproto:char;
e1,e2,e3:lstr;
f:file;
time:string;
var process:boolean; dir1:lstr;
procedure acceptfile(fname:lstr);
var process:boolean; dir1,extend:lstr; f1,f2:text; fn1,fn2:mstr; fn3:lstr;
begin
process:=true;
dir1:=copy(area.xmodemdir,1,length(area.xmodemdir)-1);
extend:=copy(fname,length(fname)-3,4);
extend:=upstring(extend);
write(^R'Received File: '^S+fname);
fn1:=faqdir+'PROCNAME.'+strr(conn);
fn2:=faqdir+'PROCMSG.'+strr(conn);
assign(f1,fn1); assign(f2,fn2);
if exist(fn1) then erase(f1);
if exist(fn2) then erase(f2);
if process then processfile(fname,extend);
if exist(fn1) then begin
reset(f1);
readln(f1,fn3);
close(f1);
ud.filename:=fn3;
fname:=fn3;
end;
if exist(fn2) then begin
reset(f2);
readln(f2,fn3);
close(f2);
write(^S' '+fn3+'. ');
end;
if not exist(xferdir+fname) then exit;
writeln(^P'Posting.');
exec(getenv('COMSPEC'),' /C copy '+xferdir+fname+' '+dir1+' >nul');
exec(getenv('COMSPEC'),' /C del '+xferdir+fname+' >nul');
end;
procedure getextras;
var r:registers; ffinfo:searchrec;
tpath:anystr; b:byte; cnt:integer; mm:text; fname:lstr;
begin
writeln; writeln(^R'Checking Upload Discrepancy.');
writeln;
tpath:=xferdir+'*.*'; cnt:=0;
findfirst (tpath,$17,ffinfo);
if doserror<>0 then begin
writeln('File not received. [Upload Aborted]');
exit;
end;
if ffinfo.name[1]<>'.' then begin
fname:=ffinfo.name;
if answer<>'H' then begin
writeln;
writestr(^R'Describe file '^S+ffinfo.name+^R+': *');
ud.programname:=input;
writestr(^R'Disk Number: *');
ud.disknum:=valu(input);
if ud.disknum<1 then ud.disknum:=1;
writestr(^R'Total # of disks: *');
ud.totaldisk:=valu(input);
if ud.totaldisk<1 then ud.totaldisk:=1;
writestr(^R'Download P/W for file: *');
ud.dlpw:=input;
end else begin
ud.programname:='Upload with no description.';
ud.disknum:=1;
ud.totaldisk:=1;
ud.dlpw:='';
ud.private:='';
end;
acceptfile(fname);
end;
end;
var pointv:longint;
pp:integer;
begin
if not allowxfer then exit;
if timetillevent<30 then begin
writestr (
'Sorry, uploads are not allowed within one half hour of the timed event!');
exit
end;
if area.upload=false then begin
writeln;
writeln ('Sorry, uploading is not allowed into this area!');
writeln;
exit;
end;
ok:=false;
write ('Free Disk Space: ');
writefreespace (area.xmodemdir);
writeln;
repeat
writestr ('Upload Filename: *');
if length(input)=0 then exit;
if not validfname(input) then begin
writeln ('Invalid filename!');
exit
end;
ud.filename:=upstring(input);
ud.path:=area.xmodemdir;
fn:=getfname(ud.path,ud.filename);
if hungupon then exit;
if exist(fn) then writeln ('File already exists!') else ok:=true
until ok;
if filepw then begin
buflen:=30;
writestr ('File Password [CR/None]: &');
if length(input)=0 then ud.dlpw:='' else ud.dlpw:=input;
end else
ud.dlpw:='';
writestr ('Private for: &');
if length(input)=0 then ud.private:='' else ud.private:=input;
buflen:=27;
writestr ('Program Description: &');
ud.programname:=input;
buflen:=2;
writestr ('Disk Number: &');
ud.disknum:=valu(input);
if ud.disknum<1 then ud.disknum:=1;
buflen:=2;
writestr ('Total Disks: &');
ud.totaldisk:=valu(input);
if ud.totaldisk<1 then ud.totaldisk:=1;
buflen:=45;
ud.extdesc:=getextdesc;
buflen:=40;
if ups>32765 then ups:=0;
inc(ups);
ud.sentby:=unam;
ud.when:=now;
ud.whenrated:=now;
ud.points:=0;
ud.downloaded:=0;
ud.newfile:=true;
ud.specialfile:=false;
crcmode:=false;
ymodem:=false;
extrnproto:='N';
listprotocols (1);
if hungupon then exit;
writestr(^R+'Protocol '^P'['^R'CR'^P'/'+^S+urec.defproto+^S' Q'^R'uit'^P']'^R' &');
if hungupon then exit;
if length(input)=0 then extrnproto:=urec.defproto else extrnproto:=upcase(input[1]);
if upstring (input)='Q' then exit;
cool:=findprot('R',extrnproto);
if not cool then exit;
askaboutbye;
if answer='A' then exit;
ultime:=timer;
if tempsysop then begin
ulvl:=regularlevel;
tempsysop:=false;
writeurec;
bottomline
end;
begin
wipedszlog;
b:=doext ('R',extrnproto,xferdir,ud.filename,baudrate,usecom);
modeminlock:=false;
modemoutlock:=false;
beepbeep (b)
end;
xtype:=checkdszlog (ud.filename);
if b>=1 then begin
writeln;
clrscr;
fn:=getfname (xferdir,ud.filename);
if exist (fn) then begin
assign(f,fn);
erase (f);
end;
exit;
end;
if b=0 then begin
writeln;
clrscr;
acceptfile(ud.filename);
getfsize(ud);
{pointv:=pointvalue;
pointv:=pointv*1000;}
if (autovalidate) and (pointvalue>0) then begin
ud.points:=(ud.filesize div pointvalue div 1024);
writeln (^R'Granting '+ud.filename+' '+strr(ud.points)+^R' points.');
end else ud.points:=0;
pp:=ud.points*uploadfactor;
writeln (^R'Granting '^S+ud.sentby+' '+strr(pp)+^R' points.');
ud.newfile:=false;
urec.udpoints:=urec.udpoints+pp;
addfile(ud);
inc(urec.uploads);
urec.upk:=urec.upk+ud.filesize;
newuploads:=newuploads+1;
writeurec;
end;
if (ulpercent>0) and (not aborted) then begin
{ endtime:=timer;
if endtime<starttime then endtime:=endtime+1440;
xfertimecredit:=(endtime-starttime);
writeln;
granted:=xfertimecredit;
granted:=granted*(ulpercent div 100);
settimeleft (timeleft+granted);
str (timeleft,time); }
ultime:=timer-ultime;
if ultime<0 then ultime:=ultime+1440;
granted:=ultime*(ulpercent div 100);
writeln (^R'Granting upload time compensation of '^S+strr(granted)+^R' minutes.');
urec.timetoday:=urec.timetoday+granted;
writeurec;
end;
avrcps;
if zipcomment then begin
addcomment (area.xmodemdir,ud.filename);
end;
showhisstats;
if answer='H' then laterdays;
end;
procedure searchfile;
var cnt,cntt,totalcnt:integer;
searchall:boolean;
wildcard:sstr;
a:arearec;
stext:anystr;
procedure searcharea;
var cnt,knt:integer; needbox:boolean;
u:udrec;
begin
knt:=0; needbox:=true;
for cnt:=1 to numuds do begin
seekudfile (cnt);
read (udfile,u);
if wildcardmatch (wildcard,u.filename) then begin
if needbox then begin
writeln;
topfileline;
needbox:=false;
end;
listfile (cnt,false);
inc(knt); inc(totalcnt);
end;
if xpressed then exit
end;
if not needbox then begin
bottomfileline;
writeln(^S+strr(knt)+^P' file(s) found.'^R);
writeln;
end;
end;
procedure totalmatch;
begin
writeln; writeln(^S+strr(totalcnt)+^P+' matches found.');
end;
procedure searchareatext (t:anystr);
var cnt,knt:integer;
u:udrec;
b,needbox:boolean;
begin
needbox:=true; knt:=0;
for cnt:=1 to numuds do begin
b:=false;
seekudfile (cnt);
read (udfile,u);
if pos(upstring(t),upstring(u.filename))>0 then b:=true;
if pos(upstring(t),upstring(u.extdesc))>0 then b:=true;
if pos(upstring(t),upstring(u.programname))>0 then b:=true;
if b then begin
if needbox then begin writeln; topfileline; end;
listfile (cnt,false);
needbox:=false;
inc(knt); inc(totalcnt);
end;
if xpressed then exit;
end;
if not needbox then begin
bottomfileline;
writeln(^S+strr(knt)+^P+' files found.'^R);
writeln;
end;
end;
begin
writeln;
totalcnt:=0;
writestr ('Look in all areas? '^S'[y/n]'^R': *');
searchall:=yes;
writeln;
begin
writestr (^R'Enter '^P'TEXT'^R' to search for:');
writeln;
if length(input)=0 then exit;
stext:=input;
if not searchall then begin
writeln(^P'Looking for "'^S+stext+^P'" in current area.');
searchareatext(stext);
totalmatch;
exit;
end;
for cntt:=1 to numareas do begin
seekafile (cntt);
read (afile,a);
if urec.udlevel>=a.level then begin
setarea (cntt);
writeln;
writeln(^R'Searching for "'^S+stext+^R'" in ['^P,cntt,^R'] '+^S+area.name+^R'.');
searchareatext (stext);
if xpressed then exit;
end;
end;
totalmatch;
end;
end;
procedure addresidentfile (fname:lstr);
var ud:udrec;
pointv:longint;
ccr:lstr;
begin
getpathname (fname,ud.path,ud.filename);
if match(fname,'USERS') then begin
writelog (16,10,unam);
writeln (^G'SECURITY VIOLATION! Paging Sysop.'^M);
exit;
end;
getfsize(ud);
{pointv:=pointvalue;
pointv:=pointv*1000;}
ud.points:=(ud.filesize div pointvalue div 1024);
if ud.filesize=-1 then begin
if not offliney then begin
writeln ('File can''t be opened!');
exit
end;
end;
writestr (^P'File Size: '^S+strlong(ud.filesize)+^P' Point Value ['^S+strr(ud.points)+^P']:');
if length(input)=0 then input:=strr(ud.points);
ud.points:=valu(input);
if ud.points<0 then ud.points:=0;
writestr ('Sent by [CR/'+unam+']: &');
if length(input)=0 then input:=unam;
ud.sentby:=input;
ud.when:=now;
ud.whenrated:=now;
ud.downloaded:=0;
buflen:=27;
writestr ('Program Description: &');
ud.programname:=input;
buflen:=2;
writestr ('Disk Number: &');
ud.disknum:=valu(input);
if ud.disknum<1 then ud.disknum:=1;
buflen:=2;
writestr ('Total Disks: &');
ud.totaldisk:=valu(input);
if ud.totaldisk<1 then ud.totaldisk:=1;
{writestr ('Description: &');
ud.descrip:=input;}
ud.extdesc:=getextdesc;
if filepw then begin
buflen:=30;
writestr ('File Password [CR/None]: &');
if length(input)=0 then ud.dlpw:='' else
ud.dlpw:=input;
end else
ud.dlpw:='';
buflen:=30;
writestr ('Private for: &');
if length(input)=0 then ud.private:='' else ud.private:=input;
writestr ('Special Request only? [Ask]: *');
ud.specialfile:=yes;
ud.newfile:=false;
addfile (ud);
if zipcomment then begin
writestr ('Add Zip Comment? [y/n]: *');
if yes then begin
addcomment (area.xmodemdir,ud.filename);
end;
end;
ups:=ups+1;
urec.uploads:=urec.uploads+1;
if ud.filesize>-1 then
urec.upk:=urec.upk+ud.filesize;
writeurec;
writelog (16,8,fname)
end;
procedure sysopadd;
var fn,fnm,fp:lstr;
begin
if ulvl<sysoplevel then begin
writeln
('Sorry, you may not add resident files without true sysop access!');
exit
end;
writehdr ('Add Resident File');
writestr ('Filename:');
fnm:=upstring(input);
writestr ('Path of File [CR/'+area.xmodemdir+']:');
fp:=upstring(input);
if length(fp)=0 then fp:=area.xmodemdir;
if fp[length(fp)]<>'\' then fp:=fp+'\';
fn:=fp+fnm;
if exist(fn)
then
begin
writestr ('Confirm: '+fn+' [y/n]:');
if yes then addresidentfile (fn)
end
else begin
writeln ('File not found!');
if length(fn)=0 then exit;
writestr ('Add it as? [Offline] [y/n]: *');
if yes then begin
offliney:=true;
addresidentfile (fn);
offliney:=false;
end else exit;
end;
end;
{function findfile (str:string):boolean;
var i:integer;
i2:integer;
b:boolean;
begin
i2:=curarea;
i:=1;
while (numuds>=i) and (b=false) do begin
seekudfile (i); if exist (datadir+'AREA'+strr(i)+'.'+strr(conn)) then begin
read (udfile,ud); if (match(ud.filename,str)) then begin
b:=true; end else b:=false; i:=i+1; end; end;
i:=1; seekudfile (i2); read (udfile,ud);
if b=true then writeln (^S+str+^P': '^R'Already exists!');
end;}
Procedure addmultiplefiles;
Var spath,pathpart:lstr;
dummy:sstr;
f:File;
ffinfo:searchrec;
Begin
If ulvl<sysoplevel Then Begin
writeln (
'Sorry, you may not add resident files without true sysop access!');
exit
End;
writehdr('Add Multiple Files By Wildcard');
writestr('Search path/wildcard:');
If Length(Input)=0 Then exit;
spath:=Input;
If spath[Length(spath)]='\' Then dec(spath[0]);
Assign(f,spath+'\con');
Reset(f);
If IOResult=0 Then Begin
Close(f);
spath:=spath+'\*.*'
End;
getpathname(spath,pathpart,dummy);
findfirst(spath,$17,ffinfo);
If doserror<>0
Then WriteLn('No files found!')
Else
While doserror=0 Do Begin
WriteLn;
displayfile(ffinfo);
writestr('Add this file? [Y/N/X]: *');
If yes
Then addresidentfile(getfname(pathpart,ffinfo.name))
Else If (Length(Input)>0) And (UpCase(Input[1])='X')
Then exit;
findnext(ffinfo)
End
End;
procedure changef;
var n,q:integer;
ud:udrec;
procedure showudrec (var ud:udrec);
var a,b,c:string;
begin
with ud do
writeln(^M^J' Filename: '^S,ud.filename,
^M^J' Path: '^S,ud.path,
^M^J' Size: '^S,ud.filesize,
^M^J' File Cost: '^S,ud.points,
{^M^J' Description: '^S,ud.descrip, }
^M^J' Program Desc: '^S,ud.programname+' '+strr(ud.disknum)+^R'/'^S+
strr(ud.totaldisk),
^M^J' # Downloaded: '^S,ud.downloaded,
^M^J' Unrated: '^S,yesno(ud.newfile),
^M^J' Special Ask: '^S,yesno(ud.specialfile),
^M^J' Sent by: '^S,sentby,
^M^J' Sent on: '^S,datestr(when),
^M^J' Sent at: '^S,timestr(when));
if filepw then begin
write ('File Password: '^S);
if length(ud.dlpw)<1 then writeln ('NONE') else
writeln (ud.dlpw);
end;
write (' Private File: '^S);
if length(ud.private)<1 then writeln ('No') else
writeln ('Yes '+ud.private);
writeln ('Extended Desc: '^S);
a:=copy (ud.extdesc,1,80);
ansicolor (urec.statcolor);
writeln (a);
if length(ud.extdesc)>80 then begin
b:=copy (ud.extdesc,81,80);
ansicolor (urec.statcolor);
writeln (b);
end;
if length(ud.extdesc)>160 then begin
c:=copy (ud.extdesc,161,80);
ansicolor (urec.statcolor);
writeln (c);
end;
end;
begin
n:=getfilenum ('Change');
if n=0 then exit;
seekudfile (n);
read (udfile,ud);
writelog (16,4,ud.filename);
showudrec (ud);
repeat
q:=menu ('File Change','FCHANGE','QUSNFPVAEDTRC?');
case q of
2:getstring ('Uploader',ud.sentby);
{3:begin
nochain:=true;
getstring ('Description',ud.descrip)
end;}
3:getboo ('Special Request only',ud.specialfile);
4:getboo ('New File (unrated)',ud.newfile);
5:getstring ('Filename',ud.filename);
6:getstring ('Path',ud.path);
7:getint ('File Cost',ud.points);
8:if (not filepw) then writeln ('File Passwords were not configured!')
else getstringgg ('File Password',ud.dlpw);
9:ud.extdesc:=getextdesc;
10:getstring ('Program Description',ud.programname);
11:begin buflen:=2; getint ('Disk Number',ud.disknum);
buflen:=2; getint ('Total Disks',ud.totaldisk);
end;
12:getstringgg ('Private File',ud.private);
13:addcomment (ud.path,ud.filename);
14:begin
fchangemenu;
end;
end
until (q=1);
getfsize(ud);
if ud.filesize=-1 then writestr ('Warning: Can''t open file!');
seekudfile (n);
write (udfile,ud)
end;
procedure deletef;
var n,cnt,anarky:integer;
fn:lstr;
ud:udrec;
f:file;
floyd:userrec;
begin
n:=getfilenum ('Delete');
if n=0 then exit;
seekudfile (n);
read (udfile,ud);
fn:=getfname(ud.path,ud.filename);
writelog (16,7,fn);
writeln;
writehdr ('Delete File');
writeln (^R'Filename: '^S,fn);
writeln (^R'Size: '^S,ud.filesize);
writeln (^R'Program Desc:'^S,ud.programname+' '+strr(ud.disknum)+^R'/'^S+
strr(ud.totaldisk));
writeln (^R'Downloaded: '^S,ud.downloaded);
writeln (^R'Uploaded by: '^S,ud.sentby);
writeln (^R);
writestr ('Delete this? [y/n]: *');
if not yes then exit;
removefile (n);
if ups<1 then ups:=1;
ups:=ups-1;
if urec.lastups<1 then urec.lastups:=1;
urec.lastups:=urec.lastups-1;
writeurec;
writestr ('Remove upload credits from uploader [y/n]? *');
if yes then begin
anarky:=lookupuser (ud.sentby);
if anarky<>0 then begin
writeurec;
seek (ufile,anarky);
read (ufile,floyd);
floyd.uploads:=floyd.uploads-1;
floyd.upk:=floyd.upk-ud.filesize;
seek (ufile,anarky);
write (ufile,floyd);
readurec
end;
end;
writestr ('Erase Disk File '+fn+'? [y/n]: *');
if not yes then exit;
assign (f,fn);
erase (f)
end;
procedure killarea;
var a:arearec;
cnt,n:integer;
oldname,newname:sstr;
begin
writestr (^R'Delete Area #'^S+strr(curarea)+^R' ['^S+area.name+^R']: *');
if not yes then exit;
writelog (16,2,'');
ups:=ups-numuds;
urec.lastups:=urec.lastups-numuds;
if ups<1 then ups:=1;
if urec.lastups<1 then urec.lastups:=1;
writeurec;
close (udfile);
oldname:='Area'+strr(curarea)+'.'+strr(conn);
erase (udfile);
for cnt:=curarea to numareas-1 do begin
newname:=oldname;
oldname:='Area'+strr(cnt+1)+'.'+strr(conn);
assign (udfile,datadir+oldname);
rename (udfile,datadir+newname);
n:=ioresult;
seekafile (cnt+1);
read (afile,a);
seekafile (cnt);
write (afile,a)
end;
seekafile (numareas);
truncate (afile);
setarea (1);
end;
procedure modarea;
var a:arearec;
q:char;
begin
a:=area;
repeat
clearscr;
writehdr ('Modify Area');
writeln(^P'['^S'A'^P'] '^R'Area Name : '^S+a.name);
writeln(^P'['^S'B'^P'] '^R'Access Level: '^S+strr(a.level));
writeln(^P'['^S'C'^P'] '^R'Area Sponsor: '^S+a.sponsor);
writeln(^P'['^S'D'^P'] '^R'Entry PW : '^S+a.areapw);
write (^P'['^S'E'^P'] '^R'Allow U/Ls : '^S);
if a.upload then writeln('Yes') else
writeln(^S'No');
write (^P'['^S'F'^P'] '^R'Allow D/Ls : '^S);
if a.download then writeln('Yes') else
writeln(^S'No');
if issysop then
writeln(^P'['^S'G'^P'] '^R'Xfer Path : '^S+a.xmodemdir+^M);
writestr (^P'['^R'Area Modify Command'^P']'^S': *');
if hungupon then exit;
q:=upcase(input[1]);
case q of
'A':begin getstringgg ('Area Name',a.name);
writelog (16,3,a.name);
seekafile (curarea);
write (afile,a);
area:=a
end;
'B':begin getint ('Access Level',a.level);
writelog (16,11,strr(a.level));
seekafile (curarea);
write (afile,a);
area:=a
end;
'C':begin getstringgg ('Sponsor',a.sponsor);
writelog (16,12,a.sponsor);
seekafile (curarea);
write (afile,a);
area:=a
end;
'D':begin getstringgg ('Entry Password',a.areapw);
writelog (16,18,a.areapw);
seekafile (curarea);
write (afile,a);
area:=a
end;
'E':begin getboo ('Able to Upload into area',a.upload);
seekafile (curarea);
write (afile,a);
area:=a
end;
'F':begin getboo ('Able to Download from area',a.download);
seekafile (curarea);
write (afile,a);
area:=a
end;
'G':if issysop then begin
a.xmodemdir:=getapath;
seekafile (curarea);
write (afile,a);
area:=a;
writelog (16,13,a.xmodemdir)
end;
end;
until q='Q';
seekafile (curarea);
write (afile,a);
area:=a
end;
procedure sortarea;
var temp,mark,cnt:integer;
u1,u2:udrec;
begin
writehdr('Sort File Area'); writeln;
writestr('Are you sure? '+^S+'[y/n]'+^P+':');
if not yes then exit;
writelog (16,6,'');
mark:=numuds-1;
repeat
if mark<>0 then begin
temp:=mark;
mark:=0;
for cnt:=1 to temp do begin
seekudfile (cnt);
read (udfile,u1);
read (udfile,u2);
if upstring(u1.filename)>upstring(u2.filename) then begin
mark:=cnt;
seekudfile (cnt);
write (udfile,u2);
write (udfile,u1)
end;
end
end
until mark=0
end;
procedure movefile;
var an,fn,oldn:integer;
ud:udrec;
pe:boolean; sz:real;
lttp,laym,honkyshide,ocky:anystr;
damn:file; drive:char; r:registers;
function unsigned (i:integer):real;
begin
if i>=0 then unsigned:=i else unsigned:=65536.0+i
end;
begin
oldn:=curarea;
fn:=getfilenum ('Move');
if fn=0 then exit;
input:='';
an:=getareanum;
if an=0 then exit;
writestr ('Physically move file to correct area? [y/n]: *');
if yes then pe:=true else pe:=false;
seekudfile (fn);
read (udfile,ud);
writelog (16,5,ud.filename);
laym:=getfname(ud.path,ud.filename);
ocky:=ud.path;
write('Moving.');
setarea (an);
if (not match(ud.path,area.xmodemdir)) and (pe) then begin
ud.path:=area.xmodemdir;
lttp:=getfname(ud.path,ud.filename);
drive:=upcase(lttp[1]);
r.ah:=$36; r.dl:=ord(drive)-64;
intr($21,r);
if r.ax=$ffff then begin
writeln;
writeln('Dest. Drive does not exist!');
exit;
end;
sz:=unsigned(r.bx)*unsigned(r.ax)*unsigned(r.cx); writeln;
writeln;
writeln('There are ',^S,streal(sz),^R,' bytes free on the '^S,drive,^R,' drive.');
if sz<=ud.filesize then begin
writeln;
writeln('That is not enough space for this file. You must clear up another');
writeln(^S,streal(ud.filesize-sz),^R,' bytes to continue.');
exit;
end;
write('Copying.');
exec(getenv('COMSPEC'),'/C copy '+laym+' '+lttp);
honkyshide:=laym;
assign(damn,honkyshide);
if exist(honkyshide) then erase (damn) else begin
ud.path:=ocky;
writeln('ERROR: Unable to move file!');
end;
end;
addfile (ud);
setarea (oldn);
removefile (fn);
writeln(' - Done.');
end;
procedure renamefile;
var fn:integer;
ud:udrec;
f:file;
begin
fn:=getfilenum ('Rename');
if fn=0 then exit;
seekudfile (fn);
read (udfile,ud);
writestr ('Enter new Filename: *');
if match(input,ud.filename)
then
ud.filename:=input
else if length(input)>0
then if validfname(input)
then if exist(getfname(ud.path,input))
then
writeln ('Name already in use!')
else
begin
assign (f,getfname(ud.path,ud.filename));
rename (f,getfname(ud.path,input));
if ioresult=0 then begin
ud.filename:=input;
writeln (^B^M'File renamed.')
end else writeln (^B^M'Unable to rename file!')
end
else writeln ('Invalid filename!');
seekudfile (fn);
write (udfile,ud)
end;
procedure listxmodem;
var cnt:integer;
u:userrec;
begin
seek (ufile,1);
writeln ('Name Level Points'^M);
for cnt:=1 to numusers do begin
read (ufile,u);
if u.handle<>'' then
if u.udlevel>0 then begin
tab (u.handle,30);
tab (strr(u.udlevel),6);
writeln (u.udpoints);
if break then exit
end
end
end;
Procedure reorderareas;
Var numa,cura,newa:Integer;
a1,a2:arearec;
f1,f2:File;
fn1,fn2:sstr;
Label exit;
Begin
writelog(16,9,'');
writehdr('Re-order Areas');
numa:=FileSize(afile);
WriteLn('Number of areas: ',numa);
For cura:=0 To numa-2 Do Begin
Repeat
writestr ('[New Area #'+strr(cura+1)+'] [?/List, CR/Quit]:');
If Length(Input)=0 Then GoTo exit;
If Input='?'
Then
Begin
listareas;
newa:=-1
End
Else
Begin
newa:=valu(Input)-1;
If (newa<0) Or (newa>numa) Then Begin
WriteLn('Not found! Please re-enter.');
newa:=-1
End
End
Until (newa>=0);
Seek(afile,cura);
Read(afile,a1);
Seek(afile,newa);
Read(afile,a2);
Seek(afile,cura);
Write(afile,a2);
Seek(afile,newa);
Write(afile,a1);
fn1:=datadir+'Area';
fn2:=fn1+strr(newa+1)+'.'+strr(conn);
fn1:=fn1+strr(cura+1)+'.'+strr(conn);
Assign(f1,fn1);
Assign(f2,fn2);
Rename(f1,'TempArea');
Rename(f2,fn1);
Rename(f1,fn2);
close (f1);
close (f2);
End;
exit:
setarea(1)
End;
procedure newfiles;
var a,fn,un:integer;
ud:udrec;
u:userrec;
flag,aborted:boolean;
procedure writeudrec;
begin
seekudfile (fn);
write (udfile,ud)
end;
procedure ratefile (p:integer);
var pp:integer;
begin
ud.points:=p;
ud.newfile:=false;
ud.whenrated:=now;
writeudrec;
p:=p*uploadfactor;
if p>-2 then begin
un:=lookupuser (ud.sentby);
if un=0
then writeln (ud.sentby,' has vanished!')
else begin
pp:=p;
writestr (^P'Actually grant '^S+ud.sentby+^P' how many points ['^S+strr(p)+^P']:');
if (length(input)=0) then pp:=p else pp:=valu(input);
writeln ('Granting '^S+ud.sentby+' '+strr(pp)+^R' points.');
if un=unum then writeurec;
seek (ufile,un);
read (ufile,u);
u.udpoints:=u.udpoints+pp;
seek (ufile,un);
write (ufile,u);
if un=unum then readurec
end
end
end;
procedure doarea;
var i,advance:integer;
done:boolean;
begin
fn:=1;
advance:=0;
while fn+advance<=numuds do begin
fn:=fn+advance;
advance:=1;
seekudfile (fn);
read (udfile,ud);
if ud.newfile then begin
flag:=false;
done:=false;
repeat
writeln (^B^M'Filename: ',ud.filename,
^M'Path: ',ud.path,
^M'Sent by: ',ud.sentby,
^M'File size: ',ud.filesize,
^M'Program Desc:',ud.programname+' '+strr(ud.disknum)+'/'^S+
strr(ud.totaldisk));
i:=menu ('File Newscan','NEWSCAN','Q#_CEPDTRM0?');
input:=' '+strr(fn);
if i<0
then
begin
ratefile (-i);
done:=true
end
else
case i of
1:begin
aborted:=true;
exit
end;
3:done:=true;
4:begin
writestr ('Enter new Program Description:');
if length(input)>0 then ud.programname:=input;
writeudrec
end;
5:begin
writestr ('Enter new Disk Number:');
if length(input)>0 then ud.disknum:=valu(input);
writeudrec
end;
6:begin
writestr ('Enter new Total Disks Number:');
if length(input)>0 then ud.totaldisk:=valu(input);
writeudrec
end;
7:begin
renamefile;
advance:=0
end;
8:begin
deletef;
advance:=0
end;
9:listarchive (fn);
10:begin
movefile;
advance:=0
end;
11:begin
ratefile (0);
done:=true
end;
12:begin
newscanmenu;
end;
end
until done or (advance=0)
end
end;
end;
begin
flag:=true;
writelog (16,1,'');
if issysop then begin
writestr ('Scan all areas? [y/n]: *');
if yes then begin
for a:=1 to numareas do begin
setarea (a);
aborted:=false;
doarea;
if aborted then exit
end;
end else begin doarea; end
end else begin doarea; end;
if flag then writeln (^B'No new files.')
end;
procedure generatelist;
var total,a,b,c,x,y,z:integer;
list:text;
yoo,ud:udrec;
s:anystr;
f:file;
str1,str2:string;
begin
total:=0;
writehdr ('Generate Master File List');
writestr ('Make complete list of all files available? [y/n]: *');
if not yes then exit;
if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
assign (list,faqdir+'MASTER.'+strr(conn));
rewrite (list);
writeln (list);
writeln (list,'[Master File List created by FAQ v'+ver+' for '+longname+']');
writeln (list);
writeln (list,'Num. Filename Description');
writeln (list,'───────────────────────────────────────────────────────────────────────────────');
for x:=1 to numareas do begin
setarea (x);
writeln (list);
writeln (list,'Area: ',area.name,' [',curarea,']');
writeln (list);
for y:=1 to numuds do
begin
seekudfile(y);
read (udfile,yoo);
total:=total+1;
write (list,strr(total)+'.');
for a:=1 to 5-(length(strr(total)+'.')) do write (list,' ');
write (list,yoo.filename);
for b:=1 to 13-(length(yoo.filename)) do write (list,' ');
if exist (getfname(yoo.path,yoo.filename)) then begin
write (list,strlong(yoo.filesize));
for c:=1 to 10-(length(strlong(yoo.filesize))) do write (list,' ');
end else
write (list,'[Offline] ');
writeln (list,yoo.programname+' '+strr(yoo.disknum)+'/'+strr(yoo.totaldisk));
end;
end;
writeln (list);
writeln (list,'- '+strr(total)+' Files Processed');
writeln (list,'- List generated by FAQ v'+ver);
textclose (list);
setarea (1);
writeln;
writeln ('Please wait while file is being Zipped up.');
addtozip (area.xmodemdir+'ALLFILES.ZIP',faqdir+'MASTER.'+strr(conn));
writeln (usr);
if not exist (area.xmodemdir+'ALLFILES.ZIP') then begin
writeln ('Cannot locate temporary Zipfile '+area.xmodemdir+'ALLFILES.ZIP!');
exit;
end;
writeln;
ud.filename:='ALLFILES.ZIP';
ud.path:=area.xmodemdir;
ud.dlpw:='';
ud.sentby:=unam;
ud.when:=now;
ud.whenrated:=now;
ud.points:=0;
ud.downloaded:=0;
ud.newfile:=false;
ud.specialfile:=false;
ud.extdesc:='Master file list for '+longname;
getfsize (ud);
addfile (ud);
writeln (^R'Downloading '^S+ud.filename+^R'.');
download (numuds,false);
removefile (numuds);
assign (f,getfname(ud.path,ud.filename));
erase (f);
writelog (16,18,unam);
end;
procedure extractfile;
var n:integer;
ud,scratch:udrec;
ok,done:boolean;
effn,master,dir,sname,tempfn:anystr;
begin
n:=getfilenum ('Extract from');
if n=0 then exit;
seekudfile (n);
read (udfile,ud);
ok:=checkok (ud);
if not ok then exit;
writeln;
writeln (^R'Archive Filename: '^S,ud.filename,^R);
done:=false;
repeat
writeln;
writeln (^R'Enter Filename to extract from Archive, or hit [V] to View.');
writestr (': *');
if length(input)=0 then exit;
if upstring(input)='V' then listarchive (n) else
done:=true;
until done or hungupon;
effn:=upstring(input);
{setarea (1);}
dir:=area.xmodemdir;
if dir[length(dir)]<>'\' then dir:=dir+'\';
if exist(effn) then begin
writeln ('File Already Exists!');
exit;
end;
master:=getfname (ud.path,ud.filename);
extract (effn,master,dir);
tempfn:=effn;
effn:=getfname(dir,effn);
if not exist (effn) then begin
writeln (^G);
writeln ('Error! Cannot find extracted file '+effn);
writeln ('Please notify Sysop!');
exit;
end;
writeln (usr);
sname:=copy (tempfn,1,(pos ('.',tempfn)));
writeln ('Please wait while file is being Zipped up.');
addtozip (dir+sname+'ZIP',effn);
writeln (usr);
if not exist (dir+sname+'ZIP') then begin
writeln ('Cannot locate temporary Zipfile '+dir+sname+'ZIP!');
exit;
end;
scratch.filename:=sname+'ZIP';
scratch.path:=dir;
scratch.dlpw:='';
scratch.sentby:=unam;
scratch.when:=now;
scratch.whenrated:=now;
scratch.points:=1;
scratch.downloaded:=0;
scratch.newfile:=false;
scratch.specialfile:=false;
scratch.extdesc:='Temporary Zipfile for downloading by '+unam+' ONLY.';
getfsize (scratch);
addfile (scratch);
writeln (^R'Downloading '^S+scratch.filename+^R'.');
download (numuds,false);
removefile (numuds);
writelog (16,19,ud.filename);
end;
procedure renameallfiles;
var e,c,w:sstr;
i,yiyi:integer;
u:udrec;
f:lstr;
bpb:boolean;
begin
writehdr ('Convert All File Extensions');
writeln (^R'This is for if you are converting all your files to ZIP');
writeln (^R'format, or are converting them all to PAK format, etc.');
writeln (^R'Instead of you having to change the file extensions by hand');
writeln (^R'this will do it for you.');
writeln (^S'But you must do the actual file converting YOURSELF.');
writeln (^R^B);
writeln (^S'Enter Global File Extension (ie ZIP), or [CR] to exit: ');
buflen:=3;
writestr (': *');
if length(input)=0 then exit;
e:=input;
writeln;
bpb:=match (longname,'The Flaming Pit');
if bpb then begin
writeln ('Enter Global "Who Uploaded this File":');
writestr (': &');
w:=input;
end;
for i:=1 to filesize(udfile) do begin
if aborted then exit;
seekudfile (i);
read (udfile,u);
yiyi:=0;
f:='';
c:='';
repeat
yiyi:=yiyi+1;
c:=copy (u.filename,yiyi,1);
f:=f+c;
until (c='.') or (yiyi=length(u.filename));
writeln ('Pass Number: ',i);
u.filename:=f+e;
writeln ('New Filename: ',u.filename);
if (bpb) and (length(w)>0) then begin
u.sentby:=w;
writeln ('New Uploader: ',u.sentby);
end;
seekudfile (i);
write (udfile,u);
end
end;
procedure showinfo (n:integer);
var ud:udrec;
begin
if n>numuds then exit;
seekudfile (n);
read (udfile,ud);
end;
procedure newscan;
var cnt,aka,insane:integer;
u:udrec;
gnuwarez,done,non:boolean;
c:char;
begin
vcr:=false;
gnuwarez:=false;
beenaborted:=false;
aka:=0;
cn:=0;
non:=false;
repeat
cn:=0;
non:=false;
for cnt:=1 to filesize(udfile) do begin
if aborted then exit;
seekudfile (cnt);
read (udfile,u);
if (u.whenrated>laston) or (u.when>laston)
then begin
inc(cn);
if (cn=18) and (non=false) then
begin
bottomfileline;
cn:=0;
writestr (^S'CR'^P'/'^R'Next '^S'+'^P'/'^R'Add to batch '^S'D'^R'ownload '^S'N'^R'on-stop '^S
+'Q'^R'uit '^S'V'^R'iew'^P': '^U'*');
if capfir(input)='A' then addtobatch (0);
if capfir(input)='D' then download (0,true);
if capfir(input)='N' then non:=true;
if capfir(input)='Q' then exit;
if capfir(input)='V' then listarchive (0);
writeln;
topfileline;
end;
aka:=aka+1;
if aka=1 then begin
clearscr;
writeln (^R'['^S,curarea,^R'] ['^S,area.name,^R']'^M);
topfileline;
end;
listfile (cnt,false);
gnuwarez:=true;
end;
end;
if not gnuwarez then done:=true else done:=false;
if gnuwarez then begin
c:='N';
bottomfileline;
writeln;
writestr (^P'Newscan Command ['^S'?/Help'^P'] ['^S'CR/Next Area'^P']'^S': '^U'*');
if length(input)<1 then input:='N';
c:=input[1];
insane:=valu(input);
c:=upcase(c);
if (insane>0) and (insane<=numuds) then begin
showinfo (insane);
writeln;
writestr ('Hit [Enter]:');
end else
c:=upcase(input[1]);
if length(input)=0 then done:=true else
case c of
'?':begin
writeln;
writeln (^S' -File Xfer Newscan Help-'^R^M);
writeln ('[N]: Next File Area [I]: More Info on a File ');
writeln ('[A]: See Files Again [V]: View a File (ZIP/ARC/PAK/LZH)');
writeln ('[D]: Download a File [+]: Add file to Batch');
writeln ('[Q]: Quit Newscan');
if sponsoron then begin
writeln (^S' -Sysop Commands- '^R);
writeln ('[C]: Change a File [!]: Validate all New Files');
writeln ('[R]: Rename a File [E]: Delete a File');
end;
writeln;
aka:=0;
writestr (^M'Hit [Enter] to continue.*');
aka:=0;
end;
'+':begin
writeln;
addtobatch (0);
writestr (^M'Hit [Enter] to continue.*');
aka:=0;
end;
'D':begin
writeln;
download (0,true);
writestr (^M'Hit [Enter] to continue.*');
aka:=0;
end;
'A':begin
done:=false;
aka:=0;
end;
'V':begin
writeln;
listarchive (0);
writestr (^M'Hit [Enter] to continue.*');
aka:=0;
end;
'Q':begin
vcr:=true;
exit;
end;
'C':begin
if not sponsoron then exit;
changef;
aka:=0;
end;
'R':begin
if not sponsoron then exit;
renamefile;
aka:=0;
end;
'E':begin
if not sponsoron then exit;
deletef;
aka:=0;
end;
'!':begin
if not sponsoron then exit;
newfiles;
aka:=0;
end;
'I':begin
writeln;
fileinfo (0);
aka:=0;
writestr ('Hit [Enter] to continue.*');
end;
'N':done:=true;
end;
end;
until done;
end;
procedure newscanall;
var cnt:integer;
a:arearec;
begin
writeln (^R'Newscanning All Areas - Press ['^S'X'^R'] to Abort.'^M);
beenaborted:=false;
if aborted then exit;
for cnt:=1 to filesize(afile) do begin
seekafile (cnt);
read (afile,a);
if urec.udlevel>=a.level then begin
if aborted then exit;
setarea (cnt);
writeln (^R+area.name+^P' ['^S+strr(curarea)+^P']');
if aborted or vcr then exit;
newscan;
end;
if aborted then exit
end;
writeln (^R^M'Newscan complete!'^G);
end;
procedure yourudstats;
begin
yourudstatus;
clearscr;
end;
procedure sysopcommands;
var i:integer;
begin
if not sponsoron then begin
reqlevel (sysoplevel);
exit
end;
writelog (15,3,area.name);
repeat
i:=menu ('File Transfer Sponsor','FSYSOP','A@CDF@G@KRNSMLO@QEW*@V?');{P}
case i of
1:sysopadd;
2:changef;
3:deletef;
4:directory;
5:offfaq;
6:killarea;
7:modarea;
8:newfiles;
9:sortarea;
10:movefile;
11:listxmodem;
12:reorderareas;
14:renamefile;
15:addmultiplefiles;
16:getarea;
17:renameallfiles;
18:begin
sponsormenu;
end;
end
until hungupon or (i=13)
end;
procedure listfile (n:integer; extended:boolean);
var ud :udrec;
q,xy :sstr;
a :string;
b :string;
c :string;
ed :string;
desc :string;
lamedata :string[1];
up1 :byte;
dah :boolean;
begin
seekudfile (n);
read (udfile,ud);
write (^S+strr(n));
spacelen(4-length(strr(n)));
if ffname in urec.filelister then begin
write(^S+UPSTRING(copy(ud.filename,1,length(ud.filename)-4)));
spacelen(9-length(copy(ud.filename,1,length(ud.filename)-4)));
end;
if ffext in urec.filelister then begin
write(^S+upstring(copy(ud.filename,length(ud.filename)-2,3)));
spacelen(4-length(copy(ud.filename,length(ud.filename)-2,3)));
end;
if ffsize in urec.filelister then begin
if exist (getfname(ud.path,ud.filename)) then begin
write(^S,strlong(ud.filesize));
spacelen(10-length(strlong(ud.filesize)));
end;
if not exist (getfname(ud.path,ud.filename)) then begin
write (^P'['^S'Offline'^P'] '^S);
end;
end;
if ffpoints in urec.filelister then begin
if ud.newfile
then write (^S'New ')
else if length(ud.private)>0
then write (^S'Priv ')
else if ud.specialfile
then write (^S'Ask ')
else if ud.points>0
then begin write (^S+strr(ud.points)); spacelen (5-length(strr(ud.points))) end
else if leechweek
then write (^S'N/A ')
else write (^S'Free ')
end;
if ffuploader in urec.filelister then begin
write(^S,ud.sentby);
spacelen(13-length(ud.sentby));
end;
if ffuploaded in urec.filelister then begin
write(^S,datestr(ud.when));
spacelen(9-length(datestr(ud.when)));
end;
if ffdown in urec.filelister then begin
write(^S,strr(ud.downloaded));
spacelen(4-length(strr(ud.downloaded)));
end;
if fffulnam in urec.filelister then begin
write (^S,ud.programname);
spacelen(28-length(ud.programname));
end;
if ffofwhat in urec.filelister then begin
xy:=^S+strr(ud.disknum)+^R'/'^S+strr(ud.totaldisk);
write (^S,xy);
spacelen(6-length(xy));
end;
writeln;
if cn>18 then cn:=18;
{end;}
end;
function nofiles:boolean;
begin
if numuds=0 then begin
nofiles:=true;
writestr (^M'Sorry, no files!')
end else nofiles:=false;
end;
Function capfir(inString:STRING):STRING;
begin
capfir:=upcase(inString[1]);
end;
procedure listfiles (extended:boolean);
var cnt,max,r1,r2:integer;
non:boolean;
begin
if nofiles then exit;
clearscr;
cn:=0;
non:=false;
max:=numuds;
thereare (max,'File','Files');
parserange (max,r1,r2);
if r1=0 then exit;
{writeln;}
topfileline;
for cnt:=r1 to r2 do begin
inc(cn);
if (cn>=18) and (non=false) then
begin
bottomfileline;
cn:=0;
writestr (^S'CR'^P'/'^R'Next '^S'+'^P'/'^R'Add to batch '^S'D'^R'ownload '^S'N'^R'on-stop '^S
+'Q'^R'uit '^S'V'^R'iew'^P': '^U'*');
if capfir(input)='A' then addtobatch (0);
if capfir(input)='D' then download (0,true);
if capfir(input)='N' then non:=true;
if capfir(input)='Q' then exit;
if capfir(input)='V' then listarchive (0);
topfileline;
end;
listfile (cnt,extended);
if break then exit
end;
bottomfileline;
end;
var i,c,kkk1,kkk2,oldarea:integer;
a:arearec;
ms:boolean;
z:integer;
x1,x2,x3:integer;
y1,y2,y3:real;
xferlist:text;
temp:file;
label ok,exit2;
begin
urec.averagecps:=baudrate div 10;
vcr:=false;
cursection:=udsysop;
ms:=false;
if (x3<xferpcr) and (ulvl<pcrexempt) then begin
writeln ('File Access Denied!');
writeln ('Your PCR is lower than the required PCR in the setup.');
goto exit2; end;
writehdr ('File Transfer Section');
input:='';
if exist ('BATCH.'+strr(conn)) then begin
assign (temp,datadir+'BATCH.'+strr(conn));
erase (temp);
end;
assign (batfile,datadir+'BATCH.'+strr(conn));
close (batfile);
reset (batfile);
if ioresult<>0 then rewrite (batfile);
assign (afile,datadir+'Areadir'+'.'+strr(conn));
if exist (datadir+'Areadir'+'.'+strr(conn)) then
begin
reset (afile);
if filesize (afile)>0 then goto ok
end
else rewrite (afile);
getconpw;
writeln ('No transfer areas exist!');
area.xmodemdir:=faqdir+'XFER\';
if issysop
then if makearea
then goto ok;
goto exit2;
ok:
seekafile (1);
read (afile,a);
if urec.udlevel<a.level then begin
writeln ('Sorry, you can''t access the first area!');
goto exit2
end;
writeln;
if exist(textfiledir+'FILENEWS.'+strr(conn)) then begin
printfile (textfiledir+'FILENEWS.'+strr(conn));
pause;
end;
x3:=percent(urec.nbu,urec.numon);
yourudstats;
setarea(1);
repeat
if withintime (xmodemclosetime,xmodemopentime) then
if not issysop then begin
printxy(42,12,^S+'Transfer section closed.'+^R);
goto exit2
end else if not ms then begin
ms:=true
end;
write (^B);
writeln (^R'Conference #'^S+strr(conn)+' '+area.name+^P' ['^S+strr(curarea)+^P']');
if sponsoron or issysop
then writeln (^R'['^S'%'^R']:Xfer Sponsor Commands');
oldarea:=curarea;
i:=menu ('File Transfer','FILE','UDLWYA*SQ%NVRFXTEGB+ZJ?');
if hungupon then goto exit2;
case i of
1:upload;
2:download (0,true);
3:listfiles (false);
4:sendmailto (area.sponsor,false);
5:yourudstats;
6,7:getarea;
8:begin;
searchfile;
setarea(oldarea);
end;
10:sysopcommands;
11:begin;
newscanall;
setarea(oldarea);
end;
12:begin;
newscan;
setarea(oldarea);
end;
13:listarchive (0);
14:{whoup;}configurefilelisting;
15:xtendedlist;
16:typefile;
17:requestfile;
18:generatelist;
19:batchmenu;
20:addtobatch (0);
21:extractfile;
22:begin changecon('X'); close (afile); close (udfile); close (batfile); i:=ioresult;
erase (batfile); assign (xferlist,textfiledir+'Xferlist.FAQ');
if exist (textfiledir+'Xferlist.FAQ') then erase (xferlist); udsection; exit; end;
23:begin
xfermenu;
end;
end
until hungupon or (i=9);
exit2:
close (afile);
close (udfile);
close (batfile);
i:=ioresult;
erase (batfile);
assign (xferlist,textfiledir+'Xferlist.FAQ');
if exist (textfiledir+'Xferlist.FAQ') then erase (xferlist);
end;
begin
end.