Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FORUM25C.ZIP/USERRET.PAS

Pascal/Delphi Source File | 1989-01-02 | 6.4 KB | 271 lines

{$R-,S-,I-,D-,V-,B-,N-,L- }
{$O+}

unit userret;


{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

interface

uses gentypes,gensubs,subs1,configrt,textret,mailret,DOS;

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}


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 writeurec;
begin
  if unum<1 then exit;
  urec.level:=ulvl;
  urec.handle:=unam;
  seek (ufile,unum);
  write (ufile,urec)
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 u:userrec;
begin
  if (n<1) or (n>numusers) then u.handle:='* Unknown *' else begin
    seek (ufile,n);
    read (ufile,u)
  end;
  if length(u.handle)=0 then u.handle:='User Disappeared';
  lookupuname:=u.handle;
end;

Function lookupuser (VAR uname:mstr):integer;
VAR u:userrec;
    cnt,s:integer;
    wildcarding:boolean;
    k:char;
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 (ufile,cnt);
    read (ufile,u);
    if length (u.handle)>0 then begin
      lookupuser:=cnt;
      uname:=u.handle
    end;
    exit
  end;
  seek (ufile,1);
  for cnt:=1 to numusers do
    begin
      read (ufile,u);
      if wildcarding and (u.handle<>'')
        then if match(copy(u.handle,1,length(uname)),uname)
          then
            begin
              write (^B,u.handle,' (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:=u.handle;
                      exit
                    end;
                 'X':exit
              end
            end
          else
        else if match (u.handle,uname)
          then
            begin
              lookupuser := cnt;
              uname := u.handle;
              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;
  seek (ufile,num);
  write (ufile,u);
  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;
  seek (ufile,n);
  write (ufile,u);
  readurec
end;

Procedure deleteuser (n:integer);
VAR u:userrec;
begin
  delallmail (n);
  fillchar (u,sizeof(u),0);
  u.infoform:=-1;
  u.emailannounce:=-1;
  seek (ufile,n);
  write (ufile,u)
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;

Begin
End.