home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Jason Aller Floppy Collection
/
276.img
/
FORUM21S.ZIP
/
WAITCALL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-02-13
|
14KB
|
511 lines
{$R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }
{$M 65500,0,0 }
unit waitcall;
interface
uses dos,crt,
gentypes,statret,configrt,modem,gensubs,subs1,subs2,mailret,
overret1,mainr1,mainr2,titlepg;
function waitforacall:boolean;
implementation
function waitforacall:boolean;
var wscount:integer;
mustgetbaud:boolean;
procedure maybewritestatus;
begin
wscount:=wscount+1;
if wscount>10 then begin
writestatus;
wscount:=0
end
end;
(***
function checkforhayesreport:boolean; { Looks for CONNECT 300 }
var n:longint;
q:sstr;
p,b:integer;
k:char;
brate:baudratetype;
const lookfor:sstr=#13#10'CONNECT ';
begin
checkforhayesreport:=false;
if numchars=0 then exit;
p:=1;
q:='';
b:=0;
repeat
n:=now;
repeat until (now>n+1) or (numchars>0);
if numchars=0 then exit else k:=getchar;
if (k=#13) and (length(q)>0) then begin
val (q,b,p);
brate:=b110;
while (brate<=b9600) and
((b<>baudarray[brate])
or (not (brate in supportedrates)))
do brate:=succ(brate);
if brate<=b9600 then begin
parity:=false;
baudrate:=b;
checkforhayesreport:=true;
mustgetbaud:=false;
n:=now;
repeat until carrier or (now>n+1)
end;
exit
end;
if p>length(lookfor) then q:=q+k else begin
if k=lookfor[p] then p:=p+1 else begin
b:=b+1;
if b=2 then exit
end
end
until false
end;
***)
procedure receivecall;
var b:byte;
timeout,autoswitch:integer;
k:char;
brate:baudratetype;
procedure nextrate (var b:baudratetype);
var ob:baudratetype;
begin
ob:=b;
repeat
b:=succ(b);
if b>b9600 then b:=b110;
if b=ob then exit
until b in supportedrates
end;
procedure disconnect;
begin
if carrier then hangupmodem;
baudrate:=defbaudrate;
parity:=false;
setparam (usecom,baudrate,parity);
setupmodem
end;
function seconds:integer;
var r:registers;
begin
r.ah:=$2c;
intr ($21,r);
seconds:=r.dh
end;
label abort,connected;
begin
local:=false;
online:=false;
textcolor (normbotcolor);
window (1,1,80,25);
clrscr;
window (1,1,80,24);
if not mustgetbaud then goto connected;
writeln (usr,'╒═════════════════════════════════════════════════╕');
writeln (usr,'│ Someone is calling │');
writeln (usr,'│ Waiting for the user to press the CR key │');
writeln (usr,'│ Press CR yourself to choose displayed BAUD rate │');
writeln (usr,'│ Press space to advance to the next BAUD rate │');
writeln (usr,'│ Press D to disconnect │');
writeln (usr,'╘═════════════════════════════════════════════════╛');
writeln;
brate:=b110;
parity:=false;
timeout:=timer+2;
repeat
nextrate (brate);
baudrate:=baudarray[brate];
textcolor (outlockcolor);
textbackground (0);
write (usr,^M^J'Trying ',baudrate,' BAUD: ');
setparam (usecom,baudrate,parity);
while numchars>0 do k:=getchar;
autoswitch:=seconds+3;
if autoswitch>59 then autoswitch:=autoswitch-60;
repeat until (not carrier) or (numchars>0) or (keyhit) or
(timer>=timeout) or (autoswitch=seconds);
if timer>=timeout then hangupmodem;
if not carrier then goto abort;
if keyhit
then
begin
k:=bioskey;
case upcase(k) of
#13:goto connected;
'D':goto abort;
end
end
else
begin
if numchars>0 then begin
b:=ord(getchar);
write (usr,b,' received.')
end else b:=0;
if b<>13
then if b=141
then parity:=true
else
begin
delay (200);
while numchars>0 do b:=ord(getchar)
end
end
until (b=13) or (b=141) or (timer>timeout);
if timer<=timeout then begin
connected:
setparam (usecom,baudrate,parity);
if parity
then baudstr:='E,7'
else baudstr:='N,8';
baudstr:=strr(baudrate)+','+baudstr+',1';
online:=true;
urec.config:=[lowercase,linefeeds,eightycols];
writestr (^M^M'Connected at '+baudstr+^M^M);
newcalls:=newcalls+1;
if carrier then exit
end;
abort:
disconnect
end;
procedure exitprog;
begin
dontanswer;
window (1,1,80,25);
textcolor (normtopcolor);
textbackground (0);
clrscr;
gotoxy (30,24);
writeln (usr,'Use FORUM-PC again!');
ensureclosed;
halt(4)
end;
procedure checkday;
begin
if lastdayup<>datestr(now) then begin
lastdayup:=datestr(now);
numdaysup:=numdaysup+1;
callstoday:=0;
writestatus
end
end;
procedure dotimedevent;
var tf:text;
begin
window (1,1,80,25);
clrscr;
writeln (usr,'Executing timed event: ',eventbatch);
writeln (usr);
assign (tf,'Door.bat');
rewrite (tf);
writeln (tf,eventbatch);
textclose (tf);
timedeventdate:=datestr(now);
ensureclosed;
halt (3)
end;
function statusscreen:char;
const statwindx=5;
statwindy=1;
firstcolx=15;
firstline=5;
secondcolx=54;
procedure col1;
begin
window (statwindx+firstcolx,statwindy+firstline,80,25);
end;
procedure col2;
begin
window (statwindx+secondcolx,statwindy+firstline,80,25);
end;
procedure percent (r1,r2:real);
begin
if (r2<1) then exit;
r2:=round((r1/r2)*1000)/10;
writeln (usr,r2:0:1,'%')
end;
procedure drawstatus;
var totalidle,totalup,totalmins,r:real;
tmp:integer;
begin
col1;
tmp:=timetillevent;
if tmp<=30 then begin
gotoxy (1,0);
write (usr,'Timed event scheduled in ',tmp,' minutes! ');
if tmp<=5 then begin
dontanswer;
if tmp<=2 then dotimedevent
end
end;
if carrier or keyhit then exit;
gotoxy (1,2);
writeln (usr,callstoday);
tmp:=elapsedtime (numminsidle);
write (usr,tmp);
gotoxy (1,6);
writeln (usr,numdaysup);
r:=round(10*numcallers/numdaysup)/10;
writeln (usr,r:0:1);
writeln (usr,timestr(now),' ');
write (usr,datestr(now),' ');
col2;
gotoxy (1,3);
totalidle:=numminsidle.total+elapsedtime(numminsidle);
writeln (usr,totalidle:0:0);
totalup:=totalidle+numminsused.total;
writeln (usr,totalup:0:0);
totalmins:=1440.0*(numdaysup-1.0)+timer;
if (totalup<1) or (totalmins<1) then exit;
percent (numminsused.total,totalmins);
percent (numminsxfer.total,totalmins);
percent (totalidle,totalmins);
percent (totalup,totalmins);
percent (totalmins-totalup,totalmins);
col1;
gotoxy (1,1);
maybewritestatus
end;
procedure writeavail;
var m:sstr;
begin
gotoxy (1,12);
m:=sysopavailstr;
while length(m)<15 do m:=m+' ';
write (usr,m);
gotoxy (1,1)
end;
var cnt,numsmail:integer;
k:char;
tmp:mstr;
b:byte;
done:boolean;
function shouldexit:boolean;
begin
shouldexit:=done or carrier
end;
procedure handlekey (k:char; beforeabout:boolean);
begin
b:=ord(k)-128;
case b of
availtogglechar:begin
toggleavail;
if not beforeabout then writeavail
end;
59,60,61,68:begin
done:=true;
statusscreen:=k
end
end
end;
function interrupted (beforeabout:boolean):boolean;
begin
if keyhit then begin
k:=bioskey;
handlekey (k,beforeabout)
end;
done:=done or carrier;
interrupted:=done
end;
procedure sendstring (x:lstr);
var cnt:integer;
k:char;
begin
for cnt:=1 to length(x) do begin
sendchar(x[cnt]);
delay (20);
end;
delay (50);
while numchars>0 do k:=getchar
end;
procedure phonesringing;
begin
sendstring (' ATA'#13)
end;
procedure connectcode (k:char);
var timer:word absolute $40:$6c;
t:word;
k2:char;
bd:baudratetype;
begin
t:=timer+18;
repeat
until (timer>t) or carrier or (numchars>0);
k2:=getchar; { Will be #0 if no chars }
case k of
'1':case k2 of
#0:bd:=b300;
'0':bd:=b2400;
else exit
end;
'5':bd:=b1200;
else exit
end;
if bd in supportedrates then begin
parity:=false;
baudrate:=baudarray[bd];
mustgetbaud:=false;
t:=timer+18;
repeat until carrier or (timer>t)
end
end;
begin
while numchars>0 do k:=getchar;
statusscreen:=#0;
done:=false;
window (1,1,80,25);
textcolor (normbotcolor);
clrscr;
window (statwindx,statwindy,80,25);
gotoxy (1,1);
if interrupted (true) then exit;
writeln (usr,' ╒═══════════════════╕');
writeln (usr,' │ ',versionnum,' │');
writeln (usr,'╒══════════════════════╡ Waiting for calls ╞═══════════════════════╕');
writeln (usr,'│ ╘═══════════════════╛ │');
writeln (usr,'│ │');
if interrupted (true) then exit;
writeln (usr,'│ Last caller: Total mins used: │');
writeln (usr,'│ Calls today: Used by transfer: │');
writeln (usr,'│ Mins idle: Total mins idle: │');
if interrupted (true) then exit;
writeln (usr,'│ Sysop mail: Total mins up: │');
writeln (usr,'│ Total calls: Percent used: │');
writeln (usr,'│ Total days: Percent xfer: │');
if interrupted (true) then exit;
writeln (usr,'│ Calls/day: Percent idle: │');
writeln (usr,'│ Time: Percent up: │');
writeln (usr,'│ Date: Percent down: │');
if interrupted (true) then exit;
writeln (usr,'│ Recent calls: Recent uploads: │');
writeln (usr,'│ Recent posts: Recent feedback: │');
writeln (usr,'│ Available: Recent mail: │');
writeln (usr,'│ │');
writeln (usr,'╘══════════════════════════════════════════════════════════════════╛');
if interrupted (true) then exit;
window (1,1,80,25);
gotoxy (1,24);
writeln (usr,' F1: Forum-Term F2: Exit Forum-PC F3-Copyright info');
write (usr,' F10: Sign on local Alt-A: Toggle chat availability');
if interrupted (true) then exit;
numsmail:=getnummail(1)+numfeedback;
tmp:=getlastcaller;
col1;
gotoxy (1,1);
textcolor (normtopcolor);
write (usr,copy(tmp,1,20));
gotoxy (1,4);
writeln (usr,numsmail);
write (usr,numcallers:0:0);
gotoxy (1,10);
writeln (usr,newcalls);
write (usr,newposts);
writeavail;
col2;
gotoxy (1,1);
writeln (usr,numminsused.total:0:0);
write (usr,numminsxfer.total:0:0);
gotoxy (1,10);
writeln (usr,newuploads);
writeln (usr,newfeedback);
write (usr,newmail);
repeat
checkday;
drawstatus;
cnt:=0;
repeat
while hashayes and (not carrier) and (numchars>0) do begin
k:=getchar;
case k of
'2':phonesringing;
'1','5':connectcode (k)
end
end;
cnt:=cnt+1
until (cnt>=10000) or interrupted (false) or done
until done
end;
var k:char;
label exit;
begin
waitforacall:=false;
setparam (usecom,defbaudrate,false);
setupmodem;
starttimer (numminsidle);
wscount:=0;
local:=false;
clrscr;
repeat
doanswer;
mustgetbaud:=true;
k:=statusscreen;
if carrier then begin
receivecall;
if carrier then goto exit;
end;
case ord(k)-128 of
59:begin
local:=false;
online:=false;
writestatus;
waitforacall:=true;
goto exit
end;
60:exitprog;
61:titlepage;
68:begin
dontanswer;
local:=true;
online:=false;
newfeedback:=0;
newuploads:=0;
newcalls:=0;
newposts:=0;
newmail:=0;
writestatus;
goto exit
end
end
until 0=1;
exit:
textcolor (normbotcolor);
window (1,1,80,25);
clrscr
end;
begin
end.