////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2023 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Serial I/O routines.                                                       //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20230630 - Created by A.K.                                                 //
////////////////////////////////////////////////////////////////////////////////

unit _crw_serio; // Serial I/O

{$I _crw_sysdef}

{$IFDEF FPC}{$mode Delphi}{$ENDIF}{$H+}

{$IFDEF UNIX}
{$PACKRECORDS C}
{$ENDIF ~UNIX}

interface

uses
 _crw_sharemem, // NB: THIS UNIT MUST BE FIRST !!!
 {$IFDEF UNIX} cthreads, dl, {$ENDIF}
 {$IFDEF WINDOWS} windows, {$ENDIF}
 {$IFDEF UNIX} baseunix, termio, unix, {$ENDIF}
 sysutils, classes, math,
 _crw_alloc, _crw_ef, _crw_str, _crw_fio;

type
  TSerialHandle = THandle;
  TParityType   = (NoneParity, OddParity, EvenParity);
  TSerialFlags  = set of (RtsCtsFlowControl);
  {$IFDEF UNIX}
  TSerialState  = record
   LineState   : LongWord;
   tios        : termios;
  end;
  TSerialStruct = packed record
   typ: cint;
   line: cint;
   port: cuint;
   irq:  cint;
   flags: cint;
   xmit_fifo_size: cint;
   custom_divisor: cint;
   baud_base: cint;
   close_delay: cushort;
   io_type: cchar;
   reserved_char:  pcchar;
   hub6: cint;
   closing_wait: cushort; // time to wait before closing
   closing_wait2: cushort; // no longer used...
   iomem_base: pcchar;
   iomem_reg_shift: cushort;
   port_high: clong; // cookie passed into ioremap
  end;
  {$ENDIF ~UNIX}
  {$IFDEF WINDOWS}
  TSerialState = TDCB;
  {$ENDIF ~WINDOWS}

const SerBuffSize = 1024*16;

 // Check serial handle is valid.
function SerValidHandle(Handle:TSerialHandle):Boolean; inline;

 // Open the serial device with the given device name, for example:
 // Unix:    /dev/ttyS0, /dev/ttyS1... for normal serial ports
 // Unix:    /dev/ttyI0, /dev/ttyI1... for ISDN emulated serial ports
 // Unix:    other device names are possible; refer to your OS documentation.
 // Windows: \COM1, \COM2 (strictly, \\.\COM1...) for normal serial ports.
 // Windows: ISDN devices, serial port redirectors/virtualisers etc. normally
 // Windows: implement names of this form, but refer to your OS documentation.
 // Returns "0" if device could not be found.
function SerOpen(const DeviceName:LongString; Flags:LongInt=0):TSerialHandle;

 // Closes a serial device previously opened with SerOpen.
procedure SerClose(var Handle:TSerialHandle);

 // Flushes the data queues of the given serial device. DO NOT USE THIS:
 // use either SerSync (non-blocking) or SerDrain (blocking).
procedure SerFlush(Handle:TSerialHandle); deprecated;

 // Suggest to the kernel that buffered output data should be sent. This
 // is unlikely to have a useful effect except possibly in the case of
 // buggy ports that lose Tx interrupts, and is implemented as a preferred
 // alternative to the deprecated SerFlush procedure.
procedure SerSync(Handle:TSerialHandle);

 // Wait until all buffered output has been transmitted. It is the caller's
 // responsibility to ensure that this won't block permanently due to an
 // inappropriate handshake state.
procedure SerDrain(Handle:TSerialHandle);

 // Discard all pending input.
procedure SerFlushInput(Handle:TSerialHandle);

 // Discard all unsent output.
procedure SerFlushOutput(Handle: TSerialHandle);

 // Reads a maximum of "Count" bytes of data into the specified buffer.
 // Result: Number of bytes read.
function SerRead(Handle:TSerialHandle; var Buffer; Count:LongInt):LongInt;
function SerReadStr(Handle:TSerialHandle; Count:LongInt):LongString;

 // Tries to write "Count" bytes from "Buffer".
 // Result: Number of bytes written.
function SerWrite(Handle:TSerialHandle; const Buffer; Count:LongInt):LongInt;
function SerWriteStr(Handle:TSerialHandle; const Buffer:LongString):LongInt;

procedure SerSetParams(Handle: TSerialHandle; BitsPerSec: LongInt;
  ByteSize: Integer; Parity: TParityType; StopBits: Integer;
  Flags: TSerialFlags);

{ Saves and restores the state of the serial device. }
function SerSaveState(Handle: TSerialHandle): TSerialState;
procedure SerRestoreState(Handle: TSerialHandle; State: TSerialState);

{ Getting and setting the line states directly. }
procedure SerSetDTR(Handle: TSerialHandle; State: Boolean);
procedure SerSetRTS(Handle: TSerialHandle; State: Boolean);
function SerGetCTS(Handle: TSerialHandle): Boolean;
function SerGetDSR(Handle: TSerialHandle): Boolean;
function SerGetCD(Handle: TSerialHandle): Boolean;
function SerGetRI(Handle: TSerialHandle): Boolean;

