{$CDecl-,OrgName-,AlignRec-,X+}

{Conditional defines that may affect this unit}

{*********************************************************}
{*                                                       *}
{*                     APOS2.PAS 1.0                     *}
{*                                                       *}
{*     Copyright (c) Konstantin Klyagin, 1996.           *}
{*                   expecialy for Tornado BBS system    *}
{*                                                       *}
{*********************************************************}

Unit ApOS2;
  {-Provides serial I/O using FOSSIL services under OS/2}

Interface

Uses
  Os2Def,
  Os2Base,
  Strings,
  ApSame,
  Os2Timer;

Var
  VirtualDCD, HandleExist                : Boolean;
  ComHandle                              : hFile;
  Com_RxBuffer                           : Array [0..4096] Of Byte;
  Com_RxBufferPtr, Com_RxCurrent         : LongInt;
  Res                                    : ApiRet;
  ComPortName                            : PChar {String [20]};

Type
  IO_Line_Parameters = Record
    DataBits, Parity, StopBits  : System. Word;
  End;

  IO_ESpeed_Parameters = Record
    Speed       : LongInt;
    Fraction    : Byte;
  End;

  IO_DTRRTSMask = Record
    _on, _off   : Byte;
  End;

  IO_RxStatus = Record
    Received, BufSize   : System. Word;
  End;

  IO_DCB = Record
    Write_Timeout               : System. Word;
    Read_Timeout                : System. Word;
    Flags1, Flags2, Flags3,
    Error_Replacement,
    Break_Replacement,
    Xon_Character,
    Xoff_Character              : Byte;
  End;

  {For accessing hi/lo words of a longint}
  LH = Record
    L, H : Word;
  End;

Const
  BufEmpty = (-1);
  NoCarrier = (-4);
  ValidModemStatus = $80;
  ValidLIneStatus = $3;
  DcdMask: Byte = $80;

  IO_Set_Speed  = $41;
  IO_Set_Line   = $42;
  IO_Set_ESpeed = $43;
  IO_TxByte     = $44;
  IO_Set_DTRRTS = $46;
  IO_Start      = $48;
  IO_WriteDCB   = $53;
  IO_Status     = $64;
  IO_Lamps      = $67;
  IO_RxInfo     = $68;
  IO_TxInfo     = $69;
  IO_ReadDCB    = $73;

Procedure os2PutBlockDirect (Buffer: PChar; Len: Word);
Function Com_TXFree : Word;

Procedure oInitPort (Var P : PortRecPtr; ComName : ComNameType;
                     Baud : LongInt; Parity : ParityType; DataBits :
                     DataBitType; StopBits : StopBitType; InSize,
                     OutSize : Word; Options : Word);
Procedure oDonePort (Var P : PortRecPtr);
Procedure oSetModem (P : PortRecPtr; DTR, RTS : Boolean);
Procedure oGetModem (P : PortRecPtr; Var DTR, RTS : Boolean);
Procedure oGetChar (P : PortRecPtr; Var C : Char);
Procedure oPutChar (P : PortRecPtr; C : Char);
Function oCharReady (P : PortRecPtr) : Boolean;
Procedure oGotError (P : PortRecPtr; StatusCode : Word);
Procedure ActivateApOS2;

Implementation

Function Min (V1, V2: LongInt): LongInt;
Begin
  If V1 < V2 Then Min := V1 Else Min := V2;
End;

Procedure oInitPort (Var P : PortRecPtr; ComName : ComNameType; Baud : LongInt;
                     Parity : ParityType; DataBits : DataBitType; StopBits :
                     StopBitType; InSize, OutSize : Word; Options : Word);

  {-OS2 open port procedure}

Const
  OpenFlag: LongInt = $01;
  OpenMode: LongInt = $42;

Var
  Error, InLen, OutLen          : ULong;
  DCB                           : IO_DCB;
  D                             : IO_ESpeed_Parameters;

Const
  Action                        : ApiRet = 0;

