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
/
MSG.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-05-04
|
69KB
|
2,403 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,O+ }
{$M 65500,0,0 }
unit msg;
interface
uses crt,dos,overlay,
gentypes,configrt,statret,gensubs,subs1,subs2,subs3,
userret,textret,mainr1,mainr2,overret1,flags,mainmenu,modem;
procedure messagemenu;
implementation
procedure messagemenu;
var q,curbul,lastreadnum:integer;
b:bulrec;
reading,quitmasterinc,cscan:boolean;
procedure togglecscan;
begin
if cscan then cscan:=false else
cscan:=true;
writeln;
write (^R'Auto-Scan is now: '^S);
if cscan then writeln ('On') else writeln ('Off');
writeln;
end;
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,datadir+copy(curboardname,1,8)+'.FI'+strr(conn));
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,datadir+copy(curboardname,1,8)+'.MS'+strr(conn));
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 are 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 getbnum (txt:mstr);
var q:boolean;
begin
if length(input)>1
then curbul:=valu(copy(input,2,255))
else begin
writestr (^M'Message to '+txt+':');
curbul:=valu(input)
end;
q:=checkcurbul
end;
procedure killbul;
var un:integer;
u:userrec;
begin
writehdr ('Message Deletion');
if not reading then
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 ('Subject: ',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);
if messages<1 then messages:=1;
messages:=messages-1;
if urec.lastmessages<1 then urec.lastmessages:=1;
urec.lastmessages:=urec.lastmessages-1;
writeln ('Message deleted.');
writelog (4,5,b.title)
end;
procedure autodelete;
begin
writeln (^R'Erasing first post '^P'-'^R' Please wait.');
delbul (1,true)
end;
function wipe(amount:byte):string;
var z:integer;
gee:string[80];
begin
for z:=1 to amount do gee:=gee+' ';
wipe:=gee;
end;
procedure postbul;
var l:integer;
m:message;
b:bulrec;
ds:longint;
begin
if ulvl<postlevel then begin
reqlevel(postlevel);
exit
end;
l:=editor(m,true,'');
if l>=0 then
begin
inc(urec.nbu);
writeurec;
if messages>32760 then messages:=0;
inc(messages);
b.anon:=m.anon;
b.title:=m.title;
b.when:=now;
b.leftby:=unam;
b.status:='['+urec.note+']';
if sponsoron then b.status:=b.status+' [Sponsor]';
b.recieved:=false;
b.leftto:=m.leftto;
b.line:=l;
b.plevel:=ulvl;
b.id:=curboard.net;
if (curboard.net>0) and (usenet) and (featurea) then begin b.where:=^R+'CelerityNet V'+netver+' - '+longname;
b.where2:=^R+netcomment; end;
addbul (b);
inc(newposts);
with curboard do
if autodel<=numbuls then autodelete;
if (curboard.net>0) and (usenet) and (featurea) then
writeln(^R'This post will be visible in all CelerityNet Boards.')
end
end;
procedure readcurbul;
var q:anystr;
t:sstr;
cnt,emusux,anarkyamerika:integer;
oligarch:mstr;
begin
q:=wipe(80);
if checkcurbul then begin
getbrec;
if (ansi and not cscan) then begin
clearscr;
end;
write (^B^M^R'Message'^P': '^S);
oligarch:=^S+strr(curbul)+^R' of '^S+strr(numbuls);
write (oligarch);
for emusux:=1 to 32-(length(oligarch)) do
write (' ');
write (^R'Posted '^P': ');
if issysop or (not b.anon) then
write(^S,datestr(b.when),' at ',timestr(b.when),^R) else writeln (^S'Unknown');
writeln;
write{ln} (^B^R'Subject'^P': ');
write(^S,b.title);
for emusux:=1 to 29-(length(b.title)) do
write (' ');
write (^R'To '^P': '^S,b.leftto);
if (b.recieved) then begin
write (' ');
write (^P'[Received]'^R);
end;
writeln;
q:=^R'From '^P': '^S;
if b.anon then
begin
q:=q+anonymousstr;
if (issysop) or (ulvl>=readanonlvl) 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+'] '+b.status;
end;
writeln (q);
if break then exit;
printtext (b.line);
if (curboard.net>0) and (usenet) and (featurea) then
write (^M+b.where+^M+b.where2);
if match (b.leftto,unam) then begin
b.recieved:=true;
seekbfile (curbul);
write (bfile,b);
end;
ansicolor (urec.regularcolor);
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 readbul;
begin
getbnum ('Read');
readcurbul
end;
procedure readnextbul;
var t:integer;
begin
t:=curbul;
inc(curbul);
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 setanon;
begin
writestr ('Allow Anonymous Posts? [Y/N]: *');
if (yes) then curboard.anony:=true;
if not yes then curboard.anony:=false;
writecurboard;
end;
procedure setnet;
begin
writestr ('CelerityNet ID # [0]: *');
if (valu(input)>0) then curboard.net:=valu(input);
if (valu(input)<1) and (valu(input)>-1) then curboard.net:=0;
writecurboard;
end;
{procedure makeboard;
begin
formatbfile;
formatffile;
with curboard do begin
shortname:=curboardname;
buflen:=30;
writestr (^M'Board Name: &');
boardname:=input;
buflen:=30;
writestr ('Sponsor [CR/'+unam+']:');
if input='' then input:=unam;
sponsor:=input;
writestr ('Minimum Level for entry:');
level:=valu(input);
setnet;
writestr ('Autodelete after [CR/100]:');
if length(input)<1 then input:='100';
autodel:=valu(input);
if autodel<10 then begin
writeln ('Must be at least 10!');
autodel:=10
end;
setanon;
setallflags (curboardnum,bylevel);
writecurboard;
writeln ('Board created.');
writelog (4,4,boardname+' ['+shortname+']')
end
end;}
Procedure makeboard;
Begin
formatbfile;
With curboard Do Begin
if ansigraphics in urec.config then begin
clearscr;
WriteLn(^R' ┌───────────'^P'['^S' FAQ Sub-Board Installation '^P']'^R'────────────┐');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
WriteLn(^R' └─────────────────────────────────────────────────────┘');
PrintXy(12,8,^P'Allow Anonymous [CR/No]: ');
PrintXy(12,7,^P'CelerityNet ID# [CR/0]: ');
PrintXy(12,6,^P'Maximum Number of Messages: ');
PrintXy(12,5,^P'Co-SysOp/Sponsor ['+^S+unam+^P+']: ');
PrintXy(12,4,^P'Minimum Access Entry: ');
PrintXy(12,3,^P'Message Area Name: ');
shortname:=curboardname;
BufLen:=29;
movexy(12,3);
writestr(^P'Message Area Name: &');
if input='' then EXiT;
boardname:=Input;
BufLen:=30;
{movexy(12,5);
writestr(^P'Access Type [G]roup [L]evel [B]oth [CR/L]: *');
If Input='' Then Input:='L';
Area_Type:=UpCase(Input[1]);
if not ( area_type[1] in [ 'B' , 'G' , 'L' ] ) then
area_type := 'L' ;
if area_type[1] in [ 'G' , 'B' ] then
begin
movexy(12,7);
writestr(^P'Group File list [CR/None]: *');
If Input='' Then Input:='None';
File_List:=Input;
end
else
File_List := 'None';
if area_type[1] in [ 'L' , 'B' ] then}
begin
movexy(12,4);
writestr(^P'Minimum Access Entry: *');
level:=valu(Input);
end
{else
level := maxint};
movexy(12,5);
writestr(^P'Co-Sysop/Sponsor ['+^S+unam+^P+']: *');
If Input='' Then Input:=unam;
sponsor:=Input;
movexy(12,6);
writestr(^P'Maximum Number of Messages: *');
autodel:=valu(Input);
If autodel<10 Then Begin
WriteLn('Must be at least 10!');
autodel:=50
End;
movexy(12,7);
writestr(^P'CelerityNet ID# [CR/0]: *');
if input='' then begin input:='0'; printxy2 (36,7,^U+'0'); end;
net:=valu(input);
movexy(12,8);
writestr(^P'Allow Anonymous [CR/No]: *');
if input='' then begin anony:=false; printxy2 (37,8,^U+'No '); end;
if yes then begin anony:=true; printxy2 (37,8,^U+'Yes'); end;
end else begin
shortname:=curboardname;
buflen:=30;
writestr (^M'Board Name: &');
boardname:=input;
buflen:=30;
writestr ('Sponsor [CR/'+unam+']:');
if input='' then input:=unam;
sponsor:=input;
writestr ('Minimum Level for entry:');
level:=valu(input);
setnet;
writestr ('Autodelete after [CR/100]:');
if length(input)<1 then input:='100';
autodel:=valu(input);
if autodel<10 then begin
writeln ('Must be at least 10!');
autodel:=10
end;
setanon;
end;
setallflags(curboardnum,bylevel);
writecurboard;
writeln (^M^M^R'Message Base Created');
writelog(4,4,boardname+' ['+shortname+']')
End
End;
procedure setactive (nn:sstr; showinfo:boolean);
procedure doswitch;
begin
openbfile;
curbul:=lastreadnum;
with curboard do
begin
writeln;
if showinfo then begin
if asciigraphics in urec.config then begin
clearscr;
writeln (^R'┌─────────────┬────────────────────────────────┐');
write (^R'│ '^S'Sub-board:'^R' │ '^S);
tab (boardname,31);
writeln (^R'│');
write (^R'│ '^S'Messages:'^R' │ '^S);
tab (strr(numbuls),31);
writeln (^R'│');
write (^R'│ '^S'Last read:'^R' │ '^S);
tab (strr(lastreadnum),31);
writeln (^R'│');
write (^R'│ '^S'Sponsor:'^R' │ '^S);
tab(sponsor,31);
writeln (^R'│');
write (^R'│ '^S'Files:'^R' │ '^S);
tab (strr(numfiles),31);
writeln (^R'│');
write (^R'│ '^S'CelerityNet:'^R'│ '^S);
if net>0 then begin
tab ('Yes',31);
end else
tab ('No ',31);
writeln (^R'│');
writeln (^R'└─────────────┴────────────────────────────────┘');
end else begin
clearscr;
writeln (^R'+-------------+--------------------------------+');
write (^R'| '^S'Sub-board:'^R' | '^S);
tab (boardname,31);
writeln (^R'|');
write (^R'| '^S'Messages:'^R' | '^S);
tab (strr(numbuls),31);
writeln (^R'|');
write (^R'| '^S'Last read:'^R' | '^S);
tab (strr(lastreadnum),31);
writeln (^R'|');
write (^R'| '^S'Sponsor:'^R' | '^S);
tab(sponsor,31);
writeln (^R'|');
write (^R'| '^S'Files:'^R' | '^S);
tab (strr(numfiles),31);
writeln (^R'|');
write (^R'| '^S'CelerityNet:'^R'| '^S);
if net>0 then begin
tab ('Yes',31);
end else
tab ('No ',31);
writeln (^R'|');
writeln (^R'+-------------+--------------------------------+');
end;
end;
writeln;
end;
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 (upstring(curboardname),true)
end
else setfirstboard
end
else setfirstboard
end
end;
function validbname (n:sstr):boolean;
var cnt:integer;
begin
if (length(n)=0) or (length(n)>15) then begin
validbname:=false;
exit;
end;
for cnt:=1 to length(n) do
if not (upcase(n[cnt]) in ['0'..'9','A'..'Z']) then begin
validbname:=false end else
exit;
validbname:=true
end;
procedure listboards;
procedure spacelen(le:byte);
var aaa:byte;
begin
for aaa:=1 to le do
write(' ');
end;
var cnt,oldcurboard:integer;
printed:boolean;
begin
oldcurboard:=curboardnum;
if exist (textfiledir+'Msgarea.'+strr(conn)) then
printfile (textfiledir+'Msgarea.'+strr(conn)) else
begin
writehdr ('Message Area List');
if asciigraphics in urec.config then begin
writeln (^R'┌────────────────┬───────────────────────────────────────┬───────┬─────┬─────┐');
writeln (^R'│ '^S'Name'^R' │ '^S'Subboard Name'^R' │ '^S'Level'^R' │ '^S'A/A'^R' │ '^S+
'Net'^R' │');
writeln (^R'├────────────────┼───────────────────────────────────────┼───────┼─────┼─────┤');
end else begin
writeln (^R'+----------------+---------------------------------------+-------+-----+-----+');
writeln (^R'| '^S'Name'^R' | '^S'Subboard Name'^R' | '^S'Level'^R' | '^S'A/A'^R' | '^S+
'Net'^R' |');
writeln (^R'|----------------|---------------------------------------|-------|-----|-----|');
end;
if (asciigraphics in urec.config) then begin
if break then exit;
for cnt:=0 to filesize(bdfile)-1 do
if haveaccess(cnt) then
with curboard do begin
write (^R'│ '^S,shortname,^R);
spacelen(15-length(shortname));
write (^R'│ '^S,boardname,^R);
spacelen(38-length(boardname));
write (^R'│ '^S,level,^R);
spacelen(6-length(strr(level)));
if anony then
write (^R'│ '^S'Yes'^R' │')
else
write (^R'│ '^S'No'^R' │');
if net>0 then
writeln (^R' '^S'Yes'^R' │')
else
writeln (^R' '^S'No'^R' │');
if break then exit
end;
end;
end;
if not (asciigraphics in urec.config) then begin
if break then exit;
for cnt:=0 to filesize(bdfile)-1 do
if haveaccess(cnt) then
with curboard do begin
write (^R'| '^S,shortname,^R);
spacelen(15-length(shortname));
write (^R'| '^S,boardname,^R);
spacelen(38-length(boardname));
write (^R'| '^S,level,^R);
spacelen(6-length(strr(level)));
if anony then
write (^R'| '^S'Yes'^R' |')
else
write (^R'| '^S'No'^R' |');
if net>0 then
writeln (^R' '^S'Yes'^R' |')
else
writeln (^R' '^S'No'^R' |');
if break then exit
end;
end;
if asciigraphics in urec.config then
writeln (^R'└────────────────┴───────────────────────────────────────┴───────┴─────┴─────┘') else
writeln (^R'+----------------+---------------------------------------+-------+-----+-----+');
writeln;
curboardnum:=oldcurboard;
seekbdfile (curboardnum);
read (bdfile,curboard)
end;
procedure activeboard;
begin
if length(input)>1
then input:=copy(input,2,255)
else begin
repeat
writestr ({^M}'Board Number [?/List]:');
input:=upstring(input);
if input='?' then listboards
until (input<>'?') or hungupon;
end;
if hungupon or (length(input)=0) then exit;
if input[1]='*' then input:=copy(input,2,255);
if validbname(input)
then setactive (input,true)
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,true)
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,'. '^S,b.title,^R' by ');
if b.anon
then writeln (anonymousstr)
else writeln (b.leftby);
if break then exit
end
end
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;
me.leftto:=b.leftto;
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 message.');
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;
writeln;
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 message.');
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 ('Message 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;
{$I rename.pas}
procedure killboard;
var cnt:integer;
f:file;
fr:filerec;
bd:boardrec;
begin
writestr ('Kill Board - You sure? [y/n]: *');
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,' ');
messages:=messages-1;
urec.lastmessages:=urec.lastmessages-1
end;
if messages<1 then messages:=1;
if urec.lastmessages<1 then urec.lastmessages:=1;
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;
(* {$I netmail.pas}
procedure netmailprocess;
var ib,ib2,ib3:integer;
fit:bulrec;
f5:file of bulrec;
hardf:file of message;
textf:message;
filename:mstr;
filename2:mstr;
fl1,fl2:sstr;
curb:boardrec;
f1,f2:text;
begin
if (curboard.net>0) and (usenet) and (featurea) then
begin writeln (^R'Subboard doesn''t support CelerityNet!');
exit;
end;
if (curboard.net>0) and (usenet) and (featurea) then
begin writeln (^R'Configuration doesn''t use CelerityNet!');
exit;
end;
{writestr('Have you switched to the proper area to receive? *');
if yes then
begin}
writeln ('Current Bulletin :'^S,curbul);
writeln ('Last Bulletin :'^S,numbuls);
writeln;
{buflen:=7;
writestr('Enter FAQpaket filename to process : *');
if (length(input)>0) then}
{filename:='C'+strr(conn)+copy(curboardname,1,6);}
filename:=strr(conn)+'NET'+curboard.shortname;
filename2:='NETRECV'+strr(conn);
begin
writeln('Please wait - removing compression/encosion on file');
extractzip(networkdir+filename2+'.ZIP','','');
fl1:=networkdir+filename+'.SQ'+strr(conn);
fl2:=networkdir+filename+'.ME'+strr(conn);
assign(f5,networkdir+filename+'.SQ'+strr(conn));
assign(hardf,networkdir+filename+'.ME'+strr(conn));
{$i-}
if exist(fl1) then erase(f5);
reset(f5);
{$i+}
if ioresult<>0 then
begin
writeln('File not found.');
exit;
end;
{$i-}
if exist(fl2) then erase(hardf);
reset(hardf);
{$i+}
if ioresult<>0 then
begin
writeln('File not found.');
exit;
end;
writeln(^R'Please wait - Processing FAQNet-paket for Sub '^P'['^S+curboard.shortname+^P']'^R'.');
while not eof(f5) do
begin
read(f5,b);
read(hardf,textf);
b.line:=maketext(textf);
addbul(b);
end;
close(f5);
close(hardf);
writeln(^R'FAQNet package for Sub '^P'['^S+curboardname+^P']'^R' processed.');
assign (f1,networkdir+filename+'.SQ'+strr(conn));
assign (f2,networkdir+filename+'.ME'+strr(conn));
reset (f1);
reset (f2);
rewrite (f1);
rewrite (f2);
erase (f1);
erase (f2);
textclose (f1);
textclose (f2);
Writestr('Do you wish to remove the FAQpaket file from your system? *');
if yes then
begin
assign (f1,networkdir+filename2+'.ZIP');
reset (f1);
rewrite (f1);
erase (f1);
textclose (f1);
end;
end;
{end
else writeln('FAQpaket processing stopped.');}
end;
{procedure netmail;
var ch:char;
begin
writehdr ('Netmail');
writeln (^P'['^S'1'^P']'^R' Process a FAQ-Paket netmail package to transmit.');
writeln (^P'['^S'2'^P']'^R' Process a FAQ-Paket netmail package already recieved.');
writeln (^P'['^S'3'^P']'^R' FAQ-Packet System Update.');
writeln;
writestr('Please make your choice [C/R]:*');
if (length(input)>0) then
begin
if (not sponsoron) and (not issysop) then begin
writeln('Invalid Command.');
exit;
end;
ch:=upcase(input[1]);
case ch of
'1':netmailsend;
'2':netmailprocess;
'3':systemlist;
end;
end;
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/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, but you aren''t the sponsor.');
exit
end;
writelog (4,3,curboard.boardname+' ['+curboard.shortname+']');
repeat
q:=menu ('Message Base Sponsor','SPONSOR','DLSTMWUEQRKCNBOVF[]PYZ*?');
case q of (* | | *)
{ 1:getautodel;
2:getblevel;
3:setsponsor; }
4:getfiletitle;
5:movefile;
6:wipeoutfile;
7:setnameaccess;
8:setallaccess;
10:modboard; {renameboard;}
11:killboard;
12:sortboards;
13:movebulletin;
14:orderboards;
15:listaccess;
16:addresident;
17:begin
writestr ('Current Posts ['+strr(urec.nbu)+']: &');
if length(input)>0 then urec.nbu:=valu(input);
writeurec;
end;
{18:netmailsend;
19:netmailprocess;
20:systemlist;}
{21:setanon;
22:setnet;}
23:activeboard;
24:begin
writeln ('
C
╔═════════════════════════════════════╗H
s');
writeln ('u
C║
Message Base Sponsor Section
║H
s');
writeln ('u
C╚═════════════════════════════════════╝HHC╔═════
s');
writeln ('u
════════════════════════════════╗HC║ [
B
]
s');
writeln ('u
Re-Order Sub-Boards
║HC║ [
C
s');
writeln ('u
]
Sort Sub-Boards
║HC║ [
s');
writeln ('u
E
]
Set All Access
║H
s');
writeln ('u
C║ [
F
]
Change # of Posts
s');
writeln ('u
║HC║ [
K
]
Kill Sub-Boards
s');
writeln ('u
║HC║ [
M
]
Move a File
s');
writeln ('u
║HC║ [
N
]
Move Message
s');
writeln ('u
║HC║ [
O
]
List Sub-Boa
s');
writeln ('u
rd Access
║HC║ [
Q
]
Quit
s');
writeln ('u
╔════════════════════════════════════
s');
writeln ('u
═╗HC
║ [
R
]
Re-Configure Sub-Boar
s');
writeln ('u
d
║ [
V
]
Add Resident File
s');
writeln ('u
║HC
║ [
T
]
Change File Titl
s');
writeln ('u
e
║ [
W
]
Delete File
s');
writeln ('u
║HC
║ [
U
]
Set Name Ac
s');
writeln ('u
cess
║ [
*
]
Change Active Sub-Bo
s');
writeln ('u
ard
║HC
╚═══════════════════════════
s');
writeln ('u
══
║ [
?
]
View This Menu
s');
writeln ('u
║HC╚═════════════════════════════════════╝
');
writeln;
pause;
end;
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'Message Newscan Aborted!')
end
end;
Function capfir(inString:STRING):char;
begin
capfir:=upcase(inString[1]);
end;
procedure newscanboard;
function getnumnum(title:lstr):integer;
var reprep :byte;
startpoint :byte;
endpoint :byte;
a :string[1];
begin
reprep :=79;
startpoint:=0;
endpoint :=0;
getnumnum :=0;
repeat
a:=copy (title,reprep,1);
if a='#' then
begin;
startpoint:=reprep;
repeat
if valu(copy(title,reprep,1))>0 then endpoint:=reprep;
inc(reprep);
until (reprep>=79);
end;
if (startpoint>0) and (endpoint>0) then
begin
dec(endpoint,startpoint);
getnumnum:=valu(copy(title,startpoint+1,endpoint));
exit;
end;
dec(reprep);
until reprep<=0
end;
function gettitle(title:lstr;reply:word):lstr;
var search :boolean;
srcstr :sstr;
cursrc :word;
tit :lstr;
begin
srcstr :=' [Reply #';
search :=false;
tit :='';
cursrc :=0;
repeat
if copy(title,cursrc,length(srcstr))=srcstr then
begin;
tit:=copy(title,1,cursrc-1);
gettitle:=tit+' [Reply #'+strr(reply)+']';
exit;
end;
if cursrc=79 then
begin
gettitle:=title+' [Reply #'+strr(reply)+']';
exit;
end;
inc(cursrc);
until cursrc=80;
end;
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>xlaston;
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 (^S,cnt,'. '^R,f.descrip);
if aborted or break then exit
end
end;
var newmsgs,oldb:boolean;
q:anystr;
wock:char;
wock2:word;
m,me:message;
l,stonerslive,swash:integer;
t:sstr;
fcpiskool:mstr;
repnumber:word;
lameo :string;
begin
beenaborted:=false;
newmsgs:=false;
curbul:=lastreadnum+1;
while curbul<=numbuls do begin
getbrec;
if b.when>laston then begin
readnum (curbul);
newmsgs:=true;
if (not cscan) then
repeat
wock:='N';
writestr (^P'Message Newscan Command ['^S'?/Help'^P']['^S'CR/Next'^P']: *');
if length(input)<1 then input:='N';
wock:=upcase(input[1]);
wock2:=valu(input);
if wock2>0 then begin
if wock2<=numbuls then begin
curbul:=wock2;
readnum (curbul);
end;
end else
wock:=upcase(wock);
case wock of
'?':begin
writeln;
writeln (^S' -Newscan Help-'^R^M);
writeln ('[N]: Next Message [#]: Read that Message #');
writeln ('[A]: Read Message Again [R]: Reply to Message');
writeln ('[D]: Delete Message [P]: Post a Message');
writeln ('[B]: Next Sub-board [/]: Toggle Auto-Scan');
if (match(unam,b.leftby)) or (issysop) or (sponsoron)
then write ('[E]: Edit Message ');
writeln ('[Q]: Quit Newscan');
writeln;
end;
'A':begin
if checkcurbul then begin
getbrec;
if ((ansigraphics in urec.config) and (not cscan)) then begin
write (#27+'[2J');
clrscr;
end;
writeln (^R'[Current Board: '^S,curboard.boardname,^R']'^M);
write (^B^P'Message: '^S);
fcpiskool:=^S+strr(curbul)+' of '+strr(numbuls);
write (fcpiskool);
for stonerslive:=1 to 25-(length(fcpiskool)) do
write (' ');
if issysop or (not b.anon) then
writeln (^P'When: '^S,datestr(b.when),^P' at '^S,timestr(b.when),^R);
writeln (^B^P'Subject: '^S,b.title);
write (^B^P'To: '^S,b.leftto);
if (b.recieved) then begin
for swash:=1 to 25-(length(b.leftto)+3) do
write (' ');
write (^P'-Recieved-'^R);
end;
writeln;
q:=^P'From: '^S;
if b.anon
then
begin
q:=q+anonymousstr;
if (issysop) or (ulvl>=readanonlvl) 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+') '+b.status;
end;
writeln (q);
ansicolor (urec.regularcolor);
if break then exit;
printtext (b.line);
end;
end;
'P':begin
postbul;
end;
'D':begin
reading:=true;
killbul;
curbul:=curbul-1;
reading:=false;
end;
'R':begin
if ulvl<postlevel then begin
reqlevel(postlevel);
exit
end;
emailing:=true;
notitle:=true;
l:=editor(m,true,'');
lameo:=b.leftby;
if l>=0 then
begin
inc(urec.nbu);
writeurec;
if messages>32760 then messages:=0;
inc(messages);
b.anon:=m.anon;
repnumber:=getnumnum(b.title);
inc(repnumber);
b.title:=gettitle(b.title,repnumber);
b.when:=now;
b.leftto:=lameo;
b.leftby:=unam;
b.status:='['+urec.note+']';
if sponsoron then b.status:=b.status+' [Sponsor]';
b.line:=l;
b.plevel:=ulvl;
addbul (b);
inc(newposts);
with curboard do
if autodel<=numbuls then autodelete
end
end;
'E':begin
if checkcurbul then begin
if (not match(b.leftby,unam)) and (not issysop) and (not sponsoron)
then begin
writeln ('You didn''t post that!');
end
else begin
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 message.');
delbul (curbul,false)
end else begin
seekbfile (curbul);
write (bfile,b)
end
end
end;
end;
end;
'B':exit;
'/':togglecscan;
'Q':begin
quitmasterinc:=true;
exit;
end;
end;
until wock in ['N'];
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 on '^S+curboard.boardname+^P'? [Y/N]: *');
writeln;
if yes then postbul
end
end;
procedure newscanall;
var cb:integer;
begin
beenaborted:=false;
writeln (^R'Newscanning All Boards. ['^S'X'^R'] will abort.'^M);
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 (^R+curboard.boardname+^P' ['^S+curboard.shortname+^P']');
if aborted then exit;
newscanboard;
if quitmasterinc then begin
quitmasterinc:=false;
writeln (^B^M'Newscan aborted!'^G);
exit;
end
end
end;
writeln (^B^M'Newscan complete!'^G);
setfirstboard
end;
procedure getconpw;
begin
if (length(confmpw[1])>0) and (conn=1) and not (issysop) then begin
echodot:=true;
writestr (^M^P'['^R'Conference #1 Password'^P']: *');
echodot:=false;
if not (match(input,confmpw[1])) then begin exit; exit; end;
end;
if (length(confmpw[2])>0) and (conn=2) and not (issysop) then begin
echodot:=true;
writestr (^M^P'['^R'Conference #2 Password'^P']: *');
echodot:=false;
if not (match(input,confmpw[2])) then begin exit; exit; end;
end;
if (length(confmpw[3])>0) and (conn=3) and not (issysop) then begin
echodot:=true;
writestr (^M^P'['^R'Conference #3 Password'^P']: *');
echodot:=false;
if not (match(input,confmpw[3])) then begin exit; exit; end;
end;
if (length(confmpw[4])>0) and (conn=4) and not (issysop) then begin
echodot:=true;
writestr (^M^P'['^R'Conference #4 Password'^P']: *');
echodot:=false;
if not (match(input,confmpw[4])) then begin exit; exit; end;
end;
if (length(confmpw[5])>0) and (conn=5) and not (issysop) then begin
echodot:=true;
writestr (^M^P'['^R'Conference #5 Password'^P']: *');
echodot:=false;
if not (match(input,confmpw[5])) then begin exit; exit; end;
end;
end;
procedure noboards;
begin
writeln ('No sub-boards exist!');
if not issysop then exit;
writestr ('Create the first sub-board now? [y/n]: *');
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,true);
exit
end
end;
writestr ('This is the last sub-board!');
setactive (obn,true)
end;
procedure listusersaxis;
procedure listacc (all:boolean);
var cnt:integer;
a:accesstype;
u:userrec;
begin
seek (ufile,1);
for cnt:=1 to numusers do begin
read (ufile,u);
a:=getuseraccflag (u,curboardnum);
case a of
letin:writeln (^S,u.handle,^R);
bylevel:if u.level>=curboard.level then writeln (^S,u.handle,^R);
end;
if break then exit
end
end;
begin
if ulvl<listuserlvl then Begin reqlevel (listuserlvl); Exit; End;
writehdr ('List Users with Board Access');
writeln;
writeln (^R'Users with access to ['^S+curboard.boardname+^R']:');
writeln;
listacc (true);
end;
procedure uploadbul;
var l:integer;
m:message;
b:bulrec;
pr:char;
t,s:mstr;
uf:text;
ds:longint;
begin
if ulvl<postlevel then begin
reqlevel(postlevel);
exit
end;
ds:=diskfree(0);
ds:=ds div 1000;
if ds<10 then begin
writeln;
writeln ('There is only '+strr(ds)+'K disk space left.');
writestr ('Are you sure you want to post? *');
if not yes then exit else
end;
assign (uf,'receive.');
if exist ('receive.') then erase(uf);
writehdr ('Message Upload');
writeln (^S'Message Upload: Zmodem/Ymodem-G Uploads Only!');
writestr (^M'Subject: &');
if length(input)=0 then exit;
s:=input;
t:='All';
Writestr ('To [CR/All]: &');
if length(input)>0 then t:=input;
with curboard do
if anony then begin
buflen:=1;
writestr ('Anonymous? [y/n]: *');
b.anon:=yes
end;
writestr ('Zmodem or Ymodem-G [Z,Y A,Q/Quit]: *');
if upcase (input[1])='Z' then pr:='Z' else if upcase (input[1])='G'
then pr:='G';
if (upcase (input[1])='A') or (upcase(input[1])='Q') then exit;
writeln (^M^S'Ready to receive Message Upload.');
if pr='Z' then
exec (GetEnv('COMSPEC'),'/C dsz port '+strr(usecom)+' speed '+strr(baudrate)+' rz receive.') else
if pr='G' then
exec (GetEnv('COMSPEC'),'/C dsz port '+strr(usecom)+' speed '+strr(baudrate)+' rb -g receive.');
reset (uf);
if ioresult<>0 then begin
writeln (^M^S'Message upload error!'^M);
textclose(uf);
exit;
end;
m.numlines:=0;
while not eof(uf) and (m.numlines<100) do begin
inc(m.numlines);
readln(uf,m.text[m.numlines]);
end;
if m.numlines<=1 then begin
writeln (^M^S'Message upload error!'^M);
textclose(uf);
exit;
end;
begin
inc(urec.nbu);
writeurec;
b.title:=s;
b.when:=now;
b.leftto:=t;
b.leftby:=unam;
b.status:=urec.note;
b.plevel:=ulvl;
b.recieved:=false;
b.line:=maketext(m);
if m.numlines>1 then addbul (b);
inc(newposts);
inc(messages);
if messages>32767 then messages:=0;
textclose (uf);
erase (uf);
writehdr ('Message Added!');
writeln ('Total Lines: '^S,m.numlines);
with curboard do
if autodel<=numbuls then autodelete
end;
end;
var boo:boolean;
label exit1;
begin
cursection:=bulletinsysop;
reading:=false;
quitmasterinc:=false;
cscan:=false;
getconpw;
openbdfile;
if filesize(bdfile)=0 then begin
noboards;
if filesize(bdfile)=0 then begin
closebdfile;
goto exit1
end
end;
if not haveaccess(0)
then
begin
writeln (^B'You do not have access to the first sub-board!');
closebdfile;
goto exit1
end;
if exist(textfiledir+'MSGNEWS.'+strr(conn)) then begin
printfile (textfiledir+'MSGNEWS.'+strr(conn));
pause;
end;
if ansi then ansicls;
setfirstboard;
repeat
boo:=checkcurbul;
with curboard do
{+' '+boardname,^R' ['^S,shortname,^R']: '}
write (^B);
writeln (^R'Conference #'^S+strr(conn)+' '+curboard.boardname+^P' ['^S+curboard.shortname+^P']');
if sponsoron or issysop
then writeln (^R'['^S'%'^R']:Board Sponsor Commands');
writeln (^R'Bulletin '^S,curbul,^R' of '^S,numbuls);
q:=menu ('Message Base <'+curboard.shortname+'-'+strr(curbul)+'/'+strr(numbuls)+
'>','MSG','PRDFUKT*MQ#_%LNBAVCES+WG!Z?');
case q of
1:postbul;
2:readbul;
3:{downloadfile};
4,22:sendmailto (curboard.sponsor,false);
5:uploadbul{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:editbul;
21:nextsubboard;
22:readnum (lastreadnum+1);
23:offfaq;
24:listusersaxis;
25:togglecscan;
27:begin
writeln('
C
╔═════════════════════════════════════╗H
s');
writeln('u
C║
Message Base Section
║H
s');
writeln('u
C╚═════════════════════════════════════╝HHC╔══
s');
writeln('u
═══════════════════════════════════╗HC║ [
A
]
s');
writeln('u
Change Active Sub-Board
║HC║ [
C
s');
writeln('u
]
Change Newscan on Sub
║HC║ [
s');
writeln('u
E
]
Edit Message
║H
s');
writeln('u
C║ [
G
]
Log off BBS
╔═════
s');
writeln('u
════════════════════════════════╗1HC
║ [
K
s');
writeln('u
]
Kill Message
║ [
U
]
s');
writeln('u
Upload Text File
║1HC
║
s');
writeln('u
[
M
]
Send Reply to Message
║ [
V
s');
writeln('u
]
Newscan Current Sub-Board
║1HC
s');
writeln('u
║ [
N
]
Newscan All Sub-Boards
║ [
s');
writeln('u
W
]
Read Next Message
║1H
s');
writeln('u
C
║ [
P
]
Post Message
s');
writeln('u
║ [
Z
]
Change Auto-Scan
║
');
writeln('
1HC
║ [
Q
]
Quit
s');
writeln('u
║ [
#
]
Read Message #
║
');
writeln('
1HC
║ [
R
]
Read Message(s)
s');
writeln('u
║ [
%
]
Message Sponsor Section
║
');
writeln('
1HC
║ [
S
]
Send Mail to Sponsor
s');
writeln('u
║ [
+
]
Next Sub-Board
║
');
writeln('
1HC
║ [
T
]
List Messages
s');
writeln('u
║ [
!
]
List Users with Access
║
');
writeln('
1HC
╚═════════════════════════════
║ [
C
s');
writeln('u
R
]
Read Next Message
║1HC║
s');
writeln('u
[
?
]
View This Menu
║
');
writeln('
1HC╚═════════════════════════════════════╝
');
writeln;
pause;
end;
else if q<0 then readnum (-q)
end
until (q=10) or hungupon or (filesize(bdfile)=0);
exit1:
close (bfile);
close (ffile);
closebdfile
end;
begin
end.