home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Jason Aller Floppy Collection
/
276.img
/
FORUM21S.ZIP
/
USERRET.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-02-15
|
6KB
|
263 lines
{$R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }
{$M 65500,0,0 }
unit userret;
interface
uses dos,
gentypes,gensubs,subs1,configrt,mailret,textret;
procedure writeufile (var u:userrec; n:integer);
procedure writeurec;
procedure readurec;
function validuname (m:mstr):boolean;
function lookupuname (n:integer):mstr;
function lookupuser (var uname:mstr):integer;
function adduser (var u:userrec):integer;
procedure delallmail (n:integer);
procedure deleteuser (n:integer);
procedure updateuserstats (disconnecting:boolean);
function postcallratio (var u:userrec):real;
function fitsspecs (var u:userrec; var us:userspecsrec):boolean;
implementation
procedure writeufile (var u:userrec; n:integer);
begin
seek (ufile,n);
write (ufile,u);
seek (uhfile,n);
write (uhfile,u.handle)
end;
procedure writeurec;
begin
if unum<1 then exit;
urec.level:=ulvl;
urec.handle:=unam;
writeufile (urec,unum)
end;
procedure readurec;
begin
seek (ufile,unum);
read (ufile,urec);
ulvl:=urec.level;
unam:=urec.handle
end;
function validuname (m:mstr):boolean;
var n:integer;
begin
if length(m)>0
then if (m<>'?') and (m[1]<>'#') and (m[1]<>'/') and (m[length(m)]<>'*')
and (not match(m,'new')) and (not match(m,'q'))
then if valu(m)=0
then validuname:=true
else begin
validuname:=false;
writeln (^B'Invalid user name!')
end
end;
function lookupuname (n:integer):mstr;
var un:mstr;
begin
if (n<1) or (n>numusers) then un:='* Unknown *' else begin
seek (uhfile,n);
read (uhfile,un);
if length(un)=0 then un:='* User Disappeared *'
end;
lookupuname:=un
end;
function lookupuser (var uname:mstr):integer;
var cnt,s:integer;
wildcarding:boolean;
k:char;
uh:mstr;
begin
lookupuser:=0;
if length(uname)=0 then exit;
if uname[1]='/' then exit;
if uname[1]='#' then delete (uname,1,1);
wildcarding:=uname[length(uname)]='*';
if wildcarding then uname[0]:=pred(uname[0]);
val (uname,cnt,s);
if (s=0) and (cnt>0) and (cnt<=numusers) then begin
seek (uhfile,cnt);
read (uhfile,uh);
if length (uh)>0 then begin
lookupuser:=cnt;
uname:=uh
end;
exit
end;
seek (uhfile,1);
for cnt:=1 to numusers do
begin
read (uhfile,uh);
if wildcarding and (uh<>'')
then if match(copy(uh,1,length(uname)),uname)
then
begin
write (^B,uh,' (Y/N/X): ');
repeat
read (k);
k:=upcase(k)
until hungupon or (k in ['Y','N','X']);
writeln (k);
case upcase(k) of
'Y':begin
lookupuser:=cnt;
uname:=uh;
exit
end;
'X':exit
end
end
else
else if match (uh,uname)
then
begin
lookupuser:=cnt;
uname:=uh;
exit
end
end
end;
function adduser (var u:userrec):integer;
var un:userrec;
num,cnt:integer;
level:integer;
handle:mstr;
password:sstr;
label found;
begin
num:=numusers+1;
for cnt:=1 to numusers do begin
seek (ufile,cnt);
read (ufile,un);
if length(un.handle)=0 then
begin
num:=cnt;
goto found
end
end;
if num>maxusers then begin
adduser:=-1;
exit
end;
numusers:=num;
found:
handle:=u.handle;
level:=u.level;
password:=u.password;
fillchar (u,sizeof(u),0);
u.config:=[lowercase,eightycols,linefeeds,postprompts];
u.udlevel:=defudlevel;
u.udpoints:=defudpoints;
u.emailannounce:=-1;
u.infoform:=-1;
u.displaylen:=25;
u.handle:=handle;
u.level:=level;
u.password:=password;
writeufile (u,num);
adduser:=num
end;
procedure delallmail (n:integer);
var cnt,delled:integer;
m:mailrec;
u:userrec;
begin
cnt:=-1;
delled:=0;
repeat
cnt:=searchmail(cnt,n);
if cnt>0 then begin
delmail(cnt);
cnt:=cnt-1;
delled:=delled+1
end
until cnt=0;
if delled>0 then writeln (^B'Mail deleted: ',delled);
writeurec;
seek (ufile,n);
read (ufile,u);
deletetext (u.infoform);
deletetext (u.emailannounce);
u.infoform:=-1;
u.emailannounce:=-1;
writeufile (u,n);
readurec
end;
procedure deleteuser (n:integer);
var u:userrec;
begin
delallmail (n);
fillchar (u,sizeof(u),0);
u.infoform:=-1;
u.emailannounce:=-1;
writeufile (u,n)
end;
procedure updateuserstats (disconnecting:boolean);
var timeon:integer;
begin
with urec do begin
timeon:=timeontoday;
timetoday:=timetoday-timeon;
if timetoday<0 then timetoday:=0;
totaltime:=totaltime+timeon;
if tempsysop then begin
ulvl:=regularlevel;
writeln (usr,'(Disabling temporary sysop powers)');
writeurec
end;
if disconnecting and (numon=1) then begin
if (ulvl=1) and (level2nd<>0) then ulvl:=level2nd;
if (udlevel=defudlevel) and (udlevel2nd<>0) then udlevel:=udlevel2nd;
if (udpoints=defudpoints) and (udpoints2nd<>0)
then udpoints:=udpoints2nd
end;
if not disconnecting then writedataarea
end;
writeurec
end;
function postcallratio (var u:userrec):real;
begin
if u.numon=0
then postcallratio:=0
else postcallratio:=u.nbu/u.numon
end;
function fitsspecs (var u:userrec; var us:userspecsrec):boolean;
var days:integer;
pcr:real;
thisyear,thismonth,thisday,t:word;
lastcall:datetime;
function inrange (n,min,max:integer):boolean;
begin
inrange:=(n>=min) and (n<=max)
end;
begin
unpacktime (u.laston,lastcall);
getdate (thisyear,thismonth,thisday,t);
days:=(thisyear-lastcall.year)*365+(thismonth-lastcall.month)*30+
(thisday-lastcall.day);
pcr:=postcallratio (u);
fitsspecs:=inrange (u.level,us.minlevel,us.maxlevel) and
inrange (days,us.minlaston,us.maxlaston) and
(pcr>=us.minpcr) and (pcr<=us.maxpcr)
end;
end.