{ Unit for handling the serial interfaces for Win32.
  (c) 2007 Luis R. Hilario B., luisdigital@gmail.com
Some differences:

Linux:
TSerialState = record
   LineState: LongWord;
   tios: termios;
 end;

Windows:
TSerialState = record
   LineState: LongWord;
   DCB: TDCB;
 end;

BitsPerSec now is Windows const. CBR_110...

procedure SerRestoreState(Handle: TSerialHandle; State: TSerialState);
Restore only DCB.

There is an error in the description of the version in Linux:

Returns "0" if device could not be found
function SerOpen(const DeviceName: String): TSerialHandle;

Really is -1}

{2008-07-12

Changes to enhance the windows serial unit and pave
the way for cross-platform usage.

TSerialFlag has been introduced because the flags
should not normally be mixed.

The following flow control options are available:
  None
  Xon/Xoff
  RTS/CTS
  DTR/DSR

TSerialFlags was left for compatibility reasons. It could be abolished
in the future.

Procedure SerSet was overloaded to use both TSerialFlag and TSerialFlags.

If a port fails to open, SerOpen will return UnusedHandle to
have multiplatform compatibility.

There are 2 constants in unit rtl\win\wininc\struct.inc
that seem to be wrongly declared:
  bm_DCB_fRtsControl = $3000. It should be $2000.
  bm_DCB_fDtrControl = $30. It should be $20.

When these are corrected, the -$1000 and -$10 in the code
below should be removed accordingly.
}

unit serial;

{$MODE objfpc}
{$H+}
{$PACKRECORDS C}

interface

uses Windows;

type

  TSerialHandle = THandle;

  TParityType = (NoneParity, OddParity, EvenParity);

  TSerialFlag = (NoneFlowControl, XOnXOffFlowControl, RtsCtsFlowControl, DtrDsrFlowControl);

  TSerialFlags = set of TSerialFlag;

  TSerialState = record
    LineState: LongWord;
    DCB: TDCB;
  end;


{ Open the serial device with the given device name, for example:
    COM1, COM2... for normal serial ports
    other device names are possible; refer to your OS documentation.
  Returns "INVALID_HANDLE_VALUE" if device could not be found }
function SerOpen(const DeviceName: String): TSerialHandle;

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

