Jason Aller Floppy Collection/270.img/FORUM25C.ZIP/GETLOGIN.PAS

Pascal/Delphi Source File | 1989-03-02 | 17KB | 631 lines

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

unit getlogin;


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

interface

USES CRT,
     DOS,
     gentypes,
     configrt,
     modem,
     userret,
     statret,
     gensubs,
     subs1,
     subs2,
     windows,
     StrLib,
     mailret,
     textret,
     overret1,
     mainr1,
     mainr2;

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


Procedure getloginproc;
Procedure returnfromdoor;


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

implementation

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


Procedure getloginproc;
VAR isnew:boolean;

{=============================================================================}

Procedure Do_today;
VAR Day,Month,Year,DayOfWeek : WORD;
    Ext                      : String3;
    Today_File               : String14;
    Data_file                : TEXT;
    No_more                  : BOOLEAN;
    Found                    : BOOLEAN;
    Was_born                 : BOOLEAN;
    Dat                      : String80;
CONST MonthStr : ARRAY[1..12] OF String3 = ('Jan','Feb','Mar','Apr','May',
                                            'Jun','Jul','Aug','Sep','Oct',
                                            'Nov','Dec');
Function Get_born : String80;
VAR Data : String80;
Begin
  Found := FALSE;
  No_More := FALSE;
  REPEAT
    Readln(Data_File,Data);
    If Data[1] = '*' THEN
     Begin
      Get_born := '';
      No_More := TRUE
     End
    ELSE
      Begin
        If Copy(Data,1,5) = 'B'+ZeroStr(Month,2)+ZeroStr(Day,2) THEN
          Begin
            Get_Born := Data;
            Found := TRUE;
          End
        ELSE
          Begin
            Found := FALSE;
            Get_born := '';
          End;
      End;
  UNTIL (No_more) Or (Found);
End;

Function Get_Special : String80;
VAR Data : String80;
Begin
  Found := FALSE;
  No_More := FALSE;
  REPEAT
    Readln(Data_File,Data);
    If Data[1] = '*' THEN
     Begin
      Get_special := '';
      No_More := TRUE
     End
    ELSE
      Begin
        If Copy(Data,1,5) = 'S'+ZeroStr(Month,2)+ZeroStr(Day,2) THEN
          Begin
            Get_special := Data;
            Found := TRUE;
          End
        ELSE
          Begin
            Found := FALSE;
            Get_special := '';
          End;
      End;
  If EOF(Data_file) THEN No_more := TRUE;
  UNTIL (No_more) Or (Found);
End;

CONST Full_month : ARRAY[1..12] OF String10 = ('January','February','March',
                                               'April','May','June','July',
                                               'August','September','October',
                                               'November','December');
CONST Week_day : ARRAY[0..6] OF String10 = ('Sunday','Monday','Tuesday',
                                            'Wednesday','Thrusday','Friday',
                                            'Saturday');
Begin
  GetDate(Year,Month,Day,DayOfWeek);
  Ext := MonthStr[Month];
  Today_file := ext+'.DAT';
  Assign(Data_file,Today_file);
  Reset(Data_file);
  If IOREsult <> 0 THEN
    Begin
      Exit;
    End;
  Was_Born := FALSE;
  Readln(Data_File,Dat);
  Readln(Data_file,Dat);
  Writeln;
  WriteStr('It''s '+Week_day[DayOfWeek]+', '+Full_month[Month]+' '+
            Strr(Day)+', '+Strr(year)+'.');
  Writeln;
  Writeln('Birthdays today: ');
  Writeln;
  REPEAT
    Dat := Get_born;
    If Dat <> '' THEN
      Begin
        If Dat[10] = 'C' THEN
          Begin
            Tab(' ',12);
            Writeln(Copy(Dat,11,80));
          End
        ELSE
          Begin
            Tab(' ',3);
            If Copy(Dat,6,4) <> '    ' THEN
            Tab('In '+Copy(Dat,6,5),9);
            Writeln(Copy(Dat,11,80));
          End;
      End;
  UNTIL No_more;
  Readln(data_file,Dat);
  Writeln;
  Writeln('Other events: ');
  Writeln;
  REPEAT
    Dat := Get_special;
    If Dat <> '' THEN
      Begin
        If Dat[10] = 'C' THEN
          Begin
            Tab(' ',12);
            Writeln(Copy(Dat,11,80));
          End
        ELSE
          Begin
            Tab(' ',3);
            If Copy(Dat,6,4) <> '    ' THEN
                Tab('In '+Copy(Dat,6,5),9);
            Writeln(Copy(Dat,11,80));
          End;
      End;
  UNTIL No_more;
  Close(Data_file);
