WinComm/delphi/KPCOMM.PAS

unit KPComm;

{ KPComm - Native Delphi 1.0 serial communications component.            }
{                                                                         }
{ TKPComm is a non-visual TComponent descendant providing RS-232 serial   }
{ I/O via the Windows 3.1 comm API.  Installs to the "KP" palette tab.   }
{                                                                         }
{ Port lifecycle: OpenComm -> BuildCommDCB + SetCommState ->              }
{   EnableCommNotification -> CloseComm.                                  }
{                                                                         }
{ WM_COMMNOTIFY messages are received through a hidden utility window     }
{ with a registered class and dispatched to ProcessReceiveNotify,         }
{ ProcessTransmitNotify, and ProcessEventNotify.                          }
{                                                                         }
{ Modem line status (CTS/DSR/CD) is tracked via shadow booleans toggled   }
{ on transition events from GetCommEventMask, since the 16-bit comm API   }
{ only provides transition events, not absolute line levels.              }

interface

uses
  SysUtils, Classes, WinTypes, WinProcs, Messages;

const
  { Communication events }
  comEvReceive  = 1;
  comEvSend     = 2;
  comEvCTS      = 3;
  comEvDSR      = 4;
  comEvCD       = 5;
  comEvRing     = 6;
  comEvEOF      = 7;

  { Error events }
  comEvtBreak   = 1001;
  comEvtFrame   = 1004;
  comEvtOverrun = 1006;
  comEvtRxOver  = 1008;
  comEvtParity  = 1009;
  comEvtTxFull  = 1010;

