pascal/synapse
1
0
Fork 0
Code Issues Releases Activity
c7bb56ed0f
synapse/synaser.pas
geby c7c54cd9df Changes for Delphi 2009 compatibility. 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@95 7c85be65-684b-0410-a082-b2ed4fbef004
2008-10-02 11:08:41 +00:00

2299 lines
66 KiB
ObjectPascal
Raw Blame History

{==============================================================================|
| Project : Ararat Synapse | 007.003.000 |
|==============================================================================|
| Content: Serial port support |
|==============================================================================|
| Copyright (c)2001-2008, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2008. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| (c)2002, Hans-Georg Joepgen (cpom Comport Ownership Manager and bugfixes) |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{: @abstract(Serial port communication library)
This unit contains a class that implements serial port communication for Windows
or Linux. This class provides numerous methods with same name and functionality
as methods of the Ararat Synapse TCP/IP library.
The following is a small example how establish a connection by modem (in this
case with my USB modem):
@longcode(#
ser:=TBlockSerial.Create;
try
ser.Connect('COM3');
ser.config(460800,8,'N',0,false,true);
ser.ATCommand('AT');
if (ser.LastError <> 0) or (not ser.ATResult) then
Exit;
ser.ATConnect('ATDT+420971200111');
if (ser.LastError <> 0) or (not ser.ATResult) then
Exit;
// you are now connected to a modem at +420971200111
// you can transmit or receive data now
finally
ser.free;
end;
#)
}
{$IFDEF FPC}
{$MODE DELPHI}
{$IFDEF WIN32}
{$ASMMODE intel}
{$ENDIF}
{define working mode w/o LIBC for fpc}
{$DEFINE NO_LIBC}
{$ENDIF}
{$Q-}
{$H+}
{$M+}
unit synaser;
interface
uses
{$IFNDEF WIN32}
{$IFNDEF NO_LIBC}
Libc,
KernelIoctl,
{$ELSE}
termio, baseunix, unix,
{$ENDIF}
{$IFNDEF FPC}
Types,
{$ENDIF}
{$ELSE}
Windows, registry,
{$IFDEF FPC}
winver,
{$ENDIF}
{$ENDIF}
synafpc,
Classes, SysUtils, synautil;
const
CR = #$0d;
LF = #$0a;
CRLF = CR + LF;
cSerialChunk = 8192;
LockfileDirectory = '/var/lock'; {HGJ}
PortIsClosed = -1; {HGJ}
ErrAlreadyOwned = 9991; {HGJ}
ErrAlreadyInUse = 9992; {HGJ}
ErrWrongParameter = 9993; {HGJ}
ErrPortNotOpen = 9994; {HGJ}
ErrNoDeviceAnswer = 9995; {HGJ}
ErrMaxBuffer = 9996;
ErrTimeout = 9997;
ErrNotRead = 9998;
ErrFrame = 9999;
ErrOverrun = 10000;
ErrRxOver = 10001;
ErrRxParity = 10002;
ErrTxFull = 10003;
dcb_Binary = $00000001;
dcb_ParityCheck = $00000002;
dcb_OutxCtsFlow = $00000004;
dcb_OutxDsrFlow = $00000008;
dcb_DtrControlMask = $00000030;
dcb_DtrControlDisable = $00000000;
dcb_DtrControlEnable = $00000010;
dcb_DtrControlHandshake = $00000020;
dcb_DsrSensivity = $00000040;
dcb_TXContinueOnXoff = $00000080;
dcb_OutX = $00000100;
dcb_InX = $00000200;
dcb_ErrorChar = $00000400;
dcb_NullStrip = $00000800;
dcb_RtsControlMask = $00003000;
dcb_RtsControlDisable = $00000000;
dcb_RtsControlEnable = $00001000;
dcb_RtsControlHandshake = $00002000;
dcb_RtsControlToggle = $00003000;
dcb_AbortOnError = $00004000;
dcb_Reserveds = $FFFF8000;
{:stopbit value for 1 stopbit}
SB1 = 0;
{:stopbit value for 1.5 stopbit}
SB1andHalf = 1;
{:stopbit value for 2 stopbits}
SB2 = 2;
{$IFNDEF WIN32}
const
INVALID_HANDLE_VALUE = THandle(-1);
CS7fix = $0000020;
type
TDCB = packed record
DCBlength: DWORD;
BaudRate: DWORD;
Flags: Longint;
wReserved: Word;
XonLim: Word;
XoffLim: Word;
ByteSize: Byte;
Parity: Byte;
StopBits: Byte;
XonChar: CHAR;
XoffChar: CHAR;
ErrorChar: CHAR;
EofChar: CHAR;
EvtChar: CHAR;
wReserved1: Word;
end;
PDCB = ^TDCB;
const
// MaxRates = 30;
MaxRates = 19; //FPC on some platforms not know high speeds?
Rates: array[0..MaxRates, 0..1] of cardinal =
(
(0, B0),
(50, B50),
(75, B75),
(110, B110),
(134, B134),
(150, B150),
(200, B200),
(300, B300),
(600, B600),
(1200, B1200),
(1800, B1800),
(2400, B2400),
(4800, B4800),
(9600, B9600),
(19200, B19200),
(38400, B38400),
(57600, B57600),
(115200, B115200),
(230400, B230400),
(460800, B460800){,
(500000, B500000),
(576000, B576000),
(921600, B921600),
(1000000, B1000000),
(1152000, B1152000),
(1500000, B1500000),
(2000000, B2000000),
(2500000, B2500000),
(3000000, B3000000),
(3500000, B3500000),
(4000000, B4000000)}
);
{$ENDIF}
const
sOK = 0;
sErr = integer(-1);
type
{:Possible status event types for @link(THookSerialStatus)}
THookSerialReason = (
HR_SerialClose,
HR_Connect,
HR_CanRead,
HR_CanWrite,
HR_ReadCount,
HR_WriteCount,
HR_Wait
);
{:procedural prototype for status event hooking}
THookSerialStatus = procedure(Sender: TObject; Reason: THookSerialReason;
const Value: string) of object;
{:@abstract(Exception type for SynaSer errors)}
ESynaSerError = class(Exception)
public
ErrorCode: integer;
ErrorMessage: string;
end;
{:@abstract(Main class implementing all communication routines)}
TBlockSerial = class(TObject)
protected
FOnStatus: THookSerialStatus;
Fhandle: THandle;
FTag: integer;
FDevice: string;
FLastError: integer;
FLastErrorDesc: string;
FBuffer: string;
FRaiseExcept: boolean;
FRecvBuffer: integer;
FSendBuffer: integer;
FModemWord: integer;
FRTSToggle: Boolean;
FDeadlockTimeout: integer;
FInstanceActive: boolean; {HGJ}
FTestDSR: Boolean;
FTestCTS: Boolean;
FLastCR: Boolean;
FLastLF: Boolean;
FMaxLineLength: Integer;
FLinuxLock: Boolean;
FMaxSendBandwidth: Integer;
FNextSend: LongWord;
FMaxRecvBandwidth: Integer;
FNextRecv: LongWord;
FConvertLineEnd: Boolean;
FATResult: Boolean;
FAtTimeout: integer;
FInterPacketTimeout: Boolean;
FComNr: integer;
{$IFDEF WIN32}
FPortAddr: Word;
function CanEvent(Event: dword; Timeout: integer): boolean;
procedure DecodeCommError(Error: DWord); virtual;
function GetPortAddr: Word; virtual;
function ReadTxEmpty(PortAddr: Word): Boolean; virtual;
{$ENDIF}
procedure SetSizeRecvBuffer(size: integer); virtual;
function GetDSR: Boolean; virtual;
procedure SetDTRF(Value: Boolean); virtual;
function GetCTS: Boolean; virtual;
procedure SetRTSF(Value: Boolean); virtual;
function GetCarrier: Boolean; virtual;
function GetRing: Boolean; virtual;
procedure DoStatus(Reason: THookSerialReason; const Value: string); virtual;
procedure GetComNr(Value: string); virtual;
function PreTestFailing: boolean; virtual;{HGJ}
function TestCtrlLine: Boolean; virtual;
{$IFNDEF WIN32}
procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual;
procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual;
{$ENDIF}
{$IFDEF LINUX}
function ReadLockfile: integer; virtual;
function LockfileName: String; virtual;
procedure CreateLockfile(PidNr: integer); virtual;
{$ENDIF}
procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); virtual;
procedure SetBandwidth(Value: Integer); virtual;
public
{: data Control Block with communication parameters. Usable only when you
need to call API directly.}
DCB: Tdcb;
{$IFNDEF WIN32}
TermiosStruc: termios;
{$ENDIF}
{:Object constructor.}
constructor Create;
{:Object destructor.}
destructor Destroy; override;
{:Returns a string containing the version number of the library.}
class function GetVersion: string; virtual;
{:Destroy handle in use. It close connection to serial port.}
procedure CloseSocket; virtual;
{:Reconfigure communication parameters on the fly. You must be connected to
port before!
@param(baud Define connection speed. Baud rate can be from 50 to 4000000
bits per second. (it depends on your hardware!))
@param(bits Number of bits in communication.)
@param(parity Define communication parity (N - None, O - Odd, E - Even, M - Mark or S - Space).)
@param(stop Define number of stopbits. Use constants @link(SB1),
@link(SB1andHalf) and @link(SB2).)
@param(softflow Enable XON/XOFF handshake.)
@param(hardflow Enable CTS/RTS handshake.)}
procedure Config(baud, bits: integer; parity: char; stop: integer;
softflow, hardflow: boolean); virtual;
{:Connects to the port indicated by comport. Comport can be used in Windows
style (COM2), or in Linux style (/dev/ttyS1). When you use windows style
in Linux, then it will be converted to Linux name. And vice versa! However
you can specify any device name! (other device names then standart is not
converted!)
After successfull connection the DTR signal is set (if you not set hardware
handshake, then the RTS signal is set, too!)
Connection parameters is predefined by your system configuration. If you
need use another parameters, then you can use Config method after.
Notes:
- Remember, the commonly used serial Laplink cable does not support
hardware handshake.
- Before setting any handshake you must be sure that it is supported by
your hardware.
- Some serial devices are slow. In some cases you must wait up to a few
seconds after connection for the device to respond.
- when you connect to a modem device, then is best to test it by an empty
AT command. (call ATCommand('AT'))}
procedure Connect(comport: string); virtual;
{:Set communication parameters from the DCB structure (the DCB structure is
simulated under Linux).}
procedure SetCommState; virtual;
{:Read communication parameters into the DCB structure (DCB structure is
simulated under Linux).}
procedure GetCommState; virtual;
{:Sends Length bytes of data from Buffer through the connected port.}
function SendBuffer(buffer: pointer; length: integer): integer; virtual;
{:One data BYTE is sent.}
procedure SendByte(data: byte); virtual;
{:Send the string in the data parameter. No terminator is appended by this
method. If you need to send a string with CR/LF terminator, you must append
the CR/LF characters to the data string!
Since no terminator is appended, you can use this function for sending
binary data too.}
procedure SendString(data: string); virtual;
{:send four bytes as integer.}
procedure SendInteger(Data: integer); virtual;
{:send data as one block. Each block begins with integer value with Length
of block.}
procedure SendBlock(const Data: string); virtual;
{:send content of stream from current position}
procedure SendStreamRaw(const Stream: TStream); virtual;
{:send content of stream as block. see @link(SendBlock)}
procedure SendStream(const Stream: TStream); virtual;
{:send content of stream as block, but this is compatioble with Indy library.
(it have swapped lenght of block). See @link(SendStream)}
procedure SendStreamIndy(const Stream: TStream); virtual;
{:Waits until the allocated buffer is filled by received data. Returns number
of data bytes received, which equals to the Length value under normal
operation. If it is not equal, the communication channel is possibly broken.
This method not using any internal buffering, like all others receiving
methods. You cannot freely combine this method with all others receiving
methods!}
function RecvBuffer(buffer: pointer; length: integer): integer; virtual;
{:Method waits until data is received. If no data is received within
the Timeout (in milliseconds) period, @link(LastError) is set to
@link(ErrTimeout). This method is used to read any amount of data
(e. g. 1MB), and may be freely combined with all receviving methods what
have Timeout parameter, like the @link(RecvString), @link(RecvByte) or
@link(RecvTerminated) methods.}
function RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer; virtual;
{:It is like recvBufferEx, but data is readed to dynamicly allocated binary
string.}
function RecvBufferStr(Length: Integer; Timeout: Integer): string; virtual;
{:Read all available data and return it in the function result string. This
function may be combined with @link(RecvString), @link(RecvByte) or related
methods.}
function RecvPacket(Timeout: Integer): string; virtual;
{:Waits until one data byte is received which is returned as the function
result. If no data is received within the Timeout (in milliseconds) period,
@link(LastError) is set to @link(ErrTimeout).}
function RecvByte(timeout: integer): byte; virtual;
{:This method waits until a terminated data string is received. This string
is terminated by the Terminator string. The resulting string is returned
without this termination string! If no data is received within the Timeout
(in milliseconds) period, @link(LastError) is set to @link(ErrTimeout).}
function RecvTerminated(Timeout: Integer; const Terminator: string): string; virtual;
{:This method waits until a terminated data string is received. The string
is terminated by a CR/LF sequence. The resulting string is returned without
the terminator (CR/LF)! If no data is received within the Timeout (in
milliseconds) period, @link(LastError) is set to @link(ErrTimeout).
If @link(ConvertLineEnd) is used, then the CR/LF sequence may not be exactly
CR/LF. See the description of @link(ConvertLineEnd).
This method serves for line protocol implementation and uses its own
buffers to maximize performance. Therefore do NOT use this method with the
@link(RecvBuffer) method to receive data as it may cause data loss.}
function Recvstring(timeout: integer): string; virtual;
{:Waits until four data bytes are received which is returned as the function
integer result. If no data is received within the Timeout (in milliseconds) period,
@link(LastError) is set to @link(ErrTimeout).}
function RecvInteger(Timeout: Integer): Integer; virtual;
{:Waits until one data block is received. See @link(sendblock). If no data
is received within the Timeout (in milliseconds) period, @link(LastError)
is set to @link(ErrTimeout).}
function RecvBlock(Timeout: Integer): string; virtual;
{:Receive all data to stream, until some error occured. (for example timeout)}
procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual;
{:receive requested count of bytes to stream}
procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); virtual;
{:receive block of data to stream. (Data can be sended by @link(sendstream)}
procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual;
{:receive block of data to stream. (Data can be sended by @link(sendstreamIndy)}
procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual;
{:Returns the number of received bytes waiting for reading. 0 is returned
when there is no data waiting.}
function WaitingData: integer; virtual;
{:Same as @link(WaitingData), but in respect to data in the internal
@link(LineBuffer).}
function WaitingDataEx: integer; virtual;
{:Returns the number of bytes waiting to be sent in the output buffer.
0 is returned when the output buffer is empty.}
function SendingData: integer; virtual;
{:Enable or disable RTS driven communication (half-duplex). It can be used
to communicate with RS485 converters, or other special equipment. If you
enable this feature, the system automatically controls the RTS signal.
Notes:
- On Windows NT (or higher) ir RTS signal driven by system driver.
- On Win9x family is used special code for waiting until last byte is
sended from your UART.
- On Linux you must have kernel 2.1 or higher!}
procedure EnableRTSToggle(value: boolean); virtual;
{:Waits until all data to is sent and buffers are emptied.
Warning: On Windows systems is this method returns when all buffers are
flushed to the serial port controller, before the last byte is sent!}
procedure Flush; virtual;
{:Unconditionally empty all buffers. It is good when you need to interrupt
communication and for cleanups.}
procedure Purge; virtual;
{:Returns @True, if you can from read any data from the port. Status is
tested for a period of time given by the Timeout parameter (in milliseconds).
If the value of the Timeout parameter is 0, the status is tested only once
and the function returns immediately. If the value of the Timeout parameter
is set to -1, the function returns only after it detects data on the port
(this may cause the process to hang).}
function CanRead(Timeout: integer): boolean; virtual;
{:Returns @True, if you can write any data to the port (this function is not
sending the contents of the buffer). Status is tested for a period of time
given by the Timeout parameter (in milliseconds). If the value of
the Timeout parameter is 0, the status is tested only once and the function
returns immediately. If the value of the Timeout parameter is set to -1,
the function returns only after it detects that it can write data to
the port (this may cause the process to hang).}
function CanWrite(Timeout: integer): boolean; virtual;
{:Same as @link(CanRead), but the test is against data in the internal
@link(LineBuffer) too.}
function CanReadEx(Timeout: integer): boolean; virtual;
{:Returns the status word of the modem. Decoding the status word could yield
the status of carrier detect signaland other signals. This method is used
internally by the modem status reading properties. You usually do not need
to call this method directly.}
function ModemStatus: integer; virtual;
{:Send a break signal to the communication device for Duration milliseconds.}
procedure SetBreak(Duration: integer); virtual;
{:This function is designed to send AT commands to the modem. The AT command
is sent in the Value parameter and the response is returned in the function
return value (may contain multiple lines!).
If the AT command is processed successfully (modem returns OK), then the
@link(ATResult) property is set to True.
This function is designed only for AT commands that return OK or ERROR
response! To call connection commands the @link(ATConnect) method.
Remember, when you connect to a modem device, it is in AT command mode.
Now you can send AT commands to the modem. If you need to transfer data to
the modem on the other side of the line, you must first switch to data mode
using the @link(ATConnect) method.}
function ATCommand(value: string): string; virtual;
{:This function is used to send connect type AT commands to the modem. It is
for commands to switch to connected state. (ATD, ATA, ATO,...)
It sends the AT command in the Value parameter and returns the modem's
response (may be multiple lines - usually with connection parameters info).
If the AT command is processed successfully (the modem returns CONNECT),
then the ATResult property is set to @True.
This function is designed only for AT commands which respond by CONNECT,
BUSY, NO DIALTONE NO CARRIER or ERROR. For other AT commands use the
@link(ATCommand) method.
The connect timeout is 90*@link(ATTimeout). If this command is successful
(@link(ATresult) is @true), then the modem is in data state. When you now
send or receive some data, it is not to or from your modem, but from the
modem on other side of the line. Now you can transfer your data.
If the connection attempt failed (@link(ATResult) is @False), then the
modem is still in AT command mode.}
function ATConnect(value: string): string; virtual;
{:If you "manually" call API functions, forward their return code in
the SerialResult parameter to this function, which evaluates it and sets
@link(LastError) and @link(LastErrorDesc).}
function SerialCheck(SerialResult: integer): integer; virtual;
{:If @link(Lasterror) is not 0 and exceptions are enabled, then this procedure
raises an exception. This method is used internally. You may need it only
in special cases.}
procedure ExceptCheck; virtual;
{:Set Synaser to error state with ErrNumber code. Usually used by internal
routines.}
procedure SetSynaError(ErrNumber: integer); virtual;
{:Raise Synaser error with ErrNumber code. Usually used by internal routines.}
procedure RaiseSynaError(ErrNumber: integer); virtual;
{$IFDEF LINUX}
function cpomComportAccessible: boolean; virtual;{HGJ}
procedure cpomReleaseComport; virtual; {HGJ}
{$ENDIF}
{:True device name of currently used port}
property Device: string read FDevice;
{:Error code of last operation. Value is defined by the host operating
system, but value 0 is always OK.}
property LastError: integer read FLastError;
{:Human readable description of LastError code.}
property LastErrorDesc: string read FLastErrorDesc;
{:Indicates if the last @link(ATCommand) or @link(ATConnect) method was successful}
property ATResult: Boolean read FATResult;
{:Read the value of the RTS signal.}
property RTS: Boolean write SetRTSF;
{:Indicates the presence of the CTS signal}
property CTS: boolean read GetCTS;
{:Use this property to set the value of the DTR signal.}
property DTR: Boolean write SetDTRF;
{:Exposes the status of the DSR signal.}
property DSR: boolean read GetDSR;
{:Indicates the presence of the Carrier signal}
property Carrier: boolean read GetCarrier;
{:Reflects the status of the Ring signal.}
property Ring: boolean read GetRing;
{:indicates if this instance of SynaSer is active. (Connected to some port)}
property InstanceActive: boolean read FInstanceActive; {HGJ}
{:Defines maximum bandwidth for all sending operations in bytes per second.
If this value is set to 0 (default), bandwidth limitation is not used.}
property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth;
{:Defines maximum bandwidth for all receiving operations in bytes per second.
If this value is set to 0 (default), bandwidth limitation is not used.}
property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth;
{:Defines maximum bandwidth for all sending and receiving operations
in bytes per second. If this value is set to 0 (default), bandwidth
limitation is not used.}
property MaxBandwidth: Integer Write SetBandwidth;
{:Size of the Windows internal receive buffer. Default value is usually
4096 bytes. Note: Valid only in Windows versions!}
property SizeRecvBuffer: integer read FRecvBuffer write SetSizeRecvBuffer;
published
{:Returns the descriptive text associated with ErrorCode. You need this
method only in special cases. Description of LastError is now accessible
through the LastErrorDesc property.}
class function GetErrorDesc(ErrorCode: integer): string;
{:Freely usable property}
property Tag: integer read FTag write FTag;
{:Contains the handle of the open communication port.
You may need this value to directly call communication functions outside
SynaSer.}
property Handle: THandle read Fhandle write FHandle;
{:Internally used read buffer.}
property LineBuffer: string read FBuffer write FBuffer;
{:If @true, communication errors raise exceptions. If @false (default), only
the @link(LastError) value is set.}
property RaiseExcept: boolean read FRaiseExcept write FRaiseExcept;
{:This event is triggered when the communication status changes. It can be
used to monitor communication status.}
property OnStatus: THookSerialStatus read FOnStatus write FOnStatus;
{:If you set this property to @true, then the value of the DSR signal
is tested before every data transfer. It can be used to detect the presence
of a communications device.}
property TestDSR: boolean read FTestDSR write FTestDSR;
{:If you set this property to @true, then the value of the CTS signal
is tested before every data transfer. It can be used to detect the presence
of a communications device. Warning: This property cannot be used if you
need hardware handshake!}
property TestCTS: boolean read FTestCTS write FTestCTS;
{:Use this property you to limit the maximum size of LineBuffer
(as a protection against unlimited memory allocation for LineBuffer).
Default value is 0 - no limit.}
property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
{:This timeout value is used as deadlock protection when trying to send data
to (or receive data from) a device that stopped communicating during data
transmission (e.g. by physically disconnecting the device).
The timeout value is in milliseconds. The default value is 30,000 (30 seconds).}
property DeadlockTimeout: Integer read FDeadlockTimeout Write FDeadlockTimeout;
{:If set to @true (default value), port locking is enabled (under Linux only).
WARNING: To use this feature, the application must run by a user with full
permission to the /var/lock directory!}
property LinuxLock: Boolean read FLinuxLock write FLinuxLock;
{:Indicates if non-standard line terminators should be converted to a CR/LF pair
(standard DOS line terminator). If @TRUE, line terminators CR, single LF
or LF/CR are converted to CR/LF. Defaults to @FALSE.
This property has effect only on the behavior of the RecvString method.}
property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd;
{:Timeout for AT modem based operations}
property AtTimeout: integer read FAtTimeout Write FAtTimeout;
{:If @true (default), then all timeouts is timeout between two characters.
If @False, then timeout is overall for whoole reading operation.}
property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout;
end;
{:Returns list of existing computer serial ports. Working properly only in Windows!}
function GetSerialPortNames: string;
implementation
constructor TBlockSerial.Create;
begin
inherited create;
FRaiseExcept := false;
FHandle := INVALID_HANDLE_VALUE;
FDevice := '';
FComNr:= PortIsClosed; {HGJ}
FInstanceActive:= false; {HGJ}
Fbuffer := '';
FRTSToggle := False;
FMaxLineLength := 0;
FTestDSR := False;
FTestCTS := False;
FDeadlockTimeout := 30000;
FLinuxLock := True;
FMaxSendBandwidth := 0;
FNextSend := 0;
FMaxRecvBandwidth := 0;
FNextRecv := 0;
FConvertLineEnd := False;
SetSynaError(sOK);
FRecvBuffer := 4096;
FLastCR := False;
FLastLF := False;
FAtTimeout := 1000;
FInterPacketTimeout := True;
end;
destructor TBlockSerial.Destroy;
begin
CloseSocket;
inherited destroy;
end;
class function TBlockSerial.GetVersion: string;
begin
Result := 'SynaSer 6.3.5';
end;
procedure TBlockSerial.CloseSocket;
begin
if Fhandle <> INVALID_HANDLE_VALUE then
begin
Purge;
RTS := False;
DTR := False;
FileClose(integer(FHandle));
end;
if InstanceActive then
begin
{$IFDEF LINUX}
if FLinuxLock then
cpomReleaseComport;
{$ENDIF}
FInstanceActive:= false
end;
Fhandle := INVALID_HANDLE_VALUE;
FComNr:= PortIsClosed;
SetSynaError(sOK);
DoStatus(HR_SerialClose, FDevice);
end;
{$IFDEF WIN32}
function TBlockSerial.GetPortAddr: Word;
begin
Result := 0;
if Win32Platform <> VER_PLATFORM_WIN32_NT then
begin
EscapeCommFunction(FHandle, 10);
asm
MOV @Result, DX;
end;
end;
end;
function TBlockSerial.ReadTxEmpty(PortAddr: Word): Boolean;
begin
Result := True;
if Win32Platform <> VER_PLATFORM_WIN32_NT then
begin
asm
MOV DX, PortAddr;
ADD DX, 5;
IN AL, DX;
AND AL, $40;
JZ @K;
MOV AL,1;
@K: MOV @Result, AL;
end;
end;
end;
{$ENDIF}
procedure TBlockSerial.GetComNr(Value: string);
begin
FComNr := PortIsClosed;
if pos('COM', uppercase(Value)) = 1 then
FComNr := StrToIntdef(copy(Value, 4, Length(Value) - 3), PortIsClosed + 1) - 1;
if pos('/DEV/TTYS', uppercase(Value)) = 1 then
FComNr := StrToIntdef(copy(Value, 10, Length(Value) - 9), PortIsClosed - 1);
end;
procedure TBlockSerial.SetBandwidth(Value: Integer);
begin
MaxSendBandwidth := Value;
MaxRecvBandwidth := Value;
end;
procedure TBlockSerial.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
var
x: LongWord;
y: LongWord;
begin
if MaxB > 0 then
begin
y := GetTick;
if Next > y then
begin
x := Next - y;
if x > 0 then
begin
DoStatus(HR_Wait, IntToStr(x));
sleep(x);
end;
end;
Next := GetTick + Trunc((Length / MaxB) * 1000);
end;
end;
procedure TBlockSerial.Config(baud, bits: integer; parity: char; stop: integer;
softflow, hardflow: boolean);
begin
FillChar(dcb, SizeOf(dcb), 0);
dcb.DCBlength := SizeOf(dcb);
dcb.BaudRate := baud;
dcb.ByteSize := bits;
case parity of
'N', 'n': dcb.parity := 0;
'O', 'o': dcb.parity := 1;
'E', 'e': dcb.parity := 2;
'M', 'm': dcb.parity := 3;
'S', 's': dcb.parity := 4;
end;
dcb.StopBits := stop;
dcb.XonChar := #17;
dcb.XoffChar := #19;
dcb.XonLim := FRecvBuffer div 4;
dcb.XoffLim := FRecvBuffer div 4;
dcb.Flags := dcb_Binary;
if softflow then
dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX;
if hardflow then
dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake
else
dcb.Flags := dcb.Flags or dcb_RtsControlEnable;
dcb.Flags := dcb.Flags or dcb_DtrControlEnable;
if dcb.Parity > 0 then
dcb.Flags := dcb.Flags or dcb_ParityCheck;
SetCommState;
end;
procedure TBlockSerial.Connect(comport: string);
{$IFDEF WIN32}
var
CommTimeouts: TCommTimeouts;
{$ENDIF}
begin
// Is this TBlockSerial Instance already busy?
if InstanceActive then {HGJ}
begin {HGJ}
RaiseSynaError(ErrAlreadyInUse);
Exit; {HGJ}
end; {HGJ}
FBuffer := '';
FDevice := comport;
GetComNr(comport);
{$IFDEF WIN32}
SetLastError (sOK);
{$ELSE}
{$IFNDEF FPC}
SetLastError (sOK);
{$ELSE}
fpSetErrno(sOK);
{$ENDIF}
{$ENDIF}
{$IFNDEF WIN32}
if FComNr <> PortIsClosed then
FDevice := '/dev/ttyS' + IntToStr(FComNr);
// Comport already owned by another process? {HGJ}
if FLinuxLock then
if not cpomComportAccessible then
begin
RaiseSynaError(ErrAlreadyOwned);
Exit;
end;
{$IFNDEF FPC}
FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC));
{$ELSE}
FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC));
{$ENDIF}
SerialCheck(integer(FHandle));
{$IFDEF LINUX}
if FLastError <> sOK then
if FLinuxLock then
cpomReleaseComport;
{$ENDIF}
ExceptCheck;
if FLastError <> sOK then
Exit;
{$ELSE}
if FComNr <> PortIsClosed then
FDevice := '\\.\COM' + IntToStr(FComNr + 1);
FHandle := THandle(CreateFile(PChar(FDevice), GENERIC_READ or GENERIC_WRITE,
0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0));
SerialCheck(integer(FHandle));
ExceptCheck;
if FLastError <> sOK then
Exit;
SetCommMask(FHandle, 0);
SetupComm(Fhandle, FRecvBuffer, 0);
CommTimeOuts.ReadIntervalTimeout := MAXWORD;
CommTimeOuts.ReadTotalTimeoutMultiplier := 0;
CommTimeOuts.ReadTotalTimeoutConstant := 0;
CommTimeOuts.WriteTotalTimeoutMultiplier := 0;
CommTimeOuts.WriteTotalTimeoutConstant := 0;
SetCommTimeOuts(FHandle, CommTimeOuts);
FPortAddr := GetPortAddr;
{$ENDIF}
SetSynaError(sOK);
if not TestCtrlLine then {HGJ}
begin
SetSynaError(ErrNoDeviceAnswer);
FileClose(integer(FHandle)); {HGJ}
{$IFDEF LINUX}
if FLinuxLock then
cpomReleaseComport; {HGJ}
{$ENDIF} {HGJ}
Fhandle := INVALID_HANDLE_VALUE; {HGJ}
FComNr:= PortIsClosed; {HGJ}
end
else
begin
FInstanceActive:= True;
RTS := True;
DTR := True;
Purge;
end;
ExceptCheck;
DoStatus(HR_Connect, FDevice);
end;
function TBlockSerial.SendBuffer(buffer: pointer; length: integer): integer;
{$IFDEF WIN32}
var
Overlapped: TOverlapped;
x, y, Err: DWord;
{$ENDIF}
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
if FRTSToggle then
begin
Flush;
RTS := True;
end;
{$IFNDEF WIN32}
result := FileWrite(integer(Fhandle), Buffer^, Length);
serialcheck(result);
{$ELSE}
FillChar(Overlapped, Sizeof(Overlapped), 0);
SetSynaError(sOK);
y := 0;
if not WriteFile(FHandle, Buffer^, Length, DWord(Result), @Overlapped) then
y := GetLastError;
if y = ERROR_IO_PENDING then
begin
x := WaitForSingleObject(FHandle, FDeadlockTimeout);
if x = WAIT_TIMEOUT then
begin
PurgeComm(FHandle, PURGE_TXABORT);
SetSynaError(ErrTimeout);
end;
GetOverlappedResult(FHandle, Overlapped, Dword(Result), False);
end
else
SetSynaError(y);
ClearCommError(FHandle, err, nil);
if err <> 0 then
DecodeCommError(err);
{$ENDIF}
if FRTSToggle then
begin
Flush;
CanWrite(255);
RTS := False;
end;
ExceptCheck;
DoStatus(HR_WriteCount, IntToStr(Result));
end;
procedure TBlockSerial.SendByte(data: byte);
begin
SendBuffer(@Data, 1);
end;
procedure TBlockSerial.SendString(data: string);
begin
SendBuffer(Pointer(Data), Length(Data));
end;
procedure TBlockSerial.SendInteger(Data: integer);
begin
SendBuffer(@data, SizeOf(Data));
end;
procedure TBlockSerial.SendBlock(const Data: string);
begin
SendInteger(Length(data));
SendString(Data);
end;
procedure TBlockSerial.SendStreamRaw(const Stream: TStream);
var
si: integer;
x, y, yr: integer;
s: string;
begin
si := Stream.Size - Stream.Position;
x := 0;
while x < si do
begin
y := si - x;
if y > cSerialChunk then
y := cSerialChunk;
Setlength(s, y);
yr := Stream.read(Pchar(s)^, y);
if yr > 0 then
begin
SetLength(s, yr);
SendString(s);
Inc(x, yr);
end
else
break;
end;
end;
procedure TBlockSerial.SendStreamIndy(const Stream: TStream);
var
si: integer;
begin
si := Stream.Size - Stream.Position;
si := Swapbytes(si);
SendInteger(si);
SendStreamRaw(Stream);
end;
procedure TBlockSerial.SendStream(const Stream: TStream);
var
si: integer;
begin
si := Stream.Size - Stream.Position;
SendInteger(si);
SendStreamRaw(Stream);
end;
function TBlockSerial.RecvBuffer(buffer: pointer; length: integer): integer;
{$IFNDEF WIN32}
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
result := FileRead(integer(FHandle), Buffer^, length);
serialcheck(result);
{$ELSE}
var
Overlapped: TOverlapped;
x, y, Err: DWord;
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
FillChar(Overlapped, Sizeof(Overlapped), 0);
SetSynaError(sOK);
y := 0;
if not ReadFile(FHandle, Buffer^, length, Dword(Result), @Overlapped) then
y := GetLastError;
if y = ERROR_IO_PENDING then
begin
x := WaitForSingleObject(FHandle, FDeadlockTimeout);
if x = WAIT_TIMEOUT then
begin
PurgeComm(FHandle, PURGE_RXABORT);
SetSynaError(ErrTimeout);
end;
GetOverlappedResult(FHandle, Overlapped, Dword(Result), False);
end
else
SetSynaError(y);
ClearCommError(FHandle, err, nil);
if err <> 0 then
DecodeCommError(err);
{$ENDIF}
ExceptCheck;
DoStatus(HR_ReadCount, IntToStr(Result));
end;
function TBlockSerial.RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer;
var
s: string;
rl, l: integer;
ti: LongWord;
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
SetSynaError(sOK);
rl := 0;
repeat
ti := GetTick;
s := RecvPacket(Timeout);
l := System.Length(s);
if (rl + l) > Length then
l := Length - rl;
Move(Pointer(s)^, IncPoint(Buffer, rl)^, l);
rl := rl + l;
if FLastError <> sOK then
Break;
if rl >= Length then
Break;
if not FInterPacketTimeout then
begin
Timeout := Timeout - integer(TickDelta(ti, GetTick));
if Timeout <= 0 then
begin
SetSynaError(ErrTimeout);
Break;
end;
end;
until False;
delete(s, 1, l);
FBuffer := s;
Result := rl;
end;
function TBlockSerial.RecvBufferStr(Length: Integer; Timeout: Integer): string;
var
x: integer;
begin
Result := '';
if PreTestFailing then {HGJ}
Exit; {HGJ}
SetSynaError(sOK);
if Length > 0 then
begin
Setlength(Result, Length);
x := RecvBufferEx(PChar(Result), Length , Timeout);
if FLastError = sOK then
SetLength(Result, x)
else
Result := '';
end;
end;
function TBlockSerial.RecvPacket(Timeout: Integer): string;
var
x: integer;
begin
Result := '';
if PreTestFailing then {HGJ}
Exit; {HGJ}
SetSynaError(sOK);
if FBuffer <> '' then
begin
Result := FBuffer;
FBuffer := '';
end
else
begin
//not drain CPU on large downloads...
Sleep(0);
x := WaitingData;
if x > 0 then
begin
SetLength(Result, x);
x := RecvBuffer(Pointer(Result), x);
if x >= 0 then
SetLength(Result, x);
end
else
begin
if CanRead(Timeout) then
begin
x := WaitingData;
if x = 0 then
SetSynaError(ErrTimeout);
if x > 0 then
begin
SetLength(Result, x);
x := RecvBuffer(Pointer(Result), x);
if x >= 0 then
SetLength(Result, x);
end;
end
else
SetSynaError(ErrTimeout);
end;
end;
ExceptCheck;
end;
function TBlockSerial.RecvByte(timeout: integer): byte;
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
SetSynaError(sOK);
if FBuffer = '' then
FBuffer := RecvPacket(Timeout);
if (FLastError = sOK) and (FBuffer <> '') then
begin
Result := Ord(FBuffer[1]);
System.Delete(FBuffer, 1, 1);
end;
ExceptCheck;
end;
function TBlockSerial.RecvTerminated(Timeout: Integer; const Terminator: string): string;
var
x: Integer;
s: string;
l: Integer;
CorCRLF: Boolean;
t: ansistring;
tl: integer;
ti: LongWord;
begin
Result := '';
if PreTestFailing then {HGJ}
Exit; {HGJ}
SetSynaError(sOK);
l := system.Length(Terminator);
if l = 0 then
Exit;
tl := l;
CorCRLF := FConvertLineEnd and (Terminator = CRLF);
s := '';
x := 0;
repeat
ti := GetTick;
//get rest of FBuffer or incomming new data...
s := s + RecvPacket(Timeout);
if FLastError <> sOK then
Break;
x := 0;
if Length(s) > 0 then
if CorCRLF then
begin
if FLastCR and (s[1] = LF) then
Delete(s, 1, 1);
if FLastLF and (s[1] = CR) then
Delete(s, 1, 1);
FLastCR := False;
FLastLF := False;
t := '';
x := PosCRLF(s, t);
tl := system.Length(t);
if t = CR then
FLastCR := True;
if t = LF then
FLastLF := True;
end
else
begin
x := pos(Terminator, s);
tl := l;
end;
if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then
begin
SetSynaError(ErrMaxBuffer);
Break;
end;
if x > 0 then
Break;
if not FInterPacketTimeout then
begin
Timeout := Timeout - integer(TickDelta(ti, GetTick));
if Timeout <= 0 then
begin
SetSynaError(ErrTimeout);
Break;
end;
end;
until False;
if x > 0 then
begin
Result := Copy(s, 1, x - 1);
System.Delete(s, 1, x + tl - 1);
end;
FBuffer := s;
ExceptCheck;
end;
function TBlockSerial.RecvString(Timeout: Integer): string;
var
s: string;
begin
Result := '';
s := RecvTerminated(Timeout, #13 + #10);
if FLastError = sOK then
Result := s;
end;
function TBlockSerial.RecvInteger(Timeout: Integer): Integer;
var
s: string;
begin
Result := 0;
s := RecvBufferStr(4, Timeout);
if FLastError = 0 then
Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536;
end;
function TBlockSerial.RecvBlock(Timeout: Integer): string;
var
x: integer;
begin
Result := '';
x := RecvInteger(Timeout);
if FLastError = 0 then
Result := RecvBufferStr(x, Timeout);
end;
procedure TBlockSerial.RecvStreamRaw(const Stream: TStream; Timeout: Integer);
var
s: string;
begin
repeat
s := RecvPacket(Timeout);
if FLastError = 0 then
WriteStrToStream(Stream, s);
until FLastError <> 0;
end;
procedure TBlockSerial.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
var
s: string;
n: integer;
begin
for n := 1 to (Size div cSerialChunk) do
begin
s := RecvBufferStr(cSerialChunk, Timeout);
if FLastError <> 0 then
Exit;
Stream.Write(Pchar(s)^, cSerialChunk);
end;
n := Size mod cSerialChunk;
if n > 0 then
begin
s := RecvBufferStr(n, Timeout);
if FLastError <> 0 then
Exit;
Stream.Write(Pchar(s)^, n);
end;
end;
procedure TBlockSerial.RecvStreamIndy(const Stream: TStream; Timeout: Integer);
var
x: integer;
begin
x := RecvInteger(Timeout);
x := SwapBytes(x);
if FLastError = 0 then
RecvStreamSize(Stream, Timeout, x);
end;
procedure TBlockSerial.RecvStream(const Stream: TStream; Timeout: Integer);
var
x: integer;
begin
x := RecvInteger(Timeout);
if FLastError = 0 then
RecvStreamSize(Stream, Timeout, x);
end;
{$IFNDEF WIN32}
function TBlockSerial.WaitingData: integer;
begin
{$IFNDEF FPC}
serialcheck(ioctl(integer(FHandle), FIONREAD, @result));
{$ELSE}
serialcheck(fpIoctl(FHandle, FIONREAD, @result));
{$ENDIF}
if FLastError <> 0 then
Result := 0;
ExceptCheck;
end;
{$ELSE}
function TBlockSerial.WaitingData: integer;
var
stat: TComStat;
err: DWORD;
begin
if ClearCommError(FHandle, err, @stat) then
begin
SetSynaError(sOK);
Result := stat.cbInQue;
end
else
begin
SerialCheck(sErr);
Result := 0;
end;
ExceptCheck;
end;
{$ENDIF}
function TBlockSerial.WaitingDataEx: integer;
begin
if FBuffer <> '' then
Result := Length(FBuffer)
else
Result := Waitingdata;
end;
{$IFNDEF WIN32}
function TBlockSerial.SendingData: integer;
begin
SetSynaError(sOK);
Result := 0;
end;
{$ELSE}
function TBlockSerial.SendingData: integer;
var
stat: TComStat;
err: DWORD;
begin
SetSynaError(sOK);
if not ClearCommError(FHandle, err, @stat) then
serialcheck(sErr);
ExceptCheck;
result := stat.cbOutQue;
end;
{$ENDIF}
{$IFNDEF WIN32}
procedure TBlockSerial.DcbToTermios(const dcb: TDCB; var term: termios);
var
n: integer;
x: cardinal;
begin
//others
cfmakeraw(term);
term.c_cflag := term.c_cflag or CREAD;
term.c_cflag := term.c_cflag or CLOCAL;
term.c_cflag := term.c_cflag or HUPCL;
//hardware handshake
if (dcb.flags and dcb_RtsControlHandshake) > 0 then
term.c_cflag := term.c_cflag or CRTSCTS
else
term.c_cflag := term.c_cflag and (not CRTSCTS);
//software handshake
if (dcb.flags and dcb_OutX) > 0 then
term.c_iflag := term.c_iflag or IXON or IXOFF or IXANY
else
term.c_iflag := term.c_iflag and (not (IXON or IXOFF or IXANY));
//size of byte
term.c_cflag := term.c_cflag and (not CSIZE);
case dcb.bytesize of
5:
term.c_cflag := term.c_cflag or CS5;
6:
term.c_cflag := term.c_cflag or CS6;
7:
{$IFDEF FPC}
term.c_cflag := term.c_cflag or CS7;
{$ELSE}
term.c_cflag := term.c_cflag or CS7fix;
{$ENDIF}
8:
term.c_cflag := term.c_cflag or CS8;
end;
//parity
if (dcb.flags and dcb_ParityCheck) > 0 then
term.c_cflag := term.c_cflag or PARENB
else
term.c_cflag := term.c_cflag and (not PARENB);
case dcb.parity of
1: //'O'
term.c_cflag := term.c_cflag or PARODD;
2: //'E'
term.c_cflag := term.c_cflag and (not PARODD);
end;
//stop bits
if dcb.stopbits > 0 then
term.c_cflag := term.c_cflag or CSTOPB
else
term.c_cflag := term.c_cflag and (not CSTOPB);
//set baudrate;
x := 0;
for n := 0 to Maxrates do
if rates[n, 0] = dcb.BaudRate then
begin
x := rates[n, 1];
break;
end;
cfsetospeed(term, x);
cfsetispeed(term, x);
end;
procedure TBlockSerial.TermiosToDcb(const term: termios; var dcb: TDCB);
var
n: integer;
x: cardinal;
begin
//set baudrate;
dcb.baudrate := 0;
{$IFDEF FPC}
//why FPC not have cfgetospeed???
x := term.c_oflag and $0F;
{$ELSE}
x := cfgetospeed(term);
{$ENDIF}
for n := 0 to Maxrates do
if rates[n, 1] = x then
begin
dcb.baudrate := rates[n, 0];
break;
end;
//hardware handshake
if (term.c_cflag and CRTSCTS) > 0 then
dcb.flags := dcb.flags or dcb_RtsControlHandshake or dcb_OutxCtsFlow
else
dcb.flags := dcb.flags and (not (dcb_RtsControlHandshake or dcb_OutxCtsFlow));
//software handshake
if (term.c_cflag and IXOFF) > 0 then
dcb.flags := dcb.flags or dcb_OutX or dcb_InX
else
dcb.flags := dcb.flags and (not (dcb_OutX or dcb_InX));
//size of byte
case term.c_cflag and CSIZE of
CS5:
dcb.bytesize := 5;
CS6:
dcb.bytesize := 6;
CS7fix:
dcb.bytesize := 7;
CS8:
dcb.bytesize := 8;
end;
//parity
if (term.c_cflag and PARENB) > 0 then
dcb.flags := dcb.flags or dcb_ParityCheck
else
dcb.flags := dcb.flags and (not dcb_ParityCheck);
dcb.parity := 0;
if (term.c_cflag and PARODD) > 0 then
dcb.parity := 1
else
dcb.parity := 2;
//stop bits
if (term.c_cflag and CSTOPB) > 0 then
dcb.stopbits := 2
else
dcb.stopbits := 0;
end;
{$ENDIF}
{$IFNDEF WIN32}
procedure TBlockSerial.SetCommState;
begin
DcbToTermios(dcb, termiosstruc);
SerialCheck(tcsetattr(integer(FHandle), TCSANOW, termiosstruc));
ExceptCheck;
end;
{$ELSE}
procedure TBlockSerial.SetCommState;
begin
SetSynaError(sOK);
if not windows.SetCommState(Fhandle, dcb) then
SerialCheck(sErr);
ExceptCheck;
end;
{$ENDIF}
{$IFNDEF WIN32}
procedure TBlockSerial.GetCommState;
begin
SerialCheck(tcgetattr(integer(FHandle), termiosstruc));
ExceptCheck;
TermiostoDCB(termiosstruc, dcb);
end;
{$ELSE}
procedure TBlockSerial.GetCommState;
begin
SetSynaError(sOK);
if not windows.GetCommState(Fhandle, dcb) then
SerialCheck(sErr);
ExceptCheck;
end;
{$ENDIF}
procedure TBlockSerial.SetSizeRecvBuffer(size: integer);
begin
{$IFDEF WIN32}
SetupComm(Fhandle, size, 0);
GetCommState;
dcb.XonLim := size div 4;
dcb.XoffLim := size div 4;
SetCommState;
{$ENDIF}
FRecvBuffer := size;
end;
function TBlockSerial.GetDSR: Boolean;
begin
ModemStatus;
{$IFNDEF WIN32}
Result := (FModemWord and TIOCM_DSR) > 0;
{$ELSE}
Result := (FModemWord and MS_DSR_ON) > 0;
{$ENDIF}
end;
procedure TBlockSerial.SetDTRF(Value: Boolean);
begin
{$IFNDEF WIN32}
ModemStatus;
if Value then
FModemWord := FModemWord or TIOCM_DTR
else
FModemWord := FModemWord and not TIOCM_DTR;
{$IFNDEF FPC}
ioctl(integer(FHandle), TIOCMSET, @FModemWord);
{$ELSE}
fpioctl(integer(FHandle), TIOCMSET, @FModemWord);
{$ENDIF}
{$ELSE}
if Value then
EscapeCommFunction(FHandle, SETDTR)
else
EscapeCommFunction(FHandle, CLRDTR);
{$ENDIF}
end;
function TBlockSerial.GetCTS: Boolean;
begin
ModemStatus;
{$IFNDEF WIN32}
Result := (FModemWord and TIOCM_CTS) > 0;
{$ELSE}
Result := (FModemWord and MS_CTS_ON) > 0;
{$ENDIF}
end;
procedure TBlockSerial.SetRTSF(Value: Boolean);
begin
{$IFNDEF WIN32}
ModemStatus;
if Value then
FModemWord := FModemWord or TIOCM_RTS
else
FModemWord := FModemWord and not TIOCM_RTS;
{$IFNDEF FPC}
ioctl(integer(FHandle), TIOCMSET, @FModemWord);
{$ELSE}
fpioctl(integer(FHandle), TIOCMSET, @FModemWord);
{$ENDIF}
{$ELSE}
if Value then
EscapeCommFunction(FHandle, SETRTS)
else
EscapeCommFunction(FHandle, CLRRTS);
{$ENDIF}
end;
function TBlockSerial.GetCarrier: Boolean;
begin
ModemStatus;
{$IFNDEF WIN32}
Result := (FModemWord and TIOCM_CAR) > 0;
{$ELSE}
Result := (FModemWord and MS_RLSD_ON) > 0;
{$ENDIF}
end;
function TBlockSerial.GetRing: Boolean;
begin
ModemStatus;
{$IFNDEF WIN32}
Result := (FModemWord and TIOCM_RNG) > 0;
{$ELSE}
Result := (FModemWord and MS_RING_ON) > 0;
{$ENDIF}
end;
{$IFDEF WIN32}
function TBlockSerial.CanEvent(Event: dword; Timeout: integer): boolean;
var
ex: DWord;
y: Integer;
Overlapped: TOverlapped;
begin
FillChar(Overlapped, Sizeof(Overlapped), 0);
Overlapped.hEvent := CreateEvent(nil, True, False, nil);
try
SetCommMask(FHandle, Event);
SetSynaError(sOK);
if (Event = EV_RXCHAR) and (Waitingdata > 0) then
Result := True
else
begin
y := 0;
if not WaitCommEvent(FHandle, ex, @Overlapped) then
y := GetLastError;
if y = ERROR_IO_PENDING then
begin
//timedout
WaitForSingleObject(Overlapped.hEvent, Timeout);
SetCommMask(FHandle, 0);
GetOverlappedResult(FHandle, Overlapped, DWord(y), True);
end;
Result := (ex and Event) = Event;
end;
finally
SetCommMask(FHandle, 0);
CloseHandle(Overlapped.hEvent);
end;
end;
{$ENDIF}
{$IFNDEF WIN32}
function TBlockSerial.CanRead(Timeout: integer): boolean;
var
FDSet: TFDSet;
TimeVal: PTimeVal;
TimeV: TTimeVal;
x: Integer;
begin
TimeV.tv_usec := (Timeout mod 1000) * 1000;
TimeV.tv_sec := Timeout div 1000;
TimeVal := @TimeV;
if Timeout = -1 then
TimeVal := nil;
{$IFNDEF FPC}
FD_ZERO(FDSet);
FD_SET(integer(FHandle), FDSet);
x := Select(integer(FHandle) + 1, @FDSet, nil, nil, TimeVal);
{$ELSE}
fpFD_ZERO(FDSet);
fpFD_SET(integer(FHandle), FDSet);
x := fpSelect(integer(FHandle) + 1, @FDSet, nil, nil, TimeVal);
{$ENDIF}
SerialCheck(x);
if FLastError <> sOK then
x := 0;
Result := x > 0;
ExceptCheck;
if Result then
DoStatus(HR_CanRead, '');
end;
{$ELSE}
function TBlockSerial.CanRead(Timeout: integer): boolean;
begin
Result := WaitingData > 0;
if not Result then
Result := CanEvent(EV_RXCHAR, Timeout);
if Result then
DoStatus(HR_CanRead, '');
end;
{$ENDIF}
{$IFNDEF WIN32}
function TBlockSerial.CanWrite(Timeout: integer): boolean;
var
FDSet: TFDSet;
TimeVal: PTimeVal;
TimeV: TTimeVal;
x: Integer;
begin
TimeV.tv_usec := (Timeout mod 1000) * 1000;
TimeV.tv_sec := Timeout div 1000;
TimeVal := @TimeV;
if Timeout = -1 then
TimeVal := nil;
{$IFNDEF FPC}
FD_ZERO(FDSet);
FD_SET(integer(FHandle), FDSet);
x := Select(integer(FHandle) + 1, nil, @FDSet, nil, TimeVal);
{$ELSE}
fpFD_ZERO(FDSet);
fpFD_SET(integer(FHandle), FDSet);
x := fpSelect(integer(FHandle) + 1, nil, @FDSet, nil, TimeVal);
{$ENDIF}
SerialCheck(x);
if FLastError <> sOK then
x := 0;
Result := x > 0;
ExceptCheck;
if Result then
DoStatus(HR_CanWrite, '');
end;
{$ELSE}
function TBlockSerial.CanWrite(Timeout: integer): boolean;
var
t: LongWord;
begin
Result := SendingData = 0;
if not Result then
Result := CanEvent(EV_TXEMPTY, Timeout);
if Result and (Win32Platform <> VER_PLATFORM_WIN32_NT) then
begin
t := GetTick;
while not ReadTxEmpty(FPortAddr) do
begin
if TickDelta(t, GetTick) > 255 then
Break;
Sleep(0);
end;
end;
if Result then
DoStatus(HR_CanWrite, '');
end;
{$ENDIF}
function TBlockSerial.CanReadEx(Timeout: integer): boolean;
begin
if Fbuffer <> '' then
Result := True
else
Result := CanRead(Timeout);
end;
procedure TBlockSerial.EnableRTSToggle(Value: boolean);
begin
SetSynaError(sOK);
{$IFNDEF WIN32}
FRTSToggle := Value;
if Value then
RTS:=False;
{$ELSE}
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
GetCommState;
if value then
dcb.Flags := dcb.Flags or dcb_RtsControlToggle
else
dcb.flags := dcb.flags and (not dcb_RtsControlToggle);
SetCommState;
end
else
begin
FRTSToggle := Value;
if Value then
RTS:=False;
end;
{$ENDIF}
end;
procedure TBlockSerial.Flush;
begin
{$IFNDEF WIN32}
SerialCheck(tcdrain(integer(FHandle)));
{$ELSE}
SetSynaError(sOK);
if not Flushfilebuffers(FHandle) then
SerialCheck(sErr);
{$ENDIF}
ExceptCheck;
end;
{$IFNDEF WIN32}
procedure TBlockSerial.Purge;
begin
{$IFNDEF FPC}
SerialCheck(ioctl(integer(FHandle), TCFLSH, TCIOFLUSH));
{$ELSE}
SerialCheck(fpioctl(integer(FHandle), TCFLSH, TCIOFLUSH));
{$ENDIF}
FBuffer := '';
ExceptCheck;
end;
{$ELSE}
procedure TBlockSerial.Purge;
var
x: integer;
begin
SetSynaError(sOK);
x := PURGE_TXABORT or PURGE_TXCLEAR or PURGE_RXABORT or PURGE_RXCLEAR;
if not PurgeComm(FHandle, x) then
SerialCheck(sErr);
FBuffer := '';
ExceptCheck;
end;
{$ENDIF}
function TBlockSerial.ModemStatus: integer;
begin
Result := 0;
{$IFNDEF WIN32}
{$IFNDEF FPC}
SerialCheck(ioctl(integer(FHandle), TIOCMGET, @Result));
{$ELSE}
SerialCheck(fpioctl(integer(FHandle), TIOCMGET, @Result));
{$ENDIF}
{$ELSE}
SetSynaError(sOK);
if not GetCommModemStatus(FHandle, dword(Result)) then
SerialCheck(sErr);
{$ENDIF}
ExceptCheck;
FModemWord := Result;
end;
procedure TBlockSerial.SetBreak(Duration: integer);
begin
{$IFNDEF WIN32}
SerialCheck(tcsendbreak(integer(FHandle), Duration));
{$ELSE}
SetCommBreak(FHandle);
Sleep(Duration);
SetSynaError(sOK);
if not ClearCommBreak(FHandle) then
SerialCheck(sErr);
{$ENDIF}
end;
{$IFDEF WIN32}
procedure TBlockSerial.DecodeCommError(Error: DWord);
begin
if (Error and DWord(CE_FRAME)) > 1 then
FLastError := ErrFrame;
if (Error and DWord(CE_OVERRUN)) > 1 then
FLastError := ErrOverrun;
if (Error and DWord(CE_RXOVER)) > 1 then
FLastError := ErrRxOver;
if (Error and DWord(CE_RXPARITY)) > 1 then
FLastError := ErrRxParity;
if (Error and DWord(CE_TXFULL)) > 1 then
FLastError := ErrTxFull;
end;
{$ENDIF}
//HGJ
function TBlockSerial.PreTestFailing: Boolean;
begin
if not FInstanceActive then
begin
RaiseSynaError(ErrPortNotOpen);
result:= true;
Exit;
end;
Result := not TestCtrlLine;
if result then
RaiseSynaError(ErrNoDeviceAnswer)
end;
function TBlockSerial.TestCtrlLine: Boolean;
begin
result := ((not FTestDSR) or DSR) and ((not FTestCTS) or CTS);
end;
function TBlockSerial.ATCommand(value: string): string;
var
s: string;
ConvSave: Boolean;
begin
result := '';
FAtResult := False;
ConvSave := FConvertLineEnd;
try
FConvertLineEnd := True;
SendString(value + #$0D);
repeat
s := RecvString(FAtTimeout);
if s <> Value then
result := result + s + CRLF;
if s = 'OK' then
begin
FAtResult := True;
break;
end;
if s = 'ERROR' then
break;
until FLastError <> sOK;
finally
FConvertLineEnd := Convsave;
end;
end;
function TBlockSerial.ATConnect(value: string): string;
var
s: string;
ConvSave: Boolean;
begin
result := '';
FAtResult := False;
ConvSave := FConvertLineEnd;
try
FConvertLineEnd := True;
SendString(value + #$0D);
repeat
s := RecvString(90 * FAtTimeout);
if s <> Value then
result := result + s + CRLF;
if s = 'NO CARRIER' then
break;
if s = 'ERROR' then
break;
if s = 'BUSY' then
break;
if s = 'NO DIALTONE' then
break;
if Pos('CONNECT', s) = 1 then
begin
FAtResult := True;
break;
end;
until FLastError <> sOK;
finally
FConvertLineEnd := Convsave;
end;
end;
function TBlockSerial.SerialCheck(SerialResult: integer): integer;
begin
if SerialResult = integer(INVALID_HANDLE_VALUE) then
{$IFDEF WIN32}
result := GetLastError
{$ELSE}
{$IFNDEF FPC}
result := GetLastError
{$ELSE}
result := fpGetErrno
{$ENDIF}
{$ENDIF}
else
result := sOK;
FLastError := result;
FLastErrorDesc := GetErrorDesc(FLastError);
end;
procedure TBlockSerial.ExceptCheck;
var
e: ESynaSerError;
s: string;
begin
if FRaiseExcept and (FLastError <> sOK) then
begin
s := GetErrorDesc(FLastError);
e := ESynaSerError.CreateFmt('Communication error %d: %s', [FLastError, s]);
e.ErrorCode := FLastError;
e.ErrorMessage := s;
raise e;
end;
end;
procedure TBlockSerial.SetSynaError(ErrNumber: integer);
begin
FLastError := ErrNumber;
FLastErrorDesc := GetErrorDesc(FLastError);
end;
procedure TBlockSerial.RaiseSynaError(ErrNumber: integer);
begin
SetSynaError(ErrNumber);
ExceptCheck;
end;
procedure TBlockSerial.DoStatus(Reason: THookSerialReason; const Value: string);
begin
if assigned(OnStatus) then
OnStatus(Self, Reason, Value);
end;
{======================================================================}
class function TBlockSerial.GetErrorDesc(ErrorCode: integer): string;
begin
Result:= '';
case ErrorCode of
sOK: Result := 'OK';
ErrAlreadyOwned: Result := 'Port owned by other process';{HGJ}
ErrAlreadyInUse: Result := 'Instance already in use'; {HGJ}
ErrWrongParameter: Result := 'Wrong paramter at call'; {HGJ}
ErrPortNotOpen: Result := 'Instance not yet connected'; {HGJ}
ErrNoDeviceAnswer: Result := 'No device answer detected'; {HGJ}
ErrMaxBuffer: Result := 'Maximal buffer length exceeded';
ErrTimeout: Result := 'Timeout during operation';
ErrNotRead: Result := 'Reading of data failed';
ErrFrame: Result := 'Receive framing error';
ErrOverrun: Result := 'Receive Overrun Error';
ErrRxOver: Result := 'Receive Queue overflow';
ErrRxParity: Result := 'Receive Parity Error';
ErrTxFull: Result := 'Tranceive Queue is full';
end;
if Result = '' then
begin
Result := SysErrorMessage(ErrorCode);
end;
end;
{---------- cpom Comport Ownership Manager Routines -------------
by Hans-Georg Joepgen of Stuttgart, Germany.
Copyright (c) 2002, by Hans-Georg Joepgen
Stefan Krauss of Stuttgart, Germany, contributed literature and Internet
research results, invaluable advice and excellent answers to the Comport
Ownership Manager.
}
{$IFDEF LINUX}
function TBlockSerial.LockfileName: String;
var
s: string;
begin
s := SeparateRight(FDevice, '/dev/');
result := LockfileDirectory + '/LCK..' + s;
end;
procedure TBlockSerial.CreateLockfile(PidNr: integer);
var
f: TextFile;
s: string;
begin
// Create content for file
s := IntToStr(PidNr);
while length(s) < 10 do
s := ' ' + s;
// Create file
try
AssignFile(f, LockfileName);
try
Rewrite(f);
writeln(f, s);
finally
CloseFile(f);
end;
// Allow all users to enjoy the benefits of cpom
s := 'chmod a+rw ' + LockfileName;
{$IFNDEF FPC}
Libc.system(pchar(s));
{$ELSE}
fpSystem(s);
{$ENDIF}
except
// not raise exception, if you not have write permission for lock.
on Exception do
;
end;
end;
function TBlockSerial.ReadLockfile: integer;
{Returns PID from Lockfile. Lockfile must exist.}
var
f: TextFile;
s: string;
begin
AssignFile(f, LockfileName);
Reset(f);
try
readln(f, s);
finally
CloseFile(f);
end;
Result := StrToIntDef(s, -1)
end;
function TBlockSerial.cpomComportAccessible: boolean;
var
MyPid: integer;
Filename: string;
begin
Filename := LockfileName;
{$IFNDEF FPC}
MyPid := Libc.getpid;
{$ELSE}
MyPid := fpGetPid;
{$ENDIF}
// Make sure, the Lock Files Directory exists. We need it.
if not DirectoryExists(LockfileDirectory) then
CreateDir(LockfileDirectory);
// Check the Lockfile
if not FileExists (Filename) then
begin // comport is not locked. Lock it for us.
CreateLockfile(MyPid);
result := true;
exit; // done.
end;
// Is port owned by orphan? Then it's time for error recovery.
//FPC forgot to add getsid.. :-(
{$IFNDEF FPC}
if Libc.getsid(ReadLockfile) = -1 then
begin // Lockfile was left from former desaster
DeleteFile(Filename); // error recovery
CreateLockfile(MyPid);
result := true;
exit;
end;
{$ENDIF}
result := false // Sorry, port is owned by living PID and locked
end;
procedure TBlockSerial.cpomReleaseComport;
begin
DeleteFile(LockfileName);
end;
{$ENDIF}
{----------------------------------------------------------------}
{$IFDEF WIN32}
function GetSerialPortNames: string;
var
reg: TRegistry;
l, v: TStringList;
n: integer;
begin
l := TStringList.Create;
v := TStringList.Create;
reg := TRegistry.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(l);
for n := 0 to l.Count - 1 do
v.Add(reg.ReadString(l[n]));
Result := v.CommaText;
finally
reg.Free;
l.Free;
v.Free;
end;
end;
{$ENDIF}
{$IFNDEF WIN32}
function GetSerialPortNames: string;
var
Index: Integer;
Data: string;
TmpPorts: String;
sr : TSearchRec;
begin
try
TmpPorts := '';
if FindFirst('/dev/ttyS*', $FFFFFFFF, sr) = 0 then
begin
repeat
if (sr.Attr and $FFFFFFFF) = Sr.Attr then
begin
data := sr.Name;
index := length(data);
while (index > 1) and (data[index] <> '/') do
index := index - 1;
TmpPorts := TmpPorts + ' ' + copy(data, 1, index + 1);
end;
until FindNext(sr) <> 0;
end;
FindClose(sr);
finally
Result:=TmpPorts;
end;
end;
{$ENDIF}
end.
Reference in New Issue View Git Blame Copy Permalink