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

Pascal/Delphi Source File | 1989-02-25 | 19KB | 817 lines

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

unit forumtrm;

interface

uses crt,printer,
     gentypes,modem,configrt,gensubs,subs1,subs2,windows,mainr2,protocol;

procedure forumterm;

implementation

procedure forumterm;

var dirloaded:boolean;

  type dialrec=record
       bbsname:string[35];
       phonenum:string[14];
       baudrate:integer;
       databits:integer;
       stopbits:integer;
       dummy:byte;
       scriptfile:string[12]
     end;

     prefixtype=(plus,minus,bang,atsign,poundsign);

var directory:array [1..200] of dialrec;
    dfile:file of dialrec;
    prefixes:array [prefixtype] of lstr;
    funckeys:array [1..10] of lstr;

  procedure loaddirectory;
  var cnt:integer;
      d:dialrec;
  begin
    assign (dfile,'TCS.Fon');
    reset (dfile);
    if ioresult<>0 then begin
      close (dfile);
      cnt:=ioresult;
      rewrite (dfile);
      fillchar (d,sizeof(d),0);
      d.baudrate:=defbaudrate;
      d.databits:=8;
      d.stopbits:=1;
      for cnt:=1 to 200 do begin
        write (dfile,d);
        directory[cnt]:=d
      end
    end else for cnt:=1 to 200 do read (dfile,directory[cnt])
  end;

  procedure savedirectory;
  var cnt:integer;
  begin
    seek (dfile,0);
    for cnt:=1 to 200 do write (dfile,directory[cnt])
  end;

  procedure writedfile (n:integer);
  begin
    seek (dfile,n-1);
    write (dfile,directory[n])
  end;

  procedure loadfunckeys;
  var kfile:text;
      cnt:integer;
  begin
    for cnt:=1 to 10 do funckeys[cnt]:='';
    assign (kfile,'TCS.Key');
    reset (kfile);
    if ioresult<>0 then exit;
    cnt:=0;
    while (not eof(kfile)) and (cnt<10) do begin
      cnt:=cnt+1;
      readln (kfile,funckeys[cnt])
    end;
    close (kfile)
  end;

  procedure savefunckeys;
  var kfile:text;
      cnt:integer;
  begin
    assign (kfile,'TCS.Key');
    rewrite (kfile);
    for cnt:=1 to 10 do writeln (kfile,funckeys[cnt]);
    close (kfile)
  end;

  procedure loadprefixes;
  var pfile:text;
      cnt:integer;
      p:prefixtype;
      fnd:boolean;
  begin
    assign (pfile,'TCS.Pre');
    reset (pfile);
    fnd:=ioresult=0;
    for p:=plus to poundsign do
      if fnd
        then readln (pfile,prefixes[p])
        else prefixes[p]:='';
    textclose (pfile);
    cnt:=ioresult
  end;

  procedure saveprefixes;
  var pfile:text;
      p:prefixtype;
      cnt:integer;
  begin
    assign (pfile,'TCS.Pre');
    rewrite (pfile);
    for p:=plus to poundsign do
      writeln (pfile,prefixes[p]);
    textclose (pfile);
    cnt:=ioresult
  end;

  procedure superprint (q:lstr; attribute:integer);
  var ss,loc:integer;
  begin
    textcolor (attribute and 15);
    textbackground (attribute shr 4);
    write (q);