{ Set a line break state. If the requested time is greater than zero this is in
  mSec, in the case of unix this is likely to be rounded up to a few hundred
  mSec and to increase by a comparable increment; on unix if the time is less
  than or equal to zero its absolute value will be passed directly to the
  operating system with implementation-specific effect. If the third parameter
  is omitted or true there will be an implicit call of SerDrain() before and
  after the break.

  NOTE THAT on Linux, the only reliable mSec parameter is zero which results in
  a break of around 250 mSec. Might be completely ineffective on Solaris.
 }
procedure SerBreak(Handle: TSerialHandle; mSec: LongInt=0; sync: boolean= true);

type    TSerialIdle= procedure(h: TSerialHandle);

{ Set this to a shim around Application.ProcessMessages if calling SerReadTimeout(),
  SerBreak() etc. from the main thread so that it doesn't lock up a Lazarus app. }
var     SerialIdle: TSerialIdle= nil;

{ This is similar to SerRead() but adds a mSec timeout. Note that this variant
  returns as soon as a single byte is available, or as dictated by the timeout. }
function SerReadTimeout(Handle: TSerialHandle; var Buffer; mSec: LongInt): LongInt; overload;

{ This is similar to SerRead() but adds a mSec timeout. Note that this variant
  attempts to accumulate as many bytes as are available, but does not exceed
  the timeout. Set up a SerIdle callback if using this in a main thread in a
  Lazarus app. }
function SerReadTimeout(Handle: TSerialHandle; var Buffer: array of byte; count, mSec: LongInt): LongInt; overload;


////////////////////////////////////////////////////////////////////////////////

 // Serial port directory prefix:
 // For Unix:    /dev/
 // For Windows: \\.\
function SerPortDirPrefix:LongString; inline;

 // Get serial port FULL name by (short) Name:
 // For Unix:     ttyS0  =>  /dev/ttyS0
 // For Windows:  COM1   =>  \\.\COM1
function SerPortFullName(const Name:LongString):LongString;

 // Search list of serial port device prefixes.
 // For Unix:    ttyS;ttyMP;ttyUSB;...
 // For Windows: COM
function SerPortSearchList(Delim:Char=';'):LongString;

 // List of special serial ports.
function SerPortSpecList(Delim:Char=';'):LongString;

{$IFDEF UNIX}
 // Read list of serial drivers from /proc/tty/drivers.
 // This list provides the serial port device prefixes.
function ReadProcTtyDriversSerial(Delim:Char=';'):LongString;
{$ENDIF ~UNIX}

const                 // GetSerialPortNames Mode flags:
 spnm_NotTryOpen = 1; // Do not try to open device(s)
 spnm_SkipOpened = 2; // Skip opened (busy) device(s)
 spnm_DelimText  = 4; // Return Delimited Text or EOL

 // Get list of serial port names with delimiter Delim.
function GetSerialPortNames(Mode:Integer=0; Delim:Char=';'):LongString;

implementation

function SerValidHandle(Handle:TSerialHandle):Boolean;
begin
 Result:=(Handle<>0) and (Handle<>INVALID_HANDLE_VALUE);
end;

function SerReadStr(Handle:TSerialHandle; Count:LongInt):LongString;
var Buff:LongString; Leng:LongInt;
begin
 Result:='';
 if (Count>0) and SerValidHandle(Handle) then begin
  Buff:=StringBuffer(Min(Count,SerBuffSize));
  repeat
   Leng:=SerRead(Handle,Buff[1],Min(Count,Length(Buff)));
   if (Leng>0) then begin
    Result:=Result+Copy(Buff,1,Leng);
    Dec(Count,Leng);
   end else Break;
  until (Count<=0);
 end;
end;

function SerWriteStr(Handle:TSerialHandle; const Buffer:LongString):LongInt;
begin
 if (Buffer<>'')
 then Result:=SerWrite(Handle,Buffer[1],Length(Buffer))
 else Result:=0;
end;

////////////////////////////////////////////////////////////////////////////////
{$IFDEF UNIX} //////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

function SerOpen(const DeviceName:LongString; Flags:LongInt=0):TSerialHandle;
begin
 if (Flags=0) then Flags:=(O_RDWR or O_NOCTTY);
 Result:=fpOpen(DeviceName,Flags);
end;

procedure SerClose(var Handle:TSerialHandle);
begin
 if SerValidHandle(Handle) then fpClose(Handle);
 Handle:=0;
end;

procedure SerFlush(Handle:TSerialHandle); deprecated;
begin
 fpfsync(Handle);
end;

procedure SerSync(Handle:TSerialHandle);
begin
 fpfsync(Handle);
end;

procedure SerDrain(Handle:TSerialHandle);
begin
 tcdrain(Handle);
end;

procedure SerFlushInput(Handle:TSerialHandle);
begin
  tcflush(Handle,TCIFLUSH);
end;

procedure SerFlushOutput(Handle:TSerialHandle);
begin
  tcflush(Handle,TCOFLUSH);
end;

function SerRead(Handle:TSerialHandle; var Buffer; Count:LongInt):LongInt;
begin
 Result:=0;
 if (@Buffer<>nil) and (Count>0)
 then Result:=fpRead(Handle,Buffer,Count);
end;

function SerWrite(Handle: TSerialHandle; Const Buffer; Count:LongInt):LongInt;
begin
 Result:=0;
 if (@Buffer<>nil) and (Count>0)
 then Result:=fpWrite(Handle,Buffer,Count);
end;

procedure SerSetParams(Handle: TSerialHandle; BitsPerSec: LongInt;
  ByteSize: Integer; Parity: TParityType; StopBits: Integer;
  Flags: TSerialFlags);
var
  tios: termios;
begin
  FillChar(tios, SizeOf(tios), #0);

  case BitsPerSec of
    50: tios.c_cflag := B50;
    75: tios.c_cflag := B75;
    110: tios.c_cflag := B110;
    134: tios.c_cflag := B134;
    150: tios.c_cflag := B150;
    200: tios.c_cflag := B200;
    300: tios.c_cflag := B300;
    600: tios.c_cflag := B600;
    1200: tios.c_cflag := B1200;
    1800: tios.c_cflag := B1800;
    2400: tios.c_cflag := B2400;
    4800: tios.c_cflag := B4800;
    19200: tios.c_cflag := B19200;
    38400: tios.c_cflag := B38400;
    57600: tios.c_cflag := B57600;
    115200: tios.c_cflag := B115200;
    230400: tios.c_cflag := B230400;
{$ifndef BSD}
    460800: tios.c_cflag := B460800;
{$endif}
    else tios.c_cflag := B9600;
  end;
{$ifndef SOLARIS}
  tios.c_ispeed := tios.c_cflag;
  tios.c_ospeed := tios.c_ispeed;
{$endif}

  tios.c_cflag := tios.c_cflag or CREAD or CLOCAL;

  case ByteSize of
    5: tios.c_cflag := tios.c_cflag or CS5;
    6: tios.c_cflag := tios.c_cflag or CS6;
    7: tios.c_cflag := tios.c_cflag or CS7;
    else tios.c_cflag := tios.c_cflag or CS8;
  end;

  case Parity of
    OddParity: tios.c_cflag := tios.c_cflag or PARENB or PARODD;
    EvenParity: tios.c_cflag := tios.c_cflag or PARENB;
  end;

  if StopBits = 2 then
    tios.c_cflag := tios.c_cflag or CSTOPB;

  if RtsCtsFlowControl in Flags then
    tios.c_cflag := tios.c_cflag or CRTSCTS;

  tcflush(Handle, TCIOFLUSH);
  tcsetattr(Handle, TCSANOW, tios)
end;

function SerSaveState(Handle: TSerialHandle): TSerialState;
begin
  fpioctl(Handle, TIOCMGET, @Result.LineState);
//  fpioctl(Handle, TCGETS, @Result.tios);
  TcGetAttr(handle,result.tios);

end;

procedure SerRestoreState(Handle: TSerialHandle; State: TSerialState);
begin
//  fpioctl(Handle, TCSETS, @State.tios);
    TCSetAttr(handle,TCSANOW,State.tios);
    fpioctl(Handle, TIOCMSET, @State.LineState);
end;

procedure SerSetDTR(Handle: TSerialHandle; State: Boolean);
const
  DTR: Cardinal = TIOCM_DTR;
begin
  if State then
    fpioctl(Handle, TIOCMBIS, @DTR)
  else
    fpioctl(Handle, TIOCMBIC, @DTR);
end;

procedure SerSetRTS(Handle: TSerialHandle; State: Boolean);
const
  RTS: Cardinal = TIOCM_RTS;
begin
  if State then
    fpioctl(Handle, TIOCMBIS, @RTS)
  else
    fpioctl(Handle, TIOCMBIC, @RTS);
end;

function SerGetCTS(Handle: TSerialHandle): Boolean;
var
  Flags: Cardinal;
begin
  fpioctl(Handle, TIOCMGET, @Flags);
  Result := (Flags and TIOCM_CTS) <> 0;
end;

function SerGetDSR(Handle: TSerialHandle): Boolean;
var
  Flags: Cardinal;
begin
  fpioctl(Handle, TIOCMGET, @Flags);
  Result := (Flags and TIOCM_DSR) <> 0;
end;

function SerGetCD(Handle: TSerialHandle): Boolean;
var
  Flags: Cardinal;
begin
  fpioctl(Handle, TIOCMGET, @Flags);
  Result := (Flags and TIOCM_CD) <> 0
end;

function SerGetRI(Handle: TSerialHandle): Boolean;
var
  Flags: Cardinal;
begin
  fpioctl(Handle, TIOCMGET, @Flags);
  Result := (Flags and TIOCM_RI) <> 0;
end;

procedure SerBreak(Handle: TSerialHandle; mSec: LongInt= 0; sync: boolean= true);
begin
  if sync then
    tcdrain(Handle);
  if mSec <= 0 then
    tcsendbreak(Handle, Abs(mSec))
  else
    tcsendbreak(Handle, Trunc(mSec / 250));
  if sync then
    tcdrain(Handle)
end;

function SerReadTimeout(Handle: TSerialHandle; var Buffer; mSec: LongInt): LongInt;

VAR     readSet: TFDSet;
        selectTimeout: TTimeVal;

begin
  fpFD_ZERO(readSet);
  fpFD_SET(Handle, readSet);
  selectTimeout.tv_sec := mSec div 1000;
  selectTimeout.tv_usec := (mSec mod 1000) * 1000;
  result := 0;
  if fpSelect(Handle + 1, @readSet, nil, nil, @selectTimeout) > 0 then
    result := fpRead(Handle, Buffer, 1)
end { SerReadTimeout } ;

{$ifdef LINUX}
  {$define SELECT_UPDATES_TIMEOUT}
{$endif}

{$ifdef SELECT_UPDATES_TIMEOUT}

function SerReadTimeout(Handle: TSerialHandle; var Buffer: array of byte; count, mSec: LongInt): LongInt;

VAR     readSet: TFDSet;
        selectTimeout: TTimeVal;

begin
  fpFD_ZERO(readSet);
  fpFD_SET(Handle, readSet);
  selectTimeout.tv_sec := mSec div 1000;
  selectTimeout.tv_usec := (mSec mod 1000) * 1000;
  result := 0;

// Note: this variant of fpSelect() is a thin wrapper around the kernel's syscall.
// In the case of Linux the syscall DOES update the timeout parameter.

  while fpSelect(Handle + 1, @readSet, nil, nil, @selectTimeout) > 0 do begin
    Inc(result,fpRead(Handle, Buffer[result], count - result));
    if result >= count then
      break;
    if Assigned(SerialIdle) then
      SerialIdle(Handle)
  end
end { SerReadTimeout } ;

{$else}

function SerReadTimeout(Handle: TSerialHandle; var Buffer: array of byte; count, mSec: LongInt): LongInt;

VAR     readSet: TFDSet;
        selectTimeout: TTimeVal;
        uSecOnEntry, uSecElapsed: QWord;

  function now64uSec: QWord;

  var   tv: timeval;

  begin
    fpgettimeofday(@tv, nil);
    result := tv.tv_sec * 1000000 + tv.tv_usec
  end { now64uSec } ;

begin
  fpFD_ZERO(readSet);
  fpFD_SET(Handle, readSet);
  selectTimeout.tv_sec := mSec div 1000;
  selectTimeout.tv_usec := (mSec mod 1000) * 1000;
  result := 0;
  uSecOnEntry := now64uSec;

// Note: this variant of fpSelect() is a thin wrapper around the kernel's syscall.
// In the case of Solaris the syscall DOES NOT update the timeout parameter.

  while fpSelect(Handle + 1, @readSet, nil, nil, @selectTimeout) > 0 do begin
    Inc(result,fpRead(Handle, Buffer[result], count - result));
    uSecElapsed := now64uSec - uSecOnEntry;
    if (result >= count) or (uSecElapsed >= mSec * 1000) then
      break;
    selectTimeout.tv_sec := (mSec * 1000 - uSecElapsed) div 1000000;
    selectTimeout.tv_usec := (mSec * 1000 - uSecElapsed) mod 1000000;
    if Assigned(SerialIdle) then
      SerialIdle(Handle)
  end
end { SerReadTimeout } ;

{$endif}

////////////////////////////////////////////////////////////////////////////////
{$ENDIF ~UNIX} /////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
{$IFDEF WINDOWS} ///////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

function SerSetParamsPrivate(Handle: TSerialHandle; BitsPerSec: LongInt;
  ByteSize: Integer; Parity: TParityType; StopBits: Integer;
  Flags: TSerialFlags): boolean;

const   bufSize= 2048;

        dcb_Binary           = $00000001;
        dcb_Parity           = $00000002;
        dcb_OutxCtsFlow      = $00000004;
        dcb_OutxDsrFlow      = $00000008;
        dcb_DtrControl       = $00000030;
        dcb_DsrSensivity     = $00000040;
        dcb_TXContinueOnXOff = $00000080;
        dcb_OutX             = $00000100;
        dcb_InX              = $00000200;
        dcb_ErrorChar        = $00000400;
        dcb_Null             = $00000800;
        dcb_RtsControl       = $00003000;
        dcb_AbortOnError     = $00004000;

var     DCB: TDCB;
        Timeouts: TCommTimeouts;

begin
  result := true;
  FillChar(DCB, SizeOf(DCB), 0);
  DCB.DCBlength := SizeOf(DCB);
  DCB.XonChar := #17;
  DCB.XoffChar := #19;
  DCB.XonLim := bufSize div 4;
  DCB.XoffLim := 1;
  DCB.Flags := DCB.Flags or dcb_Binary;
  DCB.BaudRate := BitsPerSec;
  DCB.ByteSize := ByteSize;
  case Parity of
    OddParity:  DCB.Parity := Windows.ODDPARITY;
    EvenParity: DCB.Parity := Windows.EVENPARITY
  else
    DCB.Parity := Windows.NOPARITY
  end;
  if StopBits > 1 then
    DCB.StopBits := TWOSTOPBITS
  else
    DCB.StopBits := ONESTOPBIT;
  if RtsCtsFlowControl in Flags then
    DCB.Flags := DCB.Flags or dcb_OutxCtsFlow or
                (dcb_RtsControl and (RTS_CONTROL_HANDSHAKE shl 12));
  if not SetCommState(Handle, DCB) then
    result := false;
  if GetCommTimeouts(Handle, Timeouts) then begin
    Timeouts.ReadIntervalTimeout := MAXDWORD;
    Timeouts.ReadTotalTimeoutMultiplier := 0;
    Timeouts.ReadTotalTimeoutConstant := 0;
    Timeouts.WriteTotalTimeoutMultiplier := 0;
    Timeouts.WriteTotalTimeoutConstant := 30000;
    if not SetCommTimeouts(Handle, Timeouts) then
      result := false
  end else
    result := false;
  if not SetupComm(Handle, bufSize, bufSize) then
    result := false
end { SerSetParamsPrivate } ;


function SerOpen(const DeviceName:LongString; Flags:LongInt=0):TSerialHandle;

var     securityAttributes: TSecurityAttributes;

begin
  if (Flags=0) then Flags:=(GENERIC_READ or GENERIC_WRITE);
  securityAttributes.nLength := SizeOf(TSecurityAttributes);
  securityAttributes.lpSecurityDescriptor := nil;
  securityAttributes.bInheritHandle := true;
  result := CreateFile(
    PChar(DeviceName),
    Flags,
    0,
    @securityAttributes,
    OPEN_EXISTING,
    0,
    0);
  if result = INVALID_HANDLE_VALUE then
    result := 0
  else

(* Don't trust Windows's initial state. If the internal variant (returning a    *)
(* result) of SerSetParams() fails it indicates that part of the comms API is   *)
(* unavailable, assume that this is fatal because it will probably mess up      *)
(* things like read timeouts.                                                   *)

    if not SerSetParamsPrivate(result, 9600, 8, NoneParity, 1, []) then begin
      CloseHandle(result);
      result := 0
    end
end;

procedure SerClose(var Handle:TSerialHandle);
begin
 if SerValidHandle(Handle) then CloseHandle(Handle);
 Handle:=0;
end;
procedure SerFlush(Handle: TSerialHandle); deprecated;

begin
  FlushFileBuffers(Handle);
end { SerFlush } ;


procedure SerSync(Handle: TSerialHandle);

begin
  FlushFileBuffers(Handle)
end { SerSync } ;


procedure SerDrain(Handle: TSerialHandle);

var     errors: DWORD;
        comStat: TComStat;

begin
  FlushFileBuffers(Handle);
  repeat
    if not ClearCommError(Handle, errors, @comStat) then
      break;
    if (ComStat.cbOutQue > 0) and Assigned(SerialIdle) then
      SerialIdle(Handle)
  until ComStat.cbOutQue = 0
end { SerDrain } ;


procedure SerFlushInput(Handle: TSerialHandle);

begin
  PurgeComm(Handle, PURGE_RXABORT + PURGE_RXCLEAR)
end { SerFlushInput } ;


procedure SerFlushOutput(Handle: TSerialHandle);

begin
  PurgeComm(Handle, PURGE_TXABORT + PURGE_TXCLEAR)
end { SerFlushOutput } ;


function SerRead(Handle: TSerialHandle; var Buffer; Count: LongInt): LongInt;

var     BytesRead: DWORD;
        Timeouts: TCommTimeouts;

begin
  if GetCommTimeouts(Handle, Timeouts) then begin
    Timeouts.ReadIntervalTimeout := MAXDWORD;
    Timeouts.ReadTotalTimeoutConstant := 0;
    SetCommTimeouts(Handle, Timeouts)
  end;
  if not ReadFile(Handle, Buffer, Count, BytesRead, nil) then
    result := 0
  else
    result := BytesRead
end { SerRead } ;


function SerWrite(Handle: TSerialHandle; const Buffer; Count: LongInt): LongInt;

var     BytesWritten: DWORD;

begin
  if not WriteFile(Handle, Buffer, Count, BytesWritten, nil) then
    result := 0
  else
    result := BytesWritten
end { SerWrite } ;


procedure SerSetParams(Handle: TSerialHandle; BitsPerSec: LongInt;
  ByteSize: Integer; Parity: TParityType; StopBits: Integer;
  Flags: TSerialFlags);

begin
  if SerSetParamsPrivate(Handle, BitsPerSec, ByteSize, Parity, StopBits, Flags) then begin
  end
end { SerSetParams } ;


function SerSaveState(Handle: TSerialHandle): TSerialState;

begin
  GetCommState(Handle, result)
end { SerSaveState } ;


procedure SerRestoreState(Handle: TSerialHandle; State: TSerialState);

begin
  SetCommState(Handle, State)
end { SerRestoreState } ;


(* Mask out a 2-bit field and merge in a replacement.                   *)
//
procedure merge2Bits(var flag: dword; startBit: integer; value: dword);

var     mask0, mask1: dword;
        index: integer;

begin
  mask0:= $fffffffc;
  for index:= 1 TO startBit do
    mask0:= (mask0 shl 1) or $00000001;
  mask1:= $00000003 shl startBit;
  value:= value shl startBit;
  flag:= (flag and mask0) or (value and mask1)
end { merge2Bits } ;


procedure SerSetDTR(Handle: TSerialHandle; State: Boolean);

var     dcb: TDCB;

begin
  if GetCommState(Handle, dcb) then begin
    if State then
      merge2Bits(dcb.Flags, 4, DTR_CONTROL_ENABLE)
    else
      merge2Bits(dcb.Flags, 4, DTR_CONTROL_DISABLE);
    SetCommState(Handle, dcb)
  end
end { SerSetDTR } ;


procedure SerSetRTS(Handle: TSerialHandle; State: Boolean);

var     dcb: TDCB;

begin
  if GetCommState(Handle, dcb) then begin
    if State then
      merge2Bits(dcb.Flags, 12, RTS_CONTROL_ENABLE)
    else
      merge2Bits(dcb.Flags, 12, RTS_CONTROL_DISABLE);
    SetCommState(Handle, dcb)
  end
end { SerSetRTS } ;


function SerGetCTS(Handle: TSerialHandle): Boolean;

var     status: dword;

begin
  if GetCommModemStatus(Handle, status) then
    result := status and MS_CTS_ON <> 0
  else
    result := false
end { SerGetCTS } ;


function SerGetDSR(Handle: TSerialHandle): Boolean;

var     status: dword;

begin
  if GetCommModemStatus(Handle, status) then
    result := status and MS_DSR_ON <> 0
  else
    result := false
end { SerGetDSR } ;


function SerGetCD(Handle: TSerialHandle): Boolean;

var     status: dword;

begin
  if GetCommModemStatus(Handle, status) then
    result := status and MS_RLSD_ON <> 0
  else
    result := false
end { SerGetCD } ;


function SerGetRI(Handle: TSerialHandle): Boolean;

var     status: dword;

begin
  if GetCommModemStatus(Handle, status) then
    result := status and MS_RING_ON <> 0
  else
    result := false
end { SerGetRI } ;


procedure SerBreak(Handle: TSerialHandle; mSec: LongInt=250; sync: boolean= true);

const   quantum= 100;

begin
  if sync then
    SerDrain(Handle);
  SetCommBreak(Handle);
  repeat
    if mSec < quantum then begin
      Sleep(mSec);
      mSec := 0;
    end else begin
      Sleep(quantum);
      mSec := msec-quantum;
    end;
    if (mSec > 0) and Assigned(SerialIdle) then
      SerialIdle(Handle);
  until mSec <= 0;
  ClearCommBreak(Handle);
  if sync then
    SerDrain(handle)
end { SerBreak } ;


function SerReadTimeout(Handle: TSerialHandle; var Buffer; mSec: LongInt): LongInt;

var     BytesRead: DWORD;
        Timeouts: TCommTimeouts;

begin
  if GetCommTimeouts(Handle, Timeouts) then begin
    Timeouts.ReadIntervalTimeout := 0;
    Timeouts.ReadTotalTimeoutConstant := mSec;
    SetCommTimeouts(Handle, Timeouts)
  end;
  if not ReadFile(Handle, Buffer, 1, BytesRead, nil) then
    result := 0
  else
    result := BytesRead
end { SerReadTimeout } ;


function SerReadTimeout(Handle: TSerialHandle; var Buffer: array of byte; count, mSec: LongInt): LongInt;

var     BytesRead: DWORD;
        Timeouts: TCommTimeouts;

begin
  if GetCommTimeouts(Handle, Timeouts) then begin
    Timeouts.ReadIntervalTimeout := 0;
    Timeouts.ReadTotalTimeoutConstant := mSec;
    SetCommTimeouts(Handle, Timeouts)
  end;
  if not ReadFile(Handle, Buffer[0], count, BytesRead, nil) then
    result := 0
  else
    result := BytesRead
end { SerReadTimeout } ;

////////////////////////////////////////////////////////////////////////////////
{$ENDIF ~WINDOWS} //////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

 ///////////////////////////////////////////////////////////////////////////////
 // Known serial devices (from some Lazarus libraries):
 //  ttyS     - legacy COM Ports
 //  ttyMP    - multi port cards like MOXA
 //  ttyUSB   - USB to COM converters
 //  rfcomm   - Bluetooth to Serial (rfcomm utility)
 //  ttyADV   - ?? Advantech VCOM ports
 //  ttyAP    - ?? Advantech UNO,APAX,etc
 //  vttyAP   - ?? Advantech VCOM
 //  ttyr     - ?? MOXA NPort
 //  ttyACM   - ?? ARM-based COM Ports
 //  ttyB     - ??
 //  ttyAM    - ??
 //  ttyMAX   - ??
 // Other serial devices can be read from /proc folder.
 // The directory /proc/tty/drivers provides list of TTY drivers:
 //  NAME         DEVICE          ID  N         TYPE
 //  ----------------------------------------------------------
 //  /dev/tty     /dev/tty        5   0         system:/dev/tty
 //  /dev/console /dev/console    5   1         system:console
 //  /dev/ptmx    /dev/ptmx       5   2         system
 //  /dev/vc/0    /dev/vc/0       4   0         system:vtmaster
 //  usbserial    /dev/ttyUSB     188 0-511     serial
 //  rfcomm       /dev/rfcomm     216 0-255     serial
 //  ttyprintk    /dev/ttyprintk  5   3         console
 //  max310x      /dev/ttyMAX     204 209-224   serial
 //  serial       /dev/ttyS       4   64-111    serial
 //  pty_slave    /dev/pts        136 0-1048575 pty:slave
 //  pty_master   /dev/ptm        128 0-1048575 pty:master
 //  unknown      /dev/tty        4   1-63      console
 // The driver(s) of TYPE 'serial' corresponds to serial (COM Port) devices.
 ///////////////////////////////////////////////////////////////////////////////

{$IFDEF UNIX}
const StdPortSpecList='ttyUSB;rfcomm;ttyACM';
{$IFDEF LINUX}
const StdPortSearchList='ttyS;ttyMP;ttyUSB;rfcomm;ttyADV;ttyAP;vttyAP;ttyr;ttyACM;ttyB;ttyAM;ttyMAX';
{$ENDIF}
{$IFDEF FREEBSD}
const StdPortSearchList='cuad;cuau;cuaU;ttyu;ttyU;vttyAP;ttyMP;ttyr;ttyB';
{$ENDIF}
{$IFDEF NETBSD}
const StdPortSearchList='cuad;cuau;cuaU;ttyu;ttyU;vttyAP;ttyMP;ttyr;ttyB';
{$ENDIF}
{$IFDEF OPENBSD}
const StdPortSearchList='cuad;cuau;cuaU;ttyu;ttyU;vttyAP;ttyMP;ttyr;ttyB';
{$ENDIF}
{$IFDEF SUNOS}
const StdPortSearchList='tty';
{$ENDIF}
{$IFDEF DARWIN}
const StdPortSearchList='tty.UC-232;tty.usbserial;tty.';
{$ENDIF}
{$ENDIF ~UNIX}
{$IFDEF WINDOWS}
const StdPortSpecList='';
const StdPortSearchList='COM';
{$ENDIF ~WINDOWS}

function SerPortDirPrefix:LongString;
begin
 {$IFDEF UNIX}    Result:='/dev/'; {$ENDIF ~UNIX}
 {$IFDEF WINDOWS} Result:='\\.\';  {$ENDIF ~WINDOWS}
end;

function SerPortFullName(const Name:LongString):LongString;
begin
 Result:=Trim(Name);
 if (Result<>'') and IsRelativePath(Result)
 then Result:=AddPathDelim(SerPortDirPrefix)+Result;
end;

{$IFDEF UNIX}
function ReadProcTtyDriversSerial(Delim:Char=';'):LongString;
var i:Integer; Lines:TStringList; Line,dev,typ:LongString;
const Delims=JustSpaces+[';',',',':'];
begin
 Result:='';
 try
  Lines:=TStringList.Create;
  try
   Lines.LoadFromFile('/proc/tty/drivers');
   for i:=Lines.Count-1 downto 0 do begin
    Line:=Trim(Lines[i]);
    dev:=ExtractWord(2,Line,JustSpaces);
    typ:=ExtractWord(5,Line,JustSpaces);
    if (WordIndex('serial',typ,Delims)>0) then
    if (Pos(SerPortDirPrefix,dev)=1) then begin
     Lines[i]:=Trim(ExtractBaseName(dev));
     if (Lines[i]<>'') then continue;
    end;
    Lines.Delete(i);
   end;
   Lines.Delimiter:=Delim;
   Result:=Lines.DelimitedText;
  finally
   Lines.Free;
  end;
 except
  on E:Exception do BugReport(E,nil,'ReadProcTtyDriversSerial');
 end;
end;
{$ENDIF ~UNIX}

function SerPortSearchList(Delim:Char=';'):LongString;
var Lines:TStringList; List,Item:LongString; i:Integer;
const Delims=JustSpaces+[';',',',':'];
begin
 Result:='';
 try
  Lines:=TStringList.Create;
  try
   List:=StdPortSearchList{$IFDEF UNIX}+';'+ReadProcTtyDriversSerial{$ENDIF};
   for i:=1 to WordCount(List,Delims) do begin
    Item:=ExtractWord(i,List,Delims);
    if (Lines.IndexOf(Item)<0)
    then Lines.Add(Item);
   end;
   Lines.Delimiter:=Delim;
   Result:=Lines.DelimitedText;
  finally
   Lines.Free;
  end;
 except
  on E:Exception do BugReport(E,nil,'SerPortSearchList');
 end;
end;

function SerPortSpecList(Delim:Char=';'):LongString;
begin
 Result:=StdPortSpecList;
 if (Delim<>';') then Result:=StringReplace(Result,';',Delim,[rfReplaceAll]);
end;

{$IFDEF WINDOWS}
function GetSerialPortNames(Mode:Integer=0; Delim:Char=';'):LongString;
var Reg:TRegistry; Lines,Ports: TStringList; n:Integer;
begin
 try
  Reg:=TRegistry.Create;
  Lines:=TStringList.Create;
  Ports:=TStringList.Create;
  try
   {$IFNDEF VER100}
   {$IFNDEF VER120}
   Reg.Access:=KEY_READ;
   {$ENDIF}
   {$ENDIF}
   Reg.RootKey:=HKEY_LOCAL_MACHINE;
   Reg.OpenKey('\HARDWARE\DEVICEMAP\SERIALCOMM\',false);
   Reg.GetValueNames(Lines);
   for n:=0 to Lines.Count-1 do Ports.Add(PChar(Reg.ReadString(Lines[n])));
   Ports.Delimiter:=Delim;
   if HasFlags(Mode,spnm_DelimText)
   then Result:=Ports.DelimitedText
   else Result:=Ports.Text;
  finally
   Lines.Free;
   Ports.Free;
   Reg.Free;
  end;
 except
  on E:Exception do BugReport(E,nil,'GetSerialPortNames');
 end;
end;
{$ENDIF ~WINDOWS}

{$IFDEF UNIX}
function GetSerialPortNames(Mode:Integer=0; Delim:Char=';'):LongString;
var i,Flags:LongInt; Ports:TStringList; SR:TSearchRec;
    Pref,PrefList,SpecList:LongString; Spec,TryOpenDevice:Boolean;
const Delims=JustSpaces+[';',',',':'];
 procedure ScanForPorts(const ThisRootStr:LongString; Special:Boolean);
 var dev:LongString; fd:TSerialHandle;
     {$IFNDEF DARWIN}Ser:TSerialStruct;{$ENDIF}
 begin
  if (FindFirst(ThisRootStr,Flags,SR)=0) then
  try
   repeat
    if ((SR.Attr and Flags)=SR.Attr) then begin
     dev:=SerPortFullName(SR.Name);
     if TryOpenDevice then begin
      errno:=0; // If port opened, expect ESYSEBUSY.
      fd:=SerOpen(dev,O_RDWR or O_NOCTTY or O_NONBLOCK);
      if SerValidHandle(fd) then
      try // get serial info from the device
       {$IFDEF DARWIN}
       if (fpioctl(FD,TIOCEXCL,nil)<>-1) then Ports.Add(dev);
       {$ELSE}
       if fpioctl(fd,TIOCGSERIAL,@Ser)<>-1 then begin
        // device is serial if type is not unknown (if not special device)
        if ((Ser.typ<>0) or Special) then Ports.Add(dev);
       end;
       {$ENDIF}
      finally
       SerClose(fd);
      end else begin
       // Port is already opened?
       if (errno=ESYSEBUSY) and not HasFlags(Mode,spnm_SkipOpened)
       then Ports.Add(dev);
      end;
     end else begin
      Ports.Add(dev);
     end;
    end;
   until (FindNext(SR)<>0);
  finally
   FindClose(SR);
  end;
 end;
begin
 Result:='';
 try
  Ports:=TStringList.Create;
  Ports.Sorted:=true;
  try
   SpecList:=SerPortSpecList;
   PrefList:=SerPortSearchList;
   Flags:=faAnyFile and not faDirectory;
   TryOpenDevice:=not HasFlags(Mode,spnm_NotTryOpen);
   for i:=1 to WordCount(PrefList,Delims) do begin
    Pref:=ExtractWord(i,PrefList,Delims);
    Spec:=(WordIndex(Pref,SpecList,Delims)>0);
    ScanForPorts(SerPortFullName(Pref+'*'),Spec);
   end;
   Ports.Delimiter:=Delim;
   if HasFlags(Mode,spnm_DelimText)
   then Result:=Ports.DelimitedText
   else Result:=Ports.Text;
  finally
   Ports.Free;
  end;
 except
  on E:Exception do BugReport(E,nil,'GetSerialPortNames');
 end;
end;

{$ENDIF ~UNIX}

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_serio;
begin
end;

procedure Free_crw_serio;
begin
end;

initialization

 Init_crw_serio;

finalization

 Free_crw_serio;

end.

//////////////
// END OF FILE
//////////////
