Category : Pascal Source Code
Archive   : WWIV310.ZIP
Filename : DLOADS.PAS
{*****************************}
{Copyright (c) 1986 Wayne Bell}
{*****************************}
{$V-} {$C-}
TYPE j=array[1..8] of string[14];
CONST strlen=160;
comnum=1;
maxbaud=1200;
maxusers=300;
dsaves : Integer = 0;
buffer_Max = 5120;
comptyp:j=('IBM','APPLE','TRS-80','Z-80 CP/M','COMMODORE','ATARI',
'DUMB TERMINAL','OTHER');
TYPE str=string[strlen];
restrictions=(rlogon,rchat,rvalidate,rbackspace,ramsg,rpostan,
rpost,remail,rvoting,rmsg);
acrq='@'..'G';
newtyp=(rp,lt,rm);
deflts=(spcsr,onekey,wordwrap,pause);
anontyp=(no,yes,forced,dearabby);
ansttype=(postn,emailn,pana,sanm,cosysop,lcosysop);
opts=(alert,smw,nomail);
slr=record
ttime:byte;
mallowed:integer;
emails,posts:byte;
anst:set of ansttype;
end;
messages=record
ltr:char;
number:integer;
ext:byte;
end;
smalrec=record
name:string[25];
number:integer;
end;
userrec=record
name:string[25];
realname:string[14];
deleted:boolean;
pw:string[8];
ph:string[12];
waiting:byte;
laston:string[10];
loggedon:integer;
msgpost:integer;
emailsent:integer;
feedback:integer;
linelen:byte;
pagelen:byte;
defaults:set of deflts;
ontoday:byte;
illegal:byte;
cursor:string[10];
sl:byte;
ac:set of restrictions;
ar:set of acrq;
qscan:array[1..19] of messages;
qscn:array[1..19] of boolean;
macro:array[1..2] of string[79];
comptype:byte;
option:set of opts;
vote:array[1..9] of byte;
sbn:byte;
dsl:byte;
uploads,downloads:integer;
uk,dk:integer;
end;
boardrec=record
name:string[25];
filename:string[12];
sl:byte;
maxmsgs:byte;
pw:string[10];
anonymous:anontyp;
ar:acrq;
key:char;
end;
msgstat=(validated,unvalidated,deleted);
messagerec=record
title:string[30];
messagestat:msgstat;
message:messages;
owner:integer;
date:integer;
mage:byte;
end;
systatrec=record
boardpw:string[8];
sysoppw:string[8];
hmsg:messages;
users:integer;
lastdate:string[8];
callernum:integer;
activetoday:integer;
callstoday:integer;
msgposttoday:integer;
emailtoday:integer;
fbacktoday:integer;
uptoday:integer;
closedsystem:boolean;
end;
blk=array[1..255] of byte;
mailrec=record
title:string[30];
from,destin:integer;
msg:messages;
date:integer;
mage:byte;
end;
gft=record
num:integer;
title:string[40];
filen:string[12];
end;
charfil=text;
smr=record
msg:str;
destin:integer;
end;
vdatar=record
question:string[79];
numa:integer;
answ:array[0..9] of record
ans:string[25];
numres:integer;
end;
end;
regs=record ax,bx,cx,dx,bp,si,di,ds,es,flags:integer; end;
ulrec=record
name:string[25];
filename:string[12];
password:string[10];
dsl:byte;
maxfiles:integer;
end;
ulfrec=record
filename:string[12];
description:string[60];
res:array[1..17] of byte;
ft:array[1..3] of byte;
blocks:integer;
owner:integer;
date:string[8];
daten:integer;
end;
var sf:file of smalrec;
uf:file of userrec;
bf:file of boardrec;
mf:file of messagerec;
mailfile:file of mailrec;
sysopf:charfil;
slf:file of slr;
seclev:array[0..255] of slr;
systatf:file of systatrec;
systat:systatrec;
sr:smalrec;
thisline,chatr,buf,spd,irt,lastname,ll,cursor,i:str;
thisuser,user:userrec;
boards:array[1..19] of boardrec;
fw,extramsgs,mread,board,numboards,t,usernum:integer;
pap,lil,realsl,ftoday,ptoday,etoday:integer;
c,ID:char;
hungup,useron,next,chatcall,expert,doneday,echo,hangup,incom,outcom:boolean;
extratime,timeon:real;
macok,lan,enddayf,ch,quit:boolean;
buffer:Array[0..buffer_Max] of Char;
comport,base:Integer;
Async_Irq:Integer;
buffer_Head,buffer_tail,buffer_newtail:Integer;
smf:file of smr;
srl:array[0..maxusers] of smalrec;
vqu:array[1..9] of boolean;
ret:byte absolute cseg:$0080;
ldate1:integer;
maxspd:integer;
cmd:char;
help:array[1..25000] of char;
helpi:array['0'..'^'] of integer;
helpl:char;
ihelp:boolean;
cf:text; cfo,okt:boolean;
ulf:file of ulrec;
uboards:array[0..19] of ulrec;
ulff:file of ulfrec;
crc,culb,maxulb:integer;
sortbd,doneft:boolean;
ldate:str;
ymodem,ucrc,bnp:boolean;
chksum:byte;
lrn:integer;
lfn:str;
ft:byte;
label reent;
{$I COMMON.PAS}
procedure printfile(fn:str);
var fil:text;
i:str;
abort,next:boolean;
begin
if not hangup then begin
assign(fil,fn);
{$I-} reset(fil); {$I+}
if ioresult<>0 then print('File not found.') else begin
abort:=false;
while not eof(fil) and (not abort) and (not hangup) do begin
readln(fil,i);
if i[length(i)]<>#1 then i:=i+#1;
printa(i,abort,next);
end;
close(fil);
end;
nl;nl;
end;
end;
function tcheck(s:real; i:integer):boolean;
var r:real;
begin
r:=timer;
if r
end;
function tchk(s:real; i:real):boolean;
var r:real;
begin
r:=timer;
if r
end;
{$I DLP1.PAS}
procedure i1;
begin
assign(ulf,'gfiles\uploads.dat');
reset(ulf); maxulb:=-1;
while not eof(ulf) do begin maxulb:=maxulb+1; read(ulf,uboards[maxulb]); end;
close(ulf);
culb:=1;
ldate:=thisuser.laston;
end;
function exist(fn:str):boolean;
var f:file;
begin
assign(f,fn);
{$I-} reset(f); {$I+}
if ioresult=0 then begin close(f); exist:=true end else exist:=false;
end;
function align(fn:str):str;
var f,e,t:str; c,c1:integer;
begin
c:=pos('.',fn);
if c=0 then begin
f:=fn; e:=' ';
end else begin
f:=copy(fn,1,c-1); e:=copy(fn,c+1,3);
end;
while length(f)<8 do f:=f+' ';
while length(e)<3 do e:=e+' ';
if length(f)>8 then f:=copy(f,1,8);
if length(e)>3 then e:=copy(e,1,3);
c:=pos('*',f); if c<>0 then for c1:=c to 8 do f[c1]:='?';
c:=pos('*',e); if c<>0 then for c1:=c to 3 do e[c1]:='?';
c:=pos(' ',f); if c<>0 then for c1:=c to 8 do f[c1]:=' ';
c:=pos(' ',e); if c<>0 then for c1:=c to 3 do e[c1]:=' ';
align:=f+'.'+e;
end;
function fit(f1,f2:str):boolean;
var tf:boolean; c:integer;
begin
tf:=true;
for c:=1 to 12 do
if (f1[c]<>f2[c]) and (f1[c]<>'?') then tf:=false;
fit:=tf;
end;
procedure iscan(var pl:integer);
var f:ulfrec;
begin
assign(ulff,'gfiles\'+uboards[culb].filename);
{$I-} reset(ulff); {$I+}
if ioresult<>0 then begin
rewrite(ulff);
f.blocks:=0;
write(ulff,f);
end;
seek(ulff,0);
read(ulff,f);
pl:=f.blocks;
bnp:=false;
end;
procedure recno(fn:str; var pl,rn:integer);
var c:integer;
f:ulfrec;
begin
fn:=align(fn);
iscan(pl); rn:=0; c:=1;
while (c<=pl) and (rn=0) do begin
seek(ulff,c); read(ulff,f);
if fit(fn,align(f.filename)) then rn:=c;
c:=c+1;
end;
lrn:=rn;
lfn:=fn;
end;
procedure nrecno(fn:str; var pl,rn:integer);
var c:integer;
f:ulfrec;
begin
fn:=align(fn);
if fn=lfn then begin
if (lrn
c:=lrn+1; rn:=0;
while (c<=pl) and (rn=0) do begin
seek(ulff,c); read(ulff,f);
if fit(fn,align(f.filename)) then rn:=c;
c:=c+1;
end;
lrn:=rn;
end else rn:=0;
end else rn:=0;
end;
procedure arcl(fn:str; var abort:boolean);
type ei=record l,h:integer; end;
archead=record
name:array[1..13] of char;
size:ei;
date,time,crc:integer;
len:ei;
end;
var f:file; b:byte;
head:archead;
done,next:boolean;
function valueei(x:ei):real;
var r:real; tf:boolean;
begin
if x.h>=0 then begin r:=int(x.h)*65536.0; tf:=true; end else
begin tf:=false; if x.h=$8000 then r:=65536.0*65536.0 else
r:=int(-x.h)*65536.0; end;
if x.l>=0 then r:=r+int(x.l)
else if x.l=$8000 then r:=r+32760.0
else r:=r+65536.0+x.l;
if tf then valueei:=r else valueei:=-r;
end;
procedure pfn;
var i,i1:str; try:byte;
begin
b:=0; try:=0;
while not eof(f) and (b<>26) and (try<5) do begin
blockread(f,b,1);
try:=try+1;
end;
if try>=5 then longseek(f,filesize(f)-2.0);
if longfilepos(f)+27
blockread(f,b,1);
if b<>0 then begin
if b=1 then begin
blockread(f,head,sizeof(head)-sizeof(ei));
head.len:=head.size;
end else blockread(f,head,sizeof(head));
i:=''; b:=1;
while (head.name[b]<>#0) and (b<=13) do begin
i:=i+head.name[b];
b:=b+1;
end;
i:=align(i)+' ';
i1:=cstrr(valueei(head.len));
while length(i1)<7 do i1:=' '+i1;
i:=i+i1;
printacr(i,abort,next);
end else done:=true;
longseek(f,longfilepos(f)+valueei(head.size));
end;
end;
begin
assign(f,fn);
reset(f,1); done:=false;
while (longfilepos(f)+27.0
close(f);
end;
procedure lbrl(fn:str; var abort:boolean);
var f:file;
c,n,n1:integer;
x:record
st:byte;
name:array[1..8] of char;
ext:array[1..3] of char;
index,len:integer;
fil:array[1..16] of byte;
end;
next:boolean;
i,i1:str;
begin
assign(f,fn);
reset(f,32);
blockread(f,x,1);
c:=x.len*4-1;
for n:=1 to c do begin
blockread(f,x,1); i:='';
if (x.st=0) and not abort then begin
for n1:=1 to 8 do i:=i+x.name[n1];
i:=i+'.';
for n1:=1 to 3 do i:=i+x.ext[n1];
i:=align(i)+' ';
i1:=cstrr(x.len*128.0);
while length(i1)<7 do i1:=' '+i1;
i:=i+i1;
printacr(i,abort,next);
end;
end;
close(f);
end;
procedure lfi(fn:str; var abort:boolean);
var next:boolean; i1,i2:str;
begin
if exist('dloads\'+fn) and (not abort) then
if (pos('.ARC',fn)<>0) or (pos('.LBR',fn)<>0) then begin
nl;
i1:=align(fn); i2:=''; while length(i1)>length(i2) do i2:=i2+'-';
printacr(i1,abort,next);
printacr(i2,abort,next);
nl;
if not abort then begin
if pos('.ARC',fn)<>0 then arcl('dloads\'+fn,abort);
if pos('.LBR',fn)<>0 then lbrl('dloads\'+fn,abort);
end;
nl;
end;
end;
procedure lfin(rn:integer; var abort:boolean);
var f:ulfrec;
begin
seek(ulff,rn); read(ulff,f); lfi(f.filename,abort);
end;
procedure lfii;
var fn:str; pl,rn:integer; abort:boolean;
begin
helpl:='[';
nl; print('Enter file to list interior files of');
prompt(': '); input(fn,12);
recno(fn,pl,rn);
abort:=false;
if rn=0 then print('File not found.') else begin
while (rn<>0) and (not abort) do begin
lfin(rn,abort);
nrecno(fn,pl,rn);
end;
end;
close(ulff);
end;
procedure return;
var f:file;
begin
assign(f,'bbs.com');
print('Returning to BBS...');
remove_port;
if hangup then term_ready(false);
execute(f);
end;
procedure pbn(var abort:boolean);
var i,i1:str; next:boolean;
begin
if not bnp then begin
nl;
i:=uboards[culb].name+' #'+cstr(culb);
i1:='---'; while length(i1)
printacr(i,abort,next);
printacr(i1,abort,next);
nl;
end;
bnp:=true;
end;
function uc(s:str):str;
var x:str; i:integer;
begin
x:=s;
for i:=1 to length(s) do
x[i]:=upcase(x[i]);
uc:=x;
end;
procedure dlx(f1:ulfrec; var abort:boolean);
var inte,pl,c:integer; ok,tl:boolean; u:userrec; rl:real; i,ii:str;
begin
nl; nl;
print('Filename: "'+align(f1.filename)+'"');
print('Desc. : '+f1.description);
print('# blocks: '+cstr(f1.blocks)+'-'+cstr((f1.blocks+7)div 8));
inte:=value(spd); if inte=0 then inte:=1200;
rl:=1620.0*f1.blocks/inte;
if rl>32767.0 then rl:=32000; if rl<0.0 then rl:=0;
inte:=trunc(rl);
i:=cstr(inte div 3600)+':'; ii:=cstr((inte mod 3600) div 60);
if length(ii)=1 then ii:='0'+ii; i:=i+ii+':';
ii:=cstr(inte mod 60); if length(ii)=1 then ii:='0'+ii;
i:=i+ii; print('apx time: '+i);
reset(uf); seek(uf,f1.owner); read(uf,u); close(uf);
print('U/L by : '+u.name+' #'+cstr(f1.owner));
print('U/L on : '+f1.date);
ft:=255; if (f1.ft[1]=$81) and (f1.ft[2]=$f5) then ft:=f1.ft[3];
if ft<>255 then print('File typ: '+cstr(ft));
if timer
if tl or (copy(f1.filename,1,4)='WWIV') then begin
if exist('dloads\'+f1.filename) then
send1('dloads\'+f1.filename,ok,abort)
else print('File isn''t really there!');
end else print('Not enough time left to D/L');
end;
procedure dl(fn:str);
var pl,rn:integer; f:ulfrec; abort:boolean;
begin
recno(fn,pl,rn); abort:=false;
if rn=0 then print('File not found.') else begin
while (rn<>0) and (not abort) do begin
seek(ulff,rn); read(ulff,f); dlx(f,abort);
nrecno(fn,pl,rn);
end;
end;
close(ulff);
end;
procedure dl1(n:integer);
var f1:ulfrec; abort:boolean;
begin
nl; nl;
seek(ulff,n); read(ulff,f1);
dlx(f1,abort);
nl;
end;
procedure ul(fn:str);
var x,pl,c,cc,ob,np:integer; f,f1:ulfrec; uls,ok:boolean; fi:file of byte;
begin
uls:=incom;
ob:=culb;
ok:=true; fn:=align(fn);
if (fn[1]=' ') or (fn[10]=' ') then ok:=false;
for x:=1 to length(fn) do
if not (fn[x] in ['0'..'9','A'..'Z','.',' ']) then ok:=false;
np:=0; for x:=1 to length(fn) do if fn[x]='.' then np:=np+1;
if np<>1 then ok:=false;
if ok then
if incom then
if exist('dloads\'+fn) then
if cs then begin
print('There already is one.');
prompt('Do it anyways? ');
ok:=yn;
uls:=false;
end else
ok:=false
else
ok:=true
else
ok:=exist('dloads\'+fn)
else print('Illegal filename.');
if (not incom) then
if ok then print('Am using the file in dloads\')
else begin print('To put in a file from keyboard, it must already be');
print('present in the dloads\ directory.'); end;
nl; nl;
if ok and incom and uls then begin
assign(fi,'dloads\'+fn); {$I-} rewrite(fi); {$I+}
if ioresult<>0 then begin
{$I-} close(fi); {$I+} cc:=ioresult;
ok:=false;
end else begin close(fi); erase(fi); end;
end;
if not ok then print('Can''t use that filename, sorry.') else begin
iscan(pl);
if pl>=uboards[culb].maxfiles then print('This board is full.') else begin
prompt('Upload "'+fn+'" ? ');
if yn then begin ok:=true; close(ulff);
nl; print('Please enter a one line description.'); prompt(':');
inputl(f.description,60);
if (f.description[1]='\') or (rvalidate in thisuser.ac) then culb:=0;
if f.description[1]='\' then f.description:=copy(f.description,2,80);
iscan(pl);
ok:=true; ft:=255;
if uls then receive1('dloads\'+fn,ok);
nl; nl;
if not ok then print('Not saved.') else begin
f.filename:=fn;
f.owner:=usernum;
f.date:=date;
f.daten:=daynum(date);
for x:=1 to 17 do f.res[x]:=0;
for x:=1 to 3 do f.ft[x]:=0;
if ft<>255 then begin
f.ft[1]:=$81; f.ft[2]:=$f5; f.ft[3]:=ft;
end;
assign(fi,'dloads\'+fn);
{$I-} reset(fi); {$I+}
if ioresult=0 then begin
f.blocks:=trunc((longfilesize(fi)+127.0)/128.0);
close(fi);
for x:=pl downto 1 do begin
seek(ulff,x); read(ulff,f1);
seek(ulff,x+1); write(ulff,f1);
end;
seek(ulff,1);
write(ulff,f);
seek(ulff,0); read(ulff,f); f.blocks:=pl+1;
seek(ulff,0); write(ulff,f);
sysoplog('Uploaded "'+fn+'" on '+uboards[culb].name);
print('File successfully uploaded.');
end else begin
print('Oops, system error. Not saved.');
sysoplog('Error uploading "'+fn+'"');
end;
end;
end;
end;
close(ulff); culb:=ob;
end;
nl; nl;
end;
procedure idl;
var i:str;
begin
helpl:='X';
nl; print('Download -'); nl; prompt('Enter filename: '); input(i,12);
dl(i);
nl; nl;
end;
procedure iul;
var i:str;
begin
helpl:='U';
nl; nl; print('Upload -'); nl; prompt('Enter filename: '); input(i,12);
ul(i);
nl; nl;
end;
procedure gfn(var fn:str);
begin
nl; helpl:='L';
prompt('File mask: '); input(fn,12);
if fn='' then fn:='*.*';
fn:=align(fn);
end;
function aln(i:str; n:integer):str;
begin
while length(i)
end;
procedure pfn(f:ulfrec; var abort,next:boolean);
begin
printacr(align(f.filename)+':'+aln(cstr(f.blocks),4)+' :'+f.description,abort,next);
end;
procedure searchb(b:integer; fn:str; var abort:boolean);
var oldboard,pl,rn:integer; f:ulfrec;
begin
oldboard:=culb; culb:=b;
recno(fn,pl,rn);
while (rn<=pl) and (not abort) and (not hangup) and (rn<>0) do begin
seek(ulff,rn); read(ulff,f);
pbn(abort);
pfn(f,abort,next);
nrecno(fn,pl,rn);
end;
close(ulff);
culb:=oldboard;
end;
procedure searchbd(b:integer; ts:str; var abort:boolean);
var oldboard,pl,rn:integer; f:ulfrec; next:boolean;
begin
oldboard:=culb; culb:=b; iscan(pl);
rn:=1;
while (rn<=pl) and (not abort) and (not hangup) do begin
seek(ulff,rn); read(ulff,f);
if pos(ts,uc(f.description))<>0 then begin
pbn(abort);
pfn(f,abort,next);
end;
rn:=rn+1;
end;
close(ulff);
culb:=oldboard;
end;
procedure search;
var fn:str; bn:integer; abort:boolean;
begin
nl; nl; print('Search all directories.');
gfn(fn);
if cs then bn:=0 else bn:=1; abort:=false;
while (not abort) and (bn<=maxulb) and (not hangup) do begin
if uboards[bn].dsl<=thisuser.dsl then searchb(bn,fn,abort);
bn:=bn+1;
end;
end;
procedure searchd;
var fn:str; bn:integer; abort:boolean;
begin
nl; nl; print('Find a description -'); nl;
print('Enter what to search description for.');
helpl:='Y';
prompt(': '); input(fn,20);
if fn<>'' then begin
nl; print('Searching for "'+fn+'"'); nl;
prompt('Search all directories? ');
if yn then begin
if cs then bn:=0 else bn:=1; abort:=false;
while (not abort) and (bn<=maxulb) and (not hangup) do begin
if uboards[bn].dsl<=thisuser.dsl then searchbd(bn,fn,abort);
bn:=bn+1;
end;
end else searchbd(culb,fn,abort);
end;
end;
procedure newfiles(b:integer; var abort:boolean);
var oldboard,pl,rn,ldn:integer; f:ulfrec; next:boolean;
begin
oldboard:=culb; culb:=b; iscan(pl);
ldn:=daynum(ldate);
rn:=1;
while (rn<=pl) and (not abort) and (not hangup) do begin
seek(ulff,rn); read(ulff,f);
if f.daten>=ldn then begin
pbn(abort);
pfn(f,abort,next);
end;
rn:=rn+1;
end;
close(ulff);
culb:=oldboard;
end;
procedure nf;
var bn:integer; abort:boolean;
begin
nl; print('Search for new files.'); nl;
prompt('Search all directories? ');
if yn then begin
if cs then bn:=0 else bn:=1; abort:=false;
while (not abort) and (bn<=maxulb) and (not hangup) do begin
if uboards[bn].dsl<=thisuser.dsl then newfiles(bn,abort);
bn:=bn+1;
end;
end else newfiles(culb,abort);
end;
procedure delete(rn:integer; var pl:integer);
var f:ulfrec; i:integer;
begin
if (rn<=pl) and (rn>0) then begin
pl:=pl-1;
for i:=rn to pl do begin
seek(ulff,i+1); read(ulff,f);
seek(ulff,i); write(ulff,f);
end;
seek(ulff,0); f.blocks:=pl; write(ulff,f);
end;
end;
procedure remove;
var pl,c,rn:integer; f:ulfrec; fn:str; ff:file; u:userrec; tf:boolean;
begin
print('Enter filename to remove.'); prompt(': ');
input(fn,12);
if fn<>'' then begin
recno(fn,pl,rn);
if rn<>0 then begin
seek(ulff,rn); read(ulff,f);
if (usernum=f.owner) or cs then begin
print('Filename: "'+f.filename+'"');
print('Desc. : '+f.description);
print('# blocks: '+cstr(f.blocks));
reset(uf); seek(uf,f.owner); read(uf,u); close(uf);
print('U/L by : '+u.name+' #'+cstr(f.owner));
print('U/L on : '+f.date);
prompt('Delete this? ');
if yn then begin
delete(rn,pl);
if cs then begin
prompt('Erase file too? ');
tf:=yn;
end else tf:=true;
if tf then begin
assign(ff,'dloads\'+fn);
{$I-} erase(ff); {$I+}
c:=ioresult;
end;
end;
end;
end;
close(ulff);
end;
nl; nl;
end;
procedure move;
var pl,c,rn,int,dbn:integer; f:ulfrec; fn:str; ff:file; i:str;
begin
print('Enter filename to move.'); prompt(': ');
input(fn,12);
if fn<>'' then begin
recno(fn,pl,rn);
if rn<>0 then begin
seek(ulff,rn); read(ulff,f);
print(align(f.filename)+' : '+f.description); nl; nl;
prompt('Move this? ');
if yn then begin
nl;
for int:=0 to maxulb do
print(cstr(int)+' : '+uboards[int].name);
nl; nl;
prompt('To which directory? '); input(i,3);
dbn:=value(i); if (dbn=0) and (i<>'0') then dbn:=-1;
if (dbn<0) or (dbn>maxulb) then print('Can''t move it there.')
else begin
delete(rn,pl);
close(ulff);
int:=culb; culb:=dbn; iscan(pl);
seek(ulff,pl+1); write(ulff,f);
seek(ulff,0); f.blocks:=pl+1; write(ulff,f);
culb:=int;
end;
end;
end;
close(ulff);
end;
end;
procedure ren;
var pl,c,rn,int,dbn:integer; f:ulfrec; fn,fd:str; ff:file; i:str;
begin
print('Enter filename to rename.'); prompt(': ');
input(fn,12); nl; nl;
if fn<>'' then begin
recno(fn,pl,rn);
if rn<>0 then begin
seek(ulff,rn); read(ulff,f);
print(align(f.filename)+' : '+f.description); nl; nl;
prompt('Rename this stuff? ');
if yn then begin
prompt('New filename? '); input(fn,12);
if fn<>'' then begin
if exist('dloads\'+fn) then print('Can''t use that filename.') else begin
chdir('dloads'); assign(ff,f.filename); rename(ff,fn); chdir('..');
f.filename:=fn;
end;
end;
print('New description -'); prompt(': '); inputl(fd,60);
if fd<>'' then f.description:=fd;
seek(ulff,rn); write(ulff,f);
end;
end;
close(ulff);
end;
end;
function gtr(f,f1:ulfrec):boolean;
begin
if sortbd and (f1.daten<>f.daten) then
if f1.daten
else
gtr:=true
else
if f1.filename>f.filename then
gtr:=false
else
gtr:=true;
end;
procedure sortd(c:integer);
var oldboard,trn,srn,i,i1,pl:integer; f,f1:ulfrec;
begin
oldboard:=culb; culb:=c; iscan(pl);
nl; print('Sorting '+uboards[culb].name);
for i:=1 to pl-1 do begin
seek(ulff,i); read(ulff,f); trn:=i;
for i1:=i+1 to pl do begin
seek(ulff,i1); read(ulff,f1);
if gtr(f,f1) then begin
f:=f1; trn:=i1;
end;
end;
seek(ulff,i); read(ulff,f1); seek(ulff,i);
write(ulff,f); seek(ulff,trn); write(ulff,f1);
end;
close(ulff);
culb:=oldboard;
end;
procedure sort;
var bn:integer;
begin
nl; nl; prompt('Sort by date? '); if yn then sortbd:=true else sortbd:=false;
nl; prompt('Sort all boards? ');
if yn then
for bn:=0 to maxulb do
sortd(bn)
else
sortd(culb);
end;
procedure listfiles;
var abort:boolean; fn:str;
begin
nl; nl; print('List files.');
gfn(fn); abort:=false;
searchb(culb,fn,abort);
end;
procedure listf(n:integer; var abort:boolean);
var f:ulfrec; i,i1:str; next:boolean;
begin
seek(ulff,n); read(ulff,f);
i:=cstr(n); while length(i)<3 do i:=' '+i;
i:=i+': '+align(f.filename);
while length(i)<20 do i:=i+' ';
i1:=cstr(f.blocks); while length(i1)<5 do i1:=' '+i1; i:=i+i1;
i:=i+' '+f.date+' '; i1:=cstr(f.owner); while length(i1)<3 do i1:=' '+i1;
i:=i+i1;
printacr(i,abort,next);
end;
procedure browsefiles;
var pl,n,nfl,cn:integer; f:ulfrec; i,i1:str; abort,next,list,done:boolean;
begin
iscan(pl); nl; nl; helpl:='B';
print('('+uboards[culb].name+') - '+cstr(pl)+' files');
if pl<>0 then begin
nl; abort:=false; done:=false;
prompt('Start at? '); input(i,3); cn:=value(i); if cn=0 then cn:=1;
if i='Q' then cn:=0; if cn>pl then cn:=0;
if cn>0 then begin list:=true;
repeat
tleft;
if list then begin
if cn>pl then cn:=1;
nfl:=0;
print(' NN: filename.ext blcks mm/dd/yy frm');
while (not hangup) and (nfl<10) and (not abort) and (cn<=pl) do begin
listf(cn,abort); cn:=cn+1; nfl:=nfl+1;
end;
list:=false;
end;
nl; prompt('Browse: (1-'+cstr(pl)+',^'+cstr(cn)+'),U,D,Q,L,? :');
input(i,3); n:=0;
if (i='') and (cn>pl) then i:='Q';
n:=value(i); if (n>0) and (n<=pl) then begin cn:=n; i:='D'; end;
if i='?' then begin print('U:pload D:ownload');
print('Q:uit L:ist files'); end;
if i='Q' then done:=true;
if i='L' then list:=true;
if i='U' then begin close(ulff); iul; iscan(pl); end;
if i='D' then begin
if n=0 then begin print('Download -'); nl; prompt('Which number? ');
input(i1,3); n:=value(i1); end;
if (n>0) and (n<=pl) then dl1(n);
end;
until done or hangup;
end;
end;
close(ulff);
end;
procedure pointdate;
var i:str; n:integer;
begin
nl; nl; nl; helpl:='P';
print('Enter limiting date for new files -');
print('Date is currently set to '+ldate);
print(' mm/dd/yy');
prompt(':'); input(i,8);
nl; nl;
n:=daynum(i);
if n=0 then
print('Illegal date.')
else
ldate:=i;
nl; print('Current limiting date is '+ldate);
end;
procedure listboards;
var b:integer; i:str; abort,next:boolean;
begin
nl;nl; print('Directories available to you:'); nl; nl;
b:=1; abort:=false;
while (b<=maxulb) and (not abort) and (not hangup) do begin
if uboards[b].dsl<=thisuser.dsl then begin
i:=cstr(b);
if length(i)=1 then i:=' '+i;
i:=i+' : '+uboards[b].name;
printacr(i,abort,next);
end;
b:=b+1;
end;
nl;nl;
end;
procedure mmkey(var i:str);
var c:char;
begin
repeat
repeat
getkey(c);
if c=#26 then phelp;
skey(c);
until (((c>=' ') and (c
outkey(c);
thisline:=thisline+c;
if (c='/') or (c='1') then begin
i:=c;
repeat
getkey(c);
if c=#26 then phelp;
skey(c);
until ((c>=' ')and(c<=chr(127))) or (c=chr(13)) or (c=chr(8)) or hangup;
c:=upcase(c);
if c<>chr(13) then begin outkey(c); thisline:=thisline+c; end;
if (c=chr(8)) or (c=chr(127)) then prompt(' '+c);
if c='/' then input(i,20) else if c<>chr(13) then i:=i+c;
end else i:=c;
until (c<>chr(8)) and (c<>chr(127)) or hangup;
nl;
end;
procedure reqchat;
begin
nl;nl; if (not sysop) or (rchat in thisuser.ac)
then begin
print('Sysop not available.');
end else begin
if not chatcall then begin
helpl:='C'; prompt('Reason: '); inputl(i,70);
if i<>'' then begin
sysoplog('Chat: '+i);
print('Chat call now on.');
sound(440); delay(500); nosound;
chatr:=i; chatcall:=true;
end else chatr:='';
end else
begin chatcall:=false; print('Chat call turned off.'); chatr:='';end;
end;
nl;nl; topscr;
end;
procedure yourinfo;
begin
nl; nl;
print('Your name : '+nam);
print('Your SL : '+cstr(thisuser.sl));
print('Your DSL : '+cstr(thisuser.dsl));
print('You D/L''d : '+cstr(thisuser.dk)+'K in '+cstr(thisuser.downloads)+' files');
print('You U/L''d : '+cstr(thisuser.uk)+'K in '+cstr(thisuser.uploads)+' files');
end;
procedure ftmainmenu;
var ii,i:str; int,inte:integer; rl:real;
begin
dump; tleft; nl; nl;
rl:=(seclev[thisuser.sl].ttime*60.0+extratime+timeon-timer);
if rl>32767.0 then rl:=32000; if rl<0.0 then rl:=0;
inte:=trunc(rl);
i:=cstr(inte div 3600)+':'; ii:=cstr((inte mod 3600) div 60);
if length(ii)=1 then ii:='0'+ii; i:='T - '+i+ii+':';
ii:=cstr(inte mod 60); if length(ii)=1 then ii:='0'+ii;
i:=i+ii; print(i);
i:='('+cstr(culb)+')-('+uboards[culb].name+') :';
prompt(i);
helpl:='T';
mmkey(i);
helpl:=#0;
if length(i)=1 then case i[1] of
'?':printfile('gfiles\dlmenu.msg');
'Q':doneft:=true;
'B':browsefiles;
'U':iul;
'D':idl;
'L':listfiles;
'S':search;
'F':searchd;
'C':reqchat;
'O':begin
nl;nl;prompt('Hangup? Sure? '); helpl:='O';
if yn then begin
cls;
printfile('gfiles\logoff.msg');
hangup:=true;
hungup:=false;
end;
end;
'*':listboards;
'P':pointdate;
'N':nf;
'R':remove;
'M':if cs then move;
'V':lfii;
'Y':yourinfo;
end;
if i='/O' then hangup:=true;
if (i='SORT') and cs then sort;
if (i='REN') and cs then ren;
if (i='0') and cs then culb:=0;
int:=value(i); if (int>0) and (int<=maxulb) then
if thisuser.dsl>=uboards[int].dsl then
if (uboards[int].password='') or cs then culb:=int else begin
prompt('Password? '); input(i,10);
if i<>uboards[int].password then
print('Wrong.')
else
culb:=int;
end;
end;
begin
iport; i1; doneft:=false;
while (not doneft) and (not hangup) do
ftmainmenu;
ret:=200;
return;
end.
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/