////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 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.                                                 //
// 20251118 - SerOpen(CloExec)                                                //
////////////////////////////////////////////////////////////////////////////////

unit _crw_serio; // Serial I/O

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

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

{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}
{$WARN 5028 off : Local $1 "$2" is not used}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 {$IFDEF UNIX} unix, baseunix, termio,  {$ENDIF}
 {$IFDEF WINDOWS} registry, {$ENDIF}
 sysutils, classes, math,
 _crw_alloc, _crw_ef, _crw_str, _crw_fio, _crw_hl;

type // Serial port exception
 ESerialFail=class(ESoftException);

type
 TSerialHandle  = THandle;
 TSerSafeBuff   = packed array[0..7] of LongInt;
 TSerStopBits   = (ONESTOPBIT,ONE5STOPBITS,TWOSTOPBITS);
 TSerParityType = (NoneParity,OddParity,EvenParity,MarkParity,SpaceParity);
 TSerialFlag    = (SF_CRTSCTS,  // c_cflag: RTS/CTS Flow Control
                   SF_LE,       // c_lflag: DSR (Data Set Ready/Line Enable)
                   SF_DTR,      // c_lflag: DTR (Data Terminal Ready)
                   SF_RTS,      // c_lflag: RTS (Request To Send)
                   SF_ST,       // c_lflag: ST  (Secondary Transmit)
                   SF_SR,       // c_lflag: SR  (Secondary Receive)
                   SF_CTS,      // c_lflag: CTS (Clear To Send)
                   SF_CD,       // c_lflag: CAR (Data Carrier Detect)
                   SF_RI,       // c_lflag: RNG (Ring signal)
                   SF_DSR,      // c_lflag: DSR (Data Set Ready)
                   SF_OUT1,     // c_lflag: ???
                   SF_OUT2,     // c_lflag: ???
                   SF_IXON,     // c_iflag: IXON
                   SF_IXOFF,    // c_iflag: IXOFF
                   SF_IXANY     // c_iflag: IXANY
                   );
 TSerialFlags   = set of TSerialFlag;

const
 SerBuffSize   = OS_PIPE_BUF;                  // Buffer size for serial I/O.
 SerDelims     = JustSpaces+[';',',',':','=']; // Delimeters to parse params.
 SerDelimsPlus = SerDelims+['+','[',']'];      // Delimeters to parse flags.

const                                // WinApi DCB flags:
dcb_Binary              = $00000001; // Should be always ON
dcb_ParityCheck         = $00000002; // Uses parity control
dcb_OutxCtsFlow         = $00000004; // Uses CTS for output flow control
dcb_OutxDsrFlow         = $00000008; // Uses DSR for output flow control
dcb_DtrControlMask      = $00000030; // DTR modes:
dcb_DtrControlDisable   = $00000000; // DTR is disabled
dcb_DtrControlEnable    = $00000010; // DTR is always ON
dcb_DtrControlHandshake = $00000020; // DTR handshake uses
dcb_DsrSensivity        = $00000040; // DSR uses to control data receive
dcb_TXContinueOnXoff    = $00000080; // Continue transmisson after XOFF
dcb_OutX                = $00000100; // Flag to use XOFF flow control
dcb_InX                 = $00000200; // Flag to use XON  flow control
dcb_ErrorChar           = $00000400; // Use char replacement on parity error(s)
dcb_NullStrip           = $00000800; // Null bytes are discarded when received
dcb_RtsControlMask      = $00003000; // RTS flow control modes:
dcb_RtsControlDisable   = $00000000; // RTS is disabled
dcb_RtsControlEnable    = $00001000; // RTS is always ON
dcb_RtsControlHandshake = $00002000; // RTS handshake uses
dcb_RtsControlToggle    = $00003000; // RTS control (set ON to transmit data)
dcb_AbortOnError        = $00004000; // Stop I/O on error until ClearCommError
dcb_ReservedBits        = $FFFF8000; // Reserved DCB bits

{$IFDEF WINDOWS}
type
 TSerialState = record
  DCB      : TDCB;
  MASK     : DWORD;
  PROP     : COMMPROP;
  TIMEOUTS : COMMTIMEOUTS;
 end;
{$ENDIF ~WINDOWS}

{$IFDEF UNIX}
type
 TSerialState  = record
  line : LongWord;     // Serial Line state
  tios : termios;      // Terminal IO state
  safe : TSerSafeBuff; // Just for safety
 end;

type // serial_struct: /usr/src/linux-headers-*/include/uapi/linux/serial.h
 TSerialStruct = record
  typ             : cint;    // 0..13, see KnownSerialTypes
  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;
  iomap_base      : culong;  // cookie passed into ioremap
  reserved        : TSerSafeBuff; // Just for safety
 end;
const // TSerialStruct.typ [0..13] corresponds to next serial device types:
 KnownSerialTypes='UNKNOWN,8250,16450,16550,16550A,CIRRUS,16650,16650V2,16750,'
                 +'STARTECH,16C950,16654,16850,RSA';
const
 SerPreferIoctl : Boolean = false;       // Prefer ioctl rather then TcGetAttr.
 O_SERDEFLT  = O_RDWR or O_NOCTTY;       // Default flags to open serial file.
 O_SERNOBLK  = O_SERDEFLT or O_NONBLOCK; // Flags to open non-blocking serial.
{$ENDIF ~UNIX}

 // Check serial file descriptor (fd) has non-block flag.
function SerHasNonBlockFlag(fd:THandle):Boolean;

 // Set serial file descriptor (fd) non-block flag ON/OFF.
function SerSetNonBlockFlag(fd:THandle; State:Boolean=true):Boolean;

 // Set exclusive mode for serial port.
function SerSetExclusive(Handle:TSerialHandle; Exclusive:Boolean):Boolean;

{$IFDEF WINDOWS}
const
 O_SERDEFLT  = 0;                    // Default flags to open serial file.
 O_SERNOBLK  = FILE_FLAG_OVERLAPPED; // Flags to open non-blocking serial.
{$ENDIF ~WINDOWS}

const // List of options to parse serial port params.
 SerOptListBaudRate   = '-b,baud,-baud,--baud,baudrate,-baudrate,--baudrate';
 SerOptListByteSize   = '-d,data,-data,--data,databits,-databits,--databits'
                       +',bytesize,-bytesize,--bytesize';
 SerOptListParityType = '-p,parity,-parity,--parity'
                       +',paritytype,-paritytype,--paritytype';
 SerOptListStopBits   = '-s,stop,-stop,--stop,stopbits,-stopbits,--stopbits';
 SerOptListFlags      = '-f,flags,-flags,--flags,dcbflags,-dcbflags,--dcbflags';

const // Default serial port params.
 SerDefaultBaudRate   : LongInt        = 9600;
 SerDefaultByteSize   : Integer        = 8;
 SerDefaultParityType : TSerParityType = NoneParity;
 SerDefaultStopBits   : TSerStopBits   = ONESTOPBIT;
 SerDefaultFlags      : TSerialFlags   = [];
 SerDefaultParams     : LongString     = 'baudrate 9600 databits 8 parity NONE'
                                       +' stopbits 1 dcbflags 0';

type
 TSerAsynPriv = packed record
  IoError : LongWord;
  HwError : LongWord;
  Lost    : LongWord;
  Stub    : LongWord;
 end;

{$IFDEF WINDOWS}
type
 TSerBool = {$IFDEF CPU64} QWordBool {$ELSE} LongBool {$ENDIF};
 PSerAsyncRec = ^TSerAsyncRec;
 TSerAsyncRec = packed record
  Pending : TSerBool;
  Overlap : TOverlapped;
  Buffer  : packed array[0..SerBuffSize-1] of Char;
  Stat    : TSerialState;
  Priv    : TSerAsynPriv;
 end;
{$ELSE}
type
 PSerAsyncRec = ^TSerAsyncRec;
 TSerAsyncRec = packed record
  Stat : TSerialState;
  Priv : TSerAsynPriv;
 end;
{$ENDIF ~WINDOWS}

const // SerOpen Options.
 soo_Exclusive = $00000001;
 soo_CloExec   = $00000002;
 soo_Default   = soo_Exclusive+soo_CloExec;

 // 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; Options:LongInt=soo_Default):TSerialHandle;

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

 // Flushes the data queues of the given serial device. DO NOT USE THIS:
 // use either SerSync (non-blocking) or SerDrain (blocking).
function SerFlush(Handle:TSerialHandle):Boolean; 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.
function SerSync(Handle:TSerialHandle):Boolean;

 // 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.
function SerDrain(Handle:TSerialHandle):Boolean;

 // Discard all pending input (Rx).
function SerFlushRx(Handle:TSerialHandle):Boolean;

 // Discard all unsent output (Tx).
function SerFlushTx(Handle:TSerialHandle):Boolean;

 // Discard all pending input (Rx) and unsent output (Tx).
function SerFlushRxTx(Handle:TSerialHandle):Boolean;

{$IFDEF WINDOWS}
const
 PURGE_Rx   = PURGE_RXABORT or PURGE_RXCLEAR;
 PURGE_Tx   = PURGE_TXABORT or PURGE_TXCLEAR;
 PURGE_RxTx = PURGE_Rx or PURGE_Tx;
{$ENDIF ~WINDOWS}

 // 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; Async:PSerAsyncRec=nil):LongInt;
function SerReadStr(Handle:TSerialHandle; Count:LongInt; Async:PSerAsyncRec=nil):LongString;

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

 // Get serial port parameters.
function SerGetParams(const State:TSerialState; var BaudRate:LongInt;
  var ByteSize:Integer; var Parity:TSerParityType; var StopBits:TSerStopBits;
  var Flags:TSerialFlags; lpDcbFlags:PDWORD=nil):Boolean; overload;
function SerGetParams(Handle:TSerialHandle; var BaudRate:LongInt;
  var ByteSize:Integer; var Parity:TSerParityType; var StopBits:TSerStopBits;
  var Flags:TSerialFlags; lpDcbFlags:PDWORD=nil):Boolean; overload;
function SerGetParams(Handle:TSerialHandle; var State:TSerialState):Boolean; overload;

function SerGetParamBaudRate(const State:TSerialState; Def:LongInt=0):LongInt;
function SerGetParamByteSize(const State:TSerialState; Def:Integer=8):Integer;
function SerGetParamParity(const State:TSerialState; Def:TSerParityType=NoneParity):TSerParityType;
function SerGetParamStopBits(const State:TSerialState; Def:TSerStopBits=ONESTOPBIT):TSerStopBits;
function SerGetParamFlags(const State:TSerialState; Def:TSerialFlags=[]):TSerialFlags;
function SerGetParamDcbFlags(const State:TSerialState; Def:DWORD=0):DWORD;

 // Get serial port parameters as string.
function SerGetParamsAsString(const State:TSerialState):LongString; overload;
function SerGetParamsAsString(Handle:TSerialHandle):LongString; overload;

 // Set serial port parameters.
 // BaudRate=BitsPerSec; DataBits=ByteSize;
