Jason Aller Floppy Collection/341.img/TCS161S.ZIP/WAITCALL.PAS

Pascal/Delphi Source File | 1989-12-06 | 22KB | 870 lines

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

unit waitcall;

interface

uses dos,crt,qwik,
     gentypes,statret,configrt,modem,gensubs,subs1,subs2,mailret,overlay,
     overret1,mainr1,mainr2,mainmenu,getlogin,userret,protocol,Graph3;

function waitforacall:boolean;

implementation

function waitforacall:boolean;
  const statwindx=2;
        statwindy=1;
    firstcolx=17;
    firstline=1;
    secondcolx=60;



  var wscount      :integer;
      mustgetbaud  :boolean;
      outf         :text;
      nl           :netmailrec;
      nla          :netlistrec;

    procedure col1;
    begin
      window (statwindx+firstcolx,statwindy+firstline,80,25);
    end;

    procedure col2;
    begin
      window (statwindx+secondcolx,statwindy+firstline,80,25);
    end;

   procedure seeknmfile (n:integer);
   begin
     seek (nmfile,n-1);
   end;

   procedure seeknlifile (n:integer);
   begin
     seek (nlifile,n-1);
   end;

      function numbbs:integer;
   begin
    numbbs:=filesize (nmfile);
   end;


   function numnetfiles:integer;
   begin
     numnetfiles:=filesize(nlifile)
   end;

procedure delfile(laym:byte);
var i    :integer;
    n    :integer;
    cnt  :integer;
    c    :char;

 begin
  n:=laym;
  seeknlifile (n);
  read (nlifile,nla);
    for cnt:=n to numnetfiles-1 do
     begin
        seeknlifile (cnt+1);
        read (nlifile,nla);
        seeknlifile (cnt);
        write (nlifile,nla)
     end;
   seeknlifile (numnetfiles);
   truncate (nlifile);
 end;

   procedure topwin;
    begin;
    window(3,7,79,14);
    textcolor(statlinecolor);
    end;

   procedure botwin;
    begin;
    window(3,18,79,22);
    textcolor(splitcolor);
    end;


  procedure maybewritestatus;
  begin
    wscount:=wscount+1;
    if wscount>800 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<=b19200) and
              ((b<>baudarray[brate])
                or (not (brate in supportedrates)))
              do brate:=succ(brate);
        if brate<=b19200 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>b19200 then b:=b110;
        if b=ob then exit
      until b in supportedrates
    end;

    procedure disconnect;
    begin
      if (carrier or local) 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>b19200 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);
  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('19',matrix)>0 then begin
       baudrate:=baudarray[b19200];
       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);
    if not mustgetbaud then goto connected;

    brate:=b110;
    parity:=false;
    timeout:=timer+2;
    sendchar ('H');
    sendchar ('i');
    sendchar ('t');
    sendchar (' ');
    sendchar ('[');
    sendchar ('E');
    sendchar ('n');
    sendchar ('t');
    sendchar ('e');
    sendchar ('r');
    sendchar (']');
    sendchar (':');
    repeat
      nextrate (brate);
      baudrate:=baudarray[brate];
      textcolor (outlockcolor);
      textbackground (0);
      col2;
      gotoxy(1,9);

      write (usr,'Trying ',baudrate,' ');

      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);
            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];
      window(1,1,80,25); clrscr; setcursor(cursoron);
      writeln (usr,'User connected at '+baudstr+'.');
      newcalls:=newcalls+1;
      if carrier then exit
    end;
    abort:
    disconnect
  end;
  end;
  end;

 Procedure ExitProg;
 Begin
    dontanswer;
    TextMode(80);
    window (1,1,80,25);
    textcolor (15);
    textbackground (0);
    clrscr;
    textcolor (8);
    writeln ('════════════════════════════════════════════════════════════════════════════');
    textcolor (15);
    writeln ('                           TCS ',ver,' - ',date);
    writeln ('       Renegade Bithead - Lord Zombie - Barimor - Doc. Savage - Maniac');
    Writeln ('                    The Viper - Lord Blix - Kid Devious');
    textcolor (8);
    writeln ('════════════════════════════════════════════════════════════════════════════');
    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 useredit;
  {$M 8192,0,0}           { Leave memory for child process }
var
  Command: string[127];

begin
    Command:=('Uedit');
    begin
      SwapVectors;
      Exec(GetEnv('COMSPEC'), '/C ' + Command);
      SwapVectors;
    end;
   TextMode(80);
   Clrscr;
