Jason Aller Floppy Collection/189.img/TCS120S.ZIP/WAITCALL.PAS

Pascal/Delphi Source File | 1989-04-06 | 18KB | 678 lines

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

unit waitcall;

interface

uses dos,crt,graph,
     gentypes,statret,configrt,modem,gensubs,subs1,subs2,mailret,
     overret1,mainr1,mainr2,mainmenu,getlogin,userret;

function waitforacall:boolean;

implementation

function waitforacall:boolean;

  var wscount:integer;
      mustgetbaud:boolean;

  procedure maybewritestatus;
  begin
    wscount:=wscount+1;
    if wscount>15 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; }

  procedure receivecall;
  var b:byte;
      timeout,autoswitch:integer;
      k:char;
      brate:baudratetype;
      matrix:anystr;
      joemam:anystr;
      brow:integer;

    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);
    writeln ('[Auto-Detecting Baud Rate]');
  begin
     matrix:=' ';
     online:=true;
     delay (200);
    {if numchars>0 then b:=ord(waitchar);
    if numchars>0 then k:=waitchar else k:=' ';}
    if numchars>0 then begin
    delay (100);
    while numchars>0 do matrix:=matrix+getchar;
    if (b=ord('1')) and (k<>'0') and (k<>'1') and (k<>'2') then begin
       baudrate:=baudarray[b300];
       goto connected;
       end;
    if pos('5',matrix)>0  then begin
       baudrate:=baudarray[b1200];
       goto connected;
       end;
    if pos('12',matrix)>0    then begin
       baudrate:=baudarray[b1200];
       goto connected;
       end;
    if pos('24',matrix)>0  then begin
       baudrate:=baudarray[b2400];
       goto connected;
       end;
    if  pos('11',matrix)>0  then begin
       baudrate:=baudarray[b2400];
       goto connected;
       end;
    if  pos('96',matrix)>0  then begin
       baudrate:=baudarray[b9600];
       goto connected;
       end;
    if pos('10',matrix)>0 then begin
       baudrate:=baudarray[b2400];
       goto connected;
       end;
    writeln (usr,matrix);
end;
  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 the caller       │');
    writeln (usr,'╘═════════════════════════════════════════════════╛');
    writeln;
    brate:=b110;
    parity:=false;
    timeout:=timer+2;
    sendchar ('P');
    sendchar ('r');
    sendchar ('e');
    sendchar ('s');
    sendchar ('s');
    sendchar (' ');
    sendchar ('[');
    sendchar ('R');
    sendchar ('e');
    sendchar ('t');
    sendchar ('u');
    sendchar ('r');
    sendchar ('n');
    sendchar (']');
    sendchar (':');
    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;
  end;
  end;

  procedure exitprog;
  begin
    dontanswer;
    window (1,1,80,25);
    textcolor (15);
    textbackground (0);
    clrscr;
    gotoxy (17,2);
    writeln (usr,'┌──────────────────────────────────────────────┐');
    gotoxy (17,3);
    write (usr,'│ ');
    textcolor (9);
    write (usr,'TCS BBS Software version '+ver+' - '+parsedate(date));
    textcolor (15);
    writeln (usr,' │');
    gotoxy (17,4);
    write (usr,'│ ');
    textcolor (11);
    write (usr,'  (c) 1988,89 by the TCS Programming Team.   ');
    textcolor (15);
    writeln (usr,'│');
    gotoxy (17,5);
    writeln (usr,'└──────────────────────────────────────────────┘');
    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,62,63,64,65,66,67,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;

textcolor (4);
writeln (usr,'                         ▄▄▄▄▄   ▄▄▄   ▄▄▄▄ ');
textcolor (normbotcolor);
write (usr,'                      ╒ ');
textcolor (5);
write (usr,'   █    █     █      ');
textcolor (normbotcolor);
writeln (usr,'╕');
write   (usr,'╒═════════════════════╡');
textcolor (1);
write (usr,'    █    █      ▀▀▀▄  ');
textcolor (normbotcolor);
writeln (usr,'╞═════════════════════╕');
textcolor (normbotcolor);
write   (usr,'│                     ╘');
textcolor (1);
write (usr,'    █    ▀▄▄▄  ▄▄▄▄▀  ');
textcolor (normbotcolor);
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);
    textcolor (outlockcolor);
    if length(getenv('DSZLOG'))<1 then begin
     gotoxy (1,25);
     write ('     Put string "DSZLOG='+dszlog+'" in AUTOEXEC.BAT *NOW* !!!');
    end;
    gotoxy (1,21);
    writeln (usr,'    [F10] Log on Locally     [F1] Terminal Program     [F2] Exit TCS');
    writeln (usr,'    [F3] Not used            [F4] Read Feedback        [F5] System Log');
    write   (usr,'    [Alt-A] 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 }
           clrscr;
           halt (121);
         end;
      60:exitprog;
      61:;
      62:begin
          window (1,1,80,25);
          clrscr;
           unum:=lookupuser (sysopname);
             if unum=0 then begin
               writeln ('No Sysop Created.');
               delay (1000);
              end;
            unum:=1;
            readurec;
            urec.timetoday:=999;
           readfeedback;
          end;
      63:begin
          window (1,1,80,25);
          clrscr;
          unum:=lookupuser (sysopname);
           if unum=0 then begin
            writeln ('No Sysop Created.');
            delay (1000);
           end;
          unum:=1;
          readurec;
          urec.timetoday:=999;
          viewsyslog2;
          delsyslog;
          clrscr;
         end;
      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.