Beijing Paradise BBS Backup/PARADISE.ISO/software/BBSDOORW/DIGIKIT.ZIP/APDIGI.PAS

Pascal/Delphi Source File | 1992-07-16 | 18.4 KB | 756 lines

{$S-,R-,V-,I-,B-,F+,O+,A-,D+,L+}

{$I APDEFINE.INC}

{*********************************************************}
{*                   APDIGI.PAS 1.04                     *}
{*         Copyright (c) Mustang Software 1992.          *}
{*                 All rights reserved.                  *}
{*********************************************************}

unit ApDigi;

interface

uses
  Dos,
  {$IFDEF UseOpro}
  OpInline,
  OpRoot,
  {$ENDIF}
  {$IFDEF UseTpro}
  TpCrt,
  TpInline,
  TpMemChk,
  {$ENDIF}
  ApMisc,
  ApPort;


{#Z+}
procedure dInitPort(var P : PortRecPtr; ComName : ComNameType;
                    Baud : LongInt;
                    Parity : ParityType; DataBits : DataBitType;
                    StopBits : StopBitType;
                    InSize, OutSize : Word;
                    Options : Word);
  {-Open digi port}

procedure dInitPortKeep(var P : PortRecPtr; ComName : ComNameType;
                    InSize, OutSize : Word);
  {-Open digi port (without changing line params)}

procedure dDonePort(var P : PortRecPtr);
  {-Closes digi port ComName}

procedure dSetUart(ComName : ComNameType; NewBase : Word;
                   NewIrq, NewVector : Byte);
  {-Dummy routine required by high-level routines}

procedure dSetLine(P : PortRecPtr; Baud : LongInt; Parity : ParityType;
                   DataBits : DataBitType; StopBits : StopBitType);
  {-Sets the digi and the port record with the new values}

procedure dGetLine(P : PortRecPtr; var Baud : LongInt;
                   var Parity : ParityType;
                   var DataBits : DataBitType;
                   var StopBits : StopBitType;
                   FromHardware : Boolean);
  {-Gets the line params directly from the digi}

procedure dSetModem(P : PortRecPtr; DTR, RTS : Boolean);
  {-Sets the port record with the new values}

procedure dGetModem(P : PortRecPtr; var DTR, RTS : Boolean);
  {-Gets the DTR,RTS settings directly from the digi}

procedure dGetChar(P : PortRecPtr; var C : Char);
  {-Returns C (sets error if none available)}

procedure dPeekChar(P : PortRecPtr; var C : Char; PeekAhead : Word);
  {-Looks ahead PeekAhead chars (with 1 being the next character)}

procedure dPutChar(P : PortRecPtr; C : Char);
  {-Adds char to xmit buffer or outputs in directly}

procedure dStartTransmitter(P : PortRecPtr);
  {-Does nothing (but required by some high-level routines)}

function dCharReady(P : PortRecPtr) : Boolean;
  {-Returns True if digi status call shows a character waiting}

function dTransReady(P : PortRecPtr) : Boolean;
  {-Returns True if digi status call shows room in output buffer}

function dGetLineStatusDirect(P : PortRecPtr) : Byte;

procedure dSendBreak(P : PortRecPtr);
  {-Sends a serial line break}

procedure dActivatePort(P : PortRecPtr; Restore : Boolean);
  {-Initializes the digi port}

procedure dDeactivatePort(P : PortRecPtr; Restore : Boolean);
  {-Deactivates the digi port}

procedure dSavePort(P : PortRecPtr; var PSR);
  {-Does nothing }

procedure dRestorePort(P : PortRecPtr; var PSR);
  {-Does nothing }

procedure dGotError(P : PortRecPtr; StatusCode : Word);
  {-Called when an error occurs (GotError calls the optional ErrorHandler)}
{#Z-}

procedure ActivateApDigi;
  {-Registers this unit as the active "device layer"}

implementation

const
  ecCCBTimeOut  = 9980;  {DigiChannel driver timed out on CCB command}

type
  BytePtr = ^Byte;
  OS = record
         O : Word;
         S : Word;
       end;

var
  CharReadyPtr : BytePtr;


  procedure dInitPortKeep(var P : PortRecPtr; ComName : ComNameType;
                          InSize, OutSize : Word);
  var
    Found : Boolean;
    I : Byte;
    PWord : Word;
    DTR, RTS : Boolean;

  label
    ErrorExit;

  begin
    AsyncStatus := ecOk;

    if not GetMemCheck(P, SizeOf(PortRec)) then
      begin
        AsyncStatus := ecOutOfMemory;
        Exit;
      end;

    {$IFDEF LargeComNameSet}
    if ComName > Com8 then
      begin
        AsyncStatus := ecOutOfRange;
        goto ErrorExit;
      end;
    {$ENDIF}

    with P^ do
      begin
        PortName := ComName;

        Found := False;
        I := 1;
        while not Found and (I <= MaxActivePort) do
          if ActiveComPort[I] = nil then
            begin
              CurrentPort := I;
              ActiveComPort[I] := P;
              Found := True;
            end
          else
            Inc(I);

        if not Found then
          begin
            AsyncStatus := ecNoMorePorts;
            goto ErrorExit;
          end;

        SWFState := False;
        SWFGotXoff := False;
        SWFSentXoff := False;
        SWFOnChar := DefaultXonChar;
        SWFOffChar := DefaultXoffChar;

        HWFRecHonor := 0;
        HWFTransHonor := 0;
        HWFRemoteOff := False;
        LastXmitError := 0;

        Buffered := False;
        InBuff := nil;
        InHead := nil;
        InTail := nil;
        InBuffEnd := nil;
        InBuffLen := 65535;
        InBuffCount := 0;
        OutBuff := nil;
        OutHead := nil;
        OutTail := nil;
        OutBuffEnd := nil;
        OutBuffLen := 65535;
        OutBuffCount := 0;

        UseStatusBuffer := False;
        StatBuff := nil;
        StatHead := nil;
        StatTail := nil;

        Flags := DefPortOptions;
        BreakReceived := False;
        TxReady := True;
        TxInts := True;
        TxIntsActive := False;
        LostCharCount := 0;
        DoneProc := dDonePort;
        ErrorProc := NoErrorProc;
        ErrorData := nil;
        UserAbort := NoAbortProc;
        ProtocolActive := False;
        ISRActive := False;

        dGetLine(P, CurBaud, CurParity, CurDataBits, CurStopBits, True);
        dGetModem(P, DTR, RTS);

        PWord := Word(P^.PortName);
        asm
          mov ah,$1E                        {turn CTR/RTS on}
          mov bh,$00
          mov bl,$12
          mov dx,PWord
          int $14

          mov ah,$0D                        {get char ready ptr}
          mov dx,PWord
          int $14
          mov word ptr CharReadyPtr,bx
          mov word ptr CharReadyPtr+2,es

          mov ah,$09                        {flush buffers, necessary to kick char ready flag}
          mov dx,PWord                      {on some Digicards, and to get full transmit buffer}
          int $14                           {space in next call}

          mov ah,$12                        {get transmit buffer size}
          mov dx,PWord
          int $14
          inc ax
          les di,P
          les di,es:[di]
          mov es:[di].PortRec.OutBuffLen,ax
        end;
        Exit;
      end;
  ErrorExit:
    FreeMemCheck(P, SizeOf(PortRec));
  end;


  procedure dInitPort(var P : PortRecPtr; ComName : ComNameType;
                      Baud : LongInt;
                      Parity : ParityType; DataBits : DataBitType;
                      StopBits : StopBitType; InSize, OutSize : Word;
                      Options : Word);
  var
    B : Boolean;

  begin
    dInitPortKeep(P, ComName, InSize, OutSize);
    if AsyncStatus <> ecOk then
      Exit;
    with P^ do
      begin
        dSetLine(P, Baud, Parity, DataBits, StopBits);
        if AsyncStatus <> ecOk then
          begin
            ActiveComPort[CurrentPort] := nil;
            FreeMemCheck(P, SizeOf(PortRec));
            Exit;
          end;
        Flags := Options;
        B := FlagIsSet(Flags, ptRaiseModemOnOpen);
        if B then
          ModemControl := ModemControl or (DTRMask or RTSMask);
      end;
    dSetModem(P, B, B);
  end;


  procedure dDonePort(var P : PortRecPtr);
  begin
    AsyncStatus := ecOk;
    if P = nil then
      Exit;
    with P^ do
      ActiveComPort[CurrentPort] := Nil;
    FreeMemCheck(P, SizeOf(PortRec));
    P := nil;
  end;


  procedure dSetUart(ComName : ComNameType; NewBase : Word; NewIrq, NewVector : Byte);
  begin
  end;


  procedure dSetLine(P : PortRecPtr; Baud : LongInt;
                     Parity : ParityType; DataBits : DataBitType;
                     StopBits : StopBitType);
  var
    ParityB, StopBitsB, DataBitsB, BaudB : Byte;

  begin
    AsyncStatus := ecOk;
    with P^ do
      begin
        case Parity of
          NoParity   : ParityB := 0;
          OddParity  : ParityB := 1;
          EvenParity : ParityB := 2;
        else
          dGotError(P, epFatal+ecInvalidParity);
          Exit;
        end;
        case StopBits of
          1 : StopBitsB := 0;
          2 : StopBitsB := 1;
        else
          dGotError(P, epFatal+ecOutOfRange);
          Exit;
        end;
        case DataBits of
          5 : DataBitsB := 0;
          6 : DataBitsB := 1;
          7 : DataBitsB := 2;
          8 : DataBitsB := 3;
        else
          dGotError(P, epFatal+ecOutOfRange);
          Exit;
        end;
        if Baud > 57600 then
          begin
            if Baud = 76800 then
              BaudB := $0B
            else if Baud = 115200 then
              BaudB := $0C
            else
              begin
                dGotError(P, epFatal+ecInvalidBaudRate);
                Exit;
              end;
          end
        else
          case Word(Baud) of
            50    : BaudB := $0D;
            75    : BaudB := $0E;
            110   : BaudB := $00;
            134   : BaudB := $0F;
            150   : BaudB := $01;
            200   : BaudB := $10;
            300   : BaudB := $02;
            600   : BaudB := $03;
            1200  : BaudB := $04;
            1800  : BaudB := $11;
            2400  : BaudB := $05;
            4800  : BaudB := $06;
            9600  : BaudB := $07;
            19200 : BaudB := $08;
            38400 : BaudB := $09;
            57600 : BaudB := $0A;
          else
            dGotError(P, epFatal+ecInvalidBaudRate);
            Exit;
          end;
        asm
          les di,P
          mov dl,es:[di].PortRec.PortName
          xor dh,dh
          mov ah,$04
          mov al,$00
          mov bh,ParityB
          mov bl,StopBitsB
          mov ch,DataBitsB
          mov cl,BaudB
          int $14
          les di,P
          mov es:[di].PortRec.ModemStatus,al
          mov es:[di].PortRec.LineStatus,ah
        end;
        CurBaud := Baud;
        CurParity := Parity;
        CurDataBits := DataBits;
        CurStopBits := StopBits;
      end;
  end;


  procedure dGetLine(P : PortRecPtr; var Baud : LongInt;
                     var Parity : ParityType;
                     var DataBits : DataBitType;
                     var StopBits : StopBitType;
                     FromHardware : Boolean);
  var
    ParityB, StopB, DataB, BaudB : Byte;

  begin
    AsyncStatus := ecOk;
    with P^ do
      if not FromHardware then
        begin
          Baud := CurBaud;
          Parity := CurParity;
          DataBits := CurDataBits;
          StopBits := CurStopBits;
        end
      else
        begin
          asm
            les di,P
            mov dl,es:[di].PortRec.PortName
            xor dh,dh
            mov ah,$0C
            int $14
            mov ParityB,bh
            mov StopB,bl
            mov DataB,ch
            mov BaudB,cl
          end;
          case ParityB of
            $00 : Parity := NoParity;
            $01 : Parity := OddParity;
            $02 : Parity := EvenParity;
          end;
          case StopB of
            $00 : StopBits := 1;
            $01 : StopBits := 2;
          end;
          case DataB of
            $00 : DataBits := 5;
            $01 : DataBits := 6;
            $02 : DataBits := 7;
            $03 : DataBits := 8;
          end;
          case BaudB of
            $00 : Baud := 110;
            $01 : Baud := 150;
            $02 : Baud := 300;
            $03 : Baud := 600;
            $04 : Baud := 1200;
            $05 : Baud := 2400;
            $06 : Baud := 4800;
            $07 : Baud := 9600;
            $08 : Baud := 19200;
            $09 : Baud := 38400;
            $0A : Baud := 57600;
            $0B : Baud := 76800;
            $0C : Baud := 115200;
            $0D : Baud := 50;
            $0E : Baud := 75;
            $0F : Baud := 134;
            $10 : Baud := 200;
            $11 : Baud := 1800;
          end;
          CurBaud := Baud;
          CurParity := Parity;
          CurDataBits := DataBits;
          CurStopBits := StopBits;
        end;
  end;


  procedure dSetModem(P : PortRecPtr; DTR, RTS : Boolean); assembler;
  asm
    mov AsyncStatus,ecOk
    les di,P
    mov dl,es:[di].PortRec.PortName
    xor dh,dh
    mov ah,$05
    mov al,$01
    mov bl,0
    cmp Dtr,0
    je @1
    or bl,DtrMask
  @1:
    cmp Rts,0
    je @2
    or bl,RtsMask
  @2:
    int $14
  end;


  procedure dGetModem(P : PortRecPtr; var DTR, RTS : Boolean); assembler;
  asm
    mov AsyncStatus,ecOk
    les di,P
    mov dl,es:[di].PortRec.PortName
    xor dh,dh
    mov ah,$05
    mov al,$00
    int $14
    les di,P
    mov es:[di].PortRec.LineStatus,ah
    mov es:[di].PortRec.ModemStatus,al
    mov es:[di].PortRec.ModemControl,bl
    mov al,bl
    and al,DtrMask
    cmp al,DtrMask
    mov al,0
    jne @1
    inc al
  @1:
    les di,Dtr
    mov es:[di],al
    mov al,bl
    and al,RtsMask
    cmp al,RtsMask
    mov al,0
    jne @2
    inc al
  @2:
    les di,Rts
    mov es:[di],al
  end;


  procedure dGetChar(P : PortRecPtr; var C : Char);
  label
    GotError;

  begin
    if dCharReady(P) then
      begin
        asm
          les di,P
          mov dl,es:[di].PortRec.PortName
          xor dh,dh
          mov ah,$02
          int $14
          cmp ah,$80
          je GotError
          les di,C
          mov byte ptr es:di,al
          les di,P
          mov es:[di].PortRec.LineStatus,ah
        end;
        with P^ do
          begin
            if LineStatus and OverrunErrorMask = OverrunErrorMask then
              AsyncStatus := ecOverrunError
            else if LineStatus and ParityErrorMask = ParityErrorMask then
              AsyncStatus := ecParityError
            else if LineStatus and FramingErrorMask = FramingErrorMask then
              AsyncStatus := ecFramingError
            else
              AsyncStatus := ecOk;
            if AsyncStatus <> ecOk then
              begin
                LineStatus := LineStatus and not (OverrunErrorMask or ParityErrorMask or FramingErrorMask);
                dGotError(P, epNonFatal+AsyncStatus);
              end;
          end;
        {$IFDEF Tracing}
        if TracingOn then
          AddTraceEntry('R', C);
        {$ENDIF}
        Exit;
      GotError:
        C := #$FF;
        dGotError(P, epNonFatal+ecTimeout);
      end
    else
      dGotError(P, epNonFatal+ecBufferIsEmpty);
  end;


  procedure dPeekChar(P : PortRecPtr; var C : Char; PeekAhead : Word);
  label
    GotError;

  begin
    if PeekAhead > 1 then
      begin
        dGotError(P, epNonFatal+ecInvalidArgument);
        Exit;
      end;
    asm
      les di,P
      mov dl,es:[di].PortRec.PortName
      xor dh,dh
      mov ah,$08
      int $14
      cmp ah,$FF
      je GotError
      les di,C
      mov byte ptr es:[di],al
    end;
    AsyncStatus := ecOk;
    Exit;
  GotError:
    C := #$FF;
    dGotError(P, epNonFatal+ecBufferIsEmpty);
  end;


  procedure dPutChar(P : PortRecPtr; C : Char);
  label
    GotError;

  begin
    asm
      les di,P
      mov dl,es:[di].PortRec.PortName
      xor dh,dh
      mov ah,$01
      mov al,C
      int $14
      cmp ah,$80
      je GotError
      les di,P
      mov es:[di].PortRec.LineStatus,ah
    end;
    AsyncStatus := ecOk;
    {$IFDEF Tracing}
    if TracingOn then
      AddTraceEntry('T', C);
    {$ENDIF}
    Exit;
  GotError:
    dGotError(P, epNonFatal+ecBufferIsFull);
  end;


  procedure dStartTransmitter(P : PortRecPtr);
  begin
  end;


  function dCharReady(P : PortRecPtr) : Boolean;
  begin
    dCharReady := CharReadyPtr^ = $FF;
  end;


  function dTransReady(P : PortRecPtr) : Boolean; assembler;
  asm
    les di,P
    mov dl,es:[di].PortRec.PortName
    xor dh,dh
    mov ah,$12
    int $14
    cmp ax,0
    je @1
    mov al,1
  @1:
  end;


  procedure dSendBreak(P : PortRecPtr); assembler;
  asm
    mov AsyncStatus,ecOk
    les di,P
    mov dl,es:[di].PortRec.PortName
    xor dh,dh
    mov ah,$07
    mov al,$00
    int $14
    cmp ah,0
    je @1
    mov AsyncStatus,ecCCBTimeOut
  @1:
  end;


  function dGetLineStatusDirect(P : PortRecPtr) : Byte; assembler;
  asm
    mov AsyncStatus,ecOk
    les di,P
    mov dl,es:[di].PortRec.PortName
    xor dh,dh
    mov ah,$03
    int $14
    les di,P
    mov es:[di].PortRec.LineStatus,ah
    mov al,ah
  end;


  procedure dActivatePort(P : PortRecPtr; Restore : Boolean);
  begin
    dGotError(P, epNonFatal+ecNotSupported);
  end;


  procedure dDeactivatePort(P : PortRecPtr; Restore : Boolean);
  begin
    dGotError(P, epNonFatal+ecNotSupported);
  end;


  procedure dSavePort(P : PortRecPtr; var PSR);
  begin
    dGotError(P, epNonFatal+ecNotSupported);
  end;


  procedure dRestorePort(P : PortRecPtr; var PSR);
  begin
    dGotError(P, epNonFatal+ecNotSupported);
  end;


  procedure dGotError(P : PortRecPtr; StatusCode : Word);
  begin
    AsyncStatus := StatusCode;
    with P^ do
      begin
        if @ErrorProc <> @NoErrorProc then
          ErrorProc(ErrorData, StatusCode);
        if ProtocolActive then
          AsyncStatus := AsyncStatus mod 10000;
      end;
  end;


  procedure ActivateApDigi;
  begin
    {$IFNDEF UseOOP}
    InitPort := dInitPort;
    InitPortKeep := dInitPortKeep;
    DonePort := fDonePort;
    SetLine := dSetLine;
    GetLine := dGetLine;
    SetModem := dSetModem;
    GetModem := dGetModem;
    GetChar := dGetChar;
    PeekChar := dPeekChar;
    PutChar := dPutChar;
    StartTransmitter := dStartTransmitter;
    CharReady := dCharReady;
    TransReady := dTransReady;
    SendBreak := dSendBreak;
    ActivatePort := dActivatePort;
    DeactivatePort := dDeactivatePort;
    SavePort := dSavePort;
    RestorePort := dRestorePort;
    GotError := dGotError;
    {$ENDIF}
    SetUart := dSetUart;
  end;


begin
  {$IFDEF AutoDeviceInit}
  ActivateApUart;
  {$ELSE}
  SetUart := dSetUart;
  {$ENDIF}

  AnsiOutput := dPutChar;
end.