function SerSetParams(var State:TSerialState; BaudRate:LongInt;
   ByteSize:Integer; Parity:TSerParityType; StopBits:TSerStopBits;
   Flags:TSerialFlags; DcbFlags:DWORD=0):Boolean; overload;
function SerSetParams(Handle:TSerialHandle; BaudRate:LongInt;
   ByteSize:Integer; Parity:TSerParityType; StopBits:TSerStopBits;
   Flags:TSerialFlags; DcbFlags:DWORD=0):Boolean; overload;
function SerSetParams(Handle:TSerialHandle;
   const State:TSerialState):Boolean; overload;
function SerSetParams(Handle:TSerialHandle;
   const Params:LongString):Boolean; overload;

function SerSetParamBaudRate(var State:TSerialState; aBaudRate:LongInt):Boolean;
function SerSetParamByteSize(var State:TSerialState; aByteSize:Integer):Boolean;
function SerSetParamParity(var State:TSerialState; aParity:TSerParityType):Boolean;
function SerSetParamStopBits(var State:TSerialState; aStopBits:TSerStopBits):Boolean;
function SerSetParamFlags(var State:TSerialState; aFlags:TSerialFlags):Boolean;
function SerSetParamDcbFlags(var State:TSerialState; aDcbFlags:DWORD):Boolean;

 // Clear, save and restore the state of the serial device.
procedure SerClearState(out State:TSerialState);
function SerSaveState(Handle:TSerialHandle):TSerialState;
function SerRestoreState(Handle:TSerialHandle; const State:TSerialState):Boolean;

 // Getting and setting the line states directly.
{$IFDEF UNIX}
function SerGetLineState(Handle:TSerialHandle; out line:LongWord):Boolean;
function SerSetLineState(Handle:TSerialHandle; line:LongWord):Boolean;
function SerSetLineBits(Handle:TSerialHandle; Mask:LongWord; State:Boolean):Boolean;
{$ENDIF ~UNIX}
function SerSetDTR(Handle:TSerialHandle; State:Boolean):Boolean;
function SerSetRTS(Handle:TSerialHandle; State:Boolean):Boolean;
function SerGetDTR(Handle:TSerialHandle):Boolean;
function SerGetRTS(Handle:TSerialHandle):Boolean;
function SerGetCTS(Handle:TSerialHandle):Boolean;
function SerGetDSR(Handle:TSerialHandle):Boolean;
function SerGetCD(Handle:TSerialHandle):Boolean;
function SerGetRI(Handle:TSerialHandle):Boolean;

const DefSerBreakMs={$IFDEF WINDOWS}250{$ELSE}0{$ENDIF};
 // 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=DefSerBreakMs; Sync:Boolean=true);

type
 TSerialIdle = procedure(h:TSerialHandle); // Idle procedure for serial polling.

 // 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 parameters parsing routines.
////////////////////////////////////////////////////////////////////////////////

 // Return list of valid baud rates like '2400,4800,9600,..'.
function SerListValidBaudRate(Delim:LongString=','):LongString;

// Return list of valid byte size like '5,6,7,8'.
function SerListValidByteSize(Delim:LongString=','):LongString;

 // Return list of valid parity like 'NoneParity,OddParity,EvenParity'.
function SerListValidParity(Delim:LongString=','):LongString;

// Return list of valid stop bits like '1,1.5,2'.
function SerListValidStopBits(Delim:LongString=','):LongString;

// Return list of valid flags like 'CRTSCTS,LE,RTS,CTS,..'.
function SerListValidFlags(Delim:LongString=','):LongString;

 // Convert baudrate to string and back.
function SerBaudRateToString(br:LongInt):LongString;
function SerTryStringToBaudRate(arg:LongString; var br:LongInt):Boolean;
function SerStringToBaudRate(arg:LongString; def:LongInt=9600):LongInt;

 // Convert bytesize to string and back.
function SerByteSizeToString(bs:Integer):LongString;
function SerTryStringToByteSize(arg:LongString; var bs:Integer):Boolean;
function SerStringToByteSize(arg:LongString; def:Integer=8):Integer;

 // Convert parity to string and back.
function SerParityTypeToString(pt:TSerParityType; Long:Boolean=false):LongString;
function SerTryStringToParityType(arg:LongString; var pt:TSerParityType):Boolean;
function SerStringToParityType(arg:LongString; def:TSerParityType=NoneParity):TSerParityType;

// Convert stop bits to string and back.
function SerStopBitsToString(sb:TSerStopBits):LongString;
function SerTryStringToStopBits(arg:LongString; var sb:TSerStopBits):Boolean;
function SerStringToStopBits(arg:LongString; def:TSerStopBits=ONESTOPBIT):TSerStopBits;

 // Convert serial flags to string and back.
function SerFlagsToString(Flags:TSerialFlags):LongString;
function SerTryStringToFlags(arg:LongString; var fl:TSerialFlags):Boolean;
function SerStringToFlags(arg:LongString; def:TSerialFlags=[]):TSerialFlags;

 // Return serial params as single string like:
 // 'baudrate 9600 databits 8 parity NONE stopbits 1'.
function SerParamsToString(BaudRate:LongInt; ByteSize:Integer;
         Parity:TSerParityType; StopBits:TSerStopBits;
         Flags:TSerialFlags; DcbFlags:DWORD=0):LongString;

 // Parse serial params from strings like:
 // '-b 9600 -d 8 -p NONE -s 1'
 // 'baudrate 9600 databits 8 parity NONE stopbits 1'
function SerParseParams(const Params:LongString; out BaudRate:LongInt;
  out ByteSize:Integer; out Parity:TSerParityType; out StopBits:TSerStopBits;
  out Flags:TSerialFlags):Boolean; overload;
function SerParseParams(const Params:LongString; out State:TSerialState):Boolean; overload;

procedure DcbFlagsToSerFlags(DcbFlags:Cardinal; var SerFlags:TSerialFlags);
procedure SerFlagsToDcbFlags(SerFlags:TSerialFlags; var DcbFlags:Cardinal);

////////////////////////////////////////////////////////////////////////////////
// Serial naming/enumeration routines
////////////////////////////////////////////////////////////////////////////////

 // Serial port path prefix:
 // "/dev/" on Unix or "\\.\" on Windows.
function SerPortPathPrefix:LongString; inline;

 // Get serial port FULL path by (short) Name:
 // (ttyS0=>/dev/ttyS0) on Unix or (COM1=>\\.\COM1) on Windows.
function SerPortFullPath(const Name:LongString):LongString;

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

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

 // Read list of serial drivers from /proc/tty/drivers.
 // This list provides the serial port device prefixes.
 // Return string like: "ttyS;ttyUSB;ttyMAX;rfcomm;..".
function ReadProcTtyDriversSerial(Delim:Char=';'):LongString;

// Read DRIVER=name from /sys/class/tty/BaseName/device/uevent.
function ReadSysClassTtyDeviceDriver(const BaseName:LongString):LongString;

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 (short) names with delimiter Delim.
 // 'ttyS0;ttyUSB0;...' or 'COM1,COM2,...'
function GetSerialPortNames(Mode:Integer=0; Delim:Char=';'):LongString;

type
 TSerPortNums = 1..255; // Available serial port numbers for TSerPortMap.

 ///////////////////////////////////////////////
 // TSerPortMap is class with a table to map
 // serial devices (like /dev/ttyS0 or \\.\COM1)
 // to COM port names (like COM1) with integer
 // numbers.
 ///////////////////////////////////////////////
type
 TSerPortMap = class(TLatch)
 private
  myMap      : THashList;
  myList     : record Ports,ComNames,BaseNames,PathNames:LongString; end;
  myBaseName : array[TSerPortNums] of LongString;
  myPathName : array[TSerPortNums] of LongString;
  myDriverID : array[TSerPortNums] of LongString;
  function  GetComName(n:Integer):LongString;
  function  GetBaseName(n:Integer):LongString;
  function  GetPathName(n:Integer):LongString;
  function  GetDriverId(n:Integer):LongString;
  function  AddPort(aNum:Integer; aName:LongString):Boolean;
 public
  constructor Create;
  destructor  Destroy; override;
 public
  procedure Clear;
  procedure Update;
 public     // Count ports.
  function  Count:Integer;
 public     // List like #1#2#3.
  function  ListPorts:LongString;
 public     // Get port number by base or path name.
  function  PortNum(const aPathName:LongString):Integer;
 public     // List ports COM names like 'COM1,COM2'.
  function  ListComNames(const aDelim:LongString=EOL):LongString;
 public     // List ports base names like 'ttyS0,ttyS1'.
  function  ListBaseNames(const aDelim:LongString=EOL):LongString;
 public     // List ports path names like '/dev/ttyS0,/dev/ttyS1'.
  function  ListPathNames(const aDelim:LongString=EOL):LongString;
 public     // Port table as text lines like 'COM1  /dev/ttyS0  serial8250'.
  function  Table(const aPrefix:LongString='COM'; aBase:Boolean=false):LongString;
 public     // COM port (n) name like COM1.
  property  ComName[n:Integer] : LongString read GetComName;
 public     // Base name of port (n) like ttyS0 or COM1.
  property  BaseName[n:Integer] : LongString read GetBaseName;
 public     // Path name of port (n) like /dev/ttyS0 or \\.\COM1.
  property  PathName[n:Integer] : LongString read GetPathName;
 public     // Driver ID of port (n) like 'serial8250'.
  property  DriverID[n:Integer] : LongString read GetDriverID;
 end;

function SerPortMap:TSerPortMap; // The only one Serial Port Map instance.

implementation

 ///////////////////////////
 // Common service routines.
 ///////////////////////////

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

function SerReadStr(Handle:TSerialHandle; Count:LongInt; Async:PSerAsyncRec=nil):LongString;
var Buff:LongString; Leng:LongInt;
begin
 Result:='';
 if (Count>0) and SerValidHandle(Handle) then begin
  Buff:=StringBuffer(Min(Count,SerBuffSize));
  Leng:=SerRead(Handle,Buff[1],Length(Buff),Async);
  if (Leng>0) then Result:=Copy(Buff,1,Leng);
 end;
end;

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

procedure SerClearState(out State:TSerialState);
begin
 SafeFillChar(State,SizeOf(State),0);
end;

function SerGetParams(Handle:TSerialHandle; var BaudRate:LongInt;
  var ByteSize:Integer; var Parity:TSerParityType; var StopBits:TSerStopBits;
  var Flags:TSerialFlags; lpDcbFlags:PDWORD=nil):Boolean;
begin
 Result:=SerGetParams(SerSaveState(Handle),BaudRate,ByteSize,Parity,StopBits,Flags,lpDcbFlags);
end;