Begin
  AsyncStatus := ecOk;

  {Allocate Port record}
  If Not GetMemCheck (P, SizeOf(PortRec)) Then
  Begin
    AsyncStatus := ecOutOfMemory;
    Exit;
  end;

  With P^ Do
  Begin
    {Store the port name}
    PortName := ComName;

    {No control over the modem, set to zero for now}
    ModemControl := 0;

    {No flow control}
    SWFState := 0;
    SWFGotXoff := False;
    SWFSentXoff := False;
    SWFOnChar := #17;
    SWFOffChar := #19;
    HWFTransHonor := 0;
    HWFRecHonor := 0;
    HWFRemoteOff := False;
    LastXmitError := 0;

    {Misc other inits}
    Flags := DefPortOptions or DefFossilOptions;                       {!!.02}
    Buffered := False;
    BreakReceived := False;
    TxReady := True;
    TxInts := False;
    LineStatus := 0;
    DoneProc := oDonePort;
    ErrorProc := NoErrorProc;
    ErrorData := nil;
    UserAbort := NoAbortFunc;
    ProtocolActive := False;
    FaxActive := False;

    {Zero out buffer stuff (prevents errors if buffer routines are called)}
    InBuff := nil;
    InHead := nil;
    InBuffEnd := nil;
    InBuffLen := 65535;
    InBuffCount := 0;
    OutBuff := nil;
    OutHead := nil;
    OutBuffEnd := nil;
    OutBuffLen := 65535;
    OutBuffCount := 0;
    UseStatusBuffer := False;
    StatBuff := nil;
    StatHead := nil;
    StatTail := nil;
  End;

  If Not HandleExist Then
  Begin
    If DosOpen (ComPortName, ComHandle, Action, 0, 0, OpenFlag, OpenMode or $1000,
       Nil) <> 0 Then
    Begin
      AsyncStatus := ecNoFossil;
      Exit;
    End;
  End;

  Res := DosDevIOCtl (ComHandle, 1, IO_ReadDCB, nil, 0, nil, @DCB, SizeOf (DCB), @InLen);

  With DCB Do
  Begin
    Write_Timeout := 10;
    Read_Timeout := 10;
    {Flags3 := $16;}
    Error_Replacement := 0;
    Break_Replacement := 0;
  End;

  Res := DosDevIOCtl (ComHandle, 1, IO_WriteDCB, @DCB, SizeOf (DCB), @OutLen, nil, 0, nil);

  Com_RxBufferPtr := 0;
  Com_RxCurrent := 0;

  {
  D. Speed := Baud;
  D. Fraction := 0;
  Error := 0;
  DosDevIOCtl (ComHandle, 1, IO_Set_ESpeed, @D, SizeOf (D), @OutLen,
               @Error, 2, @InLen);
  }
End;

Procedure oDonePort (Var P : PortRecPtr);
  {-Closes ComName}
Begin
  AsyncStatus := ecOk;
  If P = Nil Then Exit;

  DosClose (ComHandle);

  {Release the heap space}
  FreeMem (P, SizeOf (PortRec));
  P := Nil;
End;

Procedure oSetModem (P : PortRecPtr; DTR, RTS : Boolean);
  {-Can only set DTR}
Var
  D             : IO_DTRRTSMask;
  OutLen, InLen : LongInt;
  Error         : System. Word;
  Res           : Word;

Begin
  If DTR Then
  Begin
    D. _on := 1;
    D. _off := $ff;
  End Else
  Begin
    D. _on := 0;
    D. _off := $FE;
  End;

  Res := DosDevIOCtl (ComHandle, 1, IO_Set_DTRRTS, @D, SizeOf (D), @OutLen, @Error, 2, @InLen);

  If DTR
  Then P^. ModemControl := P^. ModemControl Or DTRMask
  Else P^. ModemControl := P^. ModemControl And Not DTRMask;

  If RTS
  Then P^. ModemControl := P^. ModemControl Or RTSMask
  Else P^. ModemControl := P^. ModemControl And Not RTSMask;
End;

