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

Pascal/Delphi Source File | 1988-09-28 | 11.9 KB | 429 lines

{$R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }
{$M 65500,0,0 }

unit getlogin;

interface

uses crt,
     gentypes,configrt,modem,userret,statret,gensubs,subs1,subs2,windows,
     mailret,textret,overret1,mainr1,mainr2;

procedure getloginproc;
procedure returnfromdoor;

implementation

procedure getloginproc;
var isnew:boolean;

  procedure addlastcaller (n:mstr);
  var qf:file of lastrec;
      last,cnt:integer;
      l:lastrec;
  begin
    assign (qf,'Callers');
    reset (qf);
    if ioresult<>0 then rewrite (qf);
    last:=filesize(qf);
    if last>maxlastcallers then last:=maxlastcallers;
    for cnt:=last-1 downto 0 do begin
      seek (qf,cnt);
      read (qf,l);
      seek (qf,cnt+1);
      write (qf,l)
    end;
    with l do begin
      name:=n;
      when:=now;
      callnum:=round(numcallers)
    end;
    seek (qf,0);
    write (qf,l);
    close (qf)
  end;

  procedure byebye (byefile:sstr);
  begin
    printfile (textfiledir+byefile);
    unum:=-1;
    disconnect
  end;

  procedure nicetry;
  begin
    byebye ('NiceTry')
  end;

  procedure getsystempassword;
  var tries:integer;
      b:boolean;
  begin
    tries:=0;
    writeln(^B'              DDT/6');
    writeln;
    writeln(^B'    Kelv''s answering machine.   ');
    writeln(^B' Leave your name and number and ');
    writeln(^B' I''ll try to get back to you as ');
    writeln(^B' soon as I can.  If it''s urgent ');
    writeln(^B' put an (*) after your name.    ');
    writeln(^B' ------------------------------ ');
    repeat
      chainstr:='';
      writeln (^B'Entry:');
      dots:=true;
      writestr ('=> *');
      tries:=tries+1;
      b:=match(input,systempassword)
    until (tries=4) or b;
    if not b then nicetry
  end;

  procedure newuser;

    function validphone:boolean;
    var p:integer;
        k:char;
    begin
      validphone:=false;
      p:=1;
      while p<=length(input) do begin
        k:=input[p];
        if k in ['0'..'9']
          then p:=p+1
          else delete (input,p,1);
      end;
      if length(input)<>10 then begin
        writestr ('The phone number must be 10 digits long.');
        exit
      end;
      if (input[2] in ['2'..'9']) or (input[1] in ['0','1'])
         or (input[4] in ['0','1']) then begin
           writestr ('Invalid phone number.');
           exit
         end;
      validphone:=true
    end;

    procedure getoption (c:configtype; txt:lstr; b:boolean);
    const yn:array [false..true] of string[3]=('No','Yes');
    begin
      if hungupon then exit;
      txt:=txt+' [def: '+yn[b]+'] ? *';
      writestr (txt);
      if length(input)<>0 then b:=yes;
      if b
        then urec.config:=urec.config+[c]
        else urec.config:=urec.config-[c]
    end;

  var oldn:integer;
      k:char;
  begin
    if private then byebye ('Newuser') else begin
      printfile (textfiledir+'Newuser');
      unum:=0;
      oldn:=0;
      repeat
        if oldn<>0 then unam:='';
        if length(unam)=0 then begin
          writestr (^B'Enter your name:'^M'=> *');
          unam:=input;
          if pos('*',unam)>0 then begin
            writestr ('Invalid user name!');
            oldn:=1
          end
        end;
        if hungupon then exit;
        if length(unam)=0
          then oldn:=0
          else begin
            writestr ('Hold on a sec..');
            if not validuname(unam)
              then oldn:=1
              else begin
                oldn:=lookupuser(unam);
                if oldn<>0 then writestr (^B'Sorry!  That name is in use!')
              end
          end
      until oldn=0;
      ulvl:=1;
      if unam<>'' then begin
        unum:=adduser (urec);
        if unum<1 then begin
          writeln (^B'Sorry!  No room for new users right now!'^M,
                   'Try again later!'^M);
          hangupmodem;
          exit
        end;
        writeln (^B^M'You are user number ',unum,'.');
        repeat
          lastprompt:=^B^M'Please choose a password now.'^B^M'> ';
          write (lastprompt)
        until getpassword or hungupon;
        with urec do begin
          regularcolor:=7;
          promptcolor:=7;
          statcolor:=7;
          inputcolor:=7
        end;
        repeat
          writestr (^M'What is your home phone number? *');
        until validphone or hungupon;
        urec.phonenum:=input;
        writeln;
        repeat
          writestr ('Can you emulate: A)NSI color, V)T52, or N)one:');
          if length(input)>0
            then k:=upcase(input[1])
            else k:='N'
        until (k in ['A','N','V']) or hungupon;
        case k of
          'A':urec.config:=urec.config+[ansigraphics];
          'V':urec.config:=urec.config+[vt52];
          'N':getoption (lowercase,'Can you display lower case',true)
        end;
        if k in ['A','V']
          then getoption (fseditor,
                  'Do you want to use the full-screen editor',true)
          else urec.config:=urec.config-[fseditor];
        getoption (moreprompts,'Should I pause after every screen',false);
        repeat
          writestr ('How many lines long is your screen? *');
          urec.displaylen:=valu(input)
        until ((urec.displaylen>20) and (urec.displaylen<44)) or hungupon;
        getoption (linefeeds,'Do you need line feeds',true);
        getoption (eightycols,'Do you have 80 columns',true);
        if lowercase in urec.config then
         getoption (asciigraphics,'Can you see IBM graphics characters',true);
        if hungupon then begin
          unum:=0;
          exit
        end;
        writeurec;
        isnew:=true
      end else begin
        unum:=0;
        writeln (^B^M'If you aren''t a new user...')
      end
    end
  end;

  procedure getunum;
  var tries,cnt:integer;
      u:userrec;
      enterednum:boolean;
  begin
    tries:=0;
    repeat
      tries:=tries+1;
      if tries>3 then nicetry else begin
        chainstr:='';
        writestr
          (^M'Enter your full name.'+^B^M+'=> *');
        unam:=input;
        isnew:=false;
        enterednum:=valu(unam)<>0;
        if hungupon then unum:=-1 else
          if length(unam)=0
            then newuser
            else begin
              unum:=lookupuser (unam);
              if unum=0
                then
                  begin
                    writestr ('Not found!  Are you new? *');
                    if yes then newuser
                  end
                else if not enterednum
                  then writeln (^M'Use ',unum,' for faster logon.')
            end
      end
    until unum<>0
  end;

  procedure getpwd;
  var u:userrec;
  begin
    seek (ufile,unum);
    read (ufile,u); che;
    if not checkpassword(u) then begin
      nicetry;
      writelog (0,2,unam)
    end;
    writeln (^M)
  end;

  procedure inituser;
  var asc:boolean;

    procedure center (c:lstr; a,b:sstr);
    var cnt:integer;
        tmp:lstr;
    begin
      if asc then begin
        a:='│';
        b:=a
      end;
      fillchar (tmp[1],80,32);
      if length(a)+length(b)+length(c)>39
        then c[0]:=chr(39-length(a)-length(b));
      tmp[0]:=chr((39-length(c)-length(a)-length(b)) div 2);
      c:=a+tmp+c;
      tmp[0]:=chr(39-length(c)-length(b));
      c:=c+tmp+b;
      while c[length(c)]=' ' do c[0]:=pred(c[0]);
      writeln (c)
    end;

  var m:mailrec;
      cnt:integer;
      tmp:lstr;
  const inoutstr:array [false..true] of string[3]=('Out','In');
  begin
    readurec;
    if ulvl=-1 then begin
      byebye ('Trashcan');
      exit
    end;
    if requireforms and (urec.infoform<0) then infoform;
    writestr ('O.K. you''re on!'^M);
    if local
      then tmp:=' (Local)'
      else tmp:=' at '+baudstr;
    writelog (0,1,unam+tmp);
    with urec do begin
      numon:=numon+1;
      numcallers:=numcallers+1;
      callstoday:=callstoday+1;
      asc:=asciigraphics in config;
      if datepart(laston)<>datepart(now) then begin
        cnt:=ulvl;
        if cnt<1 then cnt:=1;
        if cnt>100 then cnt:=100;
        timetoday:=usertime[cnt]
      end;
      if (timetillevent<timetoday+3) and (timetillevent<=63) then begin
        writestr (^M'Due to a timed event scheduled for '+eventtime+',');
        writeln ('your time today is limited to ',timetillevent-3,' mins.')
      end;
      write (^B^M);
      if asc
        then writeln ('╒══════════╡ '^S,versionnum,^N' ╞══════════╕')
        else writeln ('/----------: ',versionnum,' :----------\');
      center ('Welcome, '+unam+'.','\','/');
      center ('Caller number: '+streal(numcallers),' \','/ ');
      center ('Last caller: '+getlastcaller,' /','\ ');
      center ('This is time on #'+strr(numon)+' for you.','/','\');
      center ('Total time on: '+streal(totaltime)+' mins.','\','/');
      if laston<>0 then
        center ('Last on '+datestr(laston)+' at '+timestr(laston)+
                    '.',' !','! ');
      subs1.laston:=laston;
      laston:=now;
      center ('Time for today: '+strr(timetoday)+' mins.',' /','\ ');
      center ('Your ranking: Level '+strr(ulvl),'/','\');
      center ('Sysop is: '+inoutstr[sysopisavail],'!','!');
      if asc
        then writeln ('╘═════════════════════════════════════╛'^B^M)
        else writeln ('\-------------------------------------/'^B^M);
      cnt:=getnummail(unum);
      if cnt>0
        then writeln (^B^G'You have ',cnt,
                 ' piece',s(cnt),' of mail waiting!  Use [E] to read.');
      if (ulvl>=sysoplevel) then begin
        if numfeedback>0 then begin
          thereisare (numfeedback);
          writeln ('piece',s(cnt),' of feedback waiting!  Use [%,F] to read.')
        end;
        if exist ('Errlog')
          then writeln (^B^G'Errors have occured!  Use [%,E] to read.')
      end;
      logontime:=timer;
      logofftime:=timer+timetoday;
      logonunum:=unum
    end;
    if exist ('ad')
      then writestr ('Buy this software!  Use & to read!');
    addlastcaller (unam);
    writeurec;
    bottomline;
    if wanted in urec.config then if sysopisavail then begin
      writeln (^B,sysopname,' wishes to speak with you.');
      writeln ('Paging.. please stand by...'^M);
      for cnt:=1 to 25 do if not keyhit then summonbeep;
      chatmode:=true
    end;
    printnews;
    if tonext>-1 then begin
      writehdr ('Message from last user');
      printtext (tonext)
    end;
    disconnected:=false
  end;

begin
  stoptimer (numminsidle);
  starttimer (numminsused);
  textcolor (normbotcolor);
  clrscr;
  initwinds;
  fillchar (urec,sizeof(urec),0);
  urec.config:=[lowercase,linefeeds,eightycols];
  uselinefeeds:=true;
  usecapsonly:=false;
  getsystempassword;
  printfile (textfiledir+'Welcome.'+strr(random(numwelcomes)+1));
  if autologin and local and (not carrier) then begin
    unum:=lookupuser (sysopname);
    if unum=0
      then writeln (usr,'User ',sysopname,' not found!')
      else begin
        writeln (usr,'* SYSOP AUTOLOGIN *');
        unum:=1;
        inituser;
        exit
      end
  end;
  getunum;
  if hungupon then exit;
  if not isnew then getpwd;
  if hungupon then exit;
  inituser
end;

procedure returnfromdoor;
var t:sstr;
begin
  if not fromdoor then exit;
  readdataarea;
  baudrate:=valu(paramstr(2));
  parity:=boolean(valu(paramstr(3)));
  online:=baudrate<>0;
  local:=not online;
  if baudrate=0 then baudrate:=defbaudrate;
  setparam (usecom,baudrate,parity);
  if unum=valu(paramstr(1)) then readurec else begin
    unum:=valu(paramstr(1));
    readurec;
    if (unum<1) or (unum>numusers) then begin
      unum:=-1;
      exit
    end;
    logontime:=timer;
    logofftime:=timer+urec.timetoday
  end;
  if hungupon then begin
    unum:=-1;
    exit
  end;
  fromdoor:=true;
  t:=paramstr(4);
  if t=''
    then returnto:='D'
    else returnto:=upcase(t[1])
end;

begin
end.