home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Jason Aller Floppy Collection
/
270.img
/
FORUM25C.ZIP
/
GETLOGIN.PAS
< prev
next >
Wrap
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.