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

Pascal/Delphi Source File | 1989-02-13 | 5.0 KB | 233 lines

procedure readurec;
begin
  seek (ufile,unum);
  read (ufile,urec);
  ulvl:=urec.level;
  unam:=urec.handle
end;

overlay 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)]<>'*')
      then if valu(m)=0
        then validuname:=true
        else begin
          validuname:=false;
          writestr ('Invalid user name!')
        end
end;

overlay function lookupuname (n:integer):mstr;
var u:userrec;
begin
  pushdevice;
  if (n<1) or (n>numusers) then u.handle[0]:='* Unknown *' else begin
    seek (ufile,n);
    read (ufile,u)
  end;
  if length(u.handle)=0 then u.handle:='User Disappeared';
  lookupuname:=u.handle;
  popdevice
end;

overlay 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
        then if match(copy(u.handle,1,length(uname)),uname)
          then
            begin
              write (^B,u.handle,' (Y/N/X): ');
              repeat
                k:=readchar
              until hungupon or (k<>#0);
              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;

overlay function adduser (var u:userrec):integer;
var un:userrec;
    num,cnt:integer;
    level:integer;
    handle:mstr;
    password:sstr;
    C:integer;
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;
  for c:=1 to 9 do
  u.infoform[c]:=-1;
  u.displaylen:=25;
  u.handle:=handle;
  u.level:=level;
  u.password:=password;
  u.gflvl:=defgflevel;
  u.votey:=0;
  u.voten:=0;
  u.lastmessages:=0;
  u.lastups:=0;
  seek (ufile,num);
  write (ufile,u);
  adduser:=num
end;

overlay procedure delallmail (n:integer);
var oldunum,cnt,delled:integer;
    m:mailrec;
    u:userrec;
    c:integer;
begin
  oldunum:=unum;
  unum:=n;
  cnt:=-1;
  delled:=0;
  repeat
    cnt:=searchmail(cnt);
    if cnt>0 then begin
      delmail(cnt);
      cnt:=cnt-1;
      delled:=delled+1
    end
  until cnt=0;
  unum:=oldunum;
  if delled>0 then writeln (^B'Mail deleted: ',delled);
  seek (ufile,n);
  read (ufile,u);
  for c:=1 to 9 do
  deletetext (u.infoform[c]);
  deletetext (u.emailannounce)
end;

overlay function getpassword:boolean;
var t:sstr;
begin
  getpassword:=false;
  dots:=false;
  buflen:=15;
  getstr;
  if input=''
    then exit
    else begin
      t:=input;
      dots:=true;
      writestr ('Re-enter for verification:');
      if not match(t,input) then begin
        writeln ('They don''t match!');
        getpassword:=hungupon;
        exit
      end;
      urec.password:=t;
      getpassword:=true
    end
end;

overlay function checkpassword (var u:userrec):boolean;
var tries:integer;
begin
  tries:=0;
  checkpassword:=true;
  repeat
    splitscreen (5);
    top;
    writeln (usr,'Password Entry');
    writeln (usr,'User name: ',u.handle);
    writeln (usr,'Password: ',u.password);
    write (usr,'Has entered so far: ');
    bottom;
    dots:=true;
    writestr (^M'Password please:');
    unsplit;
    if hungupon then begin
      checkpassword:=false;
      exit
    end;
    if match(input,u.password)
      then exit
      else tries:=tries+1
  until tries>3;
  checkpassword:=false
end;

procedure deleteuser (n:integer);
var u:userrec;
begin
  delallmail (n);
  fillchar (u,sizeof(u),0);
  seek (ufile,n);
  write (ufile,u)
end;

procedure writeurec;
begin
  if unum<1 then exit;
  urec.level:=ulvl;
  urec.handle:=unam;
  seek (ufile,unum);
  write (ufile,urec)
end;