function SerGetParams(Handle:TSerialHandle; var State:TSerialState):Boolean;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 Result:=false;
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(Handle,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=SerSetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,DcbFlags);
end;

function SerGetParamsAsString(const State:TSerialState):LongString;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 Result:='';
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=SerParamsToString(BaudRate,ByteSize,Parity,StopBits,Flags,DcbFlags);
end;

function SerGetParamsAsString(Handle:TSerialHandle):LongString;
begin
 Result:=SerGetParamsAsString(SerSaveState(Handle));
end;

function SerSetParams(Handle:TSerialHandle; BaudRate:LongInt;
  ByteSize:Integer; Parity:TSerParityType; StopBits:TSerStopBits;
  Flags:TSerialFlags; DcbFlags:DWORD=0):Boolean;
var State:TSerialState;
begin
 Result:=false;
 SerClearState(State);
 if SerSetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,DcbFlags)
 then Result:=SerSetParams(Handle,State);
end;

function SerSetParams(Handle:TSerialHandle; const Params:LongString):Boolean;
var State:TSerialState;
begin
 Result:=false;
 if SerParseParams(Params,State)
 then Result:=SerSetParams(Handle,State);
end;

function SerGetParamBaudRate(const State:TSerialState; Def:LongInt=0):LongInt;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=BaudRate else Result:=Def;
end;

function SerGetParamByteSize(const State:TSerialState; Def:Integer=8):Integer;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=ByteSize else Result:=Def;
end;

function SerGetParamParity(const State:TSerialState; Def:TSerParityType=NoneParity):TSerParityType;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=Parity else Result:=Def;
end;

function SerGetParamStopBits(const State:TSerialState; Def:TSerStopBits=ONESTOPBIT):TSerStopBits;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=StopBits else Result:=Def;
end;

function SerGetParamFlags(const State:TSerialState; Def:TSerialFlags=[]):TSerialFlags;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=Flags else Result:=Def;
end;

function SerGetParamDcbFlags(const State:TSerialState; Def:DWORD=0):DWORD;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=DcbFlags else Result:=Def;
end;

function SerSetParamBaudRate(var State:TSerialState; aBaudRate:LongInt):Boolean;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 Result:=false;
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=SerSetParams(State,aBaudRate,ByteSize,Parity,StopBits,Flags,DcbFlags);
end;

function SerSetParamByteSize(var State:TSerialState; aByteSize:Integer):Boolean;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 Result:=false;
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=SerSetParams(State,BaudRate,aByteSize,Parity,StopBits,Flags,DcbFlags);
end;

function SerSetParamParity(var State:TSerialState; aParity:TSerParityType):Boolean;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 Result:=false;
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=SerSetParams(State,BaudRate,ByteSize,aParity,StopBits,Flags,DcbFlags);
end;

function SerSetParamStopBits(var State:TSerialState; aStopBits:TSerStopBits):Boolean;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 Result:=false;
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=SerSetParams(State,BaudRate,ByteSize,Parity,aStopBits,Flags,DcbFlags);
end;

function SerSetParamFlags(var State:TSerialState; aFlags:TSerialFlags):Boolean;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 Result:=false;
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=SerSetParams(State,BaudRate,ByteSize,Parity,StopBits,aFlags,DcbFlags);
end;

function SerSetParamDcbFlags(var State:TSerialState; aDcbFlags:DWORD):Boolean;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags; DcbFlags:DWORD;
begin
 Result:=false;
 BaudRate:=0; ByteSize:=0; Parity:=NoneParity;
 StopBits:=ONESTOPBIT; Flags:=[]; DcbFlags:=0;
 if SerGetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,@DcbFlags)
 then Result:=SerSetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags,aDcbFlags);
end;


 //////////////////////////////////
 // Serial params parsing routines.
 //////////////////////////////////

function SerListValidBaudRate(Delim:LongString=','):LongString;
begin
 Result:='';
 {$IFDEF WINDOWS}
 Result:=Result
       +'110,300,600,1200,2400,4800,9600,14400'
       +',19200,38400,57600,115200,128000,256000';
 {$ENDIF ~WINDOWS}
 {$IFDEF UNIX}
 Result:=Result
       +'50,75,110,134,150,200,300,600,1200,1800,2400,4800,9600,19200,38400'
       +',57600,115200,230400,460800,500000,576000,921600,1000000,1152000'
       +',1500000,2000000,2500000,3000000,3500000,4000000';
 {$ENDIF ~UNIX}
 if (Result='') then Exit;
 if (Delim<>',') then Result:=StringReplace(Result,',',Delim,[rfReplaceAll]);
end;

function SerListValidByteSize(Delim:LongString=','):LongString;
begin
 Result:='5,6,7,8';
 if (Delim<>',') then Result:=StringReplace(Result,',',Delim,[rfReplaceAll]);
end;

function SerListValidParity(Delim:LongString=','):LongString;
begin
 Result:='';
 {$IFDEF WINDOWS}
 Result:=Result+'NoneParity,OddParity,EvenParity,MarkParity,SpaceParity';
 {$ENDIF ~WINDOWS}
 {$IFDEF UNIX}
 Result:=Result+'NoneParity,OddParity,EvenParity';
 {$ENDIF ~UNIX}
 if (Result='') then Exit;
 if (Delim<>',') then Result:=StringReplace(Result,',',Delim,[rfReplaceAll]);
end;

function SerListValidStopBits(Delim:LongString=','):LongString;
begin
 Result:='1,1.5,2';
 if (Delim<>',') then Result:=StringReplace(Result,',',Delim,[rfReplaceAll]);
end;

function SerListValidFlags(Delim:LongString=','):LongString;
begin
 Result:='CRTSCTS,LE,DTR,RTS,ST,SR,CTS,CD,RI,DSR,OUT1,OUT2,IXON,IXOFF,IXANY';
 if (Delim<>',') then Result:=StringReplace(Result,',',Delim,[rfReplaceAll]);
end;

function SerBaudRateToString(br:LongInt):LongString;
begin
 Result:=IntToStr(br);
end;

function SerTryStringToBaudRate(arg:LongString; var br:LongInt):Boolean;
begin
 Result:=false; arg:=Trim(arg);
 if (WordIndex(arg,SerListValidBaudRate,SerDelims)>0)
 then Result:=TryStrToInt(arg,br);
end;

function SerStringToBaudRate(arg:LongString; def:LongInt=9600):LongInt;
begin
 Result:=def; if not SerTryStringToBaudRate(arg,Result) then Result:=def;
end;

function SerByteSizeToString(bs:Integer):LongString;
begin
 Result:=IntToStr(bs);
end;

function SerTryStringToByteSize(arg:LongString; var bs:Integer):Boolean;
begin
 Result:=false; arg:=Trim(arg);
 if (WordIndex(arg,SerListValidByteSize,SerDelims)>0)
 then Result:=TryStrToInt(arg,bs);
end;

function SerStringToByteSize(arg:LongString; def:LongInt=8):Integer;
begin
 Result:=def; if not SerTryStringToByteSize(arg,Result) then Result:=def;
end;

function SerParityTypeToString(pt:TSerParityType; Long:Boolean=false):LongString;
var iw:Integer; const rfFlags=[rfReplaceAll,rfIgnoreCase];
begin
 iw:=1+(Ord(pt)-Ord(Low(pt)));
 Result:=ExtractWord(iw,SerListValidParity,SerDelims);
 if not Long then Result:=StringReplace(Result,'Parity','',rfFlags);
end;

function SerTryStringToParityType(arg:LongString; var pt:TSerParityType):Boolean;
var p:TSerParityType; iw:Integer; id:LongString;
begin
 Result:=false;
 iw:=1; arg:=Trim(arg);
 if IsEmptyStr(arg) then Exit;
 for p:=Low(p) to High(p) do begin
  id:=SerParityTypeToString(p,true);
  if SameText(arg,id)
  or SameText(arg,Copy(id,1,1))
  or SameText(arg,Copy(id,1,Length(id)-6))
  or ((p=NoneParity) and SameText(arg,Copy(id,1,2)))
  then begin
   Result:=true;
   pt:=p;
   Break;
  end;
  inc(iw);
 end;
end;

function SerStringToParityType(arg:LongString; def:TSerParityType=NoneParity):TSerParityType;
begin
 Result:=def; if not SerTryStringToParityType(arg,Result) then Result:=def;
end;

function SerStopBitsToString(sb:TSerStopBits):LongString;
var iw:Integer;
begin
 iw:=1+(Ord(sb)-Ord(Low(sb)));
 Result:=ExtractWord(iw,SerListValidStopBits,SerDelims);
end;

function SerTryStringToStopBits(arg:LongString; var sb:TSerStopBits):Boolean;
var s:TSerStopBits; iw:Integer; id:LongString;
begin
 Result:=false;
 iw:=1; arg:=Trim(arg);
 if IsEmptyStr(arg) then Exit;
 for s:=Low(s) to High(s) do begin
  id:=SerStopBitsToString(s);
  if SameText(arg,id) then begin
   Result:=true;
   sb:=s;
   Break;
  end;
  inc(iw);
 end;
end;

function SerStringToStopBits(arg:LongString; def:TSerStopBits=ONESTOPBIT):TSerStopBits;
begin
 Result:=def; if not SerTryStringToStopBits(arg,Result) then Result:=def;
end;

function SerFlagsToString(Flags:TSerialFlags):LongString;
var Flag:TSerialFlag;
 procedure AddFlag(var S:LongString; Flag:TSerialFlag);
 var SF:LongString; iw:Integer;
 begin
  if (Flag in Flags) then begin
   iw:=1+(Ord(Flag)-Ord(Low(Flag)));
   SF:=ExtractWord(iw,SerListValidFlags,SerDelims);
   if (S='') then S:=SF else S:=S+'+'+SF;
  end;
 end;
begin
 Result:='';
 for Flag:=Low(Flag) to High(Flag) do
 if (Flag in Flags) then AddFlag(Result,Flag);
 Result:=Trim(Result);
end;

function SerTryStringToFlags(arg:LongString; var fl:TSerialFlags):Boolean;
var f:TSerialFlag; id:LongString; iw,dcbf:LongInt;
begin
 Result:=true; fl:=[];
 if IsEmptyStr(arg) then Exit;
 for iw:=1 to WordCount(arg,SerDelimsPlus) do begin
  id:=ExtractWord(iw,arg,SerDelimsPlus);
  if TryStrToInt(id,dcbf) and (dcbf<>0)
  then DcbFlagsToSerFlags(dcbf,fl);
 end;
 for f:=Low(f) to High(f) do begin
  id:=SerFlagsToString([f]);
  if (WordIndex(id,arg,SerDelimsPlus)>0)
  then Include(fl,f);
 end;
end;

function SerStringToFlags(arg:LongString; def:TSerialFlags=[]):TSerialFlags;
begin
 Result:=def; if not SerTryStringToFlags(arg,Result) then Result:=def;
end;

