home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 276.img / FORUM21S.ZIP / WAITCALL.PAS < prev    next >
Pascal/Delphi Source File  |  1988-02-13  |  14KB  |  511 lines
  1. {$R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit waitcall;
  5.  
  6. interface
  7.  
  8. uses dos,crt,
  9.      gentypes,statret,configrt,modem,gensubs,subs1,subs2,mailret,
  10.      overret1,mainr1,mainr2,titlepg;
  11.  
  12. function waitforacall:boolean;
  13.  
  14. implementation
  15.  
  16. function waitforacall:boolean;
  17.  
  18.   var wscount:integer;
  19.       mustgetbaud:boolean;
  20.  
  21.   procedure maybewritestatus;
  22.   begin
  23.     wscount:=wscount+1;
  24.     if wscount>10 then begin
  25.       writestatus;
  26.       wscount:=0
  27.     end
  28.   end;
  29.  
  30. (***
  31.  
  32.   function checkforhayesreport:boolean;  { Looks for CONNECT 300 }
  33.   var n:longint;
  34.       q:sstr;
  35.       p,b:integer;
  36.       k:char;
  37.       brate:baudratetype;
  38.   const lookfor:sstr=#13#10'CONNECT ';
  39.   begin
  40.     checkforhayesreport:=false;
  41.     if numchars=0 then exit;
  42.     p:=1;
  43.     q:='';
  44.     b:=0;
  45.     repeat
  46.       n:=now;
  47.       repeat until (now>n+1) or (numchars>0);
  48.       if numchars=0 then exit else k:=getchar;
  49.       if (k=#13) and (length(q)>0) then begin
  50.         val (q,b,p);
  51.         brate:=b110;
  52.         while (brate<=b9600) and
  53.               ((b<>baudarray[brate])
  54.                 or (not (brate in supportedrates)))
  55.               do brate:=succ(brate);
  56.         if brate<=b9600 then begin
  57.           parity:=false;
  58.           baudrate:=b;
  59.           checkforhayesreport:=true;
  60.           mustgetbaud:=false;
  61.           n:=now;
  62.           repeat until carrier or (now>n+1)
  63.         end;
  64.         exit
  65.       end;
  66.       if p>length(lookfor) then q:=q+k else begin
  67.         if k=lookfor[p] then p:=p+1 else begin
  68.           b:=b+1;
  69.           if b=2 then exit
  70.         end
  71.       end
  72.     until false
  73.   end;
  74.  
  75. ***)
  76.  
  77.   procedure receivecall;
  78.   var b:byte;
  79.       timeout,autoswitch:integer;
  80.       k:char;
  81.       brate:baudratetype;
  82.  
  83.     procedure nextrate (var b:baudratetype);
  84.     var ob:baudratetype;
  85.     begin
  86.       ob:=b;
  87.       repeat
  88.         b:=succ(b);
  89.         if b>b9600 then b:=b110;
  90.         if b=ob then exit
  91.       until b in supportedrates
  92.     end;
  93.  
  94.     procedure disconnect;
  95.     begin
  96.       if carrier then hangupmodem;
  97.       baudrate:=defbaudrate;
  98.       parity:=false;
  99.       setparam (usecom,baudrate,parity);
  100.       setupmodem
  101.     end;
  102.  
  103.     function seconds:integer;
  104.     var r:registers;
  105.     begin
  106.       r.ah:=$2c;
  107.       intr ($21,r);
  108.       seconds:=r.dh
  109.     end;
  110.  
  111.   label abort,connected;
  112.   begin
  113.     local:=false;
  114.     online:=false;
  115.     textcolor (normbotcolor);
  116.     window (1,1,80,25);
  117.     clrscr;
  118.     window (1,1,80,24);
  119.     if not mustgetbaud then goto connected;
  120.     writeln (usr,'╒═════════════════════════════════════════════════╕');
  121.     writeln (usr,'│               Someone is calling                │');
  122.     writeln (usr,'│    Waiting for the user to press the CR key     │');
  123.     writeln (usr,'│ Press CR yourself to choose displayed BAUD rate │');
  124.     writeln (usr,'│   Press space to advance to the next BAUD rate  │');
  125.     writeln (usr,'│               Press D to disconnect             │');
  126.     writeln (usr,'╘═════════════════════════════════════════════════╛');
  127.     writeln;
  128.     brate:=b110;
  129.     parity:=false;
  130.     timeout:=timer+2;
  131.     repeat
  132.       nextrate (brate);
  133.       baudrate:=baudarray[brate];
  134.       textcolor (outlockcolor);
  135.       textbackground (0);
  136.       write (usr,^M^J'Trying ',baudrate,' BAUD: ');
  137.       setparam (usecom,baudrate,parity);
  138.       while numchars>0 do k:=getchar;
  139.       autoswitch:=seconds+3;
  140.       if autoswitch>59 then autoswitch:=autoswitch-60;
  141.       repeat until (not carrier) or (numchars>0) or (keyhit) or
  142.                    (timer>=timeout) or (autoswitch=seconds);
  143.       if timer>=timeout then hangupmodem;
  144.       if not carrier then goto abort;
  145.       if keyhit
  146.         then
  147.           begin
  148.             k:=bioskey;
  149.             case upcase(k) of
  150.               #13:goto connected;
  151.               'D':goto abort;
  152.             end
  153.           end
  154.         else
  155.           begin
  156.             if numchars>0 then begin
  157.               b:=ord(getchar);
  158.               write (usr,b,' received.')
  159.             end else b:=0;
  160.             if b<>13
  161.               then if b=141
  162.                 then parity:=true
  163.                 else
  164.                   begin
  165.                     delay (200);
  166.                     while numchars>0 do b:=ord(getchar)
  167.                   end
  168.           end
  169.     until (b=13) or (b=141) or (timer>timeout);
  170.     if timer<=timeout then begin
  171.       connected:
  172.       setparam (usecom,baudrate,parity);
  173.       if parity
  174.         then baudstr:='E,7'
  175.         else baudstr:='N,8';
  176.       baudstr:=strr(baudrate)+','+baudstr+',1';
  177.       online:=true;
  178.       urec.config:=[lowercase,linefeeds,eightycols];
  179.       writestr (^M^M'Connected at '+baudstr+^M^M);
  180.       newcalls:=newcalls+1;
  181.       if carrier then exit
  182.     end;
  183.     abort:
  184.     disconnect
  185.   end;
  186.  
  187.   procedure exitprog;
  188.   begin
  189.     dontanswer;
  190.     window (1,1,80,25);
  191.     textcolor (normtopcolor);
  192.     textbackground (0);
  193.     clrscr;
  194.     gotoxy (30,24);
  195.     writeln (usr,'Use FORUM-PC again!');
  196.     ensureclosed;
  197.     halt(4)
  198.   end;
  199.  
  200.   procedure checkday;
  201.   begin
  202.     if lastdayup<>datestr(now) then begin
  203.       lastdayup:=datestr(now);
  204.       numdaysup:=numdaysup+1;
  205.       callstoday:=0;
  206.       writestatus
  207.     end
  208.   end;
  209.  
  210.   procedure dotimedevent;
  211.   var tf:text;
  212.   begin
  213.     window (1,1,80,25);
  214.     clrscr;
  215.     writeln (usr,'Executing timed event: ',eventbatch);
  216.     writeln (usr);
  217.     assign (tf,'Door.bat');
  218.     rewrite (tf);
  219.     writeln (tf,eventbatch);
  220.     textclose (tf);
  221.     timedeventdate:=datestr(now);
  222.     ensureclosed;
  223.     halt (3)
  224.   end;
  225.  
  226.   function statusscreen:char;
  227.   const statwindx=5;
  228.         statwindy=1;
  229.         firstcolx=15;
  230.         firstline=5;
  231.         secondcolx=54;
  232.  
  233.     procedure col1;
  234.     begin
  235.       window (statwindx+firstcolx,statwindy+firstline,80,25);
  236.     end;
  237.  
  238.     procedure col2;
  239.     begin
  240.       window (statwindx+secondcolx,statwindy+firstline,80,25);
  241.     end;
  242.  
  243.     procedure percent (r1,r2:real);
  244.     begin
  245.       if (r2<1) then exit;
  246.       r2:=round((r1/r2)*1000)/10;
  247.       writeln (usr,r2:0:1,'%')
  248.     end;
  249.  
  250.     procedure drawstatus;
  251.     var totalidle,totalup,totalmins,r:real;
  252.         tmp:integer;
  253.     begin
  254.       col1;
  255.       tmp:=timetillevent;
  256.       if tmp<=30 then begin
  257.         gotoxy (1,0);
  258.         write (usr,'Timed event scheduled in ',tmp,' minutes!  ');
  259.         if tmp<=5 then begin
  260.           dontanswer;
  261.           if tmp<=2 then dotimedevent
  262.         end
  263.       end;
  264.       if carrier or keyhit then exit;
  265.       gotoxy (1,2);
  266.       writeln (usr,callstoday);
  267.       tmp:=elapsedtime (numminsidle);
  268.       write (usr,tmp);
  269.       gotoxy (1,6);
  270.       writeln (usr,numdaysup);
  271.       r:=round(10*numcallers/numdaysup)/10;
  272.       writeln (usr,r:0:1);
  273.       writeln (usr,timestr(now),' ');
  274.       write (usr,datestr(now),'  ');
  275.       col2;
  276.       gotoxy (1,3);
  277.       totalidle:=numminsidle.total+elapsedtime(numminsidle);
  278.       writeln (usr,totalidle:0:0);
  279.       totalup:=totalidle+numminsused.total;
  280.       writeln (usr,totalup:0:0);
  281.       totalmins:=1440.0*(numdaysup-1.0)+timer;
  282.       if (totalup<1) or (totalmins<1) then exit;
  283.       percent (numminsused.total,totalmins);
  284.       percent (numminsxfer.total,totalmins);
  285.       percent (totalidle,totalmins);
  286.       percent (totalup,totalmins);
  287.       percent (totalmins-totalup,totalmins);
  288.       col1;
  289.       gotoxy (1,1);
  290.       maybewritestatus
  291.     end;
  292.  
  293.     procedure writeavail;
  294.     var m:sstr;
  295.     begin
  296.       gotoxy (1,12);
  297.       m:=sysopavailstr;
  298.       while length(m)<15 do m:=m+' ';
  299.       write (usr,m);
  300.       gotoxy (1,1)
  301.     end;
  302.  
  303.   var cnt,numsmail:integer;
  304.       k:char;
  305.       tmp:mstr;
  306.       b:byte;
  307.       done:boolean;
  308.  
  309.     function shouldexit:boolean;
  310.     begin
  311.       shouldexit:=done or carrier
  312.     end;
  313.  
  314.     procedure handlekey (k:char; beforeabout:boolean);
  315.     begin
  316.       b:=ord(k)-128;
  317.       case b of
  318.         availtogglechar:begin
  319.           toggleavail;
  320.           if not beforeabout then writeavail
  321.         end;
  322.         59,60,61,68:begin
  323.           done:=true;
  324.           statusscreen:=k
  325.         end
  326.       end
  327.     end;
  328.  
  329.     function interrupted (beforeabout:boolean):boolean;
  330.     begin
  331.       if keyhit then begin
  332.         k:=bioskey;
  333.         handlekey (k,beforeabout)
  334.       end;
  335.       done:=done or carrier;
  336.       interrupted:=done
  337.     end;
  338.  
  339.     procedure sendstring (x:lstr);
  340.     var cnt:integer;
  341.         k:char;
  342.     begin
  343.       for cnt:=1 to length(x) do begin
  344.         sendchar(x[cnt]);
  345.         delay (20);
  346.       end;
  347.       delay (50);
  348.       while numchars>0 do k:=getchar
  349.     end;
  350.  
  351.     procedure phonesringing;
  352.     begin
  353.       sendstring ('  ATA'#13)
  354.     end;
  355.  
  356.     procedure connectcode (k:char);
  357.     var timer:word absolute $40:$6c;
  358.         t:word;
  359.         k2:char;
  360.         bd:baudratetype;
  361.     begin
  362.       t:=timer+18;
  363.       repeat
  364.       until (timer>t) or carrier or (numchars>0);
  365.       k2:=getchar;  { Will be #0 if no chars }
  366.       case k of
  367.         '1':case k2 of
  368.               #0:bd:=b300;
  369.               '0':bd:=b2400;
  370.               else exit
  371.             end;
  372.         '5':bd:=b1200;
  373.         else exit
  374.       end;
  375.       if bd in supportedrates then begin
  376.         parity:=false;
  377.         baudrate:=baudarray[bd];
  378.         mustgetbaud:=false;
  379.         t:=timer+18;
  380.         repeat until carrier or (timer>t)
  381.       end
  382.     end;
  383.  
  384.   begin
  385.     while numchars>0 do k:=getchar;
  386.     statusscreen:=#0;
  387.     done:=false;
  388.     window (1,1,80,25);
  389.     textcolor (normbotcolor);
  390.     clrscr;
  391.     window (statwindx,statwindy,80,25);
  392.     gotoxy (1,1);
  393.     if interrupted (true) then exit;
  394. writeln (usr,'                       ╒═══════════════════╕');
  395. writeln (usr,'                       │   ',versionnum,'   │');
  396. writeln (usr,'╒══════════════════════╡ Waiting for calls ╞═══════════════════════╕');
  397. writeln (usr,'│                      ╘═══════════════════╛                       │');
  398. writeln (usr,'│                                                                  │');
  399.     if interrupted (true) then exit;
  400. writeln (usr,'│ Last caller:                      Total mins used:               │');
  401. writeln (usr,'│ Calls today:                      Used by transfer:              │');
  402. writeln (usr,'│ Mins idle:                        Total mins idle:               │');
  403.     if interrupted (true) then exit;
  404. writeln (usr,'│ Sysop mail:                       Total mins up:                 │');
  405. writeln (usr,'│ Total calls:                      Percent used:                  │');
  406. writeln (usr,'│ Total days:                       Percent xfer:                  │');
  407.     if interrupted (true) then exit;
  408. writeln (usr,'│ Calls/day:                        Percent idle:                  │');
  409. writeln (usr,'│ Time:                             Percent up:                    │');
  410. writeln (usr,'│ Date:                             Percent down:                  │');
  411.     if interrupted (true) then exit;
  412. writeln (usr,'│ Recent calls:                     Recent uploads:                │');
  413. writeln (usr,'│ Recent posts:                     Recent feedback:               │');
  414. writeln (usr,'│ Available:                        Recent mail:                   │');
  415. writeln (usr,'│                                                                  │');
  416. writeln (usr,'╘══════════════════════════════════════════════════════════════════╛');
  417.     if interrupted (true) then exit;
  418.     window (1,1,80,25);
  419.     gotoxy (1,24);
  420.     writeln (usr,'      F1: Forum-Term        F2: Exit Forum-PC      F3-Copyright info');
  421.       write (usr,'      F10: Sign on local    Alt-A: Toggle chat availability');
  422.     if interrupted (true) then exit;
  423.     numsmail:=getnummail(1)+numfeedback;
  424.     tmp:=getlastcaller;
  425.     col1;
  426.     gotoxy (1,1);
  427.     textcolor (normtopcolor);
  428.     write (usr,copy(tmp,1,20));
  429.     gotoxy (1,4);
  430.     writeln (usr,numsmail);
  431.     write (usr,numcallers:0:0);
  432.     gotoxy (1,10);
  433.     writeln (usr,newcalls);
  434.     write (usr,newposts);
  435.     writeavail;
  436.     col2;
  437.     gotoxy (1,1);
  438.     writeln (usr,numminsused.total:0:0);
  439.     write (usr,numminsxfer.total:0:0);
  440.     gotoxy (1,10);
  441.     writeln (usr,newuploads);
  442.     writeln (usr,newfeedback);
  443.     write (usr,newmail);
  444.     repeat
  445.       checkday;
  446.       drawstatus;
  447.       cnt:=0;
  448.       repeat
  449.         while hashayes and (not carrier) and (numchars>0) do begin
  450.           k:=getchar;
  451.           case k of
  452.             '2':phonesringing;
  453.             '1','5':connectcode (k)
  454.           end
  455.         end;
  456.         cnt:=cnt+1
  457.       until (cnt>=10000) or interrupted (false) or done
  458.     until done
  459.   end;
  460.  
  461. var k:char;
  462. label exit;
  463. begin
  464.   waitforacall:=false;
  465.   setparam (usecom,defbaudrate,false);
  466.   setupmodem;
  467.   starttimer (numminsidle);
  468.   wscount:=0;
  469.   local:=false;
  470.   clrscr;
  471.   repeat
  472.     doanswer;
  473.     mustgetbaud:=true;
  474.     k:=statusscreen;
  475.     if carrier then begin
  476.       receivecall;
  477.       if carrier then goto exit;
  478.     end;
  479.     case ord(k)-128 of
  480.       59:begin
  481.            local:=false;
  482.            online:=false;
  483.            writestatus;
  484.            waitforacall:=true;
  485.            goto exit
  486.          end;
  487.       60:exitprog;
  488.       61:titlepage;
  489.       68:begin
  490.            dontanswer;
  491.            local:=true;
  492.            online:=false;
  493.            newfeedback:=0;
  494.            newuploads:=0;
  495.            newcalls:=0;
  496.            newposts:=0;
  497.            newmail:=0;
  498.            writestatus;
  499.            goto exit
  500.          end
  501.     end
  502.   until 0=1;
  503.   exit:
  504.   textcolor (normbotcolor);
  505.   window (1,1,80,25);
  506.   clrscr
  507. end;
  508.  
  509. begin
  510. end.
  511.