Subj : TCP<->Fossil for plain DOS
To   : All
From : Alexander Grotewohl
Date : Tue Mar 09 2021 01:55:56

Here is some experimental code I was working on. I kind of lost interest after
it got past the "proof of concept" phase. Perhaps someone else wants to finish
it and run a single node internet bbs on a plain DOS machine ;)

sockets unit in the next message..


{$M $4000,0,0}
{x$DEFINE DEBUG}

uses
  dos, crt, sockets;

var
  h: word; { our socket handle }

  IntTable : array[0..255] of Pointer absolute 0:0;
  old14: pointer;

  buf: array[1..1024] of char;
  bcnt: word;
  bmax: word;

{For debugging only}
Procedure ScreenStr(s:string;x,y:integer;attr:byte);
var
  addr:word;
  i:integer;
begin
  addr:=(y-1)*160+(x-1)*2;
  for i:=0 to length(s)-1 do begin
    Mem[$b800:addr+i*2]:=ord(s[i+1]);
    Mem[$b800:addr+(i*2)+1]:=attr;
  end;
end;

type str10 = string[10];

Function NumStr(n,len:integer):str10;
var
  addr:word;
  i:integer;
  s:str10;
begin
  s:='';
  for i:=len downto 1 do begin
    s:=chr(n mod 10+ord('0'))+s;
    n:=n div 10;
  end;
  NumStr:=s;
end;


const
  funcstat : array[0..15] of integer = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
  hex : string[16] = '0123456789ABCDEF';

Procedure DebugOut(func:word;active:boolean);
var i:integer;
begin
  for i:=0 to 15 do
    if active and (i=func) then begin
      inc(funcstat[i]);
      if funcstat[i]>99 then funcstat[i]:=0;
      ScreenStr(hex[i+1]+':'+Numstr(funcstat[i],2),i*5+1,1,15);
    end
    else
      ScreenStr(hex[i+1]+':'+Numstr(funcstat[i],2),i*5+1,1,7);
  {ScreenStr('In:'+Numstr(InCount,2)+' Out:'+NumStr(OutCount,2)+
            ' Chk:'+Numstr(CheckInput,2)+' Stat:'+Numstr(LastStatus,2),1,2,7);}
end;

function do_status: word;
var
  tcp_state: byte;
  rec: psession_info_rec;
  t: word;
  icnt, ocnt: word;
begin
  tcp_status(h, tcp_state, icnt, ocnt, rec);
  { default }
  t:=$08;
  if (tcp_state=4) then
    t:=t or $80;
  if (icnt<>0) then
   t:=t or $0100;
  { room avail }
  t:=t or $2000;
  { buffer empty }
  t:=t or $4000;
  do_status:=t;
end;

procedure tcp14(flags, cs, ip, ax, bx, cx, dx, si, di, ds, es, bp: word); inter
upt;
var
  ch: char;
  cnt: word;
  icnt, ocnt: word;
