Bug#661122: bug#661122: cqrlog: ftbfs with fpc in sid
tag 661122 patch
thanks
hi,
I am not quite familiar with free pascal or a ham radio. just came across this bug while looking for RC bugs.
please find attached patch.
Description: <short summary of the patch>
TODO: Put a short summary on the line above and replace this paragraph
with a longer explanation of this change. Complete the meta-information
with other relevant fields (see below for details). To make it easier, the
information below has been extracted from the changelog. Adjust it or drop
it.
.
cqrlog (1.2.2-2) unstable; urgency=low
.
* debian/control: fixed alternative dependency order for lazarus, lcl
(Closes: #652176)
Author: Kamal Mostafa <kamal@whence.com>
Bug-Debian: http://bugs.debian.org/652176
---
The information above should follow the Patch Tagging Guidelines, please
checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here
are templates for supplementary fields that you might want to add:
Origin: <vendor|upstream|other>, <url of original patch>
Bug: <url in upstream bugtracker>
Bug-Debian: http://bugs.debian.org/<bugnumber>
Bug-Ubuntu: https://launchpad.net/bugs/<bugnumber>
Forwarded: <no|not-needed|url proving that it has been forwarded>
Reviewed-By: <name and email of someone who approved the patch>
Last-Update: <YYYY-MM-DD>
--- /dev/null
+++ cqrlog-1.2.2/src/synaser.pas.old
@@ -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, Pointer(PtrInt(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.
Reply to: