home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Jason Aller Floppy Collection
/
276.img
/
FORUM21S.ZIP
/
OVERRET1.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-02-15
|
18KB
|
742 lines
{$R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }
{$M 65500,0,0 }
unit overret1;
interface
uses crt,
gentypes,modem,configrt,gensubs,subs1,subs2,userret,textret,flags,mainr1;
procedure help (fn:mstr);
procedure edituser (eunum:integer);
procedure printnews;
procedure sendmodemstr (ss:anystr; endifcarrier:boolean);
function getlastcaller:mstr;
procedure showlastcallers;
procedure infoform;
function selectspecs (var us:userspecsrec):boolean; { True if user aborts }
procedure editoldspecs;
implementation
procedure help (fn:mstr);
var tf:text;
htopic,cnt:integer;
begin
fn:=textfiledir+fn;
assign (tf,fn);
reset (tf);
if ioresult<>0 then begin
writestr ('Sorry, no help is availiable!');
if issysop then begin
writeln ('Sysop: To make help, create a file called ',fn);
writeln ('Group the lines into blocks separated by periods.');
writeln ('The first group is the topic menu; the second is the');
writeln ('help for topic 1; the third for topic 2; etc.')
end;
exit
end;
repeat
textclose (tf);
assign (tf,fn);
reset (tf);
writeln (^M);
printtexttopoint (tf);
repeat
writestr (^M'Topic number [CR quits]:');
if hungupon or (length(input)=0) then
begin
textclose (tf);
exit
end;
htopic:=valu (input)
until (htopic>0);
for cnt:=2 to htopic do
if not eof(tf)
then skiptopoint (tf);
if eof(tf)
then writestr ('Sorry, no help on that topic!')
else printtexttopoint (tf)
until 0=1
end;
procedure edituser (eunum:integer);
var eurec:userrec;
ca:integer;
k:char;
const sysopstr:array [false..true] of string[6]=('Normal','Sysop');
sectionnames:array [udsysop..databasesysop] of string[20]=
('File transfer','Bulletin section','Voting booths',
'E-mail section','Doors','Main menu','Databases');
procedure truesysops;
begin
writeln ('Sorry, you may not do that without true sysop access!');
writelog (18,17,'')
end;
function truesysop:boolean;
begin
truesysop:=ulvl>=sysoplevel
end;
procedure eustatus;
var cnt:integer;
k:char;
c:configtype;
begin
writehdr ('Status');
with eurec do begin
write (^M'Number: '^S,eunum,
^M'Name: '^S,handle,
^M'Phone #: '^S,phonenum,
^M'Pwd: '^S);
if truesysop
then write (password)
else write ('Classified');
write (^M'Level: '^S,level,
^M'Last on: '^S,datestr(laston),', at ',timestr(laston),
^M'Posts: '^S,nbu,
^M'Uploads: '^S,nup,
^M'Downloads: '^S,ndn,
^M'Wanted: '^S,yesno(wanted in config),
^M'File xfer',
^M' Level: '^S,udlevel,
^M' Points: '^S,udpoints,
^M' Uploads: '^S,uploads,
^M' Dnloads: '^S,downloads,
^M^M'Time on system: '^S,totaltime:0:0,
^M'Number of calls: '^S,numon,
^M'Voting record: '^S);
for cnt:=1 to maxtopics do begin
if cnt<>1 then write (',');
write (voted[cnt])
end;
writeln (^M);
for c:=udsysop to databasesysop do
if c in eurec.config
then writeln (^B'Sysop of the '^S,sectionnames[c]);
writeln
end;
writelog (18,13,'')
end;
procedure getmstr (t:mstr; var mm);
var m:mstr absolute mm;
begin
writeln ('Old ',t,': '^S,m);
writestr ('New '+t+'? *');
if length(input)>0 then m:=input
end;
procedure getsstr (t:mstr; var s:sstr);
var m:mstr;
begin
m:=s;
getmstr (t,m);
s:=m
end;
procedure getint (t:mstr; var i:integer);
var m:mstr;
begin
m:=strr(i);
getmstr (t,m);
i:=valu(m)
end;
procedure euwanted;
begin
writestr ('Wanted status: '^S+yesno(wanted in eurec.config));
writestr ('New wanted status:');
if yes
then eurec.config:=eurec.config+[wanted]
else eurec.config:=eurec.config-[wanted];
writelog (18,1,yesno(wanted in eurec.config))
end;
procedure eudel;
begin
writestr ('Delete user --- confirm:');
if yes then begin
deleteuser (eunum);
seek (ufile,eunum);
read (ufile,eurec);
writelog (18,9,'')
end
end;
procedure euname;
var m:mstr;
begin
m:=eurec.handle;
getmstr ('name',m);
if not match (m,eurec.handle) then
if lookupuser (m)<>0 then begin
writestr ('Already exists! Are you sure? *');
if not yes then exit
end;
eurec.handle:=m;
writelog (18,6,m)
end;
procedure eupassword;
begin
if not truesysop
then truesysops
else begin
getsstr ('password',eurec.password);
writelog (18,8,'')
end
end;
procedure eulevel;
var n:integer;
begin
n:=eurec.level;
getint ('level',n);
if (n>=sysoplevel) and (not truesysop)
then truesysops
else begin
eurec.level:=n;
writelog (18,15,strr(n))
end
end;
procedure euphone;
var m:mstr;
p:integer;
begin
m:=eurec.phonenum;
buflen:=15;
getmstr ('phone number',m);
p:=1;
while p<=length(m) do
if (m[p] in ['0'..'9'])
then p:=p+1
else delete (m,p,1);
if length(m)>7 then begin
eurec.phonenum:=m;
writelog (18,16,m)
end
end;
procedure boardflags;
var quit:boolean;
procedure listflags;
var bd:boardrec;
cnt:integer;
begin
seek (bdfile,0);
for cnt:=0 to filesize(bdfile)-1 do begin
read (bdfile,bd);
tab (bd.shortname,9);
tab (bd.boardname,30);
writeln (accessstr[getuseraccflag (eurec,cnt)]);
if break then exit
end
end;
procedure changeflag;
var bn,q:integer;
bname:mstr;
ac:accesstype;
begin
buflen:=8;
writestr ('Board to change access:');
bname:=input;
bn:=searchboard(input);
if bn=-1 then begin
writeln ('Not found!');
exit
end;
writeln (^B^M'Current access: '^S,
accessstr[getuseraccflag (eurec,bn)]);
getacflag (ac,input);
if ac=invalid then exit;
setuseraccflag (eurec,bn,ac);
case ac of
letin:q:=2;
keepout:q:=3;
bylevel:q:=4
end;
writelog (18,q,bname)
end;
procedure allflags;
var ac:accesstype;
begin
writehdr ('Set all board access flags');
getacflag (ac,input);
if ac=invalid then exit;
writestr ('Confirm [Y/N]:');
if not yes then exit;
setalluserflags (eurec,ac);
writelog (18,5,accessstr[ac])
end;
begin
opentempbdfile;
quit:=false;
repeat
repeat
writestr (^M'L)ist flags, C)hange one flag, A)ll flags, or Q)uit:');
if hungupon then exit
until length(input)<>0;
case upcase(input[1]) of
'L':listflags;
'C':changeflag;
'A':allflags;
'Q':quit:=true
end
until quit;
closetempbdfile
end;
procedure specialsysop;
procedure getsysop (c:configtype);
begin
writeln ('Section ',sectionnames[c],': '^S,
sysopstr[c in eurec.config]);
writestr ('Grant sysop access? *');
if length(input)<>0
then if yes
then
begin
eurec.config:=eurec.config+[c];
writelog (18,10,sectionnames[c])
end
else
begin
eurec.config:=eurec.config-[c];
writelog (18,11,sectionnames[c])
end
end;
begin
if not truesysop then begin
truesysops;
exit
end;
writestr
('Section of M)ain, F)ile, B)ulletin, V)oting, E)mail, D)atabase, P)Doors:');
if length(input)=0 then exit;
case upcase(input[1]) of
'M':getsysop (mainsysop);
'F':getsysop (udsysop);
'B':getsysop (bulletinsysop);
'V':getsysop (votingsysop);
'E':getsysop (emailsysop);
'D':getsysop (databasesysop);
'P':getsysop (doorssysop)
end
end;
procedure getlogint (prompt:mstr; var i:integer; ln:integer);
begin
getint (prompt,i);
writelog (18,ln,strr(i))
end;
var q:integer;
begin
writeurec;
seek (ufile,eunum);
read (ufile,eurec);
writelog (2,3,eurec.handle);
repeat
q:=menu('User edit','UEDIT','SDHPLOEWTBQYNI');
case q of
1:eustatus;
2:eudel;
3:euname;
4:eupassword;
5:eulevel;
6:getlogint ('u/d points',eurec.udpoints,7);
7:getlogint ('u/d level',eurec.udlevel,14);
8:euwanted;
9:getlogint ('time for today',eurec.timetoday,12);
10:boardflags;
12:specialsysop;
13:euphone;
14:showinfoforms(strr(eunum))
end
until hungupon or (q=11);
writeufile (eurec,eunum);
readurec
end;
procedure printnews;
var nfile:file of integer;
line:integer;
begin
assign (nfile,'News');
reset (nfile);
if ioresult<>0 then exit;
if filesize (nfile)=0 then begin
close (nfile);
exit
end;
writehdr ('News: Hit <SPACE> to abort');
while not (eof(nfile) or break or hungupon) do begin
read (nfile,line);
if line>=0 then begin
writeln;
printtext (line)
end
end;
close (nfile)
end;
procedure sendmodemstr (ss:anystr; endifcarrier:boolean);
var cnt,ptr:integer;
k:char;
label exit;
begin
ptr:=0;
while ptr<length(ss) do
begin
if keyhit or (carrier=endifcarrier) then goto exit;
ptr:=ptr+1;
k:=ss[ptr];
case k of
'|':sendchar (^M);
'~':delay (500);
'^':begin
ptr:=ptr+1;
if ptr>length(ss)
then k:='^'
else k:=upcase(ss[ptr]);
if k in ['A'..'Z']
then sendchar (chr(ord(k)-64))
else sendchar (k)
end;
else sendchar (k)
end;
delay (50);
while numchars>0 do writecon (getchar)
end;
cnt:=0;
repeat
while numchars>0 do begin
cnt:=0;
writecon (getchar)
end;
cnt:=cnt+1
until (cnt=1000) or keyhit or (carrier=endifcarrier);
exit:
break:=keyhit
end;
function getlastcaller:mstr;
var qf:file of lastrec;
l:lastrec;
begin
getlastcaller:='';
assign (qf,'Callers');
reset (qf);
if ioresult=0 then
if filesize(qf)>0
then
begin
seek (qf,0);
read (qf,l);
getlastcaller:=l.name
end;
close (qf)
end;
procedure showlastcallers;
var qf:file of lastrec;
cnt:integer;
l:lastrec;
begin
assign (qf,'Callers');
reset (qf);
if ioresult=0 then begin
writehdr ('Recent caller list');
break:=false;
for cnt:=0 to filesize(qf)-1 do
if not break then begin
read (qf,l);
tab (l.name,33);
writeln (datestr(l.when)+' '+timestr(l.when))
end
end;
close (qf)
end;
procedure infoform;
var ff:text;
fn:lstr;
k:char;
me:message;
begin
writeln;
fn:=textfiledir+'InfoForm';
if not exist (fn) then begin
writestr ('There isn''t an information form right now.');
if issysop then
writeln ('Sysop: To make an information form, create a text file',
^M'called ',fn,'. Use * to indicate a pause for user input.');
exit
end;
if urec.infoform<>-1 then begin
writestr ('You have an existing information form! Replace it? *');
if not yes then exit;
deletetext (urec.infoform);
urec.infoform:=-1;
writeurec
end;
assign (ff,fn);
reset (ff);
me.numlines:=1;
me.title:='';
me.anon:=false;
me.text[1]:='Filled out on: '+datestr(now)+' at '+timestr(now);
while not eof(ff) do begin
if hungupon then begin
textclose (ff);
exit
end;
read (ff,k);
if k='*' then begin
nochain:=true;
getstr;
me.numlines:=me.numlines+1;
me.text[me.numlines]:=input
end else writechar (k)
end;
textclose (ff);
urec.infoform:=maketext (me);
writeurec
end;
procedure openusfile;
const newusers:userspecsrec=(name:'New users';minlevel:1;maxlevel:1;
minlaston:-maxint;maxlaston:maxint;minpcr:-maxint;maxpcr:maxint);
begin
assign (usfile,'userspec');
reset (usfile);
if ioresult<>0 then begin
rewrite (usfile);
if level2nd<>0 then newusers.maxlevel:=level2nd;
write (usfile,newusers)
end
end;
procedure editspecs (var us:userspecsrec);
procedure get (tex:string; var value:integer; min:boolean);
var vstr:sstr;
begin
buflen:=6;
if abs(value)=maxint then vstr:='None' else vstr:=strr(value);
writestr (tex+' ['+vstr+']:');
if input[0]<>#0
then if upcase(input[1])='N'
then if min
then value:=-maxint
else value:=maxint
else value:=valu(input)
end;
procedure getreal (tex:string; var value:real; min:boolean);
var vstr:sstr;
s:integer;
begin
buflen:=10;
if abs(value)=maxint then vstr:='None' else vstr:=streal(value);
writestr (tex+' ['+vstr+']:');
if length(input)<>0
then if upcase(input[1])='N'
then if min
then value:=-maxint
else value:=maxint
else begin
val (input,value,s);
if s<>0 then value:=0
end
end;
begin
writeln (^B^M'Enter specifications; N for none.'^M);
buflen:=30;
writestr ('Specification set name ['+us.name+']:');
if length(input)<>0
then if match(input,'N')
then us.name:='Unnamed'
else us.name:=input;
get ('Lowest level',us.minlevel,true);
get ('Highest level',us.maxlevel,true);
get ('Lowest #days since last call',us.minlaston,true);
get ('Highest #days since last call',us.maxlaston,true);
getreal ('Lowest post to call ratio',us.minpcr,true);
getreal ('Highest post to call ratio',us.maxpcr,true)
end;
function getspecs (var us:userspecsrec):integer; { -1:not saved >0:in file }
begin
with us do begin
name:='Unnamed'; { Assumes USFILE is open !! }
minlevel:=-maxint;
maxlevel:=maxint;
minlaston:=-maxint;
maxlaston:=maxint;
minpcr:=-maxint;
maxpcr:=maxint
end;
editspecs (us);
writestr (^M'Save these specs to disk? *');
if yes then begin
seek (usfile,filesize(usfile));
write (usfile,us);
getspecs:=filesize(usfile)
end else getspecs:=-1
end;
function searchspecs (var us:userspecsrec; name:mstr):integer;
var v,pos:integer;
begin
v:=valu(name);
seek (usfile,0);
pos:=1;
while not eof(usfile) do begin
read (usfile,us);
if match(us.name,name) or (valu(name)=pos) then begin
searchspecs:=pos;
exit
end;
pos:=pos+1
end;
searchspecs:=0;
writestr (^M'Not found!')
end;
procedure listspecs;
var us:userspecsrec;
pos:integer;
procedure writeval (n:integer);
begin
if abs(n)=maxint then write (' None') else write(n:7)
end;
procedure writevalreal (n:real);
begin
if abs(n)=maxint then write (' None') else write(n:7:2)
end;
begin
writehdr ('User Specification Sets');
seek (usfile,0);
pos:=0;
tab ('',35);
tab (' Level ',14);
tab (' Last Call ',14);
writeln (' Post/Call Ratio ');
while not (break or eof(usfile)) do begin
pos:=pos+1;
read (usfile,us);
write (pos:3,'. ');
tab (us.name,30);
writeval (us.minlevel);
writeval (us.maxlevel);
writeval (us.minlaston);
writeval (us.maxlaston);
writevalreal (us.minpcr);
writevalreal (us.maxpcr);
writeln
end
end;
function selectaspec (var us:userspecsrec):integer; { 0 = none }
var done:boolean; { -1 = not in file }
pos:integer; { -2 = added to end }
begin
selectaspec:=0;
openusfile;
if filesize(usfile)=0
then selectaspec:=getspecs(us)
else
repeat
if hungupon then exit;
done:=false;
writestr (^M'Specification set name (?=list, A=add):');
if length(input)=0
then done:=true
else if match(input,'A')
then
begin
pos:=getspecs(us);
if pos>0
then selectaspec:=-2
else selectaspec:=-1;
done:=true
end
else if match(input,'?')
then listspecs
else
begin
pos:=searchspecs (us,input);
done:=pos<>0;
selectaspec:=pos
end
until done;
close (usfile)
end;
function selectspecs (var us:userspecsrec):boolean;
var dummy:integer;
begin
dummy:=selectaspec (us);
selectspecs:=dummy=0
end;
procedure deletespecs (pos:integer);
var cnt:integer;
us:userspecsrec;
begin
openusfile;
for cnt:=pos to filesize(usfile)-1 do begin
seek (usfile,cnt);
read (usfile,us);
seek (usfile,cnt-1);
write (usfile,us)
end;
seek (usfile,filesize(usfile)-1);
truncate (usfile);
close (usfile)
end;
procedure editoldspecs;
var pos:integer;
us:userspecsrec;
begin
repeat
pos:=selectaspec (us);
if pos>0 then begin
buflen:=1;
writestr (^M'E)dit or D)elete? *');
if length(input)=1 then case upcase(input[1]) of
'E':begin
editspecs (us);
openusfile;
seek (usfile,pos-1);
write (usfile,us);
close (usfile)
end;
'D':deletespecs (pos)
end
end
until (pos=0) or hungupon
end;
begin
end.