From f61e0889c23666c5715e6d669e55e6884690560d Mon Sep 17 00:00:00 2001 From: geby Date: Fri, 25 Apr 2008 07:00:37 +0000 Subject: [PATCH] Added synaser.pas git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@84 7c85be65-684b-0410-a082-b2ed4fbef004 --- synaser.pas | 2298 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2298 insertions(+) create mode 100644 synaser.pas diff --git a/synaser.pas b/synaser.pas new file mode 100644 index 0000000..e12e857 --- /dev/null +++ b/synaser.pas @@ -0,0 +1,2298 @@ +{==============================================================================| +| Project : Ararat Synapse | 007.002.000 | +|==============================================================================| +| Content: Serial port support | +|==============================================================================| +| Copyright (c)2001-2007, 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-2007. | +| 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: string; + 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.