end;

 procedure Futil;
var
  Command2: string[127];

begin
    TextMode(80);
    ClrScr;
    Command2:=('Futil');
    begin
      SwapVectors;
      Exec(GetEnv('COMSPEC'), '/C ' + Command2);
      SwapVectors;
    end;
   TextMode(80);
   Clrscr;
end;

 procedure Run_Config;
var
  Command2: string[127];

begin
    TextMode(80);
    ClrScr;
    Command2:=('Config');
    begin
      SwapVectors;
      Exec(GetEnv('COMSPEC'), '/C ' + Command2);
      SwapVectors;
    end;
   TextMode(80);
   Clrscr;
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;


    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
    if screendef=0 then exit;
      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 (48,19); write(usr,timestr(now));
      gotoxy (48,20); write(usr,datestr(now));
      gotoxy (1,2);
      writeln (usr,callstoday);
      gotoxy (1,6);
      tmp:=elapsedtime (numminsidle);
      write (usr,tmp);
      gotoxy (1,4);
      writeln (usr,numdaysup);
      r:=round(10*numcallers/numdaysup)/10;
      writeln (usr,r:0:1);
{      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 ChatM:sstr; m:sstr;
    begin
      gotoxy (1,9);
{TEST for chat
      ChatM:=Timestr(Now);
      If Chatm=Availtime then SysopAvailstr='YES';}
      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;
        35:sendmodemstr ('ATH|',true);
        59,60,61,62,63,64,65,66,67,68:begin
          done:=true;
          statusscreen:=k
        end
      end
    end;

    procedure writefreespace;
    var r:registers; tempfree:real; lp:integer; total:real;
        csize:real;

      function unsigned (i:integer):real;
      begin
        if i>=0 then unsigned:=i else unsigned:=65536.0+i
      end;

    begin
    total:=0;
    for lp:=3 to 15 do begin

      r.ah:=$1c;
      r.dl:=lp;
      intr ($21,r);

      if mem[r.ds:r.bx]=$f8 then begin
          r.ah:=$36;
          r.dl:=lp;
          intr ($21,r);
          csize:=unsigned(r.ax)*unsigned(r.cx);
          tempfree:=(csize*unsigned(r.bx))/1000;
          total:=total+tempfree/1000;
          gotoxy(6,22);
          write(usr,streal(total)+' megs');
          end;

      end;
    end;

    procedure writeboardname;
    var xcoord:integer; nm:string[50];
    begin
    nm:='« '+longname+' »';
    xcoord:=39-(length(nm) div 2);
    gotoxy(xcoord,17); write(usr,nm);
    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
    col2;
    gotoxy(1,9);
    write('« Incoming Call »');
      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;

    setcursor(cursoroff);
if (screendef=1) then begin
    window (statwindx,statwindy,80,25);
    gotoxy (1,1);
writeln(usr,'┌──────────────┬─────────────────────────┬────────────────┬──────────────┐');
writeln(usr,'│ Last Caller: │                         │  Recent Calls: │              │');
writeln(usr,'│ Calls Today: │                         │     New Posts: │              │');
writeln(usr,'│ Total Calls: │                         │   New Uploads: │              │');
writeln(usr,'│  Total Days: │                         │  New Feedback: │              │');
writeln(usr,'│   Calls/Day: │                         │      New Mail: │              │');
writeln(usr,'│   Mins Idle: │                         │    Sysop Mail: │              │');
writeln(usr,'│ DSZ Logname: │                         │                │              │');
writeln(usr,'│              │                         │                │              │');
writeln(usr,'│ Sysop Avail: │                         │ System Status: │ Initializing │');
writeln(usr,'├──────────────┴─────────────────────────┴────────────────┴──────────────┤');
writeln(usr,'│                                                                        │');
writeln(usr,'│ [Alt-A] Chat Available    ▀▀█▀▀ ▄▀▀▀▀ ▄▀▀▀▀                            │');
writeln(usr,'│ [Alt-H] Hang Up Modem       █   █      ▀▀▀▄                            │');
writeln(usr,'│                             █   ▀▄▄▄▄ ▄▄▄▄▀                            │');
writeln(usr,'│                              Version '+ver+'                              │');
writeln(usr,'│                                                                        │');
writeln(usr,'│                                                                        │');
writeln(usr,'├──────────────┬─────────────[ Special Keys ]────────────┬───────────────┤');
writeln(usr,'│ Total Free   │ [F10] Local Login    [F7] Screen On/Off │ Time:         │');
writeln(usr,'│ Drive Space: │ [F2]  Exit TCS       [F4] Read Feedback │ Date:         │');
writeln(usr,'│              │ [F3]  Give Carrier   [F5] System Log    │ Node: 1       │');
writeln(usr,'└──────────────┴─────────────────────────────────────────┴───────────────┘');

    if interrupted (true) then exit;
    window (1,1,80,25);
    textcolor (outlockcolor);
 if jshutup then begin
  if length(getenv('JMODEM'))<1 then
    begin
    Assign (outf,'SETJ.BAT');
    rewrite(outf);
    WriteLn(outf,'cls');
    WriteLn(outf,'echo                 Telling Jmodem to shut its mouth - please wait');
    writeln(outf,'SET JMODEM=SHUTUP');
    WriteLn(outf,'MAIN.BAT');
    textclose(outf);
  end;
 end;
    if (getenv('DSZLOG')<>dszlogname) or (getenv('SKLOG')<>sklog) then
    begin
     Assign (outf,'SETLOG.BAT');
     rewrite (outf);
     WriteLn(outf,'Echo off');
     WriteLn(outf,'cls');
     WriteLn(outf,'echo The environment path for DSZLOG or SKLOG do not match');
     WriteLn(outf,'echo those that you are using.  Now adjusting and reloading...');
     WriteLn(outf,'SET DSZLOG='+dszlogname);
     Writeln(outf,'SET SKLOG='+sklog);
     Writeln(outf,'MAIN.BAT');
     textclose(outf);
    end;
   {If timeStr(Now)=Bytime then Sysopavail:=TRUE;}
    if interrupted (true) then exit;
    writefreespace; writeboardname;
    setupmodem;
    numsmail:=getnummail(1)+numfeedback;
    tmp:=getlastcaller;
    col1;
    gotoxy (1,1);
    textcolor (normtopcolor);
    write (usr,copy(tmp,1,20));
    gotoxy (1,3);
    write (usr,numcallers:0:0);
    writeavail;
    gotoxy(1,7); write(usr,dszlogname);
    col2;
    gotoxy (1,1);
    writeln (usr,newcalls);
    writeln (usr,newposts);
{    writeln (usr,numminsused.total:0:0);
    write (usr,numminsxfer.total:0:0);
    gotoxy (1,10);}

    writeln(usr,newuploads);
    writeln(usr,newfeedback);
    writeln(usr,newmail);
    writeln(usr,numsmail);
    gotoxy(1,9);
    writeln(usr,'Waiting.     ');
    end else setcursor(cursoroff);
      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);
  starttimer (numminsidle);
  wscount:=0;
  local:=false;
  clrscr;
  repeat
    doanswer;
    mustgetbaud:=true;
    k:=statusscreen;

    if carrier then begin
      receivecall;

      if carrier then begin
        writestatus;
        goto exit;
      end;
    end;
    case ord(k)-128 of
      59:begin
          { local:=false;
           online:=false;
           waitforacall:=true;
           goto exit }
           clrscr;
           writestatus;
           halt (125);
         end;
      60:begin
    col2;
    gotoxy(1,9); write(usr,'Exiting   ');
           writestatus;
           exitprog;
         end;
      61:begin
      writestatus;
      col2; gotoxy(1,9);
      write(usr,'Carrier On ');
          sendmodemstr('ATA|',true);
         end;
      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:=1000;
       readfeedback;
       newfeedback:=0;
          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;
      viewsyslog;
          delsyslog;
          clrscr;
         end;
      64: begin
       window(1,1,80,25);
{       start_netmail;}
          end;
      65: begin;
        screendef:=(1-screendef);
        if (screendef=0) then begin
                    clearscr;
                    setcursor(cursoroff);
                     end;
      end;
      66: Futil;
      67: Run_Config;

      68:begin
       dontanswer;
           modeminlock:=true;
           modemoutlock:=true;
           local:=true;
           online:=false;
           writestatus;
           newfeedback:=0;
           newuploads:=0;
           newcalls:=0;
           newposts:=0;
       newmail:=0;
       setcursor(cursoron);
       writestatus;
           goto exit
         end
    end
  until 0=1;
  exit:
  textcolor (normbotcolor);
  window (1,1,80,25);
  clrscr
end;

begin
end.