home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Jason Aller Floppy Collection
/
276.img
/
FORUM21S.ZIP
/
BULLETIN.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-02-13
|
37KB
|
1,554 lines
{$R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }
{$M 65500,0,0 }
unit bulletin;
interface
uses crt,
gentypes,configrt,statret,gensubs,subs1,subs2,
userret,textret,mainr1,mainr2,overret1,flags;
procedure bulletinmenu;
implementation
procedure bulletinmenu;
var q,curbul,lastreadnum:integer;
b:bulrec;
procedure makeboard; forward;
function sponsoron:boolean;
begin
sponsoron:=match(curboard.sponsor,unam)
end;
procedure clearorder (var bo:boardorder);
var cnt:integer;
begin
for cnt:=0 to 255 do bo[cnt]:=cnt
end;
procedure carryout (var bo:boardorder);
var u:userrec;
cnt,un:integer;
procedure doone;
var cnt,q:integer;
ns,a1,a2:set of byte;
begin
fillchar (ns,32,0);
fillchar (a1,32,0);
fillchar (a2,32,0);
for cnt:=0 to 255 do begin
q:=bo[cnt];
if q in u.newscanconfig then ns:=ns+[cnt];
if q in u.access1 then a1:=a1+[cnt];
if q in u.access2 then a2:=a2+[cnt]
end;
u.newscanconfig:=ns;
u.access1:=a1;
u.access2:=a2;
seek (ufile,un);
write (ufile,u)
end;
begin
writeln (^B'Adjusting user access flags...');
seek (ufile,1);
for un:=1 to numusers do begin
if (un mod 10)=0 then write (' ',un);
read (ufile,u);
if length(u.handle)>0 then doone
end
end;
procedure switchboards (bnum1,bnum2:integer; var bo:boardorder);
var bd1,bd2:boardrec;
n1:integer;
begin
seekbdfile (bnum1);
read (bdfile,bd1);
seekbdfile (bnum2);
read (bdfile,bd2);
seekbdfile (bnum1);
writebdfile (bd2);
seekbdfile (bnum2);
writebdfile (bd1);
n1:=bo[bnum1];
bo[bnum1]:=bo[bnum2];
bo[bnum2]:=n1
end;
procedure setfirstboard; forward;
procedure seekffile (n:integer);
begin
seek (ffile,n-1)
end;
function numfiles:integer;
begin
numfiles:=filesize (ffile)
end;
procedure assignffile;
begin
assign (ffile,boarddir+curboardname+'.FIL')
end;
procedure formatffile;
begin
close (ffile);
assignffile;
rewrite (ffile)
end;
procedure openffile;
var f:filerec;
i:integer;
begin
close (ffile);
assignffile;
reset (ffile);
i:=ioresult;
if i<>0 then formatffile
end;
procedure addfile (f:filerec);
begin
seekffile (numfiles+1);
write (ffile,f)
end;
procedure delfile (fn:integer);
var f:filerec;
cnt:integer;
begin
for cnt:=fn to numfiles-1 do begin
seekffile (cnt+1);
read (ffile,f);
seekffile (cnt);
write (ffile,f)
end;
seekffile (numfiles);
truncate (ffile)
end;
procedure seekbfile (n:integer);
begin
seek (bfile,n-1); che
end;
function numbuls:integer;
begin
numbuls:=filesize(bfile)
end;
procedure getlastreadnum;
var oldb:boolean;
b:bulrec;
lr:word;
begin
lastreadnum:=numbuls;
oldb:=false;
lr:=urec.lastread[curboardnum];
if lr=0
then lastreadnum:=0
else
while (lastreadnum>0) and (not oldb) do begin
seekbfile (lastreadnum);
read (bfile,b);
oldb:=b.id=lr;
if not oldb then lastreadnum:=lastreadnum-1
end
end;
procedure assignbfile;
begin
assign (bfile,boarddir+curboardname+'.BUL')
end;
procedure formatbfile;
begin
assignbfile;
rewrite (bfile);
curboardnum:=searchboard(curboardname);
if curboardnum=-1 then begin
curboardnum:=filesize(bdfile);
fillchar (curboard,sizeof(curboard),0);
writecurboard
end
end;
procedure openbfile;
var b:bulrec;
i:integer;
begin
curboardnum:=searchboard (curboardname);
if curboardnum=-1 then begin
makeboard;
exit
end;
close (bfile);
assignbfile;
reset (bfile);
i:=ioresult;
if ioresult<>0 then formatbfile;
seekbdfile (curboardnum);
read (bdfile,curboard);
getlastreadnum;
openffile
end;
function boardexist(n:sstr):boolean;
begin
boardexist:=not (searchboard(n)=-1)
end;
procedure addbul (var b:bulrec);
var b2:bulrec;
begin
if numbuls=0 then b.id:=1 else begin
seekbfile (numbuls);
read (bfile,b2);
if b2.id=65535
then b.id:=1
else b.id:=b2.id+1
end;
seekbfile (numbuls+1);
write (bfile,b)
end;
function checkcurbul:boolean;
begin
if (curbul<1) or (curbul>numbuls) then begin
checkcurbul:=false;
curbul:=0
end else checkcurbul:=true
end;
procedure getbrec;
begin
if checkcurbul then begin
seekbfile (curbul);
read (bfile,b); che
end
end;
procedure delbul (bn:integer; deltext:boolean);
var c,un:integer;
b:bulrec;
u:userrec;
begin
if (bn<1) or (bn>numbuls) then exit;
seekbfile (bn);
read (bfile,b);
if deltext then deletetext (b.line);
for c:=bn to numbuls-1 do begin
seekbfile (c+1);
read (bfile,b);
seekbfile (c);
write (bfile,b)
end;
seekbfile (numbuls);
truncate (bfile);
getlastreadnum
end;
procedure delboard (bdn:integer);
var bd1:boardrec;
cnt,nbds:integer;
bo:boardorder;
begin
clearorder (bo);
nbds:=filesize(bdfile)-1;
if nbds=0 then begin
close (bdfile);
rewrite (bdfile);
exit
end;
for cnt:=bdn to nbds-1 do begin
seekbdfile (cnt+1);
read (bdfile,bd1);
seekbdfile (cnt);
writebdfile (bd1);
bo[cnt]:=cnt+1
end;
seek (bdfile,nbds);
truncate (bdfile);
seek (bifile,nbds);
truncate (bifile);
carryout (bo)
end;
procedure sendfile (fn:integer);
var f:filerec;
cnt:integer;
k:char;
q:file of byte;
label exit;
begin
seekffile (fn);
read (ffile,f);
assign (q,f.fname);
reset (q);
iocode:=ioresult;
if iocode<>0 then begin
fileerror (f.fname,'SENDFILE (Ascii download)');
goto exit
end;
writelog (4,1,f.descrip);
writeln ('File: '^S,f.descrip);
writeln ('Uploaded by: '^S,f.sentby);
writeln ('Downloaded: '^s,f.downloaded);
writeln ('File size: '^S,filesize(q),' characters'^M);
writeln (^B'Press space when you''re ready, or [X] to abort...');
repeat
repeat until charready;
k:=readchar;
if hungupon then goto exit;
if upcase(k)='X' then goto exit
until k=' ';
if not hungupon
then
begin
printfile (f.fname);
f.downloaded:=f.downloaded+1;
seekffile (fn);
write (ffile,f);
writeln (^B^M+asciidownload+^M'Press a key...');
repeat until charready;
k:=readchar
end;
exit:
close (q)
end;
procedure receivefile (f:filerec);
var fn:lstr;
cnt,timeul:integer;
k:char;
done:boolean;
fff:text;
last3:array [1..3] of char;
procedure putchar (k:char);
begin
write (fff,k);
write (usr,k)
end;
begin
fn:='';
cnt:=1;
timeul:=timer;
repeat
if cnt<=length(f.descrip) then begin
k:=upcase(f.descrip[cnt]);
if k in ['A'..'Z'] then fn:=fn+k
end;
cnt:=cnt+1
until cnt>length(f.descrip);
if fn='' then fn:='Noname';
fn:=copy(fn,1,8);
while devicename(fn) do fn:=fn+chr(random(26)+64);
fn:=uploaddir+fn+'.';
cnt:=0;
repeat
cnt:=cnt+1
until (cnt=1000) or (not exist(fn+strr(cnt)));
if cnt=1000 then begin
writeln ('Please try another description!');
exit
end;
fn:=fn+strr(cnt);
assign (fff,fn);
rewrite (fff);
iocode:=ioresult;
if iocode<>0 then begin
error ('%I opening %1 in RECEIVEFILE (ASCII upload)','',fn);
exit
end;
f.fname:=fn;
f.sentby:=unam;
f.downloaded:=0;
f.when:=now;
writeln (^B'ASCII receive ready.'^M,
'Press [CR] and /E to end, /X to abort.'^M);
textcolor (outlockcolor);
repeat
repeat until charready;
if hungupon
then done:=true
else
begin
k:=chr(ord(readchar) and 127);
last3[1]:=last3[2];
last3[2]:=last3[3];
last3[3]:=upcase(k);
done:=((last3[1]=^M) or (last3[1]=^J))
and (last3[2]='/') and ((last3[3]='E') or (last3[3]='X'));
if not done then begin
if (last3[2]=^M) and (k<>^J) then putchar (^J);
if last3[2]='/' then putchar ('/');
if k<>'/'
then putchar (k)
end
end
until done;
textclose (fff);
textcolor (normbotcolor);
if last3[3]='E' then begin
addfile (f);
timeul:=timer-timeul;
if timeul<0 then timeul:=timeul+1440;
writeln (^B^M'That upload took ',timeul,' minutes.');
logontime:=logontime+timeul;
writelog (4,2,f.descrip)
end else begin
writestr (^M^M'Upload aborted!');
erase (fff);
iocode:=ioresult
end
end;
procedure readcurbul;
var q:anystr;
t:sstr;
cnt:integer;
begin
if checkcurbul then begin
getbrec;
writeln (^B'Bulletin '^S,curbul,^M'Title: '^S,b.title);
q:='Left by '^S;
if b.anon
then
begin
q:=q+anonymousstr;
if issysop then q:=q+' ('+b.leftby+')'
end
else
begin
if b.plevel=-1
then t:='unknown'
else t:=strr(b.plevel);
q:=q+b.leftby+' (Level '+t+')'
end;
if issysop or (not b.anon)
then writeln ('When: '^S,datestr(b.when),' at ',timestr(b.when));
writeln (q);
if break then exit;
printtext (b.line)
end;
if curbul>lastreadnum then begin
lastreadnum:=curbul;
urec.lastread[curboardnum]:=b.id
end
end;
function queryaccess:accesstype;
begin
queryaccess:=getuseraccflag (urec,curboardnum)
end;
procedure autodelete;
var cnt:integer;
begin
writeln ('Erasing first five posts...');
for cnt:=6 downto 2 do delbul (cnt,true)
end;
procedure postbul;
var l:integer;
m:message;
b:bulrec;
begin
if ulvl<postlevel then begin
reqlevel(postlevel);
exit
end;
l:=editor(m,true);
if l>=0 then
begin
urec.nbu:=urec.nbu+1;
writeurec;
b.anon:=m.anon;
b.title:=m.title;
b.when:=now;
b.leftby:=unam;
b.line:=l;
b.plevel:=ulvl;
addbul (b);
newposts:=newposts+1;
with curboard do
if autodel<=numbuls then autodelete
end
end;
procedure getbnum (txt:mstr);
var q:boolean;
begin
if length(input)>1
then curbul:=valu(copy(input,2,255))
else begin
writestr (^M'Bulletin to '+txt+':');
curbul:=valu(input)
end;
q:=checkcurbul
end;
procedure readbul;
begin
getbnum ('read');
readcurbul
end;
procedure readnextbul;
var t:integer;
begin
t:=curbul;
curbul:=curbul+1;
readcurbul;
if curbul=0 then curbul:=t
end;
procedure readnum (n:integer);
begin
curbul:=n;
readcurbul
end;
function haveaccess (n:integer):boolean;
var a:accesstype;
begin
curboardnum:=n;
seekbdfile (n);
read (bdfile,curboard);
a:=queryaccess;
if a=bylevel
then haveaccess:=ulvl>=curboard.level
else haveaccess:=a=letin
end;
procedure makeboard;
begin
formatbfile;
formatffile;
with curboard do begin
shortname:=curboardname;
buflen:=30;
writestr (^M'Board name: &');
boardname:=input;
buflen:=30;
writestr ('Sponsor (C/R for '+unam+'):');
if input='' then input:=unam;
sponsor:=input;
writestr ('Minimum level for entry:');
level:=valu(input);
writestr ('Autodelete after:');
autodel:=valu(input);
if autodel<10 then begin
writeln ('Must be at least 10!');
autodel:=10
end;
setallflags (curboardnum,bylevel);
writecurboard;
writeln ('Board created.');
writelog (4,4,boardname+' ['+shortname+']')
end
end;
procedure setactive (nn:sstr);
procedure doswitch;
begin
openbfile;
curbul:=lastreadnum;
with curboard do
writeln (^M'Sub-board: '^S,boardname,
^M'Sponsor: '^S,sponsor,
^M'Bulletins: '^S,numbuls,
^M'Last read: '^S,lastreadnum,
^M'Files: '^S,numfiles,^M)
end;
procedure tryswitch;
var n,s:integer;
procedure denyaccess;
var b:bulrec;
begin
reqlevel (curboard.level);
setfirstboard
end;
begin
curboardname:=nn;
curboardnum:=searchboard(nn);
if haveaccess(curboardnum)
then doswitch
else denyaccess
end;
var b:bulrec;
begin
curbul:=0;
close (bfile);
close (ffile);
curboardname:=nn;
if boardexist(nn) then tryswitch else begin
writeln ('No such board: ',curboardname,'!');
if issysop
then
begin
writestr (^M'Create one (Y/N)? *');
if yes
then
begin
makeboard;
setactive (curboardname)
end
else setfirstboard
end
else setfirstboard
end
end;
function validbname (n:sstr):boolean;
var cnt:integer;
begin
validbname:=false;
if (length(n)=0) or (length(n)>8) then exit;
for cnt:=1 to length(n) do
if not (upcase(n[cnt]) in ['0'..'9','A'..'Z']) then exit;
validbname:=true
end;
procedure listboards;
var cnt,oldcurboard:integer;
printed:boolean;
begin
oldcurboard:=curboardnum;
writeln (^M'Number Name Level'^M);
if break then exit;
for cnt:=0 to filesize(bdfile)-1 do
if haveaccess(cnt) then
with curboard do begin
tab (shortname,9);
tab (boardname,26);
writeln (level);
if break then exit
end;
curboardnum:=oldcurboard;
seekbdfile (curboardnum);
read (bdfile,curboard)
end;
procedure activeboard;
begin
if length(input)>1
then input:=copy(input,2,255)
else
repeat
writestr (^M^M'Board number [?=List]:');
if input='?' then listboards
until (input<>'?') or hungupon;
if hungupon or (length(input)=0) then exit;
if input[1]='*' then input:=copy(input,2,255);
if validbname(input)
then setactive (input)
else
begin
writeln (^M'Invalid board name!');
setfirstboard
end
end;
procedure setfirstboard; { FORWARD }
var fbn:sstr;
begin
if filesize(bdfile)=0 then exit;
if not haveaccess(0)
then error ('User can''t access first board','','');
seek (bifile,0);
read (bifile,fbn);
setactive (fbn)
end;
procedure listbuls;
var cnt,bn:integer;
q:boolean;
begin
if length(input)>1 then begin
curbul:=valu(copy(input,2,255));
q:=checkcurbul
end;
if curbul=0
then
begin
writestr (^M'List titles starting at #*');
curbul:=valu(input)
end
else
if length(input)>1
then curbul:=valu(input)
else curbul:=curbul+10;
if not checkcurbul then curbul:=1;
writeln ('Titles:'^M);
for cnt:=0 to 9 do
begin
bn:=curbul+cnt;
if (bn>0) and (bn<=numbuls) then
begin
seekbfile (bn);
read (bfile,b);
write (bn,'. ',b.title,' by ');
if b.anon
then writeln (anonymousstr)
else writeln (b.leftby);
if break then exit
end
end
end;
procedure killbul;
var un:integer;
u:userrec;
begin
writehdr ('Bulletin Deletion');
getbnum ('delete');
if not checkcurbul then exit;
getbrec;
if (not match(b.leftby,unam)) and (not issysop) and (not sponsoron)
then begin
writeln ('You didn''t post that!');
exit
end;
writeln ('Title: ',b.title,
^M'Left by: ',b.leftby,^M^M);
writestr ('Delete this? *');
if not yes then exit;
un:=lookupuser (b.leftby);
if un<>0 then begin
writeurec;
seek (ufile,un);
read (ufile,u);
u.nbu:=u.nbu-1;
seek (ufile,un);
write (ufile,u);
readurec
end;
delbul (curbul,true);
writeln ('Bulletin deleted.');
writelog (4,5,b.title)
end;
procedure editbul;
var me:message;
begin
getbnum ('edit');
if not checkcurbul then exit;
getbrec;
if (not match(b.leftby,unam)) and (not issysop) and (not sponsoron)
then begin
writeln ('You didn''t post that!');
exit
end;
reloadtext (b.line,me);
me.title:=b.title;
me.anon:=b.anon;
if reedit (me,true) then begin
writelog (4,6,b.title);
deletetext (b.line);
b.line:=maketext (me);
if b.line<0 then begin
writestr (^M'Deleting bulletin...');
delbul (curbul,false)
end else begin
seekbfile (curbul);
write (bfile,b)
end
end
end;
procedure sendbreply;
begin
if checkcurbul then begin
getbrec;
sendmailto (b.leftby,b.anon)
end else begin
getbnum ('reply to');
if checkcurbul then sendbreply
end
end;
procedure listfiles;
var cnt,r1,r2,nfiles:integer;
f:filerec;
begin
nfiles:=numfiles;
thereare (nfiles,'file','files');
if nfiles=0 then exit;
parserange (nfiles,r1,r2);
if r1=0 then exit;
for cnt:=r1 to r2 do begin
seekffile (cnt);
read (ffile,f); che;
writeln (cnt,'. ',f.descrip);
if break then exit
end
end;
function getfilenumber (txt:lstr):integer;
var fn:integer;
gotten:boolean;
begin
getfilenumber:=0;
input:=copy(input,2,255);
if length(input)=0 then
repeat
gotten:=true;
writestr (^M'File number to '+txt+' [?=List]:');
if input='?' then
begin
writeln;
listfiles;
writeln;
gotten:=false
end
until gotten;
fn:=valu(input);
if (fn<1) or (fn>numfiles) then fn:=0;
getfilenumber:=fn
end;
procedure downloadfile;
var fn:integer;
begin
fn:=getfilenumber ('download');
if fn<>0 then
begin
sendfile (fn);
urec.ndn:=urec.ndn+1
end;
end;
procedure uploadfile;
var f:filerec;
begin
writestr ('Describe the file'+^M+'=> *');
if length(input)<>0 then begin
f.descrip:=input;
receivefile (f);
urec.nup:=urec.nup+1
end
end;
procedure boardsponsor;
procedure getbgen (txt:mstr; var q);
var s:lstr absolute q;
begin
writeln (^B'Current ',txt,': ',s);
buflen:=30;
writestr ('Enter new '+txt+':');
if length(input)>0 then s:=input
end;
procedure getbint (txt:mstr; var i:integer);
var a:anystr;
begin
a:=strr(i);
getbgen (txt,a);
i:=valu(a);
writecurboard
end;
procedure getbstr (txt:mstr; var q);
begin
getbgen (txt,q);
writecurboard
end;
procedure setacc (ac:accesstype; un:integer);
var u:userrec;
begin
seek (ufile,un);
read (ufile,u);
setuseraccflag (u,curboardnum,ac);
seek (ufile,un);
write (ufile,u)
end;
function queryacc (un:integer):accesstype;
var u:userrec;
begin
seek (ufile,un);
read (ufile,u);
queryacc:=getuseraccflag (u,curboardnum)
end;
procedure setnameaccess;
var un,n:integer;
ac:accesstype;
q,unm:mstr;
begin
writestr (^M'Change access for user:');
un:=lookupuser(input);
if un=0 then begin
writeln ('No such user!');
exit
end;
unm:=input;
ac:=queryacc(un);
writeln (^B^M'Current access: ',accessstr[ac]);
getacflag (ac,q);
if ac=invalid then exit;
if un=unum then writeurec;
setacc (ac,un);
if un=unum then readurec;
case ac of
letin:n:=1;
keepout:n:=2;
bylevel:n:=3
end;
writelog (5,n,unm)
end;
procedure setallaccess;
var cnt:integer;
ac:accesstype;
q:mstr;
begin
writehdr ('Set Everyone''s Access');
getacflag (ac,q);
if ac=invalid then exit;
writeurec;
setallflags (curboardnum,ac);
readurec;
writeln ('Done.');
writelog (5,4,accessstr[ac])
end;
procedure listaccess;
procedure listacc (all:boolean);
var cnt:integer;
a:accesstype;
u:userrec;
procedure writeuser;
begin
if all
then
begin
tab (u.handle,30);
if a=bylevel
then writeln ('Level='+strr(u.level))
else writeln ('Let in')
end
else writeln (u.handle)
end;
begin
seek (ufile,1);
for cnt:=1 to numusers do begin
read (ufile,u);
a:=getuseraccflag (u,curboardnum);
case a of
letin:writeuser;
bylevel:if all and (u.level>=curboard.level) then writeuser
end;
if break then exit
end
end;
begin
writestr (
'List A)ll users who have access, or only those with S)pecial access? *');
if length(input)=0 then exit;
case upcase(input[1]) of
'A':listacc (true);
'S':listacc (false)
end
end;
procedure getblevel;
var b:bulrec;
begin
getbint ('level',curboard.level);
writelog (5,12,strr(curboard.level))
end;
procedure getautodel;
var b:bulrec;
begin
with curboard do begin
getbint ('auto-delete',autodel);
if autodel<10
then
begin
writeln (^B'HEY! It can''t be less than ten!');
autodel:=numbuls+1;
if autodel<10 then autodel:=10;
writeln (^B'Setting autodelete to ',autodel);
writecurboard
end
else
if autodel<=numbuls
then
begin
writeln (^B'Deleting bulletins...');
while autodel<=numbuls do delbul (2,true)
end
end;
writelog (5,11,strr(curboard.autodel))
end;
procedure getfiletitle;
var fn:integer;
f:filerec;
begin
fn:=getfilenumber ('change the title of');
if fn<>0 then begin
seekffile (fn);
read (ffile,f); che;
writeln (^B'Old description: ',f.descrip);
writestr ('New description [or CR]:');
if length(input)>0 then begin
f.descrip:=input;
seekffile (fn);
write (ffile,f);
writelog (5,9,f.descrip)
end
end
end;
procedure movefile;
var f:filerec;
tcb:boardrec;
tcbn,dbn,fn:integer;
tcbname:sstr;
begin
writehdr ('File Move');
fn:=getfilenumber ('move');
if fn=0 then exit;
seekffile (fn);
read (ffile,f);
writestr ('Move "'+f.descrip+'" to which board? *');
if length(input)=0 then exit;
tcb:=curboard;
tcbn:=curboardnum;
tcbname:=curboardname;
dbn:=searchboard(input);
if dbn=-1 then begin
writeln ('No such board!');
exit
end;
writeln ('Moving...');
delfile (fn);
close (bfile);
close (ffile);
seek (bdfile,dbn);
read (bdfile,curboard);
curboardnum:=dbn;
curboardname:=curboard.shortname;
openbfile;
addfile (f);
close (bfile);
close (ffile);
curboard:=tcb;
curboardname:=tcbname;
curboardnum:=tcbn;
openbfile;
writelog (5,6,f.descrip);
writeln (^B'Done!')
end;
procedure movebulletin;
var b:bulrec;
tcb:boardrec;
tcbn,dbn,bnum:integer;
tcbname,dbname:sstr;
begin
writehdr ('Bulletin Move');
getbnum ('move');
if not checkcurbul then exit;
bnum:=curbul;
seekbfile (bnum);
read (bfile,b);
writestr ('Move "'+b.title+'" posted by '+b.leftby+
' to which board? *');
if length(input)=0 then exit;
tcbname:=curboardname;
dbname:=input;
dbn:=searchboard(dbname);
if dbn=-1 then begin
writeln ('No such board!');
exit
end;
writeln ('Moving...');
delbul (bnum,false);
close (bfile);
close (ffile);
curboardname:=dbname;
openbfile;
addbul (b);
close (bfile);
close (ffile);
curboardname:=tcbname;
openbfile;
writelog (5,13,b.title);
writeln (^B'Done!')
end;
procedure wipeoutfile;
var un,fn:integer;
f:filerec;
q:file;
n:mstr;
u:userrec;
begin
writehdr ('File Wipe-out');
fn:=getfilenumber ('wipe out');
if fn=0 then exit;
seekffile (fn);
read (ffile,f);
writestr ('Wipe out: "'+f.descrip+'" ? *');
if not yes then exit;
writestr ('Erase disk file '+f.fname+'? *');
if yes then begin
assign (q,f.fname);
erase (q);
un:=ioresult
end;
delfile (fn);
writelog (5,7,f.descrip);
n:=f.sentby;
un:=lookupuser(n);
if un<>0
then
begin
seek (ufile,un);
read (ufile,u);
u.nup:=u.nup-1;
writeln (n,' now has ',u.nup,' uploads.');
seek (ufile,un);
write (ufile,u)
end
end;
procedure setsponsor;
var un:integer;
b:bulrec;
begin
writestr ('New sponsor:');
if length(input)=0 then exit;
un:=lookupuser (input);
if un=0
then writeln ('No such user.')
else
begin
curboard.sponsor:=input;
writelog (5,8,input);
writecurboard
end
end;
procedure renameboard;
var sn:sstr;
nfp,nbf,nff:lstr;
qf:file;
d:integer;
begin
getbstr ('board name',curboard.boardname);
sn:=curboard.shortname;
getbgen ('access name/number',sn);
writelog (5,5,curboard.boardname+' ['+sn+']');
if match(sn,curboard.shortname) then exit;
if not validbname(sn) then begin
writeln ('Invalid board name!');
exit
end;
if boardexist(sn) then begin
writeln ('Sorry! Board already exists!');
exit
end;
curboard.shortname:=sn;
writecurboard;
close (bfile);
close (ffile);
nfp:=boarddir+sn+'.';
nbf:=nfp+'BUL';
nff:=nfp+'FIL';
assign (qf,nbf);
erase (qf);
d:=ioresult;
assign (qf,nff);
erase (qf);
d:=ioresult;
rename (bfile,nbf);
rename (ffile,nff);
setfirstboard;
q:=9
end;
procedure killboard;
var cnt:integer;
f:file;
fr:filerec;
bd:boardrec;
begin
writestr ('Kill board: Are you sure? *');
if not yes then exit;
writelog (5,10,'');
writeln (^B^M'Deleting messages...');
for cnt:=numbuls downto 1 do
begin
delbul(cnt,true);
write (cnt,' ')
end;
writeln (^B^M'Deleting files...');
for cnt:=numfiles downto 1 do
begin
seekffile (cnt);
read (ffile,fr);
assign (f,fr.fname);
erase (f);
if ioresult<>0 then writeln (^B'Error erasing ',fr.fname);
delfile (cnt);
write (cnt,' ')
end;
writeln (^B^M'Deleting sub-board files...');
close (bfile);
assignbfile;
erase (bfile);
if ioresult<>0 then writeln (^B'Error erasing board file.');
close (ffile);
assignffile;
erase (ffile);
if ioresult<>0 then writeln (^B'Error erasing file directory file.');
writeln (^M'Removing sub-board...');
delboard (curboardnum);
writeln (^B'Sub-board erased!');
setfirstboard;
q:=9
end;
procedure sortboards;
var cnt,mark,temp:integer;
bd1,bd2:boardrec;
bn1,bn2:sstr;
bo:boardorder;
begin
writestr ('Sort sub-boards: Are you sure? *');
if not yes then exit;
clearorder (bo);
mark:=filesize(bdfile)-1;
repeat
if mark<>0 then begin
temp:=mark;
mark:=0;
for cnt:=0 to temp-1 do begin
seek (bifile,cnt);
read (bifile,bn1);
read (bifile,bn2);
if upstring(bn1)>upstring(bn2) then begin
mark:=cnt;
switchboards (cnt,cnt+1,bo)
end
end
end
until mark=0;
carryout (bo);
writelog (5,16,'');
setfirstboard;
q:=9
end;
procedure orderboards;
var numb,curb,newb:integer;
bo:boardorder;
label exit;
begin
clearorder (bo);
writehdr ('Re-order sub-boards');
numb:=filesize (bdfile);
thereare (numb,'sub-board','sub-boards');
for curb:=0 to numb-2 do begin
repeat
writestr ('New board #'+strr(curb+1)+' [?=List, CR to quit]:');
if length(input)=0 then goto exit;
if input='?'
then
begin
listboards;
newb:=-1
end
else
begin
newb:=searchboard(input);
if newb<0 then writeln ('Not found! Please re-enter...')
end
until (newb>=0);
switchboards (curb,newb,bo)
end;
exit:
carryout (bo);
writelog (5,14,'');
q:=9;
setfirstboard
end;
procedure addresident;
var f:filerec;
begin
writestr ('Filename (including path):');
if hungupon or (length(input)=0) then exit;
if devicename(input) then begin
writeln ('That''s a DOS device name !');
exit
end;
if not exist(input) then begin
writeln ('File not found.');
exit
end;
f.sentby:=unam;
f.fname:=input;
writestr ('Description:');
if length(input)=0 then exit;
f.descrip:=input;
f.downloaded:=0;
f.when:=now;
addfile (f);
writelog (5,15,f.fname)
end;
begin
if (not sponsoron) and (not issysop) then begin
writeln ('Nice try, except you aren''t the sponsor.');
exit
end;
writelog (4,3,curboard.boardname+' ['+curboard.shortname+']');
repeat
q:=menu ('Sponsor','SPONSOR','DLSTMWUEQRKC@BO@VA@H');
case q of
1:getautodel;
2:getblevel;
3:setsponsor;
4:getfiletitle;
5:movefile;
6:wipeoutfile;
7:setnameaccess;
8:setallaccess;
10:renameboard;
11:killboard;
12:sortboards;
13:movebulletin;
14:orderboards;
15:listaccess;
16:addresident;
17:help ('Sponsor.hlp')
end
until (q=9) or hungupon
end;
var beenaborted:boolean;
function aborted:boolean;
begin
if beenaborted then begin
aborted:=true;
exit
end;
aborted:=xpressed or hungupon;
if xpressed then begin
beenaborted:=true;
writeln (^B'Newscan aborted!')
end
end;
procedure newscanboard;
procedure shownewfiles;
var cnt,first,numf:integer;
f:filerec;
nf:boolean;
begin
numf:=numfiles;
cnt:=numf;
nf:=true;
while (cnt>0) and nf do begin
seekffile (cnt);
read (ffile,f);
nf:=f.when>laston;
if nf then cnt:=cnt-1
end;
first:=cnt+1;
if first>numf then exit;
writehdr ('New files');
if aborted or break then exit;
for cnt:=first to numf do begin
seekffile (cnt);
read (ffile,f);
writeln (cnt,'. ',f.descrip);
if aborted or break then exit
end
end;
var newmsgs:boolean;
oldb:boolean;
begin
beenaborted:=false;
newmsgs:=false;
curbul:=lastreadnum+1;
while curbul<=numbuls do begin
getbrec;
if b.when>laston then begin
readnum (curbul);
newmsgs:=true
end;
curbul:=curbul+1;
if aborted then exit
end;
shownewfiles;
if (postprompts in urec.config) and newmsgs and (ulvl>=postlevel)
then begin
writestr (^M'Post now? *');
writeln;
if yes then postbul
end
end;
procedure newscanall;
var cb:integer;
begin
beenaborted:=false;
writehdr ('New-scanning. [X] to abort.');
if aborted then exit;
for cb:=0 to filesize(bdfile)-1 do begin
if aborted then exit;
if haveaccess(cb) and (not (cb in urec.newscanconfig)) then begin
curboardname:=curboard.shortname;
openbfile;
if aborted then exit;
writeln (^B^M'Scanning ',curboard.boardname,'...'^M);
if aborted then exit;
newscanboard
end
end;
writeln (^B^M'Newscan complete!'^G);
setfirstboard
end;
procedure noboards;
begin
writeln ('No sub-boards exist!');
if not issysop then exit;
writestr ('Create the first sub-board now? *');
if not yes then exit;
writestr ('Enter its access name/number:');
if not validbname(input) then writeln (^B'Invalid board name!') else begin
curboardname:=input;
makeboard
end
end;
procedure togglenewscan;
begin
write ('Newscan this board: ');
if curboardnum in urec.newscanconfig
then
begin
writeln ('Yes');
urec.newscanconfig:=urec.newscanconfig-[curboardnum]
end
else
begin
writeln ('No');
urec.newscanconfig:=urec.newscanconfig+[curboardnum]
end
end;
procedure nextsubboard;
var cb:integer;
obn:sstr;
begin
obn:=curboardname;
cb:=curboardnum;
while cb<filesize(bdfile)-1 do begin
cb:=cb+1;
if haveaccess (cb) then begin
seek (bifile,cb);
read (bifile,obn);
setactive (obn);
exit
end
end;
writestr ('This is the last sub-board!');
setactive (obn)
end;
var boo:boolean;
label exit;
begin
cursection:=bulletinsysop;
openbdfile;
if filesize(bdfile)=0 then begin
noboards;
if filesize(bdfile)=0 then begin
closebdfile;
goto exit
end
end;
if not haveaccess(0)
then
begin
writeln (^B'You do not have access to the first sub-board!');
closebdfile;
goto exit
end;
setfirstboard;
repeat
boo:=checkcurbul;
with curboard do
writeln (^M,boardname,' [',shortname,']: ',curbul,' of ',numbuls);
if sponsoron or issysop
then writeln ('%: Board sponsor commands');
q:=menu ('Bulletin','BULLET','PRDFUKT*MQ#_%LNBAVCHES+W');
case q of
1:postbul;
2:readbul;
3:downloadfile;
4,22:sendmailto (curboard.sponsor,false);
5:uploadfile;
6:killbul;
8,16,17:activeboard;
7:listbuls;
9:sendbreply;
12:if not hungupon then readnextbul;
13:boardsponsor;
14:listfiles;
15:newscanall;
18:newscanboard;
19:togglenewscan;
20:help ('Bulletin.hlp');
21:editbul;
23:nextsubboard;
24:readnum (lastreadnum+1);
else if q<0 then readnum (-q)
end
until (q=10) or hungupon or (filesize(bdfile)=0);
exit:
close (bfile);
close (ffile);
closebdfile
end;
begin
end.