{ Flushes the data queues of the given serial device. }
procedure SerFlush(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;

{ Tries to write "Count" bytes from "Buffer".
  Result: Number of bytes written. }
function SerWrite(Handle: TSerialHandle; var Buffer; Count: LongInt): LongInt;

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

procedure SerSetParams(Handle: TSerialHandle; BitsPerSec: LongInt;
  ByteSize: Integer; Parity: TParityType; StopBits: Integer;
  Flag: TSerialFlag); overload;

{ 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 SerGetRI(Handle: TSerialHandle): Boolean;


{ ************************************************************************** }

implementation


function SerOpen(const DeviceName: String): TSerialHandle;
begin
  Result := CreateFile(PChar('\\.\' + DeviceName),
                       GENERIC_READ or GENERIC_WRITE,
                       0,
                       Nil,
                       OPEN_EXISTING,
                       FILE_ATTRIBUTE_NORMAL,
                       0);
//  The following line may be redundant, but makes
//  both Unix and Win units return a cross
//  platform constant
  if Result = INVALID_HANDLE_VALUE then
     Result := UnusedHandle;
end;

procedure SerClose(Handle: TSerialHandle);
begin
  CloseHandle(Handle);
end;

procedure SerFlush(Handle: TSerialHandle);
begin
  FlushFileBuffers(Handle);
end;

function SerRead(Handle: TSerialHandle; var Buffer; Count: LongInt): LongInt;
begin
  if not ReadFile(Handle, Buffer, Count, DWord(Result), Nil) then Result := -1
end;

function SerWrite(Handle: TSerialHandle; var Buffer; Count: LongInt): LongInt;
begin
  if not WriteFile(Handle, Buffer, Count, DWord(Result), Nil) then Result := -1
end;

procedure SerSetParams(Handle: TSerialHandle; BitsPerSec: LongInt;
  ByteSize: Integer; Parity: TParityType; StopBits: Integer;
  Flag: TSerialFlag);
begin
  SerSetParams(Handle, BitsPerSec, ByteSize, Parity, StopBits, [Flag]);
end;
  
procedure SerSetParams(Handle: TSerialHandle; BitsPerSec: LongInt;
  ByteSize: Integer; Parity: TParityType; StopBits: Integer;
  Flags: TSerialFlags);
var
  DCB: TDCB;
  COMMTIMEOUTS: TCOMMTIMEOUTS;

begin
  FillChar(COMMTIMEOUTS, SizeOf(COMMTIMEOUTS), #0);
  COMMTIMEOUTS.ReadIntervalTimeout := MAXDWORD;

  FillChar(DCB, SizeOf(DCB), #0);
  DCB.DCBLength := SizeOf(DCB);

  DCB.Flags := bm_DCB_fBinary;

  case BitsPerSec of
    110: DCB.BaudRate := CBR_110;
    300: DCB.BaudRate := CBR_300;
    600: DCB.BaudRate := CBR_600;
    1200: DCB.BaudRate := CBR_1200;
    2400: DCB.BaudRate := CBR_2400;
    4800: DCB.BaudRate := CBR_4800;
    14400: DCB.BaudRate := CBR_14400;
    19200: DCB.BaudRate := CBR_19200;
    38400: DCB.BaudRate := CBR_38400;
    56000: DCB.BaudRate := CBR_56000;
    57600: DCB.BaudRate := CBR_57600;
    115200: DCB.BaudRate := CBR_115200;
    128000: DCB.BaudRate := CBR_128000;
    256000: DCB.BaudRate := CBR_256000;
    else DCB.BaudRate := CBR_9600;
  end;

  if ByteSize in[4..7] then DCB.ByteSize := ByteSize
   else
     DCB.ByteSize := 8;

  case Parity Of
    NoneParity: DCB.Parity := windows.NOPARITY;
    EvenParity: DCB.Parity := windows.EVENPARITY;
    OddParity:  DCB.Parity := windows.ODDPARITY;
  end;
  //DCB.Parity := Ord(Parity);

  if StopBits = 2 then DCB.StopBits := TWOSTOPBITS
  else DCB.StopBits := ONESTOPBIT;

  if RtsCtsFlowControl in Flags then
    DCB.Flags := DCB.Flags or bm_DCB_fOutxCtsFlow or (bm_DCB_fRtsControl -$1000);
  if DtrDsrFlowControl in Flags then
    DCB.Flags := DCB.Flags or bm_DCB_fOutxDsrFlow or (bm_DCB_fDtrControl -$10);
  if XOnXOffFlowControl in Flags then
    DCB.Flags := DCB.Flags or bm_DCB_fOutX or bm_DCB_fInX;

  PurgeComm(Handle, PURGE_TXCLEAR or PURGE_RXCLEAR);
  SetCommState(Handle, DCB);
  SetCommTimeouts(Handle, COMMTIMEOUTS);
end;

function SerSaveState(Handle: TSerialHandle): TSerialState;
begin
  GetCommModemStatus(Handle, Result.LineState);
  GetCommState(Handle, Result.DCB);
end;

procedure SerRestoreState(Handle: TSerialHandle; State: TSerialState);
begin
  SetCommState(Handle, State.DCB);
end;

procedure SerSetDTR(Handle: TSerialHandle; State: Boolean);
begin
  if State then
    EscapeCommFunction(Handle, SETDTR)
  else
    EscapeCommFunction(Handle, CLRDTR);
end;

procedure SerSetRTS(Handle: TSerialHandle; State: Boolean);
begin
  if State then
    EscapeCommFunction(Handle, SETRTS)
  else
    EscapeCommFunction(Handle, CLRRTS);
end;

function SerGetCTS(Handle: TSerialHandle): Boolean;
var
  Flags: Cardinal;
begin
  GetCommModemStatus(Handle, Flags);
  Result := (Flags and MS_CTS_ON) <> 0;
end;

function SerGetDSR(Handle: TSerialHandle): Boolean;
var
  Flags: Cardinal;
begin
  GetCommModemStatus(Handle, Flags);
  Result := (Flags and MS_DSR_ON) <> 0;
end;

function SerGetRI(Handle: TSerialHandle): Boolean;
var
  Flags: Cardinal;
begin
  GetCommModemStatus(Handle, Flags);
  Result := (Flags and MS_RING_ON) <> 0;
end;


end.
