[Back to COMM SWAG index] [Back to Main SWAG index] [Original]

    {
    3 Files:

    PROTCOMM.PAS
    IO.PAS
    BBS.PAS

    [-----------protcomm.pas begins----------------------------------------]
    { Origin - Mark Dignam of Omen Technologies  This unit has been highly modified }

    Unit ProtComm;

    Interface

    Procedure SetBaud (NewRate : LongInt);
    Function  GetBaud : LongInt;
    Function  Comm_Init (Baud : LongInt;  ThePort : Byte) : Boolean;
    Procedure ModemDeInit;
    Procedure SetDTR (OnOff : Boolean);
    Function  SendReady: Boolean;
    Function  Carrier : Boolean;
    Function  DataAvailable : Boolean;
    Function  GetChar : Byte;
    Procedure HangUp;
    Function  Ringing : Boolean;
    Procedure SendByte (Ch : Char);
    Procedure AsyncFlushOutput;
    Procedure AsyncPurgeOutput;
    Procedure AsyncPurgeInput;
    Procedure SendBreak;
    Procedure CTS_RTS (OnOff : Boolean);
    Procedure AWrite (S : String);
    Procedure AWriteLn (S : String);

    Var CanUseFossil : Boolean;
        UsedPort     : Byte;

    Implementation

    Uses Crt, { Borland CRT Routines      }
         Dos; { Borland Disk I/O Routines }

    Const MaxPhysPort    = 7;
          BufferSize     = 8196;
          BufferMax      = 8195;
          CommInterrupt  = $14 ;
          I8088_IMR      = $21 ; { port address of the Interrupt Mask Register }
          IBM_UART_THR         = $00 ;
          IBM_UART_RBR         = $00 ;
          IBM_UART_IER         = $01 ;
          IBM_UART_IIR         = $02 ;
          IBM_UART_LCR         = $03 ;
          IBM_UART_MCR         = $04 ;
          IBM_UART_LSR         = $05 ;
          IBM_UART_MSR         = $06 ;
          PortTable  : Array [0..MaxPhysPort] Of Record
            Base : Word;
            IRQ  : Byte
          End = ( (Base : $3F8;  IRQ : 4),
                  (Base : $2F8;  IRQ : 3),
                  (Base : $3E8;  IRQ : 4),
                  (Base : $2E8;  IRQ : 3),
                  (Base : 0;  IRQ : 0),
                  (Base : 0;  IRQ : 0),
                  (Base : 0;  IRQ : 0),
                  (Base : 0;  IRQ : 0));

    Var BIOS_Ports, IRQ                             : Byte;
        Old_IER, Old_IIR, Old_LCR, Old_MCR, Old_IMR : Byte;
        ExitSave, OriginalVector                    : Pointer;
        IsOpen, OverFlow, UseFossil, CTS_RTS_On     : Boolean;
        Base, BufferHead, BufferTail, BufferNewTail : Word;
        Status, RxWord, CtsTimer                    : Word;
        Buffer                                      : Array [0..BufferMax] Of
    Byte;    Regs                                        : Registers;

    Procedure Comm_SetBios (NewRate : LongInt);
    Var BaudRate    : Byte;
        Temp0       : Integer;
    Begin
      {$IFNDEF TEST}
      Temp0 := NewRate Div 10;
      Case Temp0 of
          30 : BaudRate := $43;
          60 : BaudRate := $63;
         120 : BaudRate := $83;
         240 : BaudRate := $A3;
         480 : BaudRate := $C3;
         960 : BaudRate := $E3;
        1920 : BaudRate := $03;
        3840 : BaudRate := $23;
        5760 : BaudRate := $23;
      End;
      Regs.AH := 0;
      Regs.AL := BaudRate;
      Regs.DX := UsedPort;
      Intr ($14, Regs);
      {$ENDIF}
    End;

    Procedure Comm_SetDirect (NewRate : LongInt);
    Var I, J, K : Word;
        Temp    : LongInt;
    Begin
      {$IFNDEF TEST}
      Temp := 115200;
      Temp := Temp DIV Newrate;
      Move (Temp, J, 2);
      K := Port [IBM_UART_LCR + Base];
      port [IBM_UART_LCR + Base] := $80;
      Port [IBM_UART_THR + Base] := Lo (J);
      Port [IBM_UART_IER + Base] := Hi (J);
      Port [IBM_UART_LCR + Base] := 3;
      {$ENDIF}
    End;

    Procedure SetBaud (NewRate : LongInt);
    Begin
      {$IFNDEF TEST}
      If UseFossil Then Comm_SetBios (NewRate) Else Comm_SetDirect (NewRate);
      {$ENDIF}
    End;

    Function Getbaud : LongInt;
    Var I, J, K : Word;
        Temp    : LongInt;
    begin
      {$IFNDEF TEST}
      K := Port [ibm_UART_LCR + Base];
      Port [IBM_UART_LCR + Base] := K OR $80;
      i := Port [IBM_UART_THR + Base];
      J := Port [IBM_UART_IER + Base];
      J := J * $100;
      J := J + I;
      Port [IBM_UART_LCR + base] := k;
      Temp := 115200;
      Temp := Temp DIV J;
      GetBaud := Temp;
      {$ELSE}
      GetBaud := 4800;
      {$ENDIF}
    End;

    Function Carrier : Boolean;
    Begin
      {$IFNDEF TEST}
      Carrier := Port [IBM_UART_MSR + Base] AND $80 = $80;
      {$ELSE}
      Carrier := False;
      {$ENDIF}
    End;

    Procedure DisableInterrupts;  Inline ($FA);
    Procedure EnableInterrupts;   Inline ($FB);

    Procedure ISR;  Interrupt;
    Begin
      {$IFNDEF TEST}
      Inline(
        $FB/                                { sti                           }
        {Start:                                                             }
        { get the incoming character                                        }
        { Buffer[BufferHead] := chr(port[base + ibm_uart_rbr]);             }
        $8B/$16/Base/                       { mov dx,Base                   }
        $EC/                                { in al,dx                      }
        $8B/$1E/BufferHead/                 { mov bx,BufferHead             }
        $88/$87/Buffer/                     { mov Buffer[bx],al             }
        { BufferNewHead := Succ (BufferHead);                               }
        $43/                                { inc bx                        }
        { if BufferNewHead > BufferMax then BufferNewHead := 0 ;            }
        $81/$FB/BufferMax/                  { cmp bx,BufferMax              }
        $7E/$02/                            { jle l001                      }
        $33/$DB/                            { xor bx,bx                     }
        { if BufferNewHead = BufferTail then Overflow := true               }
        {L001:                                                              }
        $3B/$1E/BufferTail/                 { cmp bx,BufferTail             }
        $75/$07/                            { jne L002                      }
        $C6/$06/Overflow/$01/               { mov overflow,1                }
        $EB/$0E/                            { jmp short L003                }
        { ELSE BEGIN                                                        }
        {   BufferHead := BufferNewHead;                                    }
        {   Async_BufferUsed := succ(Async_BufferUsed);                     }
        {   IF Async_BufferUsed > Async_MaxBufferUsed then                  }
        {     Async_MaxBufferUsed := Async_BufferUsed                       }
        {   END ;                                                           }
        {L002:                                                              }
        $89/$1E/BufferHead/                 { mov BufferHead,bx             }
        $83/$C2/$05/                        { Add dx,5                      }
        { Check FIFO - And process if more bytes.                           }
        $EC/                                { In al,dx                      }
        $24/$01/                            { And al,$01                    }
        $3C/$01/                            { cmp al,$01                    }
        $74/$CF/                            { je start:                     }
        {L003:                                                              }
        $FA/                                { cli                           }
        { issue non-specific EOI                                            }
        { port[$20] := $20 ;                                                }
        $B0/$20/                            { mov al,20h                    }
        $E6/$20);                           { out 20h,al                    }
      {$ENDIF}
    End;

    Procedure Async_Close;
    Begin
      {$IFNDEF TEST}
      If IsOpen Then
      Begin
        DisableInterrupts;
        Port [I8088_IMR] := (Port[I8088_IMR] OR (1 SHL IRQ));
        Port [IBM_UART_IER + Base] := Old_IER;
        EnableInterrupts;
        Port [IBM_UART_MCR + Base] := Old_MCR;
        Port [IBM_UART_LCR + Base] := Old_lCR;
        SetIntVec (IRQ + 8, OriginalVector);
        IsOpen := False;
      End;
      {$ENDIF}
    End;

    Function Init_fossil (Baud : LongInt;  ThePort : Byte) : Boolean;
    Begin
      {$IFNDEF TEST}
      UsedPort := ThePort - 1;
      Regs.AH := 4;
      Regs.DX := UsedPort;
      Intr ($14, Regs);
      If Regs.AX <> $1954 Then Init_Fossil := False Else
      Begin
        Init_Fossil := True;
        UseFossil := True;
        SetBaud (Baud);
      End;
      {$ELSE}
      Init_Fossil := True;
      {$ENDIF}
    End;

    Function Async_Open(Baud : Longint; LogicalPortNum: byte): boolean;
    Var I, OldIIR        : Byte;
        Fifos, PortThere : Boolean;
    Begin
      {$IFNDEF TEST}
      If Not IsOpen Then
      Begin
        BufferHead := 0;
        BufferTail := 0;
        Overflow := False;
        UsedPort := Pred (LogicalPortNum);
        Fifos := False;
        IsOpen := False;
        If PortTable [UsedPort].Base <> 0 Then
        Begin
          Base := PortTable [UsedPort].Base;
          IRQ := PortTable [UsedPort].IRQ;
          Old_IER := Port [IBM_UART_IER + Base];
          Old_MCR := Port [IBM_UART_MCR + Base];
          Old_LCR := Port [IBM_UART_LCR + Base];
          Port [IBM_UART_LCR + Base] := $75;
          PortThere := (Port [IBM_UART_LCR + Base] = $75);
          Port [IBM_UART_LCR + Base] := $3;
          If PortThere Then
          Begin
            Comm_SetDirect (Baud);
            Port [IBM_UART_MCR + Base] := $0B;
            OldIIR := Port [IBM_UART_IIR + Base];
            Port [IBM_UART_IIR + Base] := 1;
            Fifos := (Port [IBM_UART_IIR + Base] AND $C0 = $C0);
            If Not Fifos Then Port [IBM_UART_IIR + Base] := OldIIR;
            GetIntVec (IRQ + 8, OriginalVector);
            SetIntVec (IRQ + 8, @ISR);
            DisableInterrupts;
            Port [I8088_IMR] := (Port [I8088_IMR] AND ((1 SHL IRQ) XOR $FF));
            Port [IBM_UART_IER + Base] := 1;
            EnableInterrupts;
            IsOpen := True;
          End;
        End;
      End;
      Async_Open := IsOpen
      {$ELSE}
      Async_Open := True;
      {$ENDIF}
    End;

    {$F+}
    Procedure TerminateUnit;
    {$F-}

    Begin
      Async_Close;
      ExitProc := ExitSave
    End;

    Function Comm_init (Baud : Longint; ThePort : Byte) : Boolean;
    Begin
      {$IFNDEF TEST}
      UseFossil := False;
      If Not IsOpen Then
      Begin
        If (CanUseFossil) AND (Init_Fossil (Baud, ThePort)) Then
        Begin
          Comm_Init := True;
          IsOpen := True;
          Base := PortTable [UsedPort].Base;
        End Else
        Begin
          If Async_Open (Baud, ThePort) Then
          Begin
            Comm_Init := true;
            IsOpen := True;
          End Else Comm_Init := False;
        End;
      End;
      UsedPort := ThePort;
      {$ELSE}
      Comm_Init := True;
      {$ENDIF}
    End;

    Function DataAvailable : Boolean;
    Var AHigh : Byte;
    Begin
      {$IFNDEF TEST}
      If UseFossil Then
      Begin
        Inline ($B4/$03/            { MOV AH, 3        }
                $8b/$16/UsedPort/   { MOV DX, Usedport }
                $cd/$14/            { INT 14h          }
                $a3/Status);        { MOV [Status], AL }
        DataAvailable := ((Status AND $100) <> 0);
      End Else DataAvailable := (Bufferhead <> BufferTail);
      {$ELSE}
      DataAvailable := False;
      {$ENDIF}
    End;

    Procedure ModemDeInit;
    Begin
      {$IFNDEF TEST}
      If IsOpen Then
      Begin
        If UseFossil Then
        Begin
          Regs.AH := 5;
          Regs.DX := UsedPort;
          Intr ($14, Regs);
        End Else Async_Close;
        IsOpen := False;
      End;
      {$ENDIF}
    End;

    Function GetChar : byte;
    Begin
      {$IFNDEF TEST}
      If UseFossil Then
      Begin
        Inline ($B4/$02/            { MOV AH, 3        }
                $8b/$16/UsedPort/   { MOV Dx, Usedport }
                $CD/$14/            { INT 14h          }
                $A3/RXWord);        { Mov [Status], AL }
        GetChar := Lo (RXWord);
      End Else
      Begin
        GetChar := Buffer [BufferTail] ;
        BufferTail := (Succ (BufferTail) MOD BufferSize) ;
      End;
      {$ENDIF}
    End;

    Function SendReady : boolean;
    Var Ahigh          : Byte;
        Carr, CTS, THR : boolean;
    Begin
      {$IFNDEF TEST}
      If UseFossil Then
      Begin
        Inline ($B4/$03/            { MOV AH, 3        }
                $8B/$16/UsedPort/   { MOV DX, Usedport }
                $CD/$14/            { INT 14h          }
                $A3/Status);        { MOV Status, AX   }
        THR  := (Status AND $2000) <> 0;
        Carr := (Status AND $0080) <> 0;
        SendReady := THR OR (Not Carr);

      End Else
      Begin
        THR := ((Port [IBM_UART_LSR + Base] AND $20) <> 0);
        CTS :=  (Port [IBM_UART_MSR + Base] AND $10 = $10);
        If CTS_RTS_On AND Carrier Then SendReady := THR AND Cts Else SendReady :=
    THR;  End;
      {$ELSE}
      SendReady := False;
      {$ENDIF}
    End;

    Procedure SendByte (Ch : Char);
    Begin
      {$IFNDEF TEST}
      Repeat Until SendReady;
      If UseFossil then
      Begin
        Regs.AH := 1;
        Regs.AL := Ord (Ch);
        Regs.DX := UsedPort;
        intr($14,regs);
      End Else Port [IBM_UART_THR + Base] := Ord (Ch);
      {$ENDIF}
    End;

    Procedure AsyncFlushOutput;
    Begin
      {$IFNDEF TEST}
      If Usefossil Then
      Begin
        Regs.AH := 8;
        Regs.DX := UsedPort;
        Intr ($14, Regs);
      End;
      {$ENDIF}
    End;

    Procedure AsyncPurgeOutput;
    Begin
      {$IFNDEF TEST}
      If UseFossil Then
      Begin
        Regs.AH := 9;
        Regs.DX := UsedPort;
        Intr ($14, Regs);
      End;
      {$ENDIF}
    End;

    Procedure AsyncPurgeInput;
    Begin
      {$IFNDEF TEST}
      If UseFossil then
      Begin
        Regs.AH := $0A;
        Regs.DX := UsedPort;
        Intr ($14, Regs);
      End Else
      Begin
        BufferHead := 0;
        BufferTail := 0;
        OverFlow   := False;
      End;
      {$ENDIF}
    End;

    Procedure SendBreak;
    Var I, J : Byte;
    Begin
      {$IFNDEF TEST}
      If UseFossil then
      Begin
        Regs.AX := $1A01;
        Regs.DX := UsedPort;
        Intr ($14, Regs);
        Delay (100);
        Regs.AX := $1A00;
        Regs.DX := UsedPort;
        Intr ($14, Regs);
      End Else
      Begin
        I := Port [IBM_UART_LCR + Base];
        J := I;
        I := I AND $7F;
        I := I OR $40;
        Port [IBM_UART_LCR + Base] := I;
        delay (100);
        Port [IBM_UART_LCR + Base] := J;
      End;
      {$ENDIF}
    End;

    Procedure SetDTR (OnOff : Boolean);
    Var I : Byte;
    Begin
      {$IFNDEF TEST}
      If UseFossil then
      Begin
        Regs.AH := $06;
        If OnOff Then Regs.AL := 1 Else Regs.AL := 0;
        Regs.DX := UsedPort;
        Intr ($14, Regs);
      End Else
      Begin
        If OnOff Then Port [IBM_UART_MCR + Base] := $0B Else Port [IBM_Uart_MCR +
    Base] := $0A;  End;
      {$ENDIF}
    End;

    Procedure CTS_RTS (OnOff : Boolean);
    Begin
      {$IFNDEF TEST}
      If UseFossil Then
      Begin
        Regs.DX := UsedPort;
        If OnOff Then Regs.AL := 2 Else Regs.AL := 0;
        Regs.AH := $0F;
        Intr ($14, Regs);
      End Else CTS_RTS_On := OnOff;
      {$ENDIF}
    End;

    Procedure AWrite (S : String);
    Var I : Integer;
    Begin
      {$IFNDEF TEST}
      For I := 1 To Length (S) Do SendByte ((S[I]));
      {$ENDIF}
    End;

    Procedure AWriteLn (S : String);
    Begin
      {$IFNDEF TEST}
      AWrite (S + #10#13);
      {$ENDIF}
    End;

    Function Ringing : Boolean;
    Begin
      {$IFNDEF TEST}
      Case UsedPort of
        1 : Ringing := Boolean (Port[$3FE] And 64);
        2 : Ringing := Boolean (Port[$2FE] And 64);
        3 : Ringing := Boolean (Port[$3EE] And 64);
        4 : Ringing := Boolean (Port[$2EE] And 64);
        Else Ringing := False;
      End;
      {$ELSE}
      Ringing := False;
      {$ENDIF}
    End;

    Procedure Hangup;
    Begin
      {$IFNDEF TEST}
      SetDTR (False);
      Delay (250);
      SetDTR (True);
      {$ENDIF}
    End;

    Begin
      {$IFNDEF TEST}
      ExitSave := ExitProc;
      ExitProc := @TerminateUnit;
      IsOpen   := FALSE;
      Overflow := FALSE;
      CanUseFossil := False;
      CTS_RTS_On := True;
      Bios_Ports := 4;
      {$ENDIF}
    End.

    [-----------protcomm.pas ends -------------------------------------------------]
    [-----------io.pas begins-----------------------------------------------------]
    Unit IO;

    Interface

    Procedure SWrite         (S : String);
    Procedure SWriteLn       (S : String);
    Procedure SReadLn        (Var S : String);
    Procedure SClrScr;

    Var Local : Boolean;

    Implementation

    Uses Crt, ProtComm;

    Procedure SWrite (S : String);
    Begin
      Write (S);
      If Not Local Then AWrite (S);
    End;

    Procedure SWriteLn (S : String);
    Begin
      WriteLn (S);
      If Not Local Then AWriteLn (S);
    End;

    Function SReadKey : Char;
    Var Done : Boolean;
        Ch   : Char;
    Begin
      Done := False;
      Repeat
        If (Not Local) and (Not Carrier) Then Done := True;
        If Not Local Then
        If DataAvailable Then
        Begin
          Ch := Chr (GetChar);
          Done := True;
        End;
        If KeyPressed Then
        Begin
          Ch := ReadKey;
          Done := True;
        End;
      Until Done;
      SReadKey := Ch;
    End;

    Function SKeyPressed : Boolean;
    Begin
      SKeyPressed := False;
      If DataAvailable Then SKeyPressed := True;
      If KeyPressed Then SKeyPressed := True;
    End;

    Procedure SReadLn (Var S : String);
    Var Ch : Char;
    Begin
      S := '';
      Repeat
        Ch := SReadKey;
        If Ord (Ch) in [32..122] Then
        Begin
          S := S + Ch;
          SWrite (Ch);
        End;
        If Ord (Ch) = Ord (8) Then
        Begin
          If Length (S) > 0 Then
          Begin
            SWrite (#8' '#8);
            Delete (S, Length (S), 1);
          End;
        End;
      Until (Ord (Ch) = 13) OR ((Not Carrier) AND (Not Local));
      SWrite (#13#10);
    End;

    Procedure SClrScr;
    Begin
      SWriteLn (#12);
      ClrScr;
    End;

    End.
    [-----------io.pas ends-------------------------------------------------]
    [-----------bbs.pas begins ---------------------------------------------]
    { Minimal BBS - part of the Communications Package of HTCPACK #7
      For more information or for information on where to obtain complete
    HTCPACK's  email havoc.the.chaos@iirg.com }

    Uses Crt, IO, ProtComm;

    Var TestPad : String;
        OutChar : Char;

    Procedure RunBBS;
    Var Answer : String;
    Begin
      SWriteLn ('Welcome to the minimal BBS!');
      SWrite ('Type somethin: ');
      SReadLn (Answer);
      SWriteLn ('You typed "' + Answer + '"');
      Delay (5000);
      SWriteLn ('Goodbye!');
      AsyncFlushOutput;
      Hangup;
    End;

    Procedure FrontEnd;
    Var EscPressed : Boolean;
        ModemString : String;
        Timer : Integer;
        Ch : Char;
    Begin
      If Not Local Then AWriteLn ('ATA');
      ClrScr;
      WriteLn ('*** RING ***'#7);
      ModemString := '';
      EscPressed := False;
      If Not Local Then
      Begin
        AsyncPurgeInput;
        Timer := 0;
        EscPressed := False;
        Repeat
          ModemString := '';
          While DataAvailable Do ModemString := ModemString + Chr (GetChar);
          Delay (1);
          Inc (Timer);
          If KeyPressed Then
          Begin
            Ch := ReadKey;
            If Ord (Ch) = Ord (27) Then EscPressed := True;
          End;
        Until (Carrier) or (Timer = 60000) or (Local) or (EscPressed);
      End;
      If EscPressed OR (Timer = 60000) Then
      Begin
        ClrScr;
        AWriteLn ('');
        Write ('Connection not established due to ');
        If EscPressed Then WriteLn ('local escape.');
        If Timer = 60000 Then WriteLn ('a 60 time elapse with no connection.');
        Delay (2000);
        Exit;
      End;
      If Carrier OR Local Then
      Begin
        While KeyPressed Do Write (ReadKey, #8);
        AsyncPurgeInput;
        RunBBS;
      End;
    End;

    Procedure Initialize;
    Begin
      Comm_Init (57600, 2);
      ClrScr;
      Local := False;
      AsyncPurgeInput;
      While DataAvailable Do Write (Chr (GetChar));
      If Not Carrier Then AWriteLn ('ATZ');
    End;

    Begin
      Initialize;
      Repeat
        TestPad := '';
        While DataAvailable Do
        Begin
          TestPad := TestPad + Chr (GetChar);
        End;
        TestPad := '';
        If Ringing Then
        Begin
          Local := False;
          FrontEnd;
        End;
        If KeyPressed Then
        Begin
          OutChar := ReadKey;
          Case Ord (OutChar) of
             0 : Begin
                   OutChar := ReadKey;
                   Case Ord (OutChar) of
    {F1}             59 : Begin
                            Local := True;
                            FrontEnd;
                          End;
    {ALT-X}          45 : Begin
                            ModemDeInit;
                            Halt;
                          End;
                   End;
                 End;
          End;
        End;
      Until 1 = 2;
    End.

    [-----------bbs.pas ends-------------------------------------------------]

[Back to COMM SWAG index] [Back to Main SWAG index] [Original]