home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Jason Aller Floppy Collection
/
276.img
/
FORUM21S.ZIP
/
MAINMENU.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-02-15
|
25KB
|
1,084 lines
{$R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }
{$M 65500,0,0 }
unit mainmenu;
interface
uses crt,dos,
gentypes,configrt,statret,textret,userret,mailret,
gensubs,subs1,subs2,windows,
chatstuf,mainr1,mainr2,overret1;
procedure editusers;
procedure zapspecifiedusers;
procedure summonsysop;
procedure offtheforum;
procedure listusers;
procedure transfername;
procedure editnews;
procedure yourstatus;
procedure delerrlog;
procedure feedback;
procedure settime;
procedure changepwd;
procedure requestraise;
procedure makeuser;
procedure infoformhunt;
procedure donations;
procedure viewsyslog;
procedure delsyslog;
procedure showsystemstatus;
procedure showallforms;
procedure showallsysops;
procedure mainhelp;
procedure otherbbs;
procedure readerrlog;
procedure showad;
procedure setlastcall;
procedure removeallforms;
procedure readfeedback;
implementation
procedure editusers;
var eunum:integer;
matched:boolean;
procedure elistusers (getspecs:boolean);
var cnt,f,l:integer;
u:userrec;
us:userspecsrec;
procedure listuser;
begin
write (cnt:4,' ');
tab (u.handle,31);
write (u.level:6,' ');
tab (datestr(u.laston),8);
writeln (u.nbu:6,u.numon:6,postcallratio(u):7:2)
end;
begin
if getspecs
then if selectspecs(us)
then exit
else
begin
f:=1;
l:=numusers
end
else parserange (numusers,f,l);
seek (ufile,f);
matched:=false;
writeln (^B^M^M' Num Name Level ',
'Last on Posts Calls PCR');
for cnt:=f to l do begin
read (ufile,u);
if (not getspecs) or fitsspecs(u,us) then begin
listuser;
matched:=true
end;
handleincoming;
if break then exit
end;
if not matched then
if getspecs
then writeln (^B^M'No users match specifications!')
else writeln (^B^M'No users found in that range!')
end;
begin
repeat
writestr (^M'User to edit [?,??=list]:');
if (length(input)=0) or (match(input,'Q')) then exit;
if input[1]='?'
then elistusers (input='??')
else begin
eunum:=lookupuser (input);
if eunum=0
then writestr ('User not found!')
else edituser (eunum)
end
until hungupon
end;
procedure zapspecifiedusers;
var us:userspecsrec;
confirm:boolean;
u:userrec;
cnt:integer;
done:boolean;
begin
if selectspecs (us) then exit;
writestr ('Confirm each deletion individually? *');
if length(input)=0 then exit;
confirm:=yes;
if not confirm then begin
writestr (^M'Are you SURE you want to mass delete without confirmation? *');
if not yes then exit
end;
for cnt:=1 to numusers do begin
seek (ufile,cnt);
read (ufile,u);
if (length(u.handle)>0) and fitsspecs (u,us) then begin
if confirm
then
begin
done:=false;
repeat
writestr ('Delete '+u.handle+' (Y/N/X/E):');
if length(input)>0 then case upcase(input[1]) of
'Y':begin
done:=true;
writeln ('Deleting '+u.handle+'...');
deleteuser (cnt)
end;
'N':done:=true;
'X':exit;
'E':begin
edituser(cnt);
writeln;
writeln
end
end
until done
end
else
begin
writeln ('Deleting '+u.handle+'...');
if break then begin
writestr ('Aborted!!');
exit
end;
deleteuser (cnt)
end
end
end
end;
procedure summonsysop;
var tf:text;
k:char;
begin
chatmode:=not chatmode;
bottomline;
if chatmode
then
if sysopisavail
then
begin
writestr ('Enter a short reason: &');
chatreason:=input;
if length(input)=0 then begin
chatmode:=false;
exit
end;
writelog (1,3,chatreason);
splitscreen (4);
top;
clrscr;
writeln (usr,unam,' wants to chat! His reason:');
write (usr,chatreason);
bottom;
assign (tf,textfiledir+'Summon');
reset (tf);
if ioresult=0 then begin
while (not (eof(tf) or hungupon)) and chatmode do
begin
read (tf,k);
nobreak:=true;
if ord(k)=7 then summonbeep else writechar (k);
if keyhit then begin
k:=bioskey;
clearbreak;
chat (false)
end
end;
textclose (tf)
end;
if chatmode
then writestr (^M'Use [C] again to turn off page.')
else unsplit
end
else
begin
writestr ('Sorry, '+sysopname+
' isn''t available right now!');
chatmode:=false;
writelog (1,2,'')
end
else writestr ('Page off. Use [C] to turn it back on.');
clearbreak
end;
procedure offtheforum;
var q,n:integer;
tn:file of integer;
m:message;
begin
writestr ('Hang up now? *');
if yes then begin
writestr ('Leave message to next user? *');
if yes then begin
q:=editor(m,false);
if q>=0 then begin
if tonext>=0 then deletetext (tonext);
tonext:=q;
writestatus
end
end;
printfile (textfiledir+'GoodBye');
disconnect
end
end;
procedure listusers;
var cnt:integer;
u:userrec;
begin
writeln (^B'Name Level'^M);
if break then exit;
for cnt:=1 to numusers do
begin
seek (ufile,cnt);
read (ufile,u); che;
if length(u.handle)>0 then begin
tab (u.handle,33);
if break then exit;
writestr (strr(u.level));
if break then exit
end
end
end;
procedure transfername;
var un,nlvl,ntime,tmp:integer;
u:userrec;
begin
if tempsysop then begin
writestr ('Disabling temporary sysop powers...');
ulvl:=regularlevel;
tempsysop:=false
end;
writestr ('Transfer to user name:');
if length(input)=0 then exit;
un:=lookupuser(input);
if unum=un then begin
writestr ('You can''t transfer to yourself!');
exit
end;
if un=0 then begin
writestr ('No such user.');
exit
end;
seek (ufile,un);
read (ufile,u);
if ulvl<sysoplevel then if not checkpassword(u) then begin
writelog (1,5,u.handle);
exit
end;
writelog (1,4,u.handle);
updateuserstats (false);
ntime:=0;
if datepart(u.laston)<>datepart(now) then begin
tmp:=ulvl;
if tmp<1 then tmp:=1;
if tmp>100 then tmp:=100;
ntime:=usertime[tmp]
end;
if u.timetoday<10
then if issysop or (u.level>=sysoplevel)
then
begin
writestr ('The user has '+strr(u.timetoday)+' min(s) left!');
writestr ('New time left:');
ntime:=valu(input)
end
else
if u.timetoday>0
then writeln ('Warning: You have ',u.timetoday,' minutes left!')
else
begin
writestr ('Sorry, that user doesn''t have any time left!');
exit
end;
unum:=un;
readurec;
if ntime<>0 then begin
urec.timetoday:=ntime;
writeurec
end;
end;
procedure editnews;
var nn,numnews:integer;
nf:file of integer;
procedure getnn (txt:mstr);
begin
writestr ('News number to '+txt+':');
nn:=valu(input);
if (nn<1) or (nn>numnews) then nn:=0
end;
procedure delnews;
var cnt:integer;
r:integer;
begin
if nn=0 then getnn ('delete');
if nn<>0 then begin
seek (nf,nn-1);
read (nf,r); che;
deletetext (r);
numnews:=filesize(nf)-1;
for cnt:=nn to numnews do
begin
seek (nf,cnt);
read (nf,r);
seek (nf,cnt-1);
write (nf,r)
end;
seek (nf,numnews);
truncate (nf)
end
end;
procedure listnews;
var cnt:integer;
r,sector:integer;
q:buffer;
l:anystr;
k:char;
begin
clearbreak;
for cnt:=1 to numnews do begin
seek (nf,cnt-1);
read (nf,r);
seek (tfile,r);
read (tfile,q);
write (strr(cnt)+'. ');
r:=1;
k:=' ';
l:='';
while (ord(k)<>13) and not hungupon do begin
k:=q[r];
r:=r+1;
if (k=#0) or (r>sectorsize) then k:=chr(13);
l:=l+k
end;
writeln (l);
if break then exit
end;
writeln
end;
procedure viewnews;
var r:integer;
begin
if nn=0 then getnn ('view');
if nn<>0 then begin
seek (nf,nn-1);
read (nf,r); che;
printtext (r)
end
end;
procedure adddnews;
begin
close (nf);
addnews;
assign (nf,'News');
reset (nf)
end;
var q:integer;
begin
assign (nf,'News');
reset (nf);
if ioresult<>0 then writestr ('No news! Use [A] to add some!') else begin
repeat
numnews:=filesize(nf);
write (^B^M'News entries: ',numnews);
q:=menu ('News edit','NEWS','ADLVQ');
nn:=valu(copy(input,2,255));
if (nn<1) or (nn>numnews) then nn:=0;
case q of
1:adddnews;
2:delnews;
3:listnews;
4:viewnews
end;
if numnews=0 then begin
close (nf);
erase (nf);
writestr ('No more news! Use [A] to add some.');
q:=5
end
until (q=5) or hungupon
end;
close (nf)
end;
procedure yourstatus;
begin
writehdr ('Your Status');
writeln ('Name: '^S,unam,
^M'Level: '^S,ulvl,
^M'Calls: '^S,urec.numon,
^M'Posted: '^S,urec.nbu,
^M^M'Ascii',
^M' Uploads: '^S,urec.nup,
^M' Downloads: '^S,urec.ndn,
^M'XMODEM',
^M' Uploads: '^S,urec.uploads,
^M' Downloads: '^S,urec.downloads,
^M^M'Total time on: '^S,urec.totaltime:0:0,
^M'Time left: '^S,timeleft)
end;
procedure delerrlog;
var e:text;
i:integer;
begin
writestr ('Delete error log: Confirm:');
if not yes then exit;
assign (e,'errlog');
reset (e);
i:=ioresult;
if ioresult=1
then writeln (^M'No error log!')
else begin
textclose (e);
erase (e);
writestr ('Error log deleted.');
if ioresult>1
then writeln ('I/O error ',i,' deleting error log!');
writelog (2,2,'')
end
end;
procedure feedback;
var m:mailrec;
me:message;
begin
writestr ('Leave feedback? *');
if not yes then exit;
m.line:=editor(me,true);
if m.line<0 then exit;
m.title:=me.title;
m.sentby:=unam;
m.anon:=false;
m.when:=now;
addfeedback (m);
writestr ('Feedback sent.')
end;
procedure settime;
var t:integer;
n:longint;
r:registers;
d:datetime;
begin
writestr ('Current time: '+timestr(now));
writestr ('Current date: '+datestr(now));
writestr ('Enter new time:');
if length(input)<>0
then begin
t:=timeleft;
unpacktime (timeval(input),d);
r.ch:=d.hour;
r.cl:=d.min;
r.dh:=0;
r.dl:=0;
r.ah:=$2d;
intr ($21,r);
if r.al=$ff then writestr ('Invalid time!');
settimeleft (t)
end;
writestr ('Enter new date:');
if length(input)<>0
then begin
unpacktime (dateval(input),d);
r.dl:=d.day;
r.dh:=d.month;
r.cx:=d.year;
r.ah:=$2b;
intr ($21,r);
if r.al=$ff then writestr ('Invalid date!')
end;
writelog (2,4,'')
end;
procedure changepwd;
var t:sstr;
begin
writehdr ('Password Change');
dots:=true;
buflen:=15;
write ('Enter new password: ');
if getpassword
then begin
writeurec;
writestr ('Password changed.');
writelog (1,1,'')
end else
writestr ('No change.')
end;
procedure requestraise;
var t:text;
q:lstr;
p,l1,l2:integer;
s1,s2:sstr;
me:message;
m:mailrec;
label nope,found;
begin
assign (t,textfiledir+'RAISEREQ');
reset (t);
if ioresult<>0 then goto nope;
printtexttopoint (t);
while not eof(t) do begin
readln (t,q);
p:=pos('-',q);
if p>0
then
begin
s1:=copy(q,1,p-1);
s2:=copy(q,p+1,255)
end
else
begin
s1:=copy(q,1,15);
s2:=s1
end;
val (s1,l1,p);
if p=0 then val (s2,l2,p);
if p<>0 then begin
textclose (t);
error ('Invalid range in RAISEREQ: %1','',q);
exit
end;
if (ulvl>=l1) and (ulvl<=l2) then goto found;
skiptopoint (t)
end;
nope:
error ('No text for level %1','',strr(ulvl));
textclose (t);
p:=ioresult;
exit;
found:
printtexttopoint (t);
textclose (t);
if hungupon then exit;
m.line:=editor (me,false);
if m.line<0 then exit;
m.anon:=false;
m.title:='Raise request; now lvl='+strr(ulvl);
m.sentby:=unam;
m.when:=now;
addfeedback (m);
end;
procedure makeuser;
var u:userrec;
un,ln:integer;
begin
writehdr ('Add a user');
writestr ('Name:');
if length(input)=0 then exit;
if lookupuser(input)<>0 then begin
writestr ('Sorry! Already exists!');
exit
end;
u.handle:=input;
writestr ('Password:');
u.password:=input;
writestr ('Level:');
if length(input)=0 then exit;
u.level:=valu(input);
un:=adduser(u);
if un=-1 then begin
writestr ('Sorry, no room for new users!');
exit
end;
ln:=u.level;
if ln<1 then ln:=1;
if ln>100 then ln:=100;
u.timetoday:=usertime[ln];
writeufile (u,un);
writestr ('User added as #'+strr(un)+'.');
writelog (2,8,u.handle)
end;
procedure infoformhunt;
begin
writestr ('User to search for [CR=all users]:');
writeln (^M);
showinfoforms (input)
end;
procedure donations;
var fn:lstr;
begin
fn:=textfiledir+'Donation';
if exist (fn)
then printfile (fn)
else begin
writestr ('I''m sorry, no information is currently available.');
if issysop
then writestr (
'Sysop: To create donation information text, make a file called '+fn)
end
end;
procedure viewsyslog;
var n:integer;
l:logrec;
function lookupsyslogdat (m,s:integer):integer;
var cnt:integer;
begin
for cnt:=1 to numsyslogdat do with syslogdat[cnt] do
if (menu=m) and (subcommand=s) then begin
lookupsyslogdat:=cnt;
exit
end;
lookupsyslogdat:=0
end;
function firstentry:boolean;
begin
firstentry:=(l.menu=0) and (l.subcommand in [1..2])
end;
procedure backup;
begin
while n<>0 do begin
n:=n-1;
seek (logfile,n);
read (logfile,l);
if firstentry then exit
end;
n:=-1
end;
procedure showentry (includedate:boolean);
var q:lstr;
p:integer;
begin
q:=syslogdat[lookupsyslogdat(l.menu,l.subcommand)].text;
p:=pos('%',q);
if p<>0 then q:=copy(q,1,p-1)+l.param+copy(q,p+1,255);
if includedate then q:=q+' on '+datestr(l.when);
q:=q+' at '+timestr(l.when);
writeln (q)
end;
var b:boolean;
begin
writehdr ('View system log');
writeln ('Press space to advance to the previous caller, X to abort.');
writeln;
writelog (2,6,'');
n:=filesize(logfile);
repeat
clearbreak;
writeln (^M);
backup;
if n=-1 then exit;
seek (logfile,n);
read (logfile,l);
showentry (true);
b:=false;
while not (eof(logfile) or break or xpressed or b) do begin
read (logfile,l);
b:=firstentry;
if not b then showentry (false);
end
until xpressed
end;
procedure delsyslog;
begin
writestr ('Delete system log: Confirm:');
if not yes then exit;
close (logfile);
rewrite (logfile);
writeln (^M'System log deleted.');
writelog (2,7,unam)
end;
procedure showsystemstatus;
var totalused,totalidle,totalup,totaldown,totalmins,callsday:real;
procedure percent (prompt:mstr; top,bot:real);
var p:real;
begin
write (prompt);
if bot<1 then begin
writeln ('N/A');
exit
end;
p:=round(1000*top/bot)/10;
writeln (p:0:1,'%')
end;
begin
totalused:=numminsused.total+elapsedtime(numminsused);
totalidle:=numminsidle.total;
totalup:=totalidle+numminsused.total;
totalmins:=1440.0*(numdaysup-1.0)+timer;
totaldown:=totalmins-totalup;
callsday:=round(10*numcallers/numdaysup)/10;
writehdr ('System Status');
writeln ('Time & date: '^S,timestr(now),', ',datestr(now),
^M^J'Calls today: '^S,callstoday,
^M^J'Total callers: '^S,numcallers:0:0,
^M^J'Total days up: '^S,numdaysup,
^M^J'Calls per day: '^S,callsday:0:1,
^M^J'Total mins in use: '^S,numminsused.total:0:0,
^M^J'Total mins idle: '^S,totalidle:0:0,
^M^J'Mins file xfer: '^S,numminsxfer.total:0:0,
^M^J'Total mins up: '^S,totalup:0:0,
^M^J'Total mins down: '^S,totaldown:0:0);
percent ('Percent in use: '^S,totalused,totalmins);
percent ('Percent idle: '^S,totalidle,totalmins);
percent ('Percent up: '^S,totalup,totalmins);
percent ('Percent down: '^S,totaldown,totalmins);
end;
procedure showallforms;
begin
showinfoforms ('')
end;
procedure showallsysops;
var n:integer;
u:userrec;
q:set of configtype;
s:configtype;
procedure showuser;
const sectionnames:array [udsysop..databasesysop] of string[20]=
('File transfer','Bulletin section','Voting booths',
'E-mail section','Doors','Main menu','Databases');
var s:configtype;
begin
writeln (^B^M'Name: '^S,u.handle,
^M'Level: '^S,u.level,^M);
for s:=udsysop to databasesysop do
if s in u.config then
writeln ('Sysop of the ',sectionnames[s]);
writestr (^M'Edit user? *');
if yes then edituser (n)
end;
begin
q:=[];
for s:=udsysop to databasesysop do q:=q+[s];
for n:=1 to numusers do begin
seek (ufile,n);
read (ufile,u);
if (u.level>=sysoplevel) or (q*u.config<>[]) then showuser
end
end;
procedure mainhelp;
begin
help ('Mainmenu.hlp')
end;
procedure otherbbs;
begin
printfile (textfiledir+'Otherbbs')
end;
procedure readerrlog;
begin
if exist ('Errlog')
then printfile ('Errlog')
else writestr ('No error file!')
end;
procedure showad;
var fn:lstr;
begin
fn:=textfiledir+'Forum.AD';
if exist (fn) then printfile (fn)
end;
procedure setlastcall;
function digit (k:char):boolean;
begin
digit:=ord(k) in [48..57]
end;
function validtime (inp:sstr):boolean;
var c,s,l:integer;
d1,d2,d3,d4:char;
ap,m:char;
begin
validtime:=false;
l:=length(inp);
if (l<7) or (l>8) then exit;
c:=pos(':',inp);
if c<>l-5 then exit;
s:=pos(' ',inp);
if s<>l-2 then exit;
d2:=inp[c-1];
if l=7
then d1:='0'
else d1:=inp[1];
d3:=inp[c+1];
d4:=inp[c+2];
ap:=upcase(inp[s+1]);
m:=upcase(inp[s+2]);
if d1='1' then if d2>'2' then d2:='!';
if (d1>='0') and (d1<='1') and digit(d2) and (d3>='0') and (d3<='5')
and digit(d4) and ((ap='A') or (ap='P')) and (m='M')
then validtime:=true
end;
function validdate (inp:sstr):boolean;
var k,l:char;
function gchar:char;
begin
if length(inp)=0 then begin
gchar:='?';
exit
end;
gchar:=inp[1];
delete (inp,1,1)
end;
begin
validdate:=false;
k:=gchar;
l:=gchar;
if not digit(k) then exit;
if l='/'
then if k='0'
then exit
else
else begin
if k>'1' then exit;
if not digit(l) then exit;
if (l>'2') and (k='1') then exit;
l:=gchar;
if l<>'/' then exit
end;
k:=gchar;
l:=gchar;
if l='/'
then if k='0'
then exit
else
else begin
if k>'3' then exit;
if not digit(l) then exit;
if (k='3') and (l>'1') then exit;
l:=gchar;
if l<>'/' then exit
end;
if digit(gchar) and digit(gchar) then validdate:=true
end;
begin
writeln (^M'Your last call was: '^S,datestr(laston),' at ',timestr(laston));
writestr (^M'Enter new date (mm/dd/yy):');
if length(input)>0
then if validdate (input)
then laston:=dateval(input)+timepart(laston)
else writestr ('Invalid date!');
writestr (^M'Enter new time (hh:mm am/pm):');
if length(input)>0
then if validtime(input)
then laston:=timeval(input)+datepart(laston)
else writestr ('Invalid time!')
end;
procedure removeallforms;
var cnt,ndel:integer;
u:userrec;
begin
writestr ('Erase ALL info-forms: Are you sure? *');
if not yes then exit;
writeurec;
writestr (^M'Erasing... please stand by...');
ndel:=0;
for cnt:=1 to numusers do begin
if (cnt mod 10)=0 then write (cnt,', ');
seek (ufile,cnt);
read (ufile,u);
if u.infoform>=0 then begin
deletetext (u.infoform);
u.infoform:=-1;
seek (ufile,cnt);
write (ufile,u);
ndel:=ndel+1
end
end;
writeln ('done.');
writestr (^M'All '+strr(ndel)+' forms erased.');
readurec
end;
procedure readfeedback;
var ffile:file of mailrec;
m:mailrec;
me:message;
cur:integer;
function nummessages:integer;
begin
nummessages:=filesize(ffile)
end;
function checkcur:boolean;
begin
if length(input)>1 then cur:=valu(copy(input,2,255));
if (cur<1) or (cur>nummessages) then begin
writestr (^M'Message out of range!');
cur:=0;
checkcur:=true
end else begin
checkcur:=false;
seek (ffile,cur-1);
read (ffile,m)
end
end;
procedure readnum (n:integer);
begin
cur:=n;
input:='';
if checkcur then exit;
writeln (^B^M'Message: '^S,cur,
^M'Title: '^S,m.title,
^M'Sent by: '^S,m.sentby,
^M'Sent on: '^S,datestr(m.when),' at ',timestr(m.when),^M);
if break then exit;
printtext (m.line)
end;
procedure writecurmsg;
begin
if (cur<1) or (cur>nummessages) then cur:=0;
write (^B^M'Current msg: '^S);
if cur=0 then write ('None') else begin
seek (ffile,cur-1);
read (ffile,m);
write (m.title,' by ',m.sentby)
end
end;
procedure delfeedback;
var cnt:integer;
begin
if checkcur then exit;
deletetext (m.line);
for cnt:=cur to nummessages-1 do begin
seek (ffile,cnt);
read (ffile,m);
seek (ffile,cnt-1);
write (ffile,m)
end;
seek (ffile,nummessages-1);
truncate (ffile);
cur:=cur-1
end;
procedure editusr;
var n:integer;
begin
if checkcur then exit;
n:=lookupuser (m.sentby);
if n=0
then writestr ('User disappeared!')
else edituser (n)
end;
procedure infoform;
begin
if checkcur then exit;
showinfoforms (m.sentby)
end;
procedure nextfeedback;
begin
cur:=cur+1;
if cur>nummessages then begin
writestr (^M'Sorry, no more feedback!');
cur:=0;
exit
end;
readnum (cur)
end;
procedure readagain;
begin
if checkcur then exit;
readnum (cur)
end;
procedure replyfeedback;
begin
if checkcur then exit;
sendmailto (m.sentby,false)
end;
procedure listfeedback;
var cnt:integer;
begin
if nummessages=0 then exit;
thereare (nummessages,'piece of feedback','pieces of feedback');
if break then exit;
writeln (^M'Num Title Left by'^M);
seek (ffile,0);
for cnt:=1 to nummessages do begin
read (ffile,m);
tab (strr(cnt),4);
if break then exit;
tab (m.title,31);
writeln (m.sentby);
if break then exit
end
end;
var q:integer;
label exit;
begin
assign (ffile,'Feedback');
reset (ffile);
if ioresult<>0 then rewrite (ffile);
cur:=0;
repeat
if nummessages=0 then begin
writestr ('Sorry, no feedback!');
goto exit
end;
writecurmsg;
q:=menu ('Feedback','FEED','Q#DEIR_AL');
if q<0
then readnum (-q)
else case q of
3:delfeedback;
4:editusr;
5:infoform;
6:replyfeedback;
7:nextfeedback;
8:readagain;
9:listfeedback;
end
until (q=1) or hungupon;
exit:
close (ffile)
end;
begin
end.