Procedure oGetModem (P : PortRecPtr; Var DTR, RTS : Boolean);
  {-Does nothing (can't get modem params from FOSSIL)}
Begin
  oGotError (P, epNonFatal + ecNotSupported);
  DTR := True;
  RTS := True;
End;

Procedure oGetChar (P : PortRecPtr; Var C : Char);
  {-Calls OS/2 FOSSIL to check for and return C}
Var
  Re                    : Char;
  Res                   : LongInt;
  D                     : IO_RxStatus;
  OutLen, InLen         : LongInt;
  ToReady, BufferFree   : LongInt;

Begin
  AsyncStatus := ecOk;

  If Com_RxBufferPtr > Com_RxCurrent Then
  Begin
    C := Chr (Com_RxBuffer [Com_RxCurrent]);
    Inc (Com_RxCurrent);
  End Else
  Begin
    Com_RxCurrent := 0;
    Com_RxBufferPtr := 0;
    DosDevIOCtl (ComHandle, 1, IO_RxInfo, nil, 0, nil, @D, SizeOf (D), @InLen);
    ToReady := D. BufSize - D. Received;
    BufferFree := SizeOf (Com_RxBuffer) - Com_RxBufferPtr;
    DosRead (ComHandle, Com_RxBuffer [0], Min (BufferFree, ToReady), Res);
    If Res = 0 Then AsyncStatus := ecBufferIsEmpty Else
    Begin
      Inc (Com_RxBufferPtr, Res);
      C := Chr (Com_RxBuffer [Com_RxCurrent]);
      Inc (Com_RxCurrent);
    End;
  End;
End;

Procedure oPutChar (P : PortRecPtr; C : Char);
  {-Puts a char to OS/2 FOSSIL}
Var
  Error: Longint;

Begin
  DosWrite (ComHandle, C, 1, Error);
End;

Procedure onSetLine (P: PortRecPtr; Baud : LongInt; Parity : ParityType; DataBits :
                     DataBitType; StopBits : StopBitType);
Begin
  {nothing to do}
End;

Procedure onGetLine (P: PortRecPtr; var Baud : LongInt; var Parity : ParityType; var
                     DataBits : DataBitType; var StopBits : StopBitType;
                     FromHardware : Boolean);
Begin
  {nothing to do}
End;

Procedure oNothing (P : PortRecPtr);
  {-Dummy procedure required by high-level routines}
Begin
  {nothing to do}
End;

Procedure onInitPortKeep (var P : PortRecPtr; ComName : ComNameType; InSize,
                          OutSize : Word);
Begin
  {nothing to do}
End;

Procedure oPeekChar (P: PortRecPtr; var C : Char; PeekAhead : Word);
Begin
  If PeekAhead > Com_RxBufferPtr Then
  Begin
    GetChar (P, C);
  End;
  C := Chr (Com_RxBuffer [PeekAhead-1]);
End;

Function onTransReady (P: PortRecPtr): Boolean;
Begin
  onTransReady := True;
End;

Procedure onSendBreak (P: PortRecPtr);
Begin
  {nothing to do}
End;

Procedure onActivatePort (P: PortRecPtr; Restore : Boolean);
Begin
  {nothing to do}
End;

Procedure onDeactivatePort (P: PortRecPtr; Restore : Boolean);
Begin
  {nothing to do}
End;

Procedure onSavePort (P: PortRecPtr; var PSR);
Begin
  {nothing to do}
End;

Procedure onRestorePort (P: PortRecPtr; var PSR);
Begin
  {nothing to do}
End;

Function onUpdateLineStatus (P : PortRecPtr) : Byte;
Begin
  {nothing to do}
End;

Function onUpdateModemStatus (P : PortRecPtr) : Byte;
Begin
  {nothing to do}
End;

Procedure onHWFlowSet (P : PortRecPtr; Enable : Boolean; BufferFull,
                       BufferResume : Word; Options : Word);
Begin
End;

Function onHWFlowGet (P : PortRecPtr) : FlowState;
Begin
End;

Procedure onSWFlowSet (P : PortRecPtr; Enable : Boolean; BufferFull,
                       BufferResume : Word; Options : Word);
Begin
End;

Function onSWFlowGet (P : PortRecPtr) : FlowState;
Begin
End;

Procedure onSWFlowCtl (P : PortRecPtr; OnChar, OffChar : Char; Resume : Boolean);
Begin
End;

Procedure oBufferStatus (P : PortRecPtr; Var InFree, OutFree, InUsed, OutUsed : Word);
Var
  D             : IO_RXSTATUS;
  OutLen, InLen : LongInt;

Begin
  DosDevIOCtl (ComHandle, 1, IO_TXINFO, nil, 0, nil, @D, SizeOf (D), @InLen);

  OutFree := D. Bufsize - D. Received;
  OutUsed := D. Received;

  DosDevIOCtl (ComHandle, 1, IO_RXINFO, nil, 0, nil, @D, SizeOf (D), @InLen);

  InFree := D. Bufsize - D. Received;
  InUsed := D. Received;
End;

Procedure onBufferFlush (P : PortRecPtr; FlushIn, FlushOut: Boolean);
Begin
End;

Procedure onSetUart (ComName : ComNameType; NewBase : Word; NewIrq, NewVector : Byte);
Begin
End;

Function oCharReady (P : PortRecPtr) : Boolean;
  {-Returns True if OS/2 FOSSIL status call has DataReady set}
Var
  D             : IO_RxStatus;
  OutLen, InLen : LongInt;

Begin
  If (Com_RxCurrent < Com_RXbufferPtr) Then oCharReady := True Else
  Begin
    DosDevIOCtl (ComHandle, 1, IO_RxInfo, nil, 0, nil, @D, SizeOf (D), @InLen);
    oCharReady := (D. Received > 0);
  End;
End;

Procedure oGotError (P : PortRecPtr; StatusCode : Word);
  {-Called when an error occurs (GotError calls the optional ErrorHandler)}

Begin
  AsyncStatus := StatusCode;
  With P^ Do
  If @ErrorProc <> @NoErrorProc Then
  Begin
    ErrorProc (ErrorData, StatusCode);
    If ProtocolActive Then
      {Remove error class on protocol errors}
      AsyncStatus := AsyncStatus Mod 10000;
  End;
End;

Procedure ActivateApOS2;
  {-Registers this unit as the active "device layer"}
Begin
  InitPort := oInitPort;
  InitPortKeep := onInitPortKeep;
  DonePort := oDonePort;
  SetLine := onSetLine;
  GetLine := onGetLine;
  SetModem := oSetModem;
  GetModem := oGetModem;
  GetChar := oGetChar;
  PeekChar := oPeekChar;
  PutChar := oPutChar;
  CharReady := oCharReady;
  TransReady := onTransReady;
  SendBreak := onSendBreak;
  ActivatePort := onActivatePort;
  DeactivatePort := onDeactivatePort;
  SavePort := onSavePort;
  RestorePort := onRestorePort;
  GotError := oGotError;

  UpdateLineStatus := onUpdateLineStatus;
  UpdateModemStatus := onUpdateModemStatus;
  HWFlowSet := onHWFlowSet;
  HWFlowGet := onHWFlowGet;
  SWFlowSet := onSWFlowSet;
  SWFlowGet := onSWFlowGet;
  SWFlowCtl := onSWFlowCtl;
  BufferStatus := oBufferStatus;
  BufferFlush := onBufferFlush;

  SetUart := onSetUart;
End;

Function Com_TXFree : Word;
Var
  D             : IO_RXSTATUS;
  OutLen, InLen : LongInt;

Begin
  DosDevIOCtl (ComHandle, 1, IO_TXINFO, nil, 0, nil, @D, SizeOf (D), @InLen);
  Com_TxFree := D. Bufsize - D. Received;
End;

Procedure os2PutBlockDirect (Buffer: PChar; Len: Word);
Var
  SentSize, SentPos     : LongInt;
  ToSentLen             : Word;

Begin
  If Len <> 0 Then
  Begin
    SentPos := 0;
    While Len > 0 Do
    Begin
      ToSentLen := Com_TxFree;
      ToSentLen := Min (ToSentLen, Len);
      DosWrite (ComHandle, Buffer [sentPos], ToSentLen, SentSize);
      Inc (SentPos, SentSize);
      Dec (Len, SentSize);
    End;
  End;
End;

Begin
  HandleExist := False;
End.
