WinComm/ansibbs/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 -> CloseComm.   }
{                                                                         }
{ Data is read by polling Input (ReadComm) from a PeekMessage main loop   }
{ rather than through WM_COMMNOTIFY event dispatch.                       }

interface

uses
  SysUtils, Classes, WinTypes, WinProcs, Messages;

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

  TKPComm = class(TComponent)
  private
    { Port state }
    FCommId:        Integer;     { Comm port handle from OpenComm (-1 = closed) }

    { Configuration (published properties) }
    FCommPort:      Integer;     { Port number (1-based: 1=COM1, 2=COM2, ...) }
    FSettings:      string;      { Baud/parity/data/stop string (e.g. '9600,N,8,1') }
    FPortOpen:      Boolean;     { True while port is open and operational }
    FInBufferSize:  Integer;     { Receive ring buffer size in bytes }
    FOutBufferSize: Integer;     { Transmit ring buffer size in bytes }
    FHandshaking:   THandshaking; { Flow control mode (none/XonXoff/RtsCts/both) }
    FInputLen:      Integer;     { Max bytes per Input read (0=up to 255) }
    FInputMode:     TInputMode;  { Text or binary read mode }

    { Modem control lines }
    FDTREnable:     Boolean;     { DTR line state (True=asserted) }
    FRTSEnable:     Boolean;     { RTS line state (True=asserted) }

    { DCB options }
    FNullDiscard:   Boolean;     { Strip null bytes from received data }
    FEOFEnable:     Boolean;     { Detect EOF character in stream }
    FParityReplace: string;      { Replacement char for parity errors ('' = none) }

    { Runtime state }
    FBreakState:    Boolean;     { True while break signal is being sent }

    procedure ApplyHandshaking;
    procedure ApplyOptions;
    procedure ClosePort;
    function  GetInBufferCount: Integer;
    function  GetInput: string;
    function  GetOutBufferCount: Integer;
    procedure OpenPort;
    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;
    function ReadInputBuf(Buf: PChar; BufSize: Integer): Integer;
    property Input: string read GetInput;
    property Output: string write SetOutput;
    property InBufferCount: Integer read GetInBufferCount;
    property OutBufferCount: Integer read GetOutBufferCount;
    property Break: Boolean read FBreakState write SetBreak;
  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 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;
  end;

procedure Register;

implementation

const
  { 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;


{ ----------------------------------------------------------------------- }
{ 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
  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;
end;


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


destructor TKPComm.Destroy;
begin
  if FPortOpen then
    ClosePort;
  inherited Destroy;
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
  BytesToRead: Integer;
  BytesRead:   Integer;
  Buf:         array[0..255] of Char;
begin
  Result := '';
  if not FPortOpen or (FCommId < 0) then
    Exit;

  { Read directly without querying GetCommError first.  ReadComm      }
  { returns the number of bytes actually available (up to BytesToRead) }
  { so the extra GetCommError round-trip is unnecessary overhead.      }
  BytesToRead := 255;
  if (FInputLen > 0) and (BytesToRead > FInputLen) then
    BytesToRead := FInputLen;

  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.ReadInputBuf(Buf: PChar; BufSize: Integer): Integer;
{ Read up to BufSize bytes into a caller-supplied buffer.  Bypasses the     }
{ 255-byte short string limit of the Input property, allowing the drain     }
{ loop to read 2048+ bytes per call and reducing ReadComm/API overhead.     }
var
  BytesRead: Integer;
begin
  Result := 0;
  if not FPortOpen or (FCommId < 0) then
    Exit;
  BytesRead := ReadComm(FCommId, Buf, BufSize);
  if BytesRead > 0 then
    Result := 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
  DCB:     TDCB;
  Buf:     array[0..255] of Char;
  Setting: string;
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);

  FPortOpen := True;
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
      raise Exception.Create('WriteComm failed');
  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.