function SerParamsToString(BaudRate:LongInt; ByteSize:Integer;
         Parity:TSerParityType; StopBits:TSerStopBits;
         Flags:TSerialFlags; DcbFlags:DWORD=0):LongString;
 function Param(Name,Value:LongString):LongString;
 begin
  Result:=Name+' '+Value+' ';
 end;
begin
 Result:=Param('baudrate',SerBaudRateToString(BaudRate))
        +Param('databits',SerByteSizeToString(ByteSize))
        +Param('parity',UpperCase(SerParityTypeToString(Parity)))
        +Param('stopbits',SerStopBitsToString(StopBits))
        +Param('flags',UnifySection(SerFlagsToString(Flags)));
 if (DcbFlags<>0) then Result:=Result+Param('dcbflags',Format('$%4.4X',[DcbFlags]));
 Result:=TrimRight(Result);
end;

function SerParseParams(const Params:LongString; out BaudRate:LongInt;
  out ByteSize:Integer; out Parity:TSerParityType; out StopBits:TSerStopBits;
  out Flags:TSerialFlags):Boolean;
var sn,sv:LongString; iw,wc,dm:Integer;
 procedure Done(Mask:Integer);
 begin
  dm:=dm or Mask;
  Inc(iw);
 end;
begin
 Result:=false;
 if IsEmptyStr(Params) then Exit;
 BaudRate:=SerDefaultBaudrate;
 ByteSize:=SerDefaultByteSize;
 Parity:=SerDefaultParityType;
 StopBits:=SerDefaultStopBits;
 Flags:=SerDefaultFlags;
 iw:=1; wc:=WordCount(Params,SerDelims); dm:=0;
 while (iw<=wc) do begin
  sn:=ExtractWord(iw,Params,SerDelims);
  sv:=ExtractWord(iw+1,Params,SerDelims);
  if (WordIndex(sn,SerOptListBaudRate,SerDelims)>0) then
  if SerTryStringToBaudRate(sv,BaudRate) then Done(1) else Exit;
  if (WordIndex(sn,SerOptListByteSize,SerDelims)>0) then
  if SerTryStringToByteSize(sv,ByteSize) then Done(2) else Exit;
  if (WordIndex(sn,SerOptListParityType,SerDelims)>0) then
  if SerTryStringToParityType(sv,Parity) then Done(4) else Exit;
  if (WordIndex(sn,SerOptListStopBits,SerDelims)>0) then
  if SerTryStringToStopBits(sv,StopBits) then Done(8) else Exit;
  if (WordIndex(sn,SerOptListFlags,SerDelims)>0) then
  if SerTryStringToFlags(sv,Flags) then Done(16) else Exit;
  Inc(iw);
 end;
 Result:=HasFlags(dm,1);
end;

function SerParseParams(const Params:LongString; out State:TSerialState):Boolean;
var BaudRate:LongInt; ByteSize:Integer; Parity:TSerParityType;
    StopBits:TSerStopBits; Flags:TSerialFlags;
begin
 SerClearState(State);
 Result:=SerParseParams(Params,BaudRate,ByteSize,Parity,StopBits,Flags);
 if Result then Result:=SerSetParams(State,BaudRate,ByteSize,Parity,StopBits,Flags);
end;

procedure DcbFlagsToSerFlags(DcbFlags:Cardinal; var SerFlags:TSerialFlags);
begin
 //hardware handshake
 if HasFlags(DcbFlags,dcb_RtsControlHandshake or dcb_OutxCtsFlow)
 then Include(SerFlags,SF_CRTSCTS) else Exclude(SerFlags,SF_CRTSCTS);
 //software handshake
 if HasFlags(DcbFlags,dcb_OutX or dcb_InX)
 then SerFlags:=SerFlags+[SF_IXON,SF_IXOFF,SF_IXANY]
 else SerFlags:=SerFlags-[SF_IXON,SF_IXOFF,SF_IXANY];
 // RTS
 if HasFlags(DcbFlags,dcb_RtsControlEnable)
 then Include(SerFlags,SF_RTS) else Exclude(SerFlags,SF_RTS);
 // DTR
 if HasFlags(DcbFlags,dcb_DtrControlEnable)
 then Include(SerFlags,SF_DTR) else Exclude(SerFlags,SF_DTR);
end;

procedure SerFlagsToDcbFlags(SerFlags:TSerialFlags; var DcbFlags:Cardinal);
begin
 //hardware handshake
 if (SF_CRTSCTS in SerFlags)
 then DcbFlags:=DcbFlags or      (dcb_RtsControlHandshake or dcb_OutxCtsFlow)
 else DcbFlags:=DcbFlags and not (dcb_RtsControlHandshake or dcb_OutxCtsFlow);
 //software handshake
 if (SerFlags*[SF_IXOFF,SF_IXON,SF_IXANY]<>[])
 then DcbFlags:=DcbFlags or      (dcb_OutX or dcb_InX)
 else DcbFlags:=DcbFlags and not (dcb_OutX or dcb_InX);
 // RTS
 if (SF_RTS in SerFlags)
 then DcbFlags:=DcbFlags or      dcb_RtsControlEnable
 else DcbFlags:=DcbFlags and not dcb_RtsControlEnable;
 // DTR
 if (SF_DTR in SerFlags)
 then DcbFlags:=DcbFlags or      dcb_DtrControlEnable
 else DcbFlags:=DcbFlags and not dcb_DtrControlEnable;
end;

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

function fpSucceed(Code:LongInt):Boolean; inline;
begin
 Result:=(Code<>-1);
end;

function SerHasNonBlockFlag(fd:THandle):Boolean;
begin
 Result:=HasFlags(fpfcntl(fd,F_GETFL),O_NONBLOCK);
end;

function SerSetNonBlockFlag(fd:THandle; State:Boolean=true):Boolean;
var Flag:LongInt;
begin
 Flag:=fpfcntl(fd,F_GETFL);
 if State then Flag:=(Flag or O_NONBLOCK) else Flag:=Flag and not O_NONBLOCK;
 Result:=fpSucceed(fpfcntl(fd,F_SETFL,Flag));
end;

function SerOpen(const DeviceName:LongString; Flags:LongInt=0; Options:LongInt=soo_Default):TSerialHandle;
begin
 if (Flags=0) then Flags:=O_SERDEFLT;
 if IsLinux and HasFlags(Options,soo_CloExec) then Flags:=Flags or O_CLOEXEC;
 Result:=fpOpen(DeviceName,Flags);
 if SerValidHandle(Result) and HasFlags(Options,soo_Exclusive)
 then SerSetExclusive(Result,true);
 if SerValidHandle(Result) and HasFlags(Options,soo_CloExec)
 then FileSetCloseOnExec(Result,true);
end;

function SerClose(var Handle:TSerialHandle):Boolean;
begin
 if SerValidHandle(Handle)
 then Result:=fpSucceed(fpClose(Handle))
 else Result:=true;
 Handle:=INVALID_HANDLE_VALUE;
end;

function SerSetExclusive(Handle:TSerialHandle; Exclusive:Boolean):Boolean;
begin
 Result:=false;
 if SerValidHandle(Handle) then
 if Exclusive
 then Result:=fpSucceed(fpioctl(Handle,TIOCEXCL,nil))
 else Result:=fpSucceed(fpioctl(Handle,TIOCNXCL,nil));
end;

function SerFlush(Handle:TSerialHandle):Boolean; deprecated;
begin
 Result:=fpSucceed(fpfsync(Handle));
end;

function SerSync(Handle:TSerialHandle):Boolean;
begin
 Result:=fpSucceed(fpfsync(Handle));
end;

function SerDrain(Handle:TSerialHandle):Boolean;
begin
 Result:=fpSucceed(tcdrain(Handle));
end;

function SerFlushRx(Handle:TSerialHandle):Boolean;
begin
 Result:=fpSucceed(tcflush(Handle,TCIFLUSH));
end;

function SerFlushTx(Handle:TSerialHandle):Boolean;
begin
 Result:=fpSucceed(tcflush(Handle,TCOFLUSH));
end;

function SerFlushRxTx(Handle:TSerialHandle):Boolean;
begin
 Result:=fpSucceed(tcflush(Handle,TCIOFLUSH));
end;

function SerRead(Handle:TSerialHandle; var Buffer; Count:LongInt; Async:PSerAsyncRec=nil):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; Async:PSerAsyncRec=nil):LongInt;
begin
 Result:=0;
 if (@Buffer<>nil) and (Count>0)
 then Result:=fpWrite(Handle,Buffer,Count);
end;

function SerGetParams(const State:TSerialState; var BaudRate:LongInt;
  var ByteSize:Integer; var Parity:TSerParityType; var StopBits:TSerStopBits;
  var Flags:TSerialFlags; lpDcbFlags:PDWORD=nil):Boolean;
begin
 Result:=false;
 with State do begin
  case (tios.c_cflag and CBAUD) of
   B50:      BaudRate:=50;
   B75:      BaudRate:=75;
   B110:     BaudRate:=110;
   B134:     BaudRate:=134;
   B150:     BaudRate:=150;
   B200:     BaudRate:=200;
   B300:     BaudRate:=300;
   B600:     BaudRate:=600;
   B1200:    BaudRate:=1200;
   B1800:    BaudRate:=1800;
   B2400:    BaudRate:=2400;
   B4800:    BaudRate:=4800;
   B9600:    BaudRate:=9600;
   B19200:   BaudRate:=19200;
   B38400:   BaudRate:=38400;
   B57600:   BaudRate:=57600;
   B115200:  BaudRate:=115200;
   B230400:  BaudRate:=230400;
   B460800:  BaudRate:=460800;
   B500000:  BaudRate:=500000;
   B576000:  BaudRate:=576000;
   B921600:  BaudRate:=921600;
   B1000000: BaudRate:=1000000;
   B1152000: BaudRate:=1152000;
   B1500000: BaudRate:=1500000;
   B2000000: BaudRate:=2000000;
   B2500000: BaudRate:=2500000;
   B3000000: BaudRate:=3000000;
   B3500000: BaudRate:=3500000;
   B4000000: BaudRate:=4000000;
   else      Exit;
  end;
  case (tios.c_cflag and CSIZE) of
   CS5: ByteSize:=5;
   CS6: ByteSize:=6;
   CS7: ByteSize:=7;
   CS8: ByteSize:=8;
   else Exit;
  end;
  case (tios.c_cflag and (PARENB or PARODD)) of
   0:                  Parity:=NoneParity;
   PARENB:             Parity:=EvenParity;
   (PARENB or PARODD): Parity:=OddParity;
   else                Exit;
  end;
  if HasFlags(tios.c_cflag,CSTOPB)
  then StopBits:=TWOSTOPBITS
  else StopBits:=ONESTOPBIT;
  Flags:=[];
  if HasFlags(tios.c_cflag,CRTSCTS) then Include(Flags,SF_CRTSCTS);
  if HasFlags(line,TIOCM_LE)        then Include(Flags,SF_LE);
  if HasFlags(line,TIOCM_DTR)       then Include(Flags,SF_DTR);
  if HasFlags(line,TIOCM_RTS)       then Include(Flags,SF_RTS);
  if HasFlags(line,TIOCM_ST)        then Include(Flags,SF_ST);
  if HasFlags(line,TIOCM_SR)        then Include(Flags,SF_SR);
  if HasFlags(line,TIOCM_CTS)       then Include(Flags,SF_CTS);
  if HasFlags(line,TIOCM_DSR)       then Include(Flags,SF_DSR);
  if HasFlags(line,TIOCM_CD)        then Include(Flags,SF_CD);
  if HasFlags(line,TIOCM_RI)        then Include(Flags,SF_RI);
  if HasFlags(line,TIOCM_OUT1)      then Include(Flags,SF_OUT1);
  if HasFlags(line,TIOCM_OUT2)      then Include(Flags,SF_OUT2);
  if HasFlags(tios.c_iflag,IXON)    then Include(Flags,SF_IXON);
  if HasFlags(tios.c_iflag,IXOFF)   then Include(Flags,SF_IXOFF);
  if HasFlags(tios.c_iflag,IXANY)   then Include(Flags,SF_IXANY);
  if (lpDcbFlags<>nil) then SerFlagsToDcbFlags(Flags,lpDcbFlags^);
 end;
 Result:=true;