begin
  {$IFDEF DEBUG}
  DebugOut(hi(ax),TRUE);
  {$ENDIF}
  driver_doio;
  case hi(ax) of
    $00: { set baud rate }
      begin
        { we ignore the info they send because
          we do not use it }
        { gotta send status tho}
        ax:=do_status;
        { clear a buffer we keep? }
        bcnt:=0;
        bmax:=0;
      end;
    $01: { transmit wait }
      begin
        inc(bcnt);
        buf[bcnt]:=char(lo(ax));
        if (bcnt=sizeof(buf)) then
          begin
            tcp_put(h, @buf[1], bcnt, $FFFF, cnt);
            bcnt:=0;
          end;
        ax:=do_status;
        { in:
          al        - character
          dx        - port
          out:
          ax        - status bits }
      end;
    $02: { receive wait }
      begin
        if (bcnt<>0) then
          begin
            tcp_put(h, @buf[1], bcnt, $FFFF, cnt);
            bcnt:=0;
          end;
        tcp_get(h, @ch, 1, $FFFF, cnt);
        if (cnt<>0) then
          ax:=byte(ch);
        { in:
          dx        - port
          out:
          ah = $00  - blah
          al        - character }
      end;
    $03: { status request }
      begin
        ax:=do_status;
        if (bcnt<>0) then
          inc(bmax);
        if (bmax > 5) then
          begin
            tcp_put(h, @buf[1], bcnt, $FFFF, cnt);
            bcnt:=0;
            bmax:=0;
          end;
        { in:
          dx        - port
          out:
          ax        - status bits }
      end;
    $04: { init driver }
      begin
        { in dx = port # }
        ax:=$1954; { success message }
        bx:=$100F; { duno about 10.. max func: $0C }
      end;
    $05: { deinit driver }
      begin
        { kill socket? }
      end;
    $06: { raise/lower dtr }
      begin
        { hang up! }
        if (lo(ax)=$00) then
          begin
            tcp_close(h);
            ax:=$00;
          end else
            ax:=$01;
      end;
    $07: { system timer params }
      begin
        { ignoring... }
      end;
    $08: { flush output buffer }
      begin
        if (bcnt<>0) then
          begin
            tcp_put(h, @buf[1], bcnt, $FFFF, cnt);
            bcnt:=0;
          end;
        { in dx = port # }
      end;
    $09: { purge output buffer }
      begin
        { in dx = port # }
      end;
    $0A: { purge input buffer }
      begin
        { in dx = port # }
      end;
    $0B: { transmit no wait }
      begin
        inc(bcnt);
        buf[bcnt]:=char(lo(ax));
        if (bcnt=sizeof(buf)) then
          begin
            tcp_put(h, @buf[1], bcnt, $FFFF, cnt);
            bcnt:=0;
          end;
        {ax:=do_status;}
        ax:=1;
        { in:
          al        - character
          dx        - port
          out:
          ax        - status bits }

        { in:
          al        - character
          dx        - port
          out:
          ax = 1    - sent
          ax = 0    - not sent }
      end;
    $0C:
      begin { peek ahead }
        { in:
          dx        - port
          out:
          ah = $00  - blah
          al        - character
          ax = $FFFF- no character avail }
      end;
    $0D: { peek ahead keyboard }
      begin
        { out:
          ax        - keyboard character
          ax = $FFFF- no character avail }
      end;
    $0E: { read keyboard wait }
      begin
        { out:
          ax        - keyboard character }
      end;
    $0F: { enable/disable flow control }
      begin
        { ignoring.. }
      end;
  end;
  {$IFDEF DEBUG}
  DebugOut(hi(ax),FALSE);
  {$ENDIF}
end;

var
  done: boolean;
  ch: char;

  rec: pdriver_info_rec;
  dh: byte;
  icnt, ocnt: word;

  rec2: psession_info_rec;
  dead: boolean;

  exit: boolean;

begin
  clrscr;
  exit:=false;

  done:=false;
  dead:=true;

  bcnt:=0;
  bmax:=0;

  if (not driver_info(rec)) then
    begin
      writeln('Trumpet driver not loaded!');
      halt(1);
    end;

  repeat
    if (tcp_listen(h, 23)<>0) then
      begin
        writeln('Failed to connect! Waiting 5 seconds...');
        {halt(1);}
        delay(5000);
        continue;
      end;

    clrscr;
    writeln('TcpFos Waiting for call on port 23... Ctrl-Q to Exit');

    repeat
      driver_doio;
      tcp_status(h, dh, icnt, ocnt, rec2);
      if (dead=false) and (dh<>4) then
        done:=true;
      if (dh=4) then
        begin
          if (dead=true) then
            dead:=false;
          Old14:=IntTable[$14];
          IntTable[$14]:=@tcp14;
          SwapVectors;
          exec(GetEnv('COMSPEC'),'/C c:\sbbs\node1\sbbs.bat qc38400');
          if (doserror<>0) then
            writeln('DOS error #: ', doserror);
          SwapVectors;
          IntTable[$14]:=Old14;
          done:=true;
        end else
      if (keypressed) then
        begin
          ch:=readkey;
          case ch of
            #0:
              begin
                ch:=readkey;
                case ch of
                  #45: ;
                end;
              end;
            #17:
              begin
                done:=true;
                exit:=true;
              end;
          end;
        end else
          delay(1);
    until done;
    tcp_close(h);
    dead:=true;
  until exit;
end.

--- Mystic BBS v1.12 A46 2020/08/26 (Windows/32)
 * Origin: --[!dreamland BBS bbs.dreamlandbbs.org (1:218/530)

.