(*****
    loc:=(wherey*80+wherex-81) shl 1;
    ss:=screenseg;
    inline (
!{! ^179. New stack conventions require that many Inlines be rewritten.}
$06/                     { PUSH   ES                }
$1E/                     { PUSH   DS                }
$8B/$86/ss/              { MOV    AX,ss[BP]         }
$8E/$C0/                 { MOV    ES,AX             }
$8C/$D0/                 { MOV    AX,SS             }
$8E/$D8/                 { MOV    DS,AX             }
$B8/q/                   { MOV    AX,q              }
$01/$E8/                 { ADD    AX,BP             }
$89/$C6/                 { MOV    SI,AX             }
$8B/$86/loc/             { MOV    AX,loc[BP]        }
$89/$C7/                 { MOV    DI,AX             }
$FC/                     { CLD                      }
$AC/                     { LODSB                    }
$30/$E4/                 { XOR    AH,AH             }
$89/$C1/                 { MOV    CX,AX             }
$8B/$86/attribute/       { MOV    AX,attribute[BP]  }
$88/$C4/                 { MOV    AH,AL             }
$AC/                     { LODSB                    }
$AB/                     { STOSW                    }
$E2/$FC/                 { LOOP   <=back to LODSB=> }
$1F/                     { POP    DS                }
$07                      { POP    ES                }  )

****)

  end;


  procedure displayentry (n,y:integer);
  var q:lstr;
      d:^dialrec;

    procedure put (fragment:lstr; ps:integer);
    begin
      move (fragment[1],q[ps],length(fragment))
    end;

  var t:mstr;
  begin
    fillchar (q[1],80,32);
    q[0]:=#80;
    if n=0 then put ('No number specified',6) else begin
      d:=addr(directory[n]);
      str (n:3,t);
      put (t+'.',1);
      put (d^.bbsname,6);
      t:=d^.phonenum;
      while length(t)<14 do t:=' '+t;
      put (t,42);
      t:=strr(d^.baudrate);
      if d^.databits=8 then t:=t+',N,8,' else t:=t+',E,7,';
      if d^.stopbits=1 then t:=t+'1' else t:=t+'2';
      put (t,57)
    end;
    gotoxy (1,y);
    superprint (q,normtopcolor)
  end;

  procedure dialdirectory;
  var page:integer;
      done:boolean;

    procedure refreshnums;
    var cnt,x,y:integer;
    begin
      x:=wherex;
      y:=wherey;
      for cnt:=1 to 10 do displayentry (cnt+page,cnt);
      gotoxy (x,y)
    end;

    procedure fullrefresh;
    begin
      refreshnums;
      gotoxy (1,13);
      write (usr,'Commands:  PgUp  PgDn  D)ial  R)evise  Q)uit  E)dit-prefixes');
      clreol
    end;

    procedure changepage (d:integer);
    begin
      page:=page+d;
      if page<0 then page:=page+200;
      if page>199 then page:=page-200;
      refreshnums
    end;

    function getnumber:mstr;
    var q:mstr;
        p:byte absolute q;
        k:char;

      procedure addchar (k:char);
      begin
        if p=20 then exit;
        write (usr,k);
        q:=q+k
      end;

      procedure delchar;
      begin
        if p=0 then exit;
        write (usr,^H' '^H);
        p:=p-1
      end;

    begin
      gotoxy (20,14);
      write (usr,'Number? ');
      clreol;
      p:=0;
      repeat
        k:=bioskey;
        case k of
          #201:changepage (-10);
          #209:changepage (10);
          '0'..'9','+','-','!','@','#',',':addchar (k);
          #8:delchar
        end
      until k=#13;
      getnumber:=q
    end;

    procedure dialdirectory;
    var numstrs:array [1..10] of lstr;
        ns:array [1..10] of integer;
        num,cnt,n,p,pn:integer;
        r:longint;
        d:dialrec;
        dstr:lstr;
        inp,temp:mstr;
        k:char;

      procedure addprefix (p:prefixtype);
      begin
        dstr:=dstr+prefixes[p]
      end;

    begin
      num:=0;
      gotoxy (1,13);
      write (usr,
        'Please choose up to 10 numbers, separate with CR, blank to end.');
      clreol;
      repeat
        inp:=getnumber+' ';
        dstr:='';
        temp:='';
        n:=0;
        for p:=1 to length(inp) do begin
          k:=inp[p];
          if k in ['0'..'9']
            then temp:=temp+k
            else
              begin
                if temp<>'' then begin
                  n:=valu(temp);
                  if (n<1) or (n>200)
                    then dstr:=dstr+temp
                    else dstr:=dstr+directory[n].phonenum;
                  temp:=''
                end;
                case k of
                  '+':addprefix(plus);
                  '-':addprefix(minus);
                  '!':addprefix(bang);
                  '@':addprefix(atsign);
                  '#':addprefix(poundsign)
                end
              end
        end;
        if dstr<>'' then begin
          num:=num+1;
          ns[num]:=n;
          numstrs[num]:=dstr
        end
      until (num=10) or (dstr='');
      if num=0 then begin
        fullrefresh;
        exit
      end;
      for cnt:=1 to num do displayentry (ns[cnt],cnt);
      for cnt:=num+1 to 10 do begin
        gotoxy (1,cnt);
        clreol
      end;
      cnt:=0;
      repeat
        cnt:=cnt+1;
        if cnt>num then cnt:=1;
        n:=ns[cnt];
        displayentry (n,13);
        gotoxy (1,14);
        write (usr,'Dialing: ');
        clreol;
        if n<>0 then begin
          baudrate:=directory[n].baudrate;
          parity:=directory[n].databits=7;
          setparam (usecom,baudrate,parity)
        end;
        dstr:=numstrs[cnt];
        write (usr,dstr);
        bottom;
        break:=false;
        dialnumber (dstr);
        r:=now+45;
        while (now<r) and (not (keyhit or carrier)) do
          if numchars>0
            then writecon (getchar);
        top;
        done:=carrier;
        if (keyhit or break) and not carrier then begin
          gotoxy (1,14);
          write (usr,'Aborted by operator!');
          clreol;
          sendchar (^M);
          delay (1000);
          sendchar (^M);
          fullrefresh;
          exit
        end
      until carrier
    end;

    procedure getitem (prompt:mstr; var q; len:integer);
    var a:anystr absolute q;
        t:anystr;
    begin
      writeln (usr,^M'  Current ',prompt,' is: ',a);
        write (usr,'Enter new ',prompt,'   : ');
      buflen:=len;
      readline (t);
      if length(t)>0 then a:=t
    end;

    procedure reviseentry;

      procedure getinteger (prompt:mstr; var n:integer; r1,r2:integer);
      var q:sstr;
      begin
        str (n,q);
        repeat
          getitem (prompt,q,4);
          n:=valu (q);
          if (n>=r1) and (n<=r2) then exit;
          writeln (usr,'  Sorry!  Range is ',r1,' to ',r2,'!')
        until 0=1
      end;

    var n:integer;
        q:^dialrec;
    begin
      n:=valu(getnumber);
      if (n<1) or (n>200) then exit;
      q:=addr(directory[n]);
      clrscr;
      getitem ('BBS name',q^.bbsname,35);
      getitem ('phone number',q^.phonenum,14);
      getinteger ('baud rate',q^.baudrate,50,9600);
      getinteger ('data bits',q^.databits,7,8);
      writedfile (n);
      fullrefresh
    end;

    procedure editprefixes;

      procedure getprefix (p:prefixtype);
      begin
        gotoxy (1,13);
        getitem ('prefix',prefixes[p],80)
      end;

    var k:char;
    begin
      repeat
        clrscr;
        writeln (usr,'Prefixes are: '^J);
        writeln (usr,'  + ',prefixes[plus]);
        writeln (usr,'  - ',prefixes[minus]);
        writeln (usr,'  ! ',prefixes[bang]);
        writeln (usr,'  @ ',prefixes[atsign]);
        writeln (usr,'  # ',prefixes[poundsign],^J^J);
        write (usr,'Hit prefix to change, CR when done: ');
        k:=bioskey;
        case k of
          '+':getprefix (plus);
          '-':getprefix (minus);
          '!':getprefix (bang);
          '@':getprefix (atsign);
          '#':getprefix (poundsign)
        end
      until (k=#27) or (k=#13);
      saveprefixes;
      fullrefresh
    end;

  var k:char;
  begin
    splitscreen (16);
    top;
    if not dirloaded then begin
      writeln (usr,'Loading directory...');
      dirloaded:=true;
      loaddirectory;
      loadprefixes
    end;
    page:=0;
    fullrefresh;
    done:=false;
    repeat
      gotoxy (1,14);
      write (usr,'Your choice: ');
      clreol;
      k:=upcase(bioskey);
      case k of
        '9',#201:changepage (-10);
        '3',#209:changepage (10);
        'D':dialdirectory;
        'R':reviseentry;
        'E':editprefixes;
        'Q':done:=true
      end
    until done;
    unsplit
  end;

var done,echoback,localecho,addlf,printerecho:boolean;

  procedure splitit;
  begin
    splitscreen (5);
    top;
    gotoxy (1,1)
  end;

  procedure askquestion (prompt:lstr);
  begin
    splitit;
    write (usr,prompt);
    readline (input);
    unsplit
  end;

  function getyn (prompt:mstr):boolean;
  begin
    askquestion (prompt+':  Are you sure? ');
    getyn:=yes
  end;

  procedure ansireset;
  begin
    writecon (#27);
    writecon ('[');
    writecon ('0');
    writecon ('m')
  end;

  procedure help;
  begin
    if splitmode then begin
      unsplit;
      exit
    end;
    splitscreen (10);
    top;
    writeln (usr,'Alt-X: Exit');
    writeln (usr,'Alt-I: Initialize ANSI');
    writeln (usr,'Alt-H: Hang up');
    writeln (usr,'Alt-Q: Goto DOS');
    writeln (usr,'Alt-D: Dialing directory');
    writeln (usr);
    writeln (usr,'Alt-T: Transmit file');
    writeln (usr,'Alr-R: Receive file');
    window (40,1,80,10);
    inuse:=-1;
    gotoxy (1,1);
    writeln (usr,'Alt-E: Toggle echo');
    writeln (usr,'Alt-L: Toggle line feeds');
    writeln (usr,'Alt-B: Set baud rate');
    writeln (usr,'Alt-P: Set parity');
    writeln (usr,'Alt-F: Function keys');
    bottom
  end;

  procedure editfunckeys;
  var q:lstr;
      n,cnt:integer;
  begin
    splitscreen (15);
    top;
    repeat
      for cnt:=1 to 10 do begin
        gotoxy (1,cnt);
        write (usr,'F',cnt,':');
        gotoxy (6,cnt);
        write (usr,funckeys[cnt]);
        clreol
      end;
      gotoxy (1,12);
      write (usr,'Enter number to edit, CR when done: ');
      clreol;
      buflen:=2;
      readline (q);
      if length(q)=0 then begin
        savefunckeys;
        unsplit;
        exit
      end;
      n:=valu(q);
      if (n>0) and (n<11) then begin
        gotoxy (1,12);
        write (usr,'Enter new setting:');
        clreol;
        write (usr,^M^J'-> ');
        buflen:=70;
        readline (q);
        if length(q)<>0 then funckeys[n]:=q
      end
    until 0=1
  end;

  procedure setbaud;
  var bd:integer;
  begin
    askquestion ('Enter baud rate: ');
    bd:=valu(input);
    if (bd>=110) and (bd<=9600) then begin
      baudrate:=bd;
      setparam (usecom,baudrate,parity)
    end
  end;

  procedure setparity;
  var k:char;
  begin
    askquestion ('Parity E)ven or N)one: ');
    if length(input)=0 then exit;
    k:=upcase(input[1]);
    if k='E' then parity:=true else if k='N' then parity:=false;
    setparam (usecom,baudrate,parity)
  end;

  procedure upload;
  var fn:lstr;
      f:file;
      k:char;
      b:integer;
  begin
    splitit;
    write (usr,'Filename to upload: ');
    readline (fn);
    if length(fn)=0 then begin
      unsplit;
      exit
    end;
    assign (f,fn);
    reset (f);
    if ioresult<>0 then begin
      writeln (usr,'File not found!  Hit a key..');
      k:=bioskey;
      unsplit;
      exit
    end;
    close (f);
    write (usr,'Protocol (X=Xmodem, Y=Ymodem): ');
    k:=upcase(bioskey);
    unsplit;
    b:=protocolxfer (true,true,k='Y',fn)
  end;

  procedure download;
  var fn:lstr;
      f:file;
      k:char;
      b,ymodem:boolean;
      q:sstr;
      ret:integer;
  begin
    splitit;
    write (usr,'Filename to download: ');
    readline (fn);
    if length(fn)=0 then begin
      unsplit;
      exit
    end;
    assign (f,fn);
    reset (f);
    if ioresult=0 then begin
      close (f);
      write (usr,'Overwrite existing file? ');
      readline (fn);
      if (length(fn)=0) or (upcase(fn[1])<>'Y') then begin
        unsplit;
        exit
      end
    end;
    write (usr,'Protocol (X=Xmodem, Y=Ymodem): ');
    k:=upcase(bioskey);
    ymodem:=k='Y';
    if ymodem then q:='Y' else begin
      write (usr,^M^J'CRC Mode? ');
      q[1]:='Y';
      readline (q)
    end;
    unsplit;
    b:=upcase(q[1])='Y';
    ret:=protocolxfer (false,b,ymodem,fn)
  end;

  procedure writetermchar (k:char);
  begin
    case k of
      ^J:if addlf then exit;
      #255:if addlf then k:=^J
    end;
    case k of
      ^L:begin
           ansireset;
           clrscr
         end;
      ^G:begin
           nosound;
           sound (50);
           delay (50);
           nosound
         end
      else writecon (k)
    end;
    if printerecho then write (lst,k);
    case k of
      ^M:if addlf then writetermchar (#255);
    end
  end;

  procedure received (k:char);
  begin
    writetermchar (k);
    if echoback then sendchar (k)
  end;

  procedure typed (k:char);
  begin
    sendchar (k);
    if localecho then begin
      writecon (k);
      if k=#13 then write (usr,^J)
    end
  end;

  procedure checkwherey;
  begin
    if wherey>lasty then begin
      gotoxy (wherex,lasty);
      write (usr,^J)
    end
  end;

  procedure doextended (b:byte);

    procedure funckey (n:integer);
    var cnt:integer;
    begin
      for cnt:=1 to length(funckeys[n]) do
        sendchar (funckeys[n][cnt])
    end;

  begin
    case b of
      59..68:funckey (b-58);
      119:help;
      72:typed (^E);
      75:typed (^S);
      77:typed (^D);
      80:typed (^X);
      115:typed (^A);
      116:typed (^F);
      73:typed (^R);
      81:typed (^C);
      71:typed (^Q);
      79:typed (^W);
      83:typed (^G);
      82:typed (^V);
      117:typed (^P);
      48:setbaud;
      32:dialdirectory;
      18:localecho:=not localecho;
      33:editfunckeys;
      35:if carrier then if getyn ('Hang up') then hangupmodem;
      23:ansireset;
      38:addlf:=not addlf;
      25:setparity;
      16:if getyn ('Go to DOS') then begin
           ensureclosed;
           if not carrier then dontanswer;
           halt (4)
         end;
      19:download;
      20:upload;
      45:done:=getyn ('Resume waiting for calls');
(*
        16..25:altq;
        30..38:alta;
        44..50:altz;
*)
    end
  end;

  procedure showbottom;
  var x,y,o:integer;
  begin
    o:=inuse;
    usewind (0);
    gotoxy (1,25);
    textcolor (0);
    textbackground (statlinecolor);
    write (usr,'[TCS-Term] [Ctrl-Home for Help]');
    if addlf then write (usr,' LF');
    if localecho then write (usr,' Echo');
    clreol;
    textcolor (normbotcolor);
    textbackground (0);
    usewind (o)
  end;

  function basicterm:integer;
  var k:char;
      e:boolean;
  begin
    showbottom;
    e:=false;
    repeat
      if numchars<>0 then begin
        k:=getchar;
        received (k)
      end;
      checkwherey;
      if keyhit then begin
        k:=bioskey;
        if ord(k)<128 then typed (k) else e:=true
      end
    until e;
    basicterm:=ord(k)-128
  end;

  procedure init;
  var k:char;
  begin
    setparam (usecom,baudrate,parity);
    done:=false;
    echoback:=false;
    localecho:=false;
    addlf:=false;
    printerecho:=false;
    textcolor (normbotcolor);
    window (1,1,80,25);
    clrscr;
    initwinds;
    gotoxy (1,lasty);
    bottom;
    dirloaded:=false;
    loadfunckeys;
    while keyhit do k:=bioskey
  end;

begin
  init;
  repeat
    doextended (basicterm)
  until done;
  close (dfile);
  window (1,1,25,80);
  ansireset;
  clrscr
end;

begin
end.