end;

function SerSetParams(var State:TSerialState; BaudRate:LongInt;
  ByteSize:Integer; Parity:TSerParityType; StopBits:TSerStopBits;
  Flags:TSerialFlags; DcbFlags:DWORD=0):Boolean;
var DFL:TSerialFlags;
begin
 Result:=false;
 with State do begin
  SafeFillChar(tios,SizeOf(tios),0);
  case BaudRate 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;
   9600:    tios.c_cflag := B9600;
   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;
   460800:  tios.c_cflag := B460800;
   500000:  tios.c_cflag := B500000;
   576000:  tios.c_cflag := B576000;
   921600:  tios.c_cflag := B921600;
   1000000: tios.c_cflag := B1000000;
   1152000: tios.c_cflag := B1152000;
   1500000: tios.c_cflag := B1500000;
   2000000: tios.c_cflag := B2000000;
   2500000: tios.c_cflag := B2500000;
   3000000: tios.c_cflag := B3000000;
   3500000: tios.c_cflag := B3500000;
   4000000: tios.c_cflag := B4000000;
   else     Exit;
  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;
   8:   tios.c_cflag := tios.c_cflag or CS8;
   else Exit;
  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=TWOSTOPBITS) then tios.c_cflag:=(tios.c_cflag or CSTOPB);
  if (DcbFlags<>0) then begin
   DFL:=[]; DcbFlagsToSerFlags(DcbFlags,DFL);
   Flags:=Flags+DFL;
  end;
  if (SF_CRTSCTS in Flags)  then tios.c_cflag:=(tios.c_cflag or CRTSCTS);
  if (SF_IXON  in Flags) then tios.c_iflag:=tios.c_iflag or IXON;
  if (SF_IXOFF in Flags) then tios.c_iflag:=tios.c_iflag or IXOFF;
  if (SF_IXANY in Flags) then tios.c_iflag:=tios.c_iflag or IXANY;
 end;
 Result:=true;
end;

function SerSetParams(Handle:TSerialHandle; const State:TSerialState):Boolean;
begin
 Result:=false;
 if not SerValidHandle(Handle) then Exit;
 SerFlushRxTx(Handle); // tcflush(Handle,TCIOFLUSH);
 Result:=fpSucceed(tcsetattr(Handle,TCSANOW,State.tios));
 // Also set line state ?
 if HasFlags(State.line,TIOCM_DTR) then SerSetDTR(Handle,true);
 if HasFlags(State.line,TIOCM_RTS) then SerSetRTS(Handle,true);
end;

function SerSaveState(Handle:TSerialHandle):TSerialState;
begin
 SerGetLineState(Handle,Result.line);
 if SerPreferIoctl
 then fpioctl(Handle,TCGETS,@Result.tios)
 else TcGetAttr(Handle,Result.tios);
end;

function SerRestoreState(Handle:TSerialHandle; const State:TSerialState):Boolean;
begin
 if SerPreferIoctl
 then fpioctl(Handle,TCSETS,@State.tios)
 else TCSetAttr(handle,TCSANOW,State.tios);
 Result:=SerSetLineState(Handle,State.line);
end;

function SerGetLineState(Handle:TSerialHandle; out line:LongWord):Boolean;
begin
 line:=0;
 Result:=fpSucceed(fpioctl(Handle,TIOCMGET,@line));
end;

function SerSetLineState(Handle:TSerialHandle; line:LongWord):Boolean;
begin
 Result:=fpSucceed(fpioctl(Handle,TIOCMSET,@line));
end;

function SerSetLineBits(Handle:TSerialHandle; Mask:LongWord; State:Boolean):Boolean;
begin
 if State
 then Result:=fpSucceed(fpioctl(Handle,TIOCMBIS,@Mask))
 else Result:=fpSucceed(fpioctl(Handle,TIOCMBIC,@Mask));
end;

function SerSetDTR(Handle:TSerialHandle; State:Boolean):Boolean;
begin
 Result:=SerSetLineBits(Handle,TIOCM_DTR,State);
end;

function SerSetRTS(Handle:TSerialHandle; State:Boolean):Boolean;
begin
 Result:=SerSetLineBits(Handle,TIOCM_RTS,State);
end;

function SerGetDTR(Handle:TSerialHandle):Boolean;
var Flags:LongWord;
begin
 if SerGetLineState(Handle,Flags)
 then Result:=HasFlags(Flags,TIOCM_DTR)
 else Result:=false;
end;

function SerGetRTS(Handle:TSerialHandle):Boolean;
var Flags:LongWord;
begin
 if SerGetLineState(Handle,Flags)
 then Result:=HasFlags(Flags,TIOCM_RTS)
 else Result:=false;
end;

function SerGetCTS(Handle:TSerialHandle):Boolean;
var Flags:LongWord;
begin
 if SerGetLineState(Handle,Flags)
 then Result:=HasFlags(Flags,TIOCM_CTS)
 else Result:=false;
end;

function SerGetDSR(Handle:TSerialHandle):Boolean;
var Flags:LongWord;
begin
 if SerGetLineState(Handle,Flags)
 then Result:=HasFlags(Flags,TIOCM_DSR)
 else Result:=false;
end;

function SerGetCD(Handle:TSerialHandle):Boolean;
var Flags:LongWord;
begin
 if SerGetLineState(Handle,Flags)
 then Result:=HasFlags(Flags,TIOCM_CD)
 else Result:=false;
end;

function SerGetRI(Handle:TSerialHandle):Boolean;
var Flags:LongWord;
begin
 if SerGetLineState(Handle,Flags)
 then Result:=HasFlags(Flags,TIOCM_RI)
 else Result:=false;
end;

