Jason Aller Floppy Collection/276.img/FORUM21S.ZIP/USERRET.PAS

Pascal/Delphi Source File | 1988-02-15 | 6.1 KB | 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.