type
  THandshaking = (hsNone, hsXonXoff, hsRtsCts, hsBoth);
  TInputMode = (imText, imBinary);

  TKPComm = class(TComponent)
  private
    FCommId:        Integer;
    FHWndNotify:    HWnd;
    FCommPort:      Integer;
    FSettings:      string;
    FPortOpen:      Boolean;
    FInBufferSize:  Integer;
    FOutBufferSize: Integer;
    FRThreshold:    Integer;
    FSThreshold:    Integer;
    FHandshaking:   THandshaking;
    FInputLen:      Integer;
    FInputMode:     TInputMode;
    FDTREnable:     Boolean;
    FRTSEnable:     Boolean;
    FNullDiscard:   Boolean;
    FEOFEnable:     Boolean;
    FParityReplace: string;
    FBreakState:    Boolean;
    FCommEvent:     Integer;
    FCTSState:      Boolean;
    FDSRState:      Boolean;
    FCDState:       Boolean;
    FOnComm:        TNotifyEvent;
    procedure ApplyHandshaking;
    procedure ApplyOptions;
    procedure ClosePort;
    procedure DoCommEvent(EventCode: Integer);
    function  GetInBufferCount: Integer;
    function  GetInput: string;
    function  GetOutBufferCount: Integer;
    procedure OpenPort;
    procedure ProcessEventNotify;
    procedure ProcessReceiveNotify;
    procedure ProcessTransmitNotify;
    procedure SetBreak(Value: Boolean);
    procedure SetCommPort(Value: Integer);
    procedure SetDTREnable(Value: Boolean);
    procedure SetHandshaking(Value: THandshaking);
    procedure SetInBufferSize(Value: Integer);
    procedure SetNullDiscard(Value: Boolean);
    procedure SetOutBufferSize(Value: Integer);
    procedure SetOutput(const Value: string);
    procedure SetParityReplace(const Value: string);
    procedure SetPortOpen(Value: Boolean);
    procedure SetRTSEnable(Value: Boolean);
    procedure SetSettings(const Value: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Input: string read GetInput;
    property Output: string write SetOutput;
    property InBufferCount: Integer read GetInBufferCount;
    property OutBufferCount: Integer read GetOutBufferCount;
    property CDHolding: Boolean read FCDState;
    property CTSHolding: Boolean read FCTSState;
    property DSRHolding: Boolean read FDSRState;
    property Break: Boolean read FBreakState write SetBreak;
    property CommEvent: Integer read FCommEvent;
  published
    property CommPort: Integer read FCommPort write SetCommPort default 1;
    property Settings: string read FSettings write SetSettings;
    property PortOpen: Boolean read FPortOpen write SetPortOpen default False;
    property InBufferSize: Integer read FInBufferSize write SetInBufferSize default 4096;
    property OutBufferSize: Integer read FOutBufferSize write SetOutBufferSize default 4096;
    property RThreshold: Integer read FRThreshold write FRThreshold default 0;
    property SThreshold: Integer read FSThreshold write FSThreshold default 0;
    property Handshaking: THandshaking read FHandshaking write SetHandshaking default hsNone;
    property InputLen: Integer read FInputLen write FInputLen default 0;
    property InputMode: TInputMode read FInputMode write FInputMode default imText;
    property DTREnable: Boolean read FDTREnable write SetDTREnable default True;
    property RTSEnable: Boolean read FRTSEnable write SetRTSEnable default True;
    property NullDiscard: Boolean read FNullDiscard write SetNullDiscard default False;
    property EOFEnable: Boolean read FEOFEnable write FEOFEnable default False;
    property ParityReplace: string read FParityReplace write SetParityReplace;
    property OnComm: TNotifyEvent read FOnComm write FOnComm;
  end;

procedure Register;

implementation

const
  { WM_COMMNOTIFY notification codes }
  CN_RECEIVE  = $0001;
  CN_TRANSMIT = $0002;
  CN_EVENT    = $0004;

  { DCB Flags field bit masks.  The Windows 3.1 DCB packs thirteen 1-bit }
  { fields into a single UINT (Word) at offset 12 of the structure.      }
  { Delphi 1.0 maps this UINT to TDCB.Flags.                            }
  dcbBinary      = $0001;
  dcbRtsDisable  = $0002;
  dcbParity      = $0004;
  dcbOutxCtsFlow = $0008;
  dcbOutxDsrFlow = $0010;
  dcbDtrDisable  = $0020;
  dcbOutX        = $0040;
  dcbInX         = $0080;
  dcbPeChar      = $0100;
  dcbNull        = $0200;
  dcbChEvt       = $0400;
  dcbDtrflow     = $0800;
  dcbRtsflow     = $1000;

  { Hidden notification window class name }
  NotifyClassName = 'KPCommNotify';

var
  NotifyClassRegistered: Boolean;


{ ----------------------------------------------------------------------- }
{ Hidden notification window procedure                                     }
{                                                                          }
{ Receives WM_COMMNOTIFY from the comm driver.  Retrieves the TKPComm     }
{ instance pointer stored in the window's extra bytes (offset 0) and       }
{ dispatches to the appropriate Process* method.                           }
{ ----------------------------------------------------------------------- }

function NotifyWndProc(Wnd: HWnd; Msg: Word;
  WParam: Word; LParam: Longint): Longint; export;
var
  Comm:       TKPComm;
  NotifyCode: Word;
begin
  if Msg = wm_CommNotify then
  begin
    Comm := TKPComm(GetWindowLong(Wnd, 0));
    if (Comm <> nil) and Comm.FPortOpen and (Comm.FCommId >= 0) then
    begin
      NotifyCode := Word(LParam);
      if (NotifyCode and CN_RECEIVE) <> 0 then
        Comm.ProcessReceiveNotify;
      if (NotifyCode and CN_TRANSMIT) <> 0 then
        Comm.ProcessTransmitNotify;
      if (NotifyCode and CN_EVENT) <> 0 then
        Comm.ProcessEventNotify;
    end;
    Result := 0;
  end
  else
    Result := DefWindowProc(Wnd, Msg, WParam, LParam);
end;


{ ----------------------------------------------------------------------- }
{ TKPComm                                                                  }
{ ----------------------------------------------------------------------- }

procedure TKPComm.ApplyHandshaking;
var
  DCB: TDCB;
begin
  if GetCommState(FCommId, DCB) <> 0 then
    Exit;

  { Clear all flow control flags }
  DCB.Flags := DCB.Flags and
    not (dcbOutxCtsFlow or dcbOutxDsrFlow or dcbOutX or dcbInX or
         dcbRtsDisable or dcbRtsflow);

  case FHandshaking of
    hsXonXoff:
      begin
        DCB.Flags    := DCB.Flags or dcbOutX or dcbInX;
        DCB.XonChar  := #$11;
        DCB.XoffChar := #$13;
        DCB.XonLim   := 256;
        DCB.XoffLim  := 256;
      end;
    hsRtsCts:
      begin
        DCB.Flags := DCB.Flags or dcbOutxCtsFlow or dcbRtsflow;
      end;
    hsBoth:
      begin
        DCB.Flags    := DCB.Flags or dcbOutxCtsFlow or dcbRtsflow or
                         dcbOutX or dcbInX;
        DCB.XonChar  := #$11;
        DCB.XoffChar := #$13;
        DCB.XonLim   := 256;
        DCB.XoffLim  := 256;
      end;
  end;

  DCB.Id := FCommId;
  SetCommState(DCB);
end;


procedure TKPComm.ApplyOptions;
var
  DCB: TDCB;
begin
  if GetCommState(FCommId, DCB) <> 0 then
    Exit;

  if FNullDiscard then
    DCB.Flags := DCB.Flags or dcbNull
  else
    DCB.Flags := DCB.Flags and not dcbNull;

  if Length(FParityReplace) > 0 then
  begin
    DCB.Flags  := DCB.Flags or dcbParity;
    DCB.PeChar := FParityReplace[1];
  end
  else
  begin
    DCB.Flags  := DCB.Flags and not dcbParity;
    DCB.PeChar := #0;
  end;

  DCB.Id := FCommId;
  SetCommState(DCB);
end;


procedure TKPComm.ClosePort;
begin
  { Set FPortOpen first to prevent stale WM_COMMNOTIFY processing }
  FPortOpen := False;

  if FCommId >= 0 then
  begin
    if FBreakState then
    begin
      ClearCommBreak(FCommId);
      FBreakState := False;
    end;
    EscapeCommFunction(FCommId, CLRDTR);
    EscapeCommFunction(FCommId, CLRRTS);
    CloseComm(FCommId);
    FCommId := -1;
  end;

  if FHWndNotify <> 0 then
  begin
    DestroyWindow(FHWndNotify);
    FHWndNotify := 0;
  end;

  FCTSState := False;
  FDSRState := False;
  FCDState  := False;
end;


constructor TKPComm.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCommId        := -1;
  FHWndNotify    := 0;
  FCommPort      := 1;
  FSettings      := '9600,N,8,1';
  FPortOpen      := False;
  FInBufferSize  := 4096;
  FOutBufferSize := 4096;
  FRThreshold    := 0;
  FSThreshold    := 0;
  FHandshaking   := hsNone;
  FInputLen      := 0;
  FInputMode     := imText;
  FDTREnable     := True;
  FRTSEnable     := True;
  FNullDiscard   := False;
  FEOFEnable     := False;
  FParityReplace := '?';
  FBreakState    := False;
  FCommEvent     := 0;
  FCTSState      := False;
  FDSRState      := False;
  FCDState       := False;
end;


destructor TKPComm.Destroy;
begin
  if FPortOpen then
    ClosePort;
  inherited Destroy;
end;


procedure TKPComm.DoCommEvent(EventCode: Integer);
begin
  FCommEvent := EventCode;
  if Assigned(FOnComm) then
    FOnComm(Self);
end;


function TKPComm.GetInBufferCount: Integer;
var
  Stat: TComStat;
begin
  Result := 0;
  if not FPortOpen or (FCommId < 0) then
    Exit;
  GetCommError(FCommId, Stat);
  Result := Stat.cbInQue;
end;


function TKPComm.GetInput: string;
var
  Stat:        TComStat;
  BytesToRead: Integer;
  BytesRead:   Integer;
  Buf:         array[0..255] of Char;
begin
  Result := '';
  if not FPortOpen or (FCommId < 0) then
    Exit;

  GetCommError(FCommId, Stat);
  BytesToRead := Stat.cbInQue;

  if (FInputLen > 0) and (BytesToRead > FInputLen) then
    BytesToRead := FInputLen;
  if BytesToRead > 255 then
    BytesToRead := 255;
  if BytesToRead <= 0 then
    Exit;

  BytesRead := ReadComm(FCommId, @Buf, BytesToRead);
  if BytesRead <= 0 then
    Exit;

  { Set string length and copy data directly -- preserves embedded nulls }
  { for binary mode, and works correctly for text mode as well.          }
  Result[0] := Chr(BytesRead);
  Move(Buf, Result[1], BytesRead);
end;


function TKPComm.GetOutBufferCount: Integer;
var
  Stat: TComStat;
begin
  Result := 0;
  if not FPortOpen or (FCommId < 0) then
    Exit;
  GetCommError(FCommId, Stat);
  Result := Stat.cbOutQue;
end;


procedure TKPComm.OpenPort;
var
  WC:      TWndClass;
  DCB:     TDCB;
  Buf:     array[0..255] of Char;
  Setting: string;
  RxTh:    Integer;
  TxTh:    Integer;
begin
  { Open the comm port }
  StrPCopy(Buf, 'COM' + IntToStr(FCommPort));
  FCommId := OpenComm(Buf, FInBufferSize, FOutBufferSize);
  if FCommId < 0 then
    raise Exception.Create('Cannot open COM' + IntToStr(FCommPort) +
      ' (error ' + IntToStr(FCommId) + ')');

  { Configure baud/parity/data/stop from Settings string }
  if GetCommState(FCommId, DCB) <> 0 then
  begin
    CloseComm(FCommId);
    FCommId := -1;
    raise Exception.Create('GetCommState failed');
  end;

  Setting := 'COM' + IntToStr(FCommPort) + ':' + FSettings;
  StrPCopy(Buf, Setting);
  if BuildCommDCB(Buf, DCB) <> 0 then
  begin
    CloseComm(FCommId);
    FCommId := -1;
    raise Exception.Create('Invalid Settings: ' + FSettings);
  end;

  DCB.Flags := DCB.Flags or dcbBinary;
  DCB.Id    := FCommId;
  if SetCommState(DCB) <> 0 then
  begin
    CloseComm(FCommId);
    FCommId := -1;
    raise Exception.Create('SetCommState failed');
  end;

  { Apply handshaking }
  ApplyHandshaking;

  { Apply null-discard and parity-replace }
  ApplyOptions;

  { Set DTR and RTS lines }
  if FDTREnable then
    EscapeCommFunction(FCommId, SETDTR)
  else
    EscapeCommFunction(FCommId, CLRDTR);
  if FRTSEnable then
    EscapeCommFunction(FCommId, SETRTS)
  else
    EscapeCommFunction(FCommId, CLRRTS);

  { Register notification window class (once per process) }
  if not NotifyClassRegistered then
  begin
    FillChar(WC, SizeOf(WC), 0);
    WC.lpfnWndProc   := @NotifyWndProc;
    WC.cbWndExtra    := SizeOf(Longint);
    WC.hInstance     := HInstance;
    WC.lpszClassName := NotifyClassName;
    if not RegisterClass(WC) then
    begin
      CloseComm(FCommId);
      FCommId := -1;
      raise Exception.Create('RegisterClass failed');
    end;
    NotifyClassRegistered := True;
  end;

  { Create hidden notification window and store Self for dispatch }
  FHWndNotify := CreateWindow(NotifyClassName, '', ws_Popup,
    0, 0, 0, 0, 0, 0, HInstance, nil);
  if FHWndNotify = 0 then
  begin
    CloseComm(FCommId);
    FCommId := -1;
    raise Exception.Create('CreateWindow failed');
  end;
  SetWindowLong(FHWndNotify, 0, Longint(Self));

  { Enable event mask for modem status, errors, and breaks }
  SetCommEventMask(FCommId,
    ev_CTS or ev_DSR or ev_RLSD or ev_Ring or
    ev_Err or ev_Break or ev_RxChar);

  { Enable comm notifications -- -1 disables the notification }
  if FRThreshold > 0 then
    RxTh := FRThreshold
  else
    RxTh := -1;
  if FSThreshold > 0 then
    TxTh := FSThreshold
  else
    TxTh := -1;
  EnableCommNotification(FCommId, FHWndNotify, RxTh, TxTh);

  { Reset modem line shadow state }
  FCTSState := False;
  FDSRState := False;
  FCDState  := False;

  FPortOpen := True;
end;


procedure TKPComm.ProcessEventNotify;
var
  EvtMask:  Word;
  Stat:     TComStat;
  ErrFlags: Integer;
begin
  EvtMask := GetCommEventMask(FCommId,
    ev_CTS or ev_DSR or ev_RLSD or ev_Ring or ev_Err or ev_Break);

  if (EvtMask and ev_Break) <> 0 then
    DoCommEvent(comEvtBreak);

  { Modem line shadow state: toggle on each transition event. }
  { The 16-bit comm API only provides transition events, not  }
  { absolute line levels.                                      }
  if (EvtMask and ev_CTS) <> 0 then
  begin
    FCTSState := not FCTSState;
    DoCommEvent(comEvCTS);
  end;

  if (EvtMask and ev_DSR) <> 0 then
  begin
    FDSRState := not FDSRState;
    DoCommEvent(comEvDSR);
  end;

  if (EvtMask and ev_RLSD) <> 0 then
  begin
    FCDState := not FCDState;
    DoCommEvent(comEvCD);
  end;

  if (EvtMask and ev_Ring) <> 0 then
    DoCommEvent(comEvRing);

  if (EvtMask and ev_Err) <> 0 then
  begin
    ErrFlags := GetCommError(FCommId, Stat);
    if (ErrFlags and ce_Frame) <> 0 then
      DoCommEvent(comEvtFrame);
    if (ErrFlags and ce_Overrun) <> 0 then
      DoCommEvent(comEvtOverrun);
    if (ErrFlags and ce_RxOver) <> 0 then
      DoCommEvent(comEvtRxOver);
    if (ErrFlags and ce_RxParity) <> 0 then
      DoCommEvent(comEvtParity);
    if (ErrFlags and ce_TxFull) <> 0 then
      DoCommEvent(comEvtTxFull);
  end;
end;


procedure TKPComm.ProcessReceiveNotify;
var
  Stat: TComStat;
begin
  if FRThreshold <= 0 then
    Exit;
  GetCommError(FCommId, Stat);
  if Integer(Stat.cbInQue) >= FRThreshold then
    DoCommEvent(comEvReceive);
end;


procedure TKPComm.ProcessTransmitNotify;
var
  Stat: TComStat;
begin
  if FSThreshold <= 0 then
    Exit;
  GetCommError(FCommId, Stat);
  if Integer(Stat.cbOutQue) <= FSThreshold then
    DoCommEvent(comEvSend);
end;


procedure TKPComm.SetBreak(Value: Boolean);
begin
  FBreakState := Value;
  if FPortOpen and (FCommId >= 0) then
  begin
    if FBreakState then
      SetCommBreak(FCommId)
    else
      ClearCommBreak(FCommId);
  end;
end;


procedure TKPComm.SetCommPort(Value: Integer);
begin
  if FPortOpen then
    raise Exception.Create('Cannot change CommPort while port is open');
  if (Value < 1) or (Value > 16) then
    raise Exception.Create('CommPort must be 1..16');
  FCommPort := Value;
end;


procedure TKPComm.SetDTREnable(Value: Boolean);
begin
  FDTREnable := Value;
  if FPortOpen and (FCommId >= 0) then
  begin
    if FDTREnable then
      EscapeCommFunction(FCommId, SETDTR)
    else
      EscapeCommFunction(FCommId, CLRDTR);
  end;
end;


procedure TKPComm.SetHandshaking(Value: THandshaking);
begin
  FHandshaking := Value;
  if FPortOpen and (FCommId >= 0) then
    ApplyHandshaking;
end;


procedure TKPComm.SetInBufferSize(Value: Integer);
begin
  if FPortOpen then
    raise Exception.Create('Cannot change InBufferSize while port is open');
  if Value < 64 then
    raise Exception.Create('InBufferSize must be >= 64');
  FInBufferSize := Value;
end;


procedure TKPComm.SetNullDiscard(Value: Boolean);
begin
  FNullDiscard := Value;
  if FPortOpen and (FCommId >= 0) then
    ApplyOptions;
end;


procedure TKPComm.SetOutBufferSize(Value: Integer);
begin
  if FPortOpen then
    raise Exception.Create('Cannot change OutBufferSize while port is open');
  if Value < 64 then
    raise Exception.Create('OutBufferSize must be >= 64');
  FOutBufferSize := Value;
end;


procedure TKPComm.SetOutput(const Value: string);
var
  Written: Integer;
begin
  if not FPortOpen or (FCommId < 0) then
    raise Exception.Create('Port is not open');
  if Length(Value) > 0 then
  begin
    Written := WriteComm(FCommId, @Value[1], Length(Value));
    if Written < 0 then
      DoCommEvent(comEvtTxFull);
  end;
end;


procedure TKPComm.SetParityReplace(const Value: string);
begin
  FParityReplace := Value;
  if FPortOpen and (FCommId >= 0) then
    ApplyOptions;
end;


procedure TKPComm.SetPortOpen(Value: Boolean);
begin
  if Value = FPortOpen then
    Exit;
  if Value then
    OpenPort
  else
    ClosePort;
end;


procedure TKPComm.SetRTSEnable(Value: Boolean);
begin
  FRTSEnable := Value;
  if FPortOpen and (FCommId >= 0) then
  begin
    if FRTSEnable then
      EscapeCommFunction(FCommId, SETRTS)
    else
      EscapeCommFunction(FCommId, CLRRTS);
  end;
end;


procedure TKPComm.SetSettings(const Value: string);
var
  DCB:     TDCB;
  Buf:     array[0..255] of Char;
  Setting: string;
begin
  FSettings := Value;
  if FPortOpen and (FCommId >= 0) then
  begin
    if GetCommState(FCommId, DCB) <> 0 then
      Exit;
    Setting := 'COM' + IntToStr(FCommPort) + ':' + FSettings;
    StrPCopy(Buf, Setting);
    if BuildCommDCB(Buf, DCB) <> 0 then
      Exit;
    DCB.Flags := DCB.Flags or dcbBinary;
    DCB.Id    := FCommId;
    SetCommState(DCB);
  end;
end;


{ ----------------------------------------------------------------------- }
{ Component registration                                                   }
{ ----------------------------------------------------------------------- }

procedure Register;
begin
  RegisterComponents('KP', [TKPComm]);
end;

end.