procedure SerBreak(Handle:TSerialHandle; mSec:LongInt=DefSerBreakMs; 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
 Result:=0;
 if SerValidHandle(Handle) then begin
  fpFD_ZERO(readSet);
  fpFD_SET(Handle,readSet);
  selectTimeout.tv_sec:=(mSec div 1000);
  selectTimeout.tv_usec:=((mSec mod 1000)*1000);
  if (fpSelect(Handle+1,@readSet,nil,nil,@selectTimeout)>0)
  then Result:=fpRead(Handle,Buffer,1);
 end;
end;

{$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
 Result:=0;
 if SerValidHandle(Handle) then begin
  fpFD_ZERO(readSet);
  fpFD_SET(Handle,readSet);
  selectTimeout.tv_sec:=(mSec div 1000);
  selectTimeout.tv_usec:=((mSec mod 1000)*1000);
  // 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;
end;

{$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;
begin
 Result := 0;
 if SerValidHandle(Handle) then begin
  fpFD_ZERO(readSet);
  fpFD_SET(Handle,readSet);
  selectTimeout.tv_sec:=(mSec div 1000);
  selectTimeout.tv_usec:=(mSec mod 1000)*1000;
  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;
end;

{$ENDIF}

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

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

function SerHasNonBlockFlag(fd:THandle):Boolean;
var Timeouts:TCommTimeouts;
begin
 Result:=false;
 if SerValidHandle(fd) then begin
  Timeouts:=Default(TCommTimeouts);
  if GetCommTimeouts(fd,Timeouts) then
  if (Timeouts.ReadIntervalTimeout=MAXDWORD) then
  if (Timeouts.ReadTotalTimeoutMultiplier=0) then
  if (Timeouts.ReadTotalTimeoutConstant=0) then
  if (Timeouts.WriteTotalTimeoutConstant=0) then
  if (Timeouts.WriteTotalTimeoutMultiplier=0) then
  Result:=true;
 end;
end;

function SerSetNonBlockFlag(fd:THandle; State:Boolean=true):Boolean;
var Timeouts:TCommTimeouts;
begin
 Result:=false;
 if SerValidHandle(fd) then begin
  Timeouts:=Default(TCommTimeouts);
  if State then Timeouts.ReadIntervalTimeout:=MAXDWORD;
  Result:=SetCommTimeouts(fd,Timeouts);
 end;
end;

function SerOpen(const DeviceName:LongString; Flags:LongInt=0; Options:LongInt=soo_Default):TSerialHandle;
var noBlk:Boolean; acMode,shMode:LongWord;
begin
 noBlk:=True;
 //noBlk:=HasFlags(Flags,FILE_FLAG_OVERLAPPED);
 //Flags:=(Flags and not FILE_FLAG_OVERLAPPED);
 acMode:=(GENERIC_READ or GENERIC_WRITE); shMode:=0;
 Result:=CreateFile(PChar(DeviceName),acMode,shMode,nil,OPEN_EXISTING,Flags,0);
 // 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 SerValidHandle(Result) then
 if not SerSetParams(Result,9600,8,NoneParity,ONESTOPBIT,[]) then SerClose(Result);
 if not SetCommMask(Result,0) then SerClose(Result); { don`t use any events }
 if noBlk then SerSetNonBlockFlag(Result,noBlk);
 if SerValidHandle(Result) and HasFlags(Options,soo_Exclusive)
 then SerSetExclusive(Result,true);
end;

function SerClose(var Handle:TSerialHandle):Boolean;
begin
 if SerValidHandle(Handle)
 then Result:=CloseHandle(Handle)
 else Result:=true;
 Handle:=INVALID_HANDLE_VALUE;
end;

function SerSetExclusive(Handle:TSerialHandle; Exclusive:Boolean):Boolean;
begin
 Result:=false;
 if SerValidHandle(Handle) then Result:=true;
end;

function SerFlush(Handle:TSerialHandle):Boolean; deprecated;
begin
 Result:=FlushFileBuffers(Handle);
end;

function SerSync(Handle:TSerialHandle):Boolean;
begin
 Result:=FlushFileBuffers(Handle);
end;

function SerDrain(Handle:TSerialHandle):Boolean;
var errors:DWORD; comStat:TComStat;
begin
 Result:=FlushFileBuffers(Handle); errors:=0;
 repeat
  if not ClearCommError(Handle,errors,@comStat) then break;
  if (ComStat.cbOutQue>0) and Assigned(SerialIdle) then SerialIdle(Handle)
 until (ComStat.cbOutQue=0);
end;

function SerFlushRx(Handle:TSerialHandle):Boolean;
begin
 Result:=PurgeComm(Handle,PURGE_Rx);
end;

function SerFlushTx(Handle:TSerialHandle):Boolean;
begin
 Result:=PurgeComm(Handle,PURGE_Tx);
end;

function SerFlushRxTx(Handle:TSerialHandle):Boolean;
begin
 Result:=PurgeComm(Handle,PURGE_RxTx);
end;

function SerRead(Handle:TSerialHandle; var Buffer; Count:LongInt; Async:PSerAsyncRec=nil):LongInt;
var BytesRead,RxBlock,lpErrors,LastError:DWORD; lpStat:ComStat;
 procedure FixIoError(Code:DWORD);
 begin
  Async.Priv.IoError:=Code;
 end;
 procedure FixHwError(Code:DWORD);
 begin
  if (Code<>0) then LiftFlags(Async.Priv.HwError,Code);
 end;
begin
 Result:=0;
 if SerValidHandle(Handle) and (Count>0) then begin
  if (Async=nil) then begin
   // Synchronous read
   if not SerHasNonBlockFlag(Handle) then
   if not SerSetNonBlockFlag(Handle) then Exit(0);
   BytesRead:=0;
   if ReadFile(Handle,Buffer,Count,BytesRead,nil)
   then Result:=BytesRead
   else Result:=0;
  end else begin
   // Asynchronous read
   Count:=Min(Count,SizeOf(Async.Buffer));
   Async.Priv.IoError:=0; Async.Priv.HwError:=0; Async.Priv.Lost:=0;
   BytesRead:=0; RxBlock:=0; lpErrors:=0; LastError:=0; lpStat:=Default(ComStat);
   if Async.Pending then begin
    { pending I/O completion, check overlapped I/O status, no wait }
    if GetOverlappedResult(Handle,Async.Overlap,BytesRead,False) then begin
     { I/O operation complete, try to put FIFO and clear pending flag }
     Result:=Min(BytesRead,Count); Async.Priv.Lost:=BytesRead-Result;
     if (Async.Priv.Lost>0) then FixIoError(9); {ue_RxFIFO_OVER}
     if (Result>0) then SafeMove(Async.Buffer,Buffer,Result);
     Async.Pending:=False;
    end else begin
     if GetLastError=ERROR_IO_INCOMPLETE then begin
      { expected result, do nothing, wait I/O completion }
      Result:=0;
     end else begin
      { error, fix it, clear queue and error flag, break pending I/O }
      LastError:=GetLastError; { Save GetLastError to restore in future }
      if ClearCommError(Handle,lpErrors,nil) then FixHwError(lpErrors);
      PurgeComm(Handle,PURGE_Rx);
      SetLastError(LastError);
      Async.Pending:=False;
      {ue_UNEXPECTED}
      FixIoError(12);
      Result:=-1;
     end;
    end;
   end else begin
    { no pending I/O, check receiver queue and read if not empty }
    if ClearCommError(Handle,lpErrors,@lpStat) then begin
     FixHwError(lpErrors);
     RxBlock:=Min(Min(lpStat.cbInQue,SizeOf(Async.Buffer)),Count);
     if (RxBlock>0) then begin
      if ReadFile(Handle,Async.Buffer,RxBlock,BytesRead,@Async.Overlap) then begin
       { read complete immediatly, try to put FIFO and clear pending flag }
       Result:=Min(BytesRead,Count); Async.Priv.Lost:=BytesRead-Result;
       if (Async.Priv.Lost>0) then FixIoError(9); {ue_RxFIFO_OVER}
       if (Result>0) then SafeMove(Async.Buffer,Buffer,Result);
       Async.Pending:=False;
      end else begin
       if GetLastError=ERROR_IO_PENDING then begin
        { expected result, overlapped read, set pending flag }
        Async.Pending:=True;
        Result:=0;
       end else begin
        { error }
        LastError:=GetLastError; { Save GetLastError to restore in future }
        if ClearCommError(Handle,lpErrors,nil) then FixHwError(lpErrors);
        PurgeComm(Handle,PURGE_Rx);
        SetLastError(LastError);
        Async.Pending:=False;
        {ue_UNEXPECTED}
        FixIoError(12);
        Result:=-1;
       end;
      end;
     end;
    end else begin
     {ue_UNEXPECTED}
     FixIoError(12);
     Result:=-1;
    end;
   end;
  end;
 end;
end;

function SerWrite(Handle:TSerialHandle; const Buffer; Count:LongInt; Async:PSerAsyncRec=nil):LongInt;
var BytesWritten,TxBlock,lpErrors,LastError:DWORD; lpStat:ComStat;
 procedure FixIoError(Code:DWORD);
 begin
  Async.Priv.IoError:=Code;
 end;
 procedure FixHwError(Code:DWORD);
 begin
  if (Code<>0) then LiftFlags(Async.Priv.HwError,Code);
 end;
begin
 Result:=0;
 if SerValidHandle(Handle) and (Count>0) then begin
  if (Async=nil) then begin
   // Synchronous write
   BytesWritten:=0;
   if WriteFile(Handle,Buffer,Count,BytesWritten,nil)
   then Result:=BytesWritten
   else Result:=0;
  end else begin
   // Asynchronous write
   Count:=Min(Count,SizeOf(Async.Buffer));
   Async.Priv.IoError:=0; Async.Priv.HwError:=0; Async.Priv.Lost:=0;
   BytesWritten:=0; TxBlock:=0; lpErrors:=0; LastError:=0; lpStat:=Default(ComStat);
   if Async.Pending then begin
    { pending I/O completion, check overlapped I/O status, no wait }
    if GetOverlappedResult(Handle,Async.Overlap,BytesWritten,False) then begin
     { I/O operation complete, fix it and clear pending flag }
     Result:=BytesWritten;
     Async.Pending:=False;
    end else begin
     if GetLastError=ERROR_IO_INCOMPLETE then begin
      { expected result, do nothing, wait I/O completion }
      Result:=0;
     end else begin
      LastError:=GetLastError; { Save GetLastError to restore in future }
      { error, fix it, clear queue and error flag, break pending I/O }
      if ClearCommError(Handle,lpErrors,nil) then FixHwError(lpErrors);
      PurgeComm(Handle,PURGE_Tx);
      SetLastError(LastError);
      Async.Pending:=False;
      {ue_UNEXPECTED}
      FixIoError(12);
      Result:=-1;
     end;
    end;
   end else begin
    if ClearCommError(Handle,lpErrors,@lpStat) then begin
     FixHwError(lpErrors);
     TxBlock:=Min(Count,SizeOf(Async.Buffer));
     if (Async.Stat.PROP.dwCurrentTxQueue>lpStat.cbOutQue) then
     TxBlock:=Min(TxBlock,Async.Stat.PROP.dwCurrentTxQueue-lpStat.cbOutQue);
     if (TxBlock>0) then begin
      SafeMove(Buffer,Async.Buffer,TxBlock);
      if WriteFile(Handle,Async.Buffer,TxBlock,BytesWritten,@Async.Overlap) then begin
       {write immediatly, fix it and clear pending flag}
       Result:=BytesWritten;
       Async.Pending:=False;
      end else begin
       if GetLastError=ERROR_IO_PENDING then begin
        { expected result, set pending flag }
        Async.Pending:=True;
        Result:=0;
       end else begin
        { error }
        LastError:=GetLastError; { Save GetLastError to restore in future }
        if ClearCommError(Handle,lpErrors,nil) then FixHwError(lpErrors);
        PurgeComm(Handle,PURGE_Tx);
        SetLastError(LastError);
        Async.Pending:=False;
        {ue_UNEXPECTED}
        FixIoError(12);
        Result:=-1;
       end;
      end;
     end;
    end else begin
     {ue_UNEXPECTED}
     FixIoError(12);
     Result:=-1;
    end;
   end;
  end;
 end;
end;

function SerGetParams(const State:TSerialState; var BaudRate:LongInt;
  var ByteSize:Integer; var Parity:TSerParityType; var StopBits:TSerStopBits;
  var Flags:TSerialFlags; lpDcbFlags:PDWORD=nil):Boolean;
begin
 Result:=false;
 BaudRate:=State.DCB.BaudRate;
 ByteSize:=State.DCB.ByteSize;
 case State.DCB.Parity of
  Windows.NOPARITY:    Parity:=NoneParity;
  Windows.ODDPARITY:   Parity:=OddParity;
  Windows.EVENPARITY:  Parity:=EvenParity;
  Windows.MARKPARITY:  Parity:=MarkParity;
  Windows.SPACEPARITY: Parity:=SpaceParity;
  else                 Exit;
 end;
 case State.DCB.StopBits of
  Windows.ONESTOPBIT:   StopBits:=ONESTOPBIT;
  Windows.ONE5STOPBITS: StopBits:=ONE5STOPBITS;
  Windows.TWOSTOPBITS:  StopBits:=TWOSTOPBITS;
  else                  Exit;
 end;
 if HasFlags(State.DCB.Flags,dcb_OutxCtsFlow) then Include(Flags,SF_CRTSCTS);
 if (lpDcbFlags<>nil) then lpDcbFlags^:=State.DCB.Flags;
 Result:=true;
end;

function SerSetParams(var State:TSerialState; BaudRate:LongInt;
  ByteSize:Integer; Parity:TSerParityType; StopBits:TSerStopBits;
  Flags:TSerialFlags; DcbFlags:DWORD=0):Boolean;
const
 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;
begin
 Result:=false;
 with State do begin
  FillChar(DCB,SizeOf(DCB),0);
  DCB.DCBlength:=SizeOf(DCB);
  DCB.BaudRate:=BaudRate;
  DCB.ByteSize:=ByteSize;
  DCB.Flags:=(DCB.Flags or dcb_Binary);
  DCB.Flags:=(DCB.Flags or dcb_AbortOnError);
  if (Parity<>NONEPARITY) then DCB.Flags:=(DCB.Flags or dcb_Parity);
  if (SF_IXON in Flags) or (SF_IXOFF in Flags) then begin
   DCB.Flags:=DCB.Flags or dcb_TXContinueOnXOff;
   DCB.Flags:=DCB.Flags or dcb_OutX;
   DCB.Flags:=DCB.Flags or dcb_InX;
  end;
  case Parity of
   NoneParity:  DCB.Parity:=Windows.NOPARITY;
   OddParity:   DCB.Parity:=Windows.ODDPARITY;
   EvenParity:  DCB.Parity:=Windows.EVENPARITY;
   MarkParity:  DCB.Parity:=Windows.MARKPARITY;
   SpaceParity: DCB.Parity:=Windows.SPACEPARITY;
   else         Exit;
  end;
  case StopBits of
   ONESTOPBIT   : DCB.StopBits := Windows.ONESTOPBIT;
   ONE5STOPBITS : DCB.StopBits := Windows.ONE5STOPBITS;
   TWOSTOPBITS  : DCB.StopBits := Windows.TWOSTOPBITS;
   else           Exit;
  end;
  DCB.XonLim:=(SerBuffSize div 4);
  DCB.XoffLim:=(SerBuffSize div 4);
  DCB.XonChar:=ASCII_XON;
  DCB.XoffChar:=ASCII_XOFF;
  DCB.ErrorChar:=ASCII_NUL;
  DCB.EofChar:=ASCII_FS;
  DCB.EvtChar:=ASCII_CR;
  if (SF_CRTSCTS in Flags)
  then DCB.Flags:=DCB.Flags or dcb_OutxCtsFlow or
                (dcb_RtsControl and (RTS_CONTROL_HANDSHAKE shl 12));
  DcbFlags:=DcbFlags and not DCB.Flags;
  if (DcbFlags<>0) then DCB.Flags:=DCB.Flags or DcbFlags;
 end;
 Result:=true;
end;

function SerSetParams(Handle:TSerialHandle; const State:TSerialState):Boolean;
var RxQ,TxQ:DWORD; PROP:TCOMMPROP;
begin
 Result:=true;
 if not SerValidHandle(Handle) then Exit(false);
 if not SetCommState(Handle,State.DCB) then Result:=false;
 if not SerHasNonBlockFlag(Handle) then
 if not SerSetNonBlockFlag(Handle) then Result:=false;
 // setup Rx & Tx queue size
 SafeFillChar(PROP,SizeOf(PROP),0);
 RxQ:=SerBuffSize; TxQ:=SerBuffSize;
 if not GetCommProperties(Handle,PROP) then Result:=false else begin
  if PROP.dwMaxRxQueue>0 then RxQ:=Min(RxQ,PROP.dwMaxRxQueue);
  if PROP.dwMaxTxQueue>0 then TxQ:=Min(TxQ,PROP.dwMaxTxQueue);
  if not SetupComm(Handle,RxQ,TxQ) then Result:=false;
 end;
end;

function SerSaveState(Handle:TSerialHandle):TSerialState;
begin
 SafeFillChar(Result,SizeOf(Result),0);
 if not GetCommState(Handle,Result.DCB)
 then SafeFillChar(Result.DCB,SizeOf(Result.DCB),0);
 if not GetCommTimeouts(Handle,Result.TIMEOUTS)
 then SafeFillChar(Result.TIMEOUTS,SizeOf(Result.TIMEOUTS),0);
 if not GetCommProperties(Handle,Result.PROP)
 then SafeFillChar(Result.PROP,SizeOf(Result.PROP),0);
 if not GetCommMask(Handle,Result.MASK)
 then Result.MASK:=0;
end;

function SerRestoreState(Handle:TSerialHandle; const State:TSerialState):Boolean;
begin
 Result:=SetCommState(Handle,State.DCB);
 Result:=Result and SetCommMask(Handle,State.MASK);
 Result:=Result and SetCommTimeouts(Handle,State.TIMEOUTS);
end;

// 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;

function SerSetDTR(Handle:TSerialHandle; State:Boolean):Boolean;
var dcb:TDCB;
begin
 Result:=false;
 SafeFillChar(dcb,SizeOf(dcb),0);
 if GetCommState(Handle,dcb) then begin
  if State
  then merge2Bits(dcb.Flags,4,DTR_CONTROL_ENABLE)
  else merge2Bits(dcb.Flags,4,DTR_CONTROL_DISABLE);
  Result:=SetCommState(Handle,dcb);
 end;
end;

function SerSetRTS(Handle:TSerialHandle; State:Boolean):Boolean;
var dcb:TDCB;
begin
 Result:=false;
 SafeFillChar(dcb,SizeOf(dcb),0);
 if GetCommState(Handle,dcb) then begin
  if State
  then merge2Bits(dcb.Flags,12,RTS_CONTROL_ENABLE)
  else merge2Bits(dcb.Flags,12,RTS_CONTROL_DISABLE);
  Result:=SetCommState(Handle,dcb);
 end;
end;

function SerGetDTR(Handle:TSerialHandle):Boolean;
var dcb:TDCB;
begin
 Result:=false;
 SafeFillChar(dcb,SizeOf(dcb),0);
 if not GetCommState(Handle,dcb) then Exit;
 Result:=((dcb.Flags and dcb_DtrControlMask)=dcb_DtrControlEnable);
end;

function SerGetRTS(Handle:TSerialHandle):Boolean;
var dcb:TDCB;
begin
 Result:=false;
 SafeFillChar(dcb,SizeOf(dcb),0);
 if not GetCommState(Handle,dcb) then Exit;
 Result:=((dcb.Flags and dcb_RtsControlMask)=dcb_RtsControlEnable);
end;

function SerGetCTS(Handle:TSerialHandle):Boolean;
var status:DWORD;
begin
 status:=0;
 if GetCommModemStatus(Handle,status)
 then Result:=HasFlags(status,MS_CTS_ON)
 else Result:=false;
end;

function SerGetDSR(Handle:TSerialHandle):Boolean;
var status:DWORD;
begin
 status:=0;
 if GetCommModemStatus(Handle,status)
 then Result:=HasFlags(status,MS_DSR_ON)
 else Result:=false;
end;

function SerGetCD(Handle:TSerialHandle):Boolean;
var status:DWORD;
begin
 status:=0;
 if GetCommModemStatus(Handle,status)
 then Result:=HasFlags(status,MS_RLSD_ON)
 else Result:=false;
end;

function SerGetRI(Handle:TSerialHandle):Boolean;
var status:DWORD;
begin
 status:=0;
 if GetCommModemStatus(Handle,status)
 then Result:=HasFlags(status,MS_RING_ON)
 else Result:=false;
end;

procedure SerBreak(Handle:TSerialHandle; mSec:LongInt=DefSerBreakMs; 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;

function SerReadTimeout(Handle: TSerialHandle; var Buffer; mSec: LongInt): LongInt;
var BytesRead:DWORD; Timeouts:TCommTimeouts;
begin
 SafeFillChar(Timeouts,SizeOf(Timeouts),0);
 if GetCommTimeouts(Handle,Timeouts) then begin
  Timeouts.ReadIntervalTimeout:=0;
  Timeouts.ReadTotalTimeoutConstant:=mSec;
  SetCommTimeouts(Handle,Timeouts);
 end;
 BytesRead:=0;
 if ReadFile(Handle,Buffer,1,BytesRead,nil)
 then Result:=BytesRead
 else Result:=0;
end;

function SerReadTimeout(Handle:TSerialHandle; var Buffer:array of Byte; Count,mSec:LongInt):LongInt;
var BytesRead:DWORD; Timeouts:TCommTimeouts;
begin
 SafeFillChar(Timeouts,SizeOf(Timeouts),0);
 if GetCommTimeouts(Handle,Timeouts) then begin
  Timeouts.ReadIntervalTimeout:=0;
  Timeouts.ReadTotalTimeoutConstant:=mSec;
  SetCommTimeouts(Handle,Timeouts);
 end;
 BytesRead:=0;
 if ReadFile(Handle,Buffer[0],Count,BytesRead,nil)
 then Result:=BytesRead
 else Result:=0;
end;

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

 ///////////////////////////////////////////////////////////////////////////////
 // Known serial devices (from several Lazarus libraries):
 //  ttyS     - legacy COM Ports
 //  ttyMI    - multi port cards by MOXA
 //  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/cua        5   64-67     serial:callout
 //  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;ttyMI;ttyMP;ttyADV;ttyAP;vttyAP;ttyr;ttyACM;ttyUSB;rfcomm;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 SerPortPathPrefix:LongString;
begin
 {$IFDEF UNIX}    Result:='/dev/'; {$ENDIF ~UNIX}
 {$IFDEF WINDOWS} Result:='\\.\';  {$ENDIF ~WINDOWS}
end;

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

{$IFDEF UNIX}
function ReadProcTtyDriversSerial(Delim:Char=';'):LongString;
var i:Integer; Lines:TStringList; FileName,Line,dev,typ:LongString;
begin
 Result:='';
 FileName:='/proc/tty/drivers';
 if FileExists(FileName) then
 try
  Lines:=TStringList.Create;
  try
   StringsLoadFromFile(Lines,FileName);
   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,SerDelims)>0) then
    if (Pos(SerPortPathPrefix,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}

{$IFDEF UNIX}
function ReadSysClassTtyDeviceDriver(const BaseName:LongString):LongString;
var Lines:TStringList; FileName:LongString;
begin
 Result:='';
 FileName:='/sys/class/tty/'+Trim(BaseName)+'/device/uevent';
 if (Trim(BaseName)<>'') then
 if FileExists(FileName) then
 try
  Lines:=TStringList.Create;
  try
   StringsLoadFromFile(Lines,FileName);
   Result:=Lines.Values['DRIVER'];
  finally
   Lines.Free;
  end;
 except
  on E:Exception do BugReport(E,nil,'ReadSysClassTtyDeviceDriver');
 end;
end;
{$ENDIF ~UNIX}

{$IFDEF WINDOWS}
function ReadProcTtyDriversSerial(Delim:Char=';'):LongString;
begin
 Result:='';
end;
function ReadSysClassTtyDeviceDriver(const BaseName:LongString):LongString;
begin
 Result:='serial';
end;
{$ENDIF ~WINDOWS}

function SerPortSearchList(Delim:Char=';'):LongString;
var Lines:TStringList; List,Item:LongString; i:Integer;
begin
 Result:='';
 try
  Lines:=TStringList.Create;
  try
   List:=StdPortSearchList{$IFDEF UNIX}+';'+ReadProcTtyDriversSerial{$ENDIF};
   for i:=1 to WordCount(List,SerDelims) do begin
    Item:=ExtractWord(i,List,SerDelims);
    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;

const ThePortSearchList:LongString='';
function CurPortSearchList:LongString;
begin
 if (ThePortSearchList='') then ThePortSearchList:=SerPortSearchList;
 Result:=ThePortSearchList;
end;

function SerPortCompare(List:TStringList; Index1,Index2:Integer):Integer;
var S1,S2,SP1,SP2,SD1,SD2,SN1,SN2,PSL:LongString; p,N1,N2,WI1,WI2:Integer;
const Big=1024;
begin
 Result:=0;
 PSL:=CurPortSearchList;
 S1:=List[Index1]; S2:=List[Index2]; if SameStr(S1,S2) then Exit;
 p:=Length(S1); while (p>0) and (S1[p] in ['0'..'9']) do Dec(p);
 SP1:=Copy(S1,1,p); N1:=StrToIntDef(Copy(S1,p+1,Length(S1)-p),0);
 p:=Length(S2); while (p>0) and (S2[p] in ['0'..'9']) do Dec(p);
 SP2:=Copy(S2,1,p); N2:=StrToIntDef(Copy(S2,p+1,Length(S2)-p),0);
 if SameStr(SP1,SP2) then begin Result:=Sign(N1-N2); Exit; end;
 SD1:=ExtractFileDir(SP1);  SD2:=ExtractFileDir(SP2);
 if SameText(SD1,SD2) then begin
  SN1:=ExtractFileName(SP1); SN2:=ExtractFileName(SP2);
  WI1:=WordIndex(SN1,PSL,SerDelims); if (WI1=0) then WI1:=Big;
  WI2:=WordIndex(SN2,PSL,SerDelims); if (WI2=0) then WI2:=Big;
  if (WI1<>WI2) then begin Result:=Sign(WI1-WI2); Exit; end;
 end;
 Result:=CompareStr(SP1,SP2);
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.CustomSort(SerPortCompare);
   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;
 procedure ScanForPorts(const ThisRootStr:LongString; Special:Boolean);
 var dev:LongString; fd:TSerialHandle;
     {$IFNDEF DARWIN}Ser:TSerialStruct;{$ENDIF}
 begin
  if fpSucceed(FindFirst(ThisRootStr,Flags,SR)) then
  try
   repeat
    if ((SR.Attr and Flags)=SR.Attr) then begin
     dev:=SerPortFullPath(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 fpSucceed(fpioctl(FD,TIOCEXCL,nil)) then Ports.Add(dev);
       {$ELSE}
       if fpSucceed(fpioctl(fd,TIOCGSERIAL,@Ser)) 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;
 procedure TestPorts;
 var i:Integer;
 begin
  Ports.Text:=''; // Test of sorting
  for i:=0 to 31 do Ports.Add('/dev/ttyACM'+IntToStr(31-i));
  for i:=0 to 31 do Ports.Add('/dev/ttyMP'+IntToStr(31-i));
  for i:=0 to 31 do Ports.Add('/dev/ttyr'+IntToStr(31-i));
  for i:=0 to 31 do Ports.Add('/dev/ttyUSB'+IntToStr(31-i));
  for i:=0 to 31 do Ports.Add('/dev/ttyS'+IntToStr(31-i));
  for i:=0 to 31 do Ports.Add('/dev/ttyMI'+IntToStr(31-i));
 end;
begin
 Result:='';
 try
  Ports:=TStringList.Create;
  try
   SpecList:=SerPortSpecList;
   PrefList:=SerPortSearchList;
   Ports.Duplicates:=dupIgnore;
   Flags:=faAnyFile and not faDirectory;
   TryOpenDevice:=not HasFlags(Mode,spnm_NotTryOpen);
   for i:=1 to WordCount(PrefList,SerDelims) do begin
    Pref:=ExtractWord(i,PrefList,SerDelims);
    Spec:=(WordIndex(Pref,SpecList,SerDelims)>0);
    ScanForPorts(SerPortFullPath(Pref+'*'),Spec);
   end;
   // TestPorts; // <= To test sort.
   Ports.CustomSort(SerPortCompare);
   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}

 //////////////
 // TSerPortMap
 //////////////

constructor TSerPortMap.Create;
begin
 inherited Create;
 myMap:=NewHashList(false,HashList_DefaultHasher);
 myMap.Master:=@myMap;
 Update;
end;

destructor TSerPortMap.Destroy;
begin
 Clear;
 Kill(myMap);
 inherited Destroy;
end;

function TSerPortMap.GetComName(n:Integer):LongString;
begin
 Result:='';
 if Assigned(Self) then
 if (n>=Low(TSerPortNums)) then
 if (n<=High(TSerPortNums)) then Result:='COM'+IntToStr(n);
end;

function TSerPortMap.GetBaseName(n:Integer):LongString;
begin
 Result:='';
 if Assigned(Self) then
 if (n>=Low(TSerPortNums)) then
 if (n<=High(TSerPortNums)) then
 try
  Lock;
  Result:=myBaseName[n];
 finally
  Unlock;
 end;
end;

function TSerPortMap.GetPathName(n:Integer):LongString;
begin
 Result:='';
 if Assigned(Self) then
 if (n>=Low(TSerPortNums)) then
 if (n<=High(TSerPortNums)) then
 try
  Lock;
  Result:=myPathName[n];
 finally
  Unlock;
 end;
end;

function TSerPortMap.GetDriverID(n:Integer):LongString;
begin
 Result:='';
 if Assigned(Self) then
 if (n>=Low(TSerPortNums)) then
 if (n<=High(TSerPortNums)) then
 try
  Lock;
  Result:=myDriverID[n];
 finally
  Unlock;
 end;
end;

function TSerPortMap.Count:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  Result:=Length(myList.Ports);
 finally
  Unlock;
 end;
end;

function TSerPortMap.ListPorts:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  Result:=myList.Ports;
 finally
  Unlock;
 end;
end;

function TSerPortMap.ListComNames(const aDelim:LongString=EOL):LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  Result:=myList.ComNames;
 finally
  Unlock;
 end;
 if (aDelim=EOL) then Exit;
 Result:=StringReplace(TrimRight(Result),EOL,aDelim,[rfReplaceAll]);
end;

function TSerPortMap.ListBaseNames(const aDelim:LongString=EOL):LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  Result:=myList.BaseNames;
 finally
  Unlock;
 end;
 if (aDelim=EOL) then Exit;
 Result:=StringReplace(TrimRight(Result),EOL,aDelim,[rfReplaceAll]);
end;

function TSerPortMap.ListPathNames(const aDelim:LongString=EOL):LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  Result:=myList.PathNames;
 finally
  Unlock;
 end;
 if (aDelim=EOL) then Exit;
 Result:=StringReplace(TrimRight(Result),EOL,aDelim,[rfReplaceAll]);
end;

function TSerPortMap.PortNum(const aPathName:LongString):Integer;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  Result:=myMap.KeyedLinks[aPathName];
 finally
  Unlock;
 end;
end;

function DetectDriverName(const BaseName:LongString):LongString;
begin
 {$IFDEF UNIX}
 Result:=Trim(ReadSysClassTtyDeviceDriver(BaseName));
 if (Result='') then Result:='unknown';
 {$ELSE}
 Result:='serial';
 {$ENDIF ~UNIX}
end;

function TSerPortMap.AddPort(aNum:Integer; aName:LongString):Boolean;
var aPath,cName:LongString; n:Integer;
begin
 Result:=false;
 if Assigned(Self) then
 if IsNonEmptyStr(aName) then
 if InRange(aNum,Low(TSerPortNums),High(TSerPortNums)) then
 try
  Lock;
  cName:='COM'+IntToStr(aNum);
  aName:=ExtractBaseName(Trim(aName));
  aPath:=SerPortFullPath(Trim(aName));
  myMap.KeyedLinks[aName]:=aNum;
  myMap.KeyedLinks[aPath]:=aNum;
  myMap.KeyedLinks[cName]:=aNum;
  myBaseName[aNum]:=aName;
  myPathName[aNum]:=aPath;
  myDriverID[aNum]:=DetectDriverName(aName);
  myList.Ports:='';
  for n:=Low(TSerPortNums) to High(TSerPortNums) do
  if (myBaseName[n]<>'') then myList.Ports:=myList.Ports+Chr(n);
  myList.BaseNames:=myList.BaseNames+aName+EOL;
  myList.PathNames:=myList.PathNames+aPath+EOL;
  myList.ComNames:=myList.ComNames+cName+EOL;
 finally
  Unlock;
 end;
end;

procedure TSerPortMap.Clear;
var n:Integer;
begin
 if Assigned(Self) then
 try
  Lock;
  ThePortSearchList:='';
  for n:=Low(TSerPortNums) to High(TSerPortNums) do myBaseName[n]:='';
  for n:=Low(TSerPortNums) to High(TSerPortNums) do myPathName[n]:='';
  for n:=Low(TSerPortNums) to High(TSerPortNums) do myDriverID[n]:='';
  myList.Ports:=''; myList.BaseNames:=''; myList.PathNames:='';
  myList.ComNames:='';
  myMap.Clear;
 finally
  Unlock;
 end;
end;

procedure TSerPortMap.Update;
var aList,aItem:LongString; i,n,p:Integer;
begin
 if Assigned(Self) then
 try
  Lock;
  Clear; aList:=GetSerialPortNames;
  for i:=1 to WordCount(aList,SerDelims) do begin
   aItem:=ExtractWord(i,aList,SerDelims); n:=i;
   if IsWindows then begin
    p:=PosI('COM',aItem); if (p=0) then continue;
    n:=StrToIntDef(Copy(aItem,p+3,3),0);
    if (n=0) then continue;
   end;
   AddPort(n,aItem);
  end;
 finally
  Unlock;
 end;
end;

function TSerPortMap.Table(const aPrefix:LongString='COM'; aBase:Boolean=false):LongString;
var i,n,iter,w1,w2:Integer; Lines:TStringList; Line,Driver:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lines:=TStringList.Create;
  try
   Lock;
   w1:=1; w2:=1;
   for iter:=1 to 2 do
   for i:=1 to Length(myList.Ports) do begin
    n:=Ord(myList.Ports[i]); Driver:=DriverID[n];
    if aBase then Line:=BaseName[n] else Line:=PathName[n];
    w1:=Max(w1,Length(IntToStr(n))); w2:=Max(w2,Length(Line));
    Line:=Format('%s%-*d  %-*s  %s',[aPrefix,w1,n,w2,Line,Driver]);
    if (iter=2) then Lines.Add(TrimRight(Line));
   end;
   Result:=Lines.Text;
  finally
   Unlock;
   Lines.Free;
  end;
 except
  on E:Exception do BugReport(E,nil,'Table');
 end;
end;

////////////////////////////
// SerPortMap implementation
////////////////////////////

const
 TheSerPortMap:TSerPortMap=nil;

function SerPortMap:TSerPortMap;
begin
 if not Assigned(TheSerPortMap) then begin
  TheSerPortMap:=TSerPortMap.Create;
  TheSerPortMap.Master:=@TheSerPortMap;
 end;
 Result:=TheSerPortMap;
end;

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

procedure Init_crw_serio;
begin
 // SerPortMap.Ok;
 ThePortSearchList:='';
end;

procedure Free_crw_serio;
begin
 TheSerPortMap.Free;
 ThePortSearchList:='';
end;

initialization

 Init_crw_serio;

finalization

 Free_crw_serio;

end.

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