End;

{=============================================================================}

  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
    if (length(systempassword)=0) or (autologin and local) then exit;
    tries:=0;
    repeat
      chainstr:='';
      writeln (^B'System password:');
      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;
      Valid_set : SET OF 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 New User 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 ('Searching for duplicate user name.');
            if not validuname(unam)
              then oldn:=1
              else begin
                oldn := lookupuser(unam);
                if oldn<>0 then writestr(^B'Name is already in use.')
              end
          end
      until oldn=0;
      ulvl := NewUserLevel;
      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;
        Valid_Set := ['1'];
        URec.Config := URec.Config - [Fseditor];

        If (ANSIGraphics In Urec.Config) OR (VT52 in URec.Config) THEN
          GetOption(FSeditor,'Do you want to use the full screen editor',TRUE);
        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);
        GetOption(ExtClrScr,'Clear screen between posts (Extenden newscan)',
                  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
      Inc(tries);
      if tries > MaxLoginTries then nicetry
       else
        begin
         chainstr:='';
{        writestr(^M'Enter your UserName[NEW=NEWUSER]'+^B^M+'[> *'); }
         WriteStr(^M+User_name_prompt+^B^M+'[> *');
         unam := input;
         isnew := false;
         enterednum := valu(unam)<>0;
         if hungupon then
           unum:=-1
         else
           begin
             If UpString(Unam) = 'NEW' THEN
              Begin
               Unam := '';
               Newuser
              End
             ELSE
              Begin
               unum := lookupuser(unam);
               if unum=0 THEN
                 Begin
                   writestr('User not found');
                 End
               else
                 IF NOT enterednum THEN
                   writeln (^M'Use ',unum,' for faster logon.')
             end
         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;
    printfile(textfiledir+'Welcom'+strr(random(numwelcomes)+1));
    if requireforms and (urec.infoform<0) then infoform;
    if local
      then tmp:=' (Local)'
      else tmp:=' at '+baudstr;
    Writeln;
    Writeln;
{    If Local THEN
      WriteStr(LongName+' running locally.')
    ELSE
      WriteStr(LongName+' operating at '+tmp);  }
    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)+
                    '.',' !','! ');
      GenTypes.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.');
      if (ulvl>=sysoplevel) then begin
        if numfeedback>0 then begin
          thereisare (numfeedback);
          writeln('piece',s(numfeedback),' of feedback waiting.')
        end;
        if exist('Errlog') then
           writeln (^B^G'Errors have occured!')
      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) OR (Ulvl >= 90) 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;
    Writeln;
    Do_today;
    Writeln;
    if tonext>-1 then begin
      writehdr ('-%-  Message from last user  -%-');
      printtext (tonext)
    end;
    disconnected:=false;
    Writeln;
    Writeln;
  End;

begin
  stoptimer (numminsidle);
  starttimer (numminsused);
  textcolor (normbotcolor);
  clrscr;
  fillchar (urec,sizeof(urec),0);
  urec.config:=[lowercase,linefeeds,eightycols];
  uselinefeeds:=true;
  usecapsonly:=false;
  getsystempassword;

  Urec.DisplayLen := 24;
  DontStop := FALSE;

  Printfile(Textfiledir+'Prelog.');

  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;
  Writeln;
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:='P'
  else
    returnto:=upcase(t[1])
end;


Begin
End.