1 {==============================================================================|
2 | Project : Ararat Synapse | 007.006.001 |
3 |==============================================================================|
4 | Content: Serial port support |
5 |==============================================================================|
6 | Copyright (c)2001-2017, Lukas Gebauer |
7 | All rights reserved. |
8 | |
9 | Redistribution and use in source and binary forms, with or without |
10 | modification, are permitted provided that the following conditions are met: |
11 | |
12 | Redistributions of source code must retain the above copyright notice, this |
13 | list of conditions and the following disclaimer. |
14 | |
15 | Redistributions in binary form must reproduce the above copyright notice, |
16 | this list of conditions and the following disclaimer in the documentation |
17 | and/or other materials provided with the distribution. |
18 | |
19 | Neither the name of Lukas Gebauer nor the names of its contributors may |
20 | be used to endorse or promote products derived from this software without |
21 | specific prior written permission. |
22 | |
23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
24 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
25 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
26 | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
27 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
28 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
29 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
30 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
31 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
32 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
33 | DAMAGE. |
34 |==============================================================================|
35 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
36 | Portions created by Lukas Gebauer are Copyright (c)2001-2017. |
37 | All Rights Reserved. |
38 |==============================================================================|
39 | Contributor(s): |
40 | (c)2002, Hans-Georg Joepgen (cpom Comport Ownership Manager and bugfixes) |
41 |==============================================================================|
42 | History: see HISTORY.HTM from distribution package |
43 | (Found at URL: http://www.ararat.cz/synapse/) |
44 |==============================================================================}
45
46 {: @abstract(Serial port communication library)
47 This unit contains a class that implements serial port communication
48 for Windows, Linux, Unix or MacOSx. This class provides numerous methods with
49 same name and functionality as methods of the Ararat Synapse TCP/IP library.
50
51 The following is a small example how establish a connection by modem (in this
52 case with my USB modem):
53 @longcode(#
54 ser:=TBlockSerial.Create;
55 try
56 ser.Connect('COM3');
57 ser.config(460800,8,'N',0,false,true);
58 ser.ATCommand('AT');
59 if (ser.LastError <> 0) or (not ser.ATResult) then
60 Exit;
61 ser.ATConnect('ATDT+420971200111');
62 if (ser.LastError <> 0) or (not ser.ATResult) then
63 Exit;
64 // you are now connected to a modem at +420971200111
65 // you can transmit or receive data now
66 finally
67 ser.free;
68 end;
69 #)
70 }
71
72 //old Delphi does not have MSWINDOWS define.
73 {$IFDEF WIN32}
74 {$IFNDEF MSWINDOWS}
75 {$DEFINE MSWINDOWS}
76 {$ENDIF}
77 {$ENDIF}
78
79 //Kylix does not known UNIX define
80 {$IFDEF LINUX}
81 {$IFNDEF UNIX}
82 {$DEFINE UNIX}
83 {$ENDIF}
84 {$ENDIF}
85
86 {$IFDEF FPC}
87 {$MODE DELPHI}
88 {$IFDEF MSWINDOWS}
89 {$ASMMODE intel}
90 {$ENDIF}
91 {define working mode w/o LIBC for fpc}
92 {$DEFINE NO_LIBC}
93 {$ENDIF}
94 {$Q-}
95 {$H+}
96 {$M+}
97
98 unit synaser;
99
100 interface
101
102 uses
103 {$IFNDEF MSWINDOWS}
104 {$IFNDEF NO_LIBC}
105 Libc,
106 KernelIoctl,
107 {$ELSE}
108 termio, baseunix, unix,
109 {$ENDIF}
110 {$IFNDEF FPC}
111 Types,
112 {$ENDIF}
113 {$ELSE}
114 Windows, registry,
115 {$IFDEF FPC}
116 winver,
117 {$ENDIF}
118 {$ENDIF}
119 synafpc,
120 Classes, SysUtils, synautil;
121
122 const
123 CR = #$0d;
124 LF = #$0a;
125 CRLF = CR + LF;
126 cSerialChunk = 8192;
127
128 LockfileDirectory = '/var/lock'; {HGJ}
129 PortIsClosed = -1; {HGJ}
130 ErrAlreadyOwned = 9991; {HGJ}
131 ErrAlreadyInUse = 9992; {HGJ}
132 ErrWrongParameter = 9993; {HGJ}
133 ErrPortNotOpen = 9994; {HGJ}
134 ErrNoDeviceAnswer = 9995; {HGJ}
135 ErrMaxBuffer = 9996;
136 ErrTimeout = 9997;
137 ErrNotRead = 9998;
138 ErrFrame = 9999;
139 ErrOverrun = 10000;
140 ErrRxOver = 10001;
141 ErrRxParity = 10002;
142 ErrTxFull = 10003;
143
144 dcb_Binary = $00000001;
145 dcb_ParityCheck = $00000002;
146 dcb_OutxCtsFlow = $00000004;
147 dcb_OutxDsrFlow = $00000008;
148 dcb_DtrControlMask = $00000030;
149 dcb_DtrControlDisable = $00000000;
150 dcb_DtrControlEnable = $00000010;
151 dcb_DtrControlHandshake = $00000020;
152 dcb_DsrSensivity = $00000040;
153 dcb_TXContinueOnXoff = $00000080;
154 dcb_OutX = $00000100;
155 dcb_InX = $00000200;
156 dcb_ErrorChar = $00000400;
157 dcb_NullStrip = $00000800;
158 dcb_RtsControlMask = $00003000;
159 dcb_RtsControlDisable = $00000000;
160 dcb_RtsControlEnable = $00001000;
161 dcb_RtsControlHandshake = $00002000;
162 dcb_RtsControlToggle = $00003000;
163 dcb_AbortOnError = $00004000;
164 dcb_Reserveds = $FFFF8000;
165
166 {:stopbit value for 1 stopbit}
167 SB1 = 0;
168 {:stopbit value for 1.5 stopbit}
169 SB1andHalf = 1;
170 {:stopbit value for 2 stopbits}
171 SB2 = 2;
172
173 {$IFNDEF MSWINDOWS}
174 const
175 INVALID_HANDLE_VALUE = THandle(-1);
176 CS7fix = $0000020;
177
178 type
179 TDCB = record
180 DCBlength: DWORD;
181 BaudRate: DWORD;
182 Flags: Longint;
183 wReserved: Word;
184 XonLim: Word;
185 XoffLim: Word;
186 ByteSize: Byte;
187 Parity: Byte;
188 StopBits: Byte;
189 XonChar: CHAR;
190 XoffChar: CHAR;
191 ErrorChar: CHAR;
192 EofChar: CHAR;
193 EvtChar: CHAR;
194 wReserved1: Word;
195 end;
196 PDCB = ^TDCB;
197
198 const
199 {$IFDEF UNIX}
200 {$IFDEF BSD}
201 MaxRates = 18; //MAC
202 {$ELSE}
203 MaxRates = 19; //UNIX
204 {$ENDIF}
205 {$ELSE}
206 MaxRates = 19; //WIN
207 {$ENDIF}
208 Rates: array[0..MaxRates, 0..1] of cardinal =
209 (
210 (0, B0),
211 (50, B50),
212 (75, B75),
213 (110, B110),
214 (134, B134),
215 (150, B150),
216 (200, B200),
217 (300, B300),
218 (600, B600),
219 (1200, B1200),
220 (1800, B1800),
221 (2400, B2400),
222 (4800, B4800),
223 (9600, B9600),
224 (19200, B19200),
225 (38400, B38400),
226 (57600, B57600),
227 (115200, B115200),
228 (230400, B230400)
229 {$IFNDEF BSD}
230 ,(460800, B460800)
231 {$IFDEF UNIX}
232 {
233 ,(500000, B500000),
234 (576000, B576000),
235 (921600, B921600),
236 (1000000, B1000000),
237 (1152000, B1152000),
238 (1500000, B1500000),
239 (2000000, B2000000),
240 (2500000, B2500000),
241 (3000000, B3000000),
242 (3500000, B3500000),
243 (4000000, B4000000)
244 }
245 {$ENDIF}
246 {$ENDIF}
247 );
248 {$ENDIF}
249
250 {$IFDEF BSD}
251 const // From fcntl.h
252 O_SYNC = $0080; { synchronous writes }
253 {$ENDIF}
254
255 const
256 sOK = 0;
257 sErr = integer(-1);
258
259 type
260
261 {:Possible status event types for @link(THookSerialStatus)}
262 THookSerialReason = (
263 HR_SerialClose,
264 HR_Connect,
265 HR_CanRead,
266 HR_CanWrite,
267 HR_ReadCount,
268 HR_WriteCount,
269 HR_Wait
270 );
271
272 {:procedural prototype for status event hooking}
273 THookSerialStatus = procedure(Sender: TObject; Reason: THookSerialReason;
274 const Value: string) of object;
275
276 {:@abstract(Exception type for SynaSer errors)}
277 ESynaSerError = class(Exception)
278 public
279 ErrorCode: integer;
280 ErrorMessage: string;
281 end;
282
283 {:@abstract(Main class implementing all communication routines)}
284 TBlockSerial = class(TObject)
285 protected
286 FOnStatus: THookSerialStatus;
287 Fhandle: THandle;
288 FTag: integer;
289 FDevice: string;
290 FLastError: integer;
291 FLastErrorDesc: string;
292 FBuffer: AnsiString;
293 FRaiseExcept: boolean;
294 FRecvBuffer: integer;
295 FSendBuffer: integer;
296 FModemWord: integer;
297 FRTSToggle: Boolean;
298 FDeadlockTimeout: integer;
299 FInstanceActive: boolean; {HGJ}
300 FTestDSR: Boolean;
301 FTestCTS: Boolean;
302 FLastCR: Boolean;
303 FLastLF: Boolean;
304 FMaxLineLength: Integer;
305 FLinuxLock: Boolean;
306 FMaxSendBandwidth: Integer;
307 FNextSend: LongWord;
308 FMaxRecvBandwidth: Integer;
309 FNextRecv: LongWord;
310 FConvertLineEnd: Boolean;
311 FATResult: Boolean;
312 FAtTimeout: integer;
313 FInterPacketTimeout: Boolean;
314 FComNr: integer;
315 {$IFDEF MSWINDOWS}
316 FPortAddr: Word;
CanEventnull317 function CanEvent(Event: dword; Timeout: integer): boolean;
318 procedure DecodeCommError(Error: DWord); virtual;
319 {$IFDEF WIN32}
GetPortAddrnull320 function GetPortAddr: Word; virtual;
ReadTxEmptynull321 function ReadTxEmpty(PortAddr: Word): Boolean; virtual;
322 {$ENDIF}
323 {$ENDIF}
324 procedure SetSizeRecvBuffer(size: integer); virtual;
GetDSRnull325 function GetDSR: Boolean; virtual;
326 procedure SetDTRF(Value: Boolean); virtual;
GetCTSnull327 function GetCTS: Boolean; virtual;
328 procedure SetRTSF(Value: Boolean); virtual;
GetCarriernull329 function GetCarrier: Boolean; virtual;
GetRingnull330 function GetRing: Boolean; virtual;
331 procedure DoStatus(Reason: THookSerialReason; const Value: string); virtual;
332 procedure GetComNr(Value: string); virtual;
PreTestFailingnull333 function PreTestFailing: boolean; virtual;{HGJ}
TestCtrlLinenull334 function TestCtrlLine: Boolean; virtual;
335 {$IFDEF UNIX}
336 procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual;
337 procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual;
ReadLockfilenull338 function ReadLockfile: integer; virtual;
LockfileNamenull339 function LockfileName: String; virtual;
340 procedure CreateLockfile(PidNr: integer); virtual;
341 {$ENDIF}
342 procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); virtual;
343 procedure SetBandwidth(Value: Integer); virtual;
344 public
345 {: data Control Block with communication parameters. Usable only when you
346 need to call API directly.}
347 DCB: Tdcb;
348 {$IFDEF UNIX}
349 TermiosStruc: termios;
350 {$ENDIF}
351 {:Object constructor.}
352 constructor Create;
353 {:Object destructor.}
354 destructor Destroy; override;
355
356 {:Returns a string containing the version number of the library.}
GetVersionnull357 class function GetVersion: string; virtual;
358
359 {:Destroy handle in use. It close connection to serial port.}
360 procedure CloseSocket; virtual;
361
362 {:Reconfigure communication parameters on the fly. You must be connected to
363 port before!
364 @param(baud Define connection speed. Baud rate can be from 50 to 4000000
365 bits per second. (it depends on your hardware!))
366 @param(bits Number of bits in communication.)
367 @param(parity Define communication parity (N - None, O - Odd, E - Even, M - Mark or S - Space).)
368 @param(stop Define number of stopbits. Use constants @link(SB1),
369 @link(SB1andHalf) and @link(SB2).)
370 @param(softflow Enable XON/XOFF handshake.)
371 @param(hardflow Enable CTS/RTS handshake.)}
372 procedure Config(baud, bits: integer; parity: char; stop: integer;
373 softflow, hardflow: boolean); virtual;
374
375 {:Connects to the port indicated by comport. Comport can be used in Windows
376 style (COM2), or in Linux style (/dev/ttyS1). When you use windows style
377 in Linux, then it will be converted to Linux name. And vice versa! However
378 you can specify any device name! (other device names then standart is not
379 converted!)
380
381 After successfull connection the DTR signal is set (if you not set hardware
382 handshake, then the RTS signal is set, too!)
383
384 Connection parameters is predefined by your system configuration. If you
385 need use another parameters, then you can use Config method after.
386 Notes:
387
388 - Remember, the commonly used serial Laplink cable does not support
389 hardware handshake.
390
391 - Before setting any handshake you must be sure that it is supported by
392 your hardware.
393
394 - Some serial devices are slow. In some cases you must wait up to a few
395 seconds after connection for the device to respond.
396
397 - when you connect to a modem device, then is best to test it by an empty
398 AT command. (call ATCommand('AT'))}
399 procedure Connect(comport: string); virtual;
400
401 {:Set communication parameters from the DCB structure (the DCB structure is
402 simulated under Linux).}
403 procedure SetCommState; virtual;
404
405 {:Read communication parameters into the DCB structure (DCB structure is
406 simulated under Linux).}
407 procedure GetCommState; virtual;
408
409 {:Sends Length bytes of data from Buffer through the connected port.}
SendBuffernull410 function SendBuffer(buffer: pointer; length: integer): integer; virtual;
411
412 {:One data BYTE is sent.}
413 procedure SendByte(data: byte); virtual;
414
415 {:Send the string in the data parameter. No terminator is appended by this
416 method. If you need to send a string with CR/LF terminator, you must append
417 the CR/LF characters to the data string!
418
419 Since no terminator is appended, you can use this function for sending
420 binary data too.}
421 procedure SendString(data: AnsiString); virtual;
422
423 {:send four bytes as integer.}
424 procedure SendInteger(Data: integer); virtual;
425
426 {:send data as one block. Each block begins with integer value with Length
427 of block.}
428 procedure SendBlock(const Data: AnsiString); virtual;
429
430 {:send content of stream from current position}
431 procedure SendStreamRaw(const Stream: TStream); virtual;
432
433 {:send content of stream as block. see @link(SendBlock)}
434 procedure SendStream(const Stream: TStream); virtual;
435
436 {:send content of stream as block, but this is compatioble with Indy library.
437 (it have swapped lenght of block). See @link(SendStream)}
438 procedure SendStreamIndy(const Stream: TStream); virtual;
439
440 {:Waits until the allocated buffer is filled by received data. Returns number
441 of data bytes received, which equals to the Length value under normal
442 operation. If it is not equal, the communication channel is possibly broken.
443
444 This method not using any internal buffering, like all others receiving
445 methods. You cannot freely combine this method with all others receiving
446 methods!}
RecvBuffernull447 function RecvBuffer(buffer: pointer; length: integer): integer; virtual;
448
449 {:Method waits until data is received. If no data is received within
450 the Timeout (in milliseconds) period, @link(LastError) is set to
451 @link(ErrTimeout). This method is used to read any amount of data
452 (e. g. 1MB), and may be freely combined with all receviving methods what
453 have Timeout parameter, like the @link(RecvString), @link(RecvByte) or
454 @link(RecvTerminated) methods.}
RecvBufferExnull455 function RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer; virtual;
456
457 {:It is like recvBufferEx, but data is readed to dynamicly allocated binary
458 string.}
RecvBufferStrnull459 function RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; virtual;
460
461 {:Read all available data and return it in the function result string. This
462 function may be combined with @link(RecvString), @link(RecvByte) or related
463 methods.}
RecvPacketnull464 function RecvPacket(Timeout: Integer): AnsiString; virtual;
465
466 {:Waits until one data byte is received which is returned as the function
467 result. If no data is received within the Timeout (in milliseconds) period,
468 @link(LastError) is set to @link(ErrTimeout).}
RecvBytenull469 function RecvByte(timeout: integer): byte; virtual;
470
471 {:This method waits until a terminated data string is received. This string
472 is terminated by the Terminator string. The resulting string is returned
473 without this termination string! If no data is received within the Timeout
474 (in milliseconds) period, @link(LastError) is set to @link(ErrTimeout).}
RecvTerminatednull475 function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual;
476
477 {:This method waits until a terminated data string is received. The string
478 is terminated by a CR/LF sequence. The resulting string is returned without
479 the terminator (CR/LF)! If no data is received within the Timeout (in
480 milliseconds) period, @link(LastError) is set to @link(ErrTimeout).
481
482 If @link(ConvertLineEnd) is used, then the CR/LF sequence may not be exactly
483 CR/LF. See the description of @link(ConvertLineEnd).
484
485 This method serves for line protocol implementation and uses its own
486 buffers to maximize performance. Therefore do NOT use this method with the
487 @link(RecvBuffer) method to receive data as it may cause data loss.}
Recvstringnull488 function Recvstring(timeout: integer): AnsiString; virtual;
489
490 {:Waits until four data bytes are received which is returned as the function
491 integer result. If no data is received within the Timeout (in milliseconds) period,
492 @link(LastError) is set to @link(ErrTimeout).}
RecvIntegernull493 function RecvInteger(Timeout: Integer): Integer; virtual;
494
495 {:Waits until one data block is received. See @link(sendblock). If no data
496 is received within the Timeout (in milliseconds) period, @link(LastError)
497 is set to @link(ErrTimeout).}
RecvBlocknull498 function RecvBlock(Timeout: Integer): AnsiString; virtual;
499
500 {:Receive all data to stream, until some error occured. (for example timeout)}
501 procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual;
502
503 {:receive requested count of bytes to stream}
504 procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); virtual;
505
506 {:receive block of data to stream. (Data can be sended by @link(sendstream)}
507 procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual;
508
509 {:receive block of data to stream. (Data can be sended by @link(sendstreamIndy)}
510 procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual;
511
512 {:Returns the number of received bytes waiting for reading. 0 is returned
513 when there is no data waiting.}
WaitingDatanull514 function WaitingData: integer; virtual;
515
516 {:Same as @link(WaitingData), but in respect to data in the internal
517 @link(LineBuffer).}
WaitingDataExnull518 function WaitingDataEx: integer; virtual;
519
520 {:Returns the number of bytes waiting to be sent in the output buffer.
521 0 is returned when the output buffer is empty.}
SendingDatanull522 function SendingData: integer; virtual;
523
524 {:Enable or disable RTS driven communication (half-duplex). It can be used
525 to communicate with RS485 converters, or other special equipment. If you
526 enable this feature, the system automatically controls the RTS signal.
527
528 Notes:
529
530 - On Windows NT (or higher) ir RTS signal driven by system driver.
531
532 - On Win9x family is used special code for waiting until last byte is
533 sended from your UART.
534
535 - On Linux you must have kernel 2.1 or higher!}
536 procedure EnableRTSToggle(value: boolean); virtual;
537
538 {:Waits until all data to is sent and buffers are emptied.
539 Warning: On Windows systems is this method returns when all buffers are
540 flushed to the serial port controller, before the last byte is sent!}
541 procedure Flush; virtual;
542
543 {:Unconditionally empty all buffers. It is good when you need to interrupt
544 communication and for cleanups.}
545 procedure Purge; virtual;
546
547 {:Returns @True, if you can from read any data from the port. Status is
548 tested for a period of time given by the Timeout parameter (in milliseconds).
549 If the value of the Timeout parameter is 0, the status is tested only once
550 and the function returns immediately. If the value of the Timeout parameter
551 is set to -1, the function returns only after it detects data on the port
552 (this may cause the process to hang).}
CanReadnull553 function CanRead(Timeout: integer): boolean; virtual;
554
555 {:Returns @True, if you can write any data to the port (this function is not
556 sending the contents of the buffer). Status is tested for a period of time
557 given by the Timeout parameter (in milliseconds). If the value of
558 the Timeout parameter is 0, the status is tested only once and the function
559 returns immediately. If the value of the Timeout parameter is set to -1,
560 the function returns only after it detects that it can write data to
561 the port (this may cause the process to hang).}
CanWritenull562 function CanWrite(Timeout: integer): boolean; virtual;
563
564 {:Same as @link(CanRead), but the test is against data in the internal
565 @link(LineBuffer) too.}
CanReadExnull566 function CanReadEx(Timeout: integer): boolean; virtual;
567
568 {:Returns the status word of the modem. Decoding the status word could yield
569 the status of carrier detect signaland other signals. This method is used
570 internally by the modem status reading properties. You usually do not need
571 to call this method directly.}
ModemStatusnull572 function ModemStatus: integer; virtual;
573
574 {:Send a break signal to the communication device for Duration milliseconds.}
575 procedure SetBreak(Duration: integer); virtual;
576
577 {:This function is designed to send AT commands to the modem. The AT command
578 is sent in the Value parameter and the response is returned in the function
579 return value (may contain multiple lines!).
580 If the AT command is processed successfully (modem returns OK), then the
581 @link(ATResult) property is set to True.
582
583 This function is designed only for AT commands that return OK or ERROR
584 response! To call connection commands the @link(ATConnect) method.
585 Remember, when you connect to a modem device, it is in AT command mode.
586 Now you can send AT commands to the modem. If you need to transfer data to
587 the modem on the other side of the line, you must first switch to data mode
588 using the @link(ATConnect) method.}
ATCommandnull589 function ATCommand(value: AnsiString): AnsiString; virtual;
590
591 {:This function is used to send connect type AT commands to the modem. It is
592 for commands to switch to connected state. (ATD, ATA, ATO,...)
593 It sends the AT command in the Value parameter and returns the modem's
594 response (may be multiple lines - usually with connection parameters info).
595 If the AT command is processed successfully (the modem returns CONNECT),
596 then the ATResult property is set to @True.
597
598 This function is designed only for AT commands which respond by CONNECT,
599 BUSY, NO DIALTONE NO CARRIER or ERROR. For other AT commands use the
600 @link(ATCommand) method.
601
602 The connect timeout is 90*@link(ATTimeout). If this command is successful
603 (@link(ATresult) is @true), then the modem is in data state. When you now
604 send or receive some data, it is not to or from your modem, but from the
605 modem on other side of the line. Now you can transfer your data.
606 If the connection attempt failed (@link(ATResult) is @False), then the
607 modem is still in AT command mode.}
ATConnectnull608 function ATConnect(value: AnsiString): AnsiString; virtual;
609
610 {:If you "manually" call API functions, forward their return code in
611 the SerialResult parameter to this function, which evaluates it and sets
612 @link(LastError) and @link(LastErrorDesc).}
SerialChecknull613 function SerialCheck(SerialResult: integer): integer; virtual;
614
615 {:If @link(Lasterror) is not 0 and exceptions are enabled, then this procedure
616 raises an exception. This method is used internally. You may need it only
617 in special cases.}
618 procedure ExceptCheck; virtual;
619
620 {:Set Synaser to error state with ErrNumber code. Usually used by internal
621 routines.}
622 procedure SetSynaError(ErrNumber: integer); virtual;
623
624 {:Raise Synaser error with ErrNumber code. Usually used by internal routines.}
625 procedure RaiseSynaError(ErrNumber: integer); virtual;
626 {$IFDEF UNIX}
cpomComportAccessiblenull627 function cpomComportAccessible: boolean; virtual;{HGJ}
628 procedure cpomReleaseComport; virtual; {HGJ}
629 {$ENDIF}
630 {:True device name of currently used port}
631 property Device: string read FDevice;
632
633 {:Error code of last operation. Value is defined by the host operating
634 system, but value 0 is always OK.}
635 property LastError: integer read FLastError;
636
637 {:Human readable description of LastError code.}
638 property LastErrorDesc: string read FLastErrorDesc;
639
640 {:Indicates if the last @link(ATCommand) or @link(ATConnect) method was successful}
641 property ATResult: Boolean read FATResult;
642
643 {:Read the value of the RTS signal.}
644 property RTS: Boolean write SetRTSF;
645
646 {:Indicates the presence of the CTS signal}
647 property CTS: boolean read GetCTS;
648
649 {:Use this property to set the value of the DTR signal.}
650 property DTR: Boolean write SetDTRF;
651
652 {:Exposes the status of the DSR signal.}
653 property DSR: boolean read GetDSR;
654
655 {:Indicates the presence of the Carrier signal}
656 property Carrier: boolean read GetCarrier;
657
658 {:Reflects the status of the Ring signal.}
659 property Ring: boolean read GetRing;
660
661 {:indicates if this instance of SynaSer is active. (Connected to some port)}
662 property InstanceActive: boolean read FInstanceActive; {HGJ}
663
664 {:Defines maximum bandwidth for all sending operations in bytes per second.
665 If this value is set to 0 (default), bandwidth limitation is not used.}
666 property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth;
667
668 {:Defines maximum bandwidth for all receiving operations in bytes per second.
669 If this value is set to 0 (default), bandwidth limitation is not used.}
670 property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth;
671
672 {:Defines maximum bandwidth for all sending and receiving operations
673 in bytes per second. If this value is set to 0 (default), bandwidth
674 limitation is not used.}
675 property MaxBandwidth: Integer Write SetBandwidth;
676
677 {:Size of the Windows internal receive buffer. Default value is usually
678 4096 bytes. Note: Valid only in Windows versions!}
679 property SizeRecvBuffer: integer read FRecvBuffer write SetSizeRecvBuffer;
680 published
681 {:Returns the descriptive text associated with ErrorCode. You need this
682 method only in special cases. Description of LastError is now accessible
683 through the LastErrorDesc property.}
GetErrorDescnull684 class function GetErrorDesc(ErrorCode: integer): string;
685
686 {:Freely usable property}
687 property Tag: integer read FTag write FTag;
688
689 {:Contains the handle of the open communication port.
690 You may need this value to directly call communication functions outside
691 SynaSer.}
692 property Handle: THandle read Fhandle write FHandle;
693
694 {:Internally used read buffer.}
695 property LineBuffer: AnsiString read FBuffer write FBuffer;
696
697 {:If @true, communication errors raise exceptions. If @false (default), only
698 the @link(LastError) value is set.}
699 property RaiseExcept: boolean read FRaiseExcept write FRaiseExcept;
700
701 {:This event is triggered when the communication status changes. It can be
702 used to monitor communication status.}
703 property OnStatus: THookSerialStatus read FOnStatus write FOnStatus;
704
705 {:If you set this property to @true, then the value of the DSR signal
706 is tested before every data transfer. It can be used to detect the presence
707 of a communications device.}
708 property TestDSR: boolean read FTestDSR write FTestDSR;
709
710 {:If you set this property to @true, then the value of the CTS signal
711 is tested before every data transfer. It can be used to detect the presence
712 of a communications device. Warning: This property cannot be used if you
713 need hardware handshake!}
714 property TestCTS: boolean read FTestCTS write FTestCTS;
715
716 {:Use this property you to limit the maximum size of LineBuffer
717 (as a protection against unlimited memory allocation for LineBuffer).
718 Default value is 0 - no limit.}
719 property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
720
721 {:This timeout value is used as deadlock protection when trying to send data
722 to (or receive data from) a device that stopped communicating during data
723 transmission (e.g. by physically disconnecting the device).
724 The timeout value is in milliseconds. The default value is 30,000 (30 seconds).}
725 property DeadlockTimeout: Integer read FDeadlockTimeout Write FDeadlockTimeout;
726
727 {:If set to @true (default value), port locking is enabled (under Linux only).
728 WARNING: To use this feature, the application must run by a user with full
729 permission to the /var/lock directory!}
730 property LinuxLock: Boolean read FLinuxLock write FLinuxLock;
731
732 {:Indicates if non-standard line terminators should be converted to a CR/LF pair
733 (standard DOS line terminator). If @TRUE, line terminators CR, single LF
734 or LF/CR are converted to CR/LF. Defaults to @FALSE.
735 This property has effect only on the behavior of the RecvString method.}
736 property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd;
737
738 {:Timeout for AT modem based operations}
739 property AtTimeout: integer read FAtTimeout Write FAtTimeout;
740
741 {:If @true (default), then all timeouts is timeout between two characters.
742 If @False, then timeout is overall for whoole reading operation.}
743 property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout;
744 end;
745
746 {:Returns list of existing computer serial ports. Working properly only in Windows!}
GetSerialPortNamesnull747 function GetSerialPortNames: string;
748
749 implementation
750
751 constructor TBlockSerial.Create;
752 begin
753 inherited create;
754 FRaiseExcept := false;
755 FHandle := INVALID_HANDLE_VALUE;
756 FDevice := '';
757 FComNr:= PortIsClosed; {HGJ}
758 FInstanceActive:= false; {HGJ}
759 Fbuffer := '';
760 FRTSToggle := False;
761 FMaxLineLength := 0;
762 FTestDSR := False;
763 FTestCTS := False;
764 FDeadlockTimeout := 30000;
765 FLinuxLock := True;
766 FMaxSendBandwidth := 0;
767 FNextSend := 0;
768 FMaxRecvBandwidth := 0;
769 FNextRecv := 0;
770 FConvertLineEnd := False;
771 SetSynaError(sOK);
772 FRecvBuffer := 4096;
773 FLastCR := False;
774 FLastLF := False;
775 FAtTimeout := 1000;
776 FInterPacketTimeout := True;
777 end;
778
779 destructor TBlockSerial.Destroy;
780 begin
781 CloseSocket;
782 inherited destroy;
783 end;
784
TBlockSerial.GetVersionnull785 class function TBlockSerial.GetVersion: string;
786 begin
787 Result := 'SynaSer 7.6.0';
788 end;
789
790 procedure TBlockSerial.CloseSocket;
791 begin
792 if Fhandle <> INVALID_HANDLE_VALUE then
793 begin
794 Purge;
795 RTS := False;
796 DTR := False;
797 FileClose(FHandle);
798 end;
799 if InstanceActive then
800 begin
801 {$IFDEF UNIX}
802 if FLinuxLock then
803 cpomReleaseComport;
804 {$ENDIF}
805 FInstanceActive:= false
806 end;
807 Fhandle := INVALID_HANDLE_VALUE;
808 FComNr:= PortIsClosed;
809 SetSynaError(sOK);
810 DoStatus(HR_SerialClose, FDevice);
811 end;
812
813 {$IFDEF WIN32}
TBlockSerial.GetPortAddrnull814 function TBlockSerial.GetPortAddr: Word;
815 begin
816 Result := 0;
817 if Win32Platform <> VER_PLATFORM_WIN32_NT then
818 begin
Handlenull819 EscapeCommFunction(FHandle, 10);
820 asm
821 MOV @Result, DX;
822 end;
823 end;
824 end;
825
TBlockSerial.ReadTxEmptynull826 function TBlockSerial.ReadTxEmpty(PortAddr: Word): Boolean;
827 begin
828 Result := True;
829 if Win32Platform <> VER_PLATFORM_WIN32_NT then
830 begin
831 asm
832 MOV DX, PortAddr;
833 ADD DX, 5;
834 IN AL, DX;
835 AND AL, $40;
836 JZ @K;
837 MOV AL,1;
838 @K: MOV @Result, AL;
839 end;
840 end;
841 end;
842 {$ENDIF}
843
844 procedure TBlockSerial.GetComNr(Value: string);
845 begin
846 FComNr := PortIsClosed;
847 if pos('COM', uppercase(Value)) = 1 then
848 FComNr := StrToIntdef(copy(Value, 4, Length(Value) - 3), PortIsClosed + 1) - 1;
849 if pos('/DEV/TTYS', uppercase(Value)) = 1 then
850 FComNr := StrToIntdef(copy(Value, 10, Length(Value) - 9), PortIsClosed - 1);
851 end;
852
853 procedure TBlockSerial.SetBandwidth(Value: Integer);
854 begin
855 MaxSendBandwidth := Value;
856 MaxRecvBandwidth := Value;
857 end;
858
859 procedure TBlockSerial.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
860 var
861 x: LongWord;
862 y: LongWord;
863 begin
864 if MaxB > 0 then
865 begin
866 y := GetTick;
867 if Next > y then
868 begin
869 x := Next - y;
870 if x > 0 then
871 begin
872 DoStatus(HR_Wait, IntToStr(x));
873 sleep(x);
874 end;
875 end;
876 Next := GetTick + Trunc((Length / MaxB) * 1000);
877 end;
878 end;
879
880 procedure TBlockSerial.Config(baud, bits: integer; parity: char; stop: integer;
881 softflow, hardflow: boolean);
882 begin
883 FillChar(dcb, SizeOf(dcb), 0);
884 GetCommState;
885 dcb.DCBlength := SizeOf(dcb);
886 dcb.BaudRate := baud;
887 dcb.ByteSize := bits;
888 case parity of
889 'N', 'n': dcb.parity := 0;
890 'O', 'o': dcb.parity := 1;
891 'E', 'e': dcb.parity := 2;
892 'M', 'm': dcb.parity := 3;
893 'S', 's': dcb.parity := 4;
894 end;
895 dcb.StopBits := stop;
896 dcb.XonChar := #17;
897 dcb.XoffChar := #19;
898 dcb.XonLim := FRecvBuffer div 4;
899 dcb.XoffLim := FRecvBuffer div 4;
900 dcb.Flags := dcb_Binary;
901 if softflow then
902 dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX;
903 if hardflow then
904 dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake
905 else
906 dcb.Flags := dcb.Flags or dcb_RtsControlEnable;
907 dcb.Flags := dcb.Flags or dcb_DtrControlEnable;
908 if dcb.Parity > 0 then
909 dcb.Flags := dcb.Flags or dcb_ParityCheck;
910 SetCommState;
911 end;
912
913 procedure TBlockSerial.Connect(comport: string);
914 {$IFDEF MSWINDOWS}
915 var
916 CommTimeouts: TCommTimeouts;
917 {$ENDIF}
918 begin
919 // Is this TBlockSerial Instance already busy?
920 if InstanceActive then {HGJ}
921 begin {HGJ}
922 RaiseSynaError(ErrAlreadyInUse);
923 Exit; {HGJ}
924 end; {HGJ}
925 FBuffer := '';
926 FDevice := comport;
927 GetComNr(comport);
928 {$IFDEF MSWINDOWS}
929 SetLastError (sOK);
930 {$ELSE}
931 {$IFNDEF FPC}
932 SetLastError (sOK);
933 {$ELSE}
934 fpSetErrno(sOK);
935 {$ENDIF}
936 {$ENDIF}
937 {$IFNDEF MSWINDOWS}
938 if FComNr <> PortIsClosed then
939 FDevice := '/dev/ttyS' + IntToStr(FComNr);
940 // Comport already owned by another process? {HGJ}
941 if FLinuxLock then
942 if not cpomComportAccessible then
943 begin
944 RaiseSynaError(ErrAlreadyOwned);
945 Exit;
946 end;
947 {$IFNDEF FPC}
948 FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC));
949 {$ELSE}
950 FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC));
951 {$ENDIF}
952 if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms!
953 SerialCheck(-1)
954 else
955 SerialCheck(0);
956 {$IFDEF UNIX}
957 if FLastError <> sOK then
958 if FLinuxLock then
959 cpomReleaseComport;
960 {$ENDIF}
961 ExceptCheck;
962 if FLastError <> sOK then
963 Exit;
964 {$ELSE}
965 if FComNr <> PortIsClosed then
966 FDevice := '\\.\COM' + IntToStr(FComNr + 1);
967 FHandle := THandle(CreateFile(PChar(FDevice), GENERIC_READ or GENERIC_WRITE,
968 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0));
969 if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms!
970 SerialCheck(-1)
971 else
972 SerialCheck(0);
973 ExceptCheck;
974 if FLastError <> sOK then
975 Exit;
976 SetCommMask(FHandle, 0);
977 SetupComm(Fhandle, FRecvBuffer, 0);
978 CommTimeOuts.ReadIntervalTimeout := MAXWORD;
979 CommTimeOuts.ReadTotalTimeoutMultiplier := 0;
980 CommTimeOuts.ReadTotalTimeoutConstant := 0;
981 CommTimeOuts.WriteTotalTimeoutMultiplier := 0;
982 CommTimeOuts.WriteTotalTimeoutConstant := 0;
983 SetCommTimeOuts(FHandle, CommTimeOuts);
984 {$IFDEF WIN32}
985 FPortAddr := GetPortAddr;
986 {$ENDIF}
987 {$ENDIF}
988 SetSynaError(sOK);
989 if not TestCtrlLine then {HGJ}
990 begin
991 SetSynaError(ErrNoDeviceAnswer);
992 FileClose(FHandle); {HGJ}
993 {$IFDEF UNIX}
994 if FLinuxLock then
995 cpomReleaseComport; {HGJ}
996 {$ENDIF} {HGJ}
997 Fhandle := INVALID_HANDLE_VALUE; {HGJ}
998 FComNr:= PortIsClosed; {HGJ}
999 end
1000 else
1001 begin
1002 FInstanceActive:= True;
1003 RTS := True;
1004 DTR := True;
1005 Purge;
1006 end;
1007 ExceptCheck;
1008 DoStatus(HR_Connect, FDevice);
1009 end;
1010
TBlockSerial.SendBuffernull1011 function TBlockSerial.SendBuffer(buffer: pointer; length: integer): integer;
1012 {$IFDEF MSWINDOWS}
1013 var
1014 Overlapped: TOverlapped;
1015 x, y, Err: DWord;
1016 {$ENDIF}
1017 begin
1018 Result := 0;
1019 if PreTestFailing then {HGJ}
1020 Exit; {HGJ}
1021 LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
1022 if FRTSToggle then
1023 begin
1024 Flush;
1025 RTS := True;
1026 end;
1027 {$IFNDEF MSWINDOWS}
1028 result := FileWrite(Fhandle, Buffer^, Length);
1029 serialcheck(result);
1030 {$ELSE}
1031 FillChar(Overlapped, Sizeof(Overlapped), 0);
1032 SetSynaError(sOK);
1033 y := 0;
1034 if not WriteFile(FHandle, Buffer^, Length, DWord(Result), @Overlapped) then
1035 y := GetLastError;
1036 if y = ERROR_IO_PENDING then
1037 begin
1038 x := WaitForSingleObject(FHandle, FDeadlockTimeout);
1039 if x = WAIT_TIMEOUT then
1040 begin
1041 PurgeComm(FHandle, PURGE_TXABORT);
1042 SetSynaError(ErrTimeout);
1043 end;
1044 GetOverlappedResult(FHandle, Overlapped, Dword(Result), False);
1045 end
1046 else
1047 SetSynaError(y);
1048 err := 0;
1049 ClearCommError(FHandle, err, nil);
1050 if err <> 0 then
1051 DecodeCommError(err);
1052 {$ENDIF}
1053 if FRTSToggle then
1054 begin
1055 Flush;
1056 CanWrite(255);
1057 RTS := False;
1058 end;
1059 ExceptCheck;
1060 DoStatus(HR_WriteCount, IntToStr(Result));
1061 end;
1062
1063 procedure TBlockSerial.SendByte(data: byte);
1064 begin
1065 SendBuffer(@Data, 1);
1066 end;
1067
1068 procedure TBlockSerial.SendString(data: AnsiString);
1069 begin
1070 SendBuffer(Pointer(Data), Length(Data));
1071 end;
1072
1073 procedure TBlockSerial.SendInteger(Data: integer);
1074 begin
1075 SendBuffer(@data, SizeOf(Data));
1076 end;
1077
1078 procedure TBlockSerial.SendBlock(const Data: AnsiString);
1079 begin
1080 SendInteger(Length(data));
1081 SendString(Data);
1082 end;
1083
1084 procedure TBlockSerial.SendStreamRaw(const Stream: TStream);
1085 var
1086 si: integer;
1087 x, y, yr: integer;
1088 s: AnsiString;
1089 begin
1090 si := Stream.Size - Stream.Position;
1091 x := 0;
1092 while x < si do
1093 begin
1094 y := si - x;
1095 if y > cSerialChunk then
1096 y := cSerialChunk;
1097 Setlength(s, y);
1098 yr := Stream.read(PAnsiChar(s)^, y);
1099 if yr > 0 then
1100 begin
1101 SetLength(s, yr);
1102 SendString(s);
1103 Inc(x, yr);
1104 end
1105 else
1106 break;
1107 end;
1108 end;
1109
1110 procedure TBlockSerial.SendStreamIndy(const Stream: TStream);
1111 var
1112 si: integer;
1113 begin
1114 si := Stream.Size - Stream.Position;
1115 si := Swapbytes(si);
1116 SendInteger(si);
1117 SendStreamRaw(Stream);
1118 end;
1119
1120 procedure TBlockSerial.SendStream(const Stream: TStream);
1121 var
1122 si: integer;
1123 begin
1124 si := Stream.Size - Stream.Position;
1125 SendInteger(si);
1126 SendStreamRaw(Stream);
1127 end;
1128
TBlockSerial.RecvBuffernull1129 function TBlockSerial.RecvBuffer(buffer: pointer; length: integer): integer;
1130 {$IFNDEF MSWINDOWS}
1131 begin
1132 Result := 0;
1133 if PreTestFailing then {HGJ}
1134 Exit; {HGJ}
1135 LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
1136 result := FileRead(FHandle, Buffer^, length);
1137 serialcheck(result);
1138 {$ELSE}
1139 var
1140 Overlapped: TOverlapped;
1141 x, y, Err: DWord;
1142 begin
1143 Result := 0;
1144 if PreTestFailing then {HGJ}
1145 Exit; {HGJ}
1146 LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
1147 FillChar(Overlapped, Sizeof(Overlapped), 0);
1148 SetSynaError(sOK);
1149 y := 0;
1150 if not ReadFile(FHandle, Buffer^, length, Dword(Result), @Overlapped) then
1151 y := GetLastError;
1152 if y = ERROR_IO_PENDING then
1153 begin
1154 x := WaitForSingleObject(FHandle, FDeadlockTimeout);
1155 if x = WAIT_TIMEOUT then
1156 begin
1157 PurgeComm(FHandle, PURGE_RXABORT);
1158 SetSynaError(ErrTimeout);
1159 end;
1160 GetOverlappedResult(FHandle, Overlapped, Dword(Result), False);
1161 end
1162 else
1163 SetSynaError(y);
1164 err := 0;
1165 ClearCommError(FHandle, err, nil);
1166 if err <> 0 then
1167 DecodeCommError(err);
1168 {$ENDIF}
1169 ExceptCheck;
1170 DoStatus(HR_ReadCount, IntToStr(Result));
1171 end;
1172
TBlockSerial.RecvBufferExnull1173 function TBlockSerial.RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer;
1174 var
1175 s: AnsiString;
1176 rl, l: integer;
1177 ti: LongWord;
1178 begin
1179 Result := 0;
1180 if PreTestFailing then {HGJ}
1181 Exit; {HGJ}
1182 SetSynaError(sOK);
1183 rl := 0;
1184 repeat
1185 ti := GetTick;
1186 s := RecvPacket(Timeout);
1187 l := System.Length(s);
1188 if (rl + l) > Length then
1189 l := Length - rl;
1190 Move(Pointer(s)^, IncPoint(Buffer, rl)^, l);
1191 rl := rl + l;
1192 if FLastError <> sOK then
1193 Break;
1194 if rl >= Length then
1195 Break;
1196 if not FInterPacketTimeout then
1197 begin
1198 Timeout := Timeout - integer(TickDelta(ti, GetTick));
1199 if Timeout <= 0 then
1200 begin
1201 SetSynaError(ErrTimeout);
1202 Break;
1203 end;
1204 end;
1205 until False;
1206 delete(s, 1, l);
1207 FBuffer := s;
1208 Result := rl;
1209 end;
1210
TBlockSerial.RecvBufferStrnull1211 function TBlockSerial.RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString;
1212 var
1213 x: integer;
1214 begin
1215 Result := '';
1216 if PreTestFailing then {HGJ}
1217 Exit; {HGJ}
1218 SetSynaError(sOK);
1219 if Length > 0 then
1220 begin
1221 Setlength(Result, Length);
1222 x := RecvBufferEx(PAnsiChar(Result), Length , Timeout);
1223 if FLastError = sOK then
1224 SetLength(Result, x)
1225 else
1226 Result := '';
1227 end;
1228 end;
1229
RecvPacketnull1230 function TBlockSerial.RecvPacket(Timeout: Integer): AnsiString;
1231 var
1232 x: integer;
1233 begin
1234 Result := '';
1235 if PreTestFailing then {HGJ}
1236 Exit; {HGJ}
1237 SetSynaError(sOK);
1238 if FBuffer <> '' then
1239 begin
1240 Result := FBuffer;
1241 FBuffer := '';
1242 end
1243 else
1244 begin
1245 //not drain CPU on large downloads...
1246 Sleep(0);
1247 x := WaitingData;
1248 if x > 0 then
1249 begin
1250 SetLength(Result, x);
1251 x := RecvBuffer(Pointer(Result), x);
1252 if x >= 0 then
1253 SetLength(Result, x);
1254 end
1255 else
1256 begin
1257 if CanRead(Timeout) then
1258 begin
1259 x := WaitingData;
1260 if x = 0 then
1261 SetSynaError(ErrTimeout);
1262 if x > 0 then
1263 begin
1264 SetLength(Result, x);
1265 x := RecvBuffer(Pointer(Result), x);
1266 if x >= 0 then
1267 SetLength(Result, x);
1268 end;
1269 end
1270 else
1271 SetSynaError(ErrTimeout);
1272 end;
1273 end;
1274 ExceptCheck;
1275 end;
1276
1277
RecvBytenull1278 function TBlockSerial.RecvByte(timeout: integer): byte;
1279 begin
1280 Result := 0;
1281 if PreTestFailing then {HGJ}
1282 Exit; {HGJ}
1283 SetSynaError(sOK);
1284 if FBuffer = '' then
1285 FBuffer := RecvPacket(Timeout);
1286 if (FLastError = sOK) and (FBuffer <> '') then
1287 begin
1288 Result := Ord(FBuffer[1]);
1289 System.Delete(FBuffer, 1, 1);
1290 end;
1291 ExceptCheck;
1292 end;
1293
RecvTerminatednull1294 function TBlockSerial.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString;
1295 var
1296 x: Integer;
1297 s: AnsiString;
1298 l: Integer;
1299 CorCRLF: Boolean;
1300 t: ansistring;
1301 tl: integer;
1302 ti: LongWord;
1303 begin
1304 Result := '';
1305 if PreTestFailing then {HGJ}
1306 Exit; {HGJ}
1307 SetSynaError(sOK);
1308 l := system.Length(Terminator);
1309 if l = 0 then
1310 Exit;
1311 tl := l;
1312 CorCRLF := FConvertLineEnd and (Terminator = CRLF);
1313 s := '';
1314 x := 0;
1315 repeat
1316 ti := GetTick;
1317 //get rest of FBuffer or incomming new data...
1318 s := s + RecvPacket(Timeout);
1319 if FLastError <> sOK then
1320 Break;
1321 x := 0;
1322 if Length(s) > 0 then
1323 if CorCRLF then
1324 begin
1325 if FLastCR and (s[1] = LF) then
1326 Delete(s, 1, 1);
1327 if FLastLF and (s[1] = CR) then
1328 Delete(s, 1, 1);
1329 FLastCR := False;
1330 FLastLF := False;
1331 t := '';
1332 x := PosCRLF(s, t);
1333 tl := system.Length(t);
1334 if t = CR then
1335 FLastCR := True;
1336 if t = LF then
1337 FLastLF := True;
1338 end
1339 else
1340 begin
1341 x := pos(Terminator, s);
1342 tl := l;
1343 end;
1344 if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then
1345 begin
1346 SetSynaError(ErrMaxBuffer);
1347 Break;
1348 end;
1349 if x > 0 then
1350 Break;
1351 if not FInterPacketTimeout then
1352 begin
1353 Timeout := Timeout - integer(TickDelta(ti, GetTick));
1354 if Timeout <= 0 then
1355 begin
1356 SetSynaError(ErrTimeout);
1357 Break;
1358 end;
1359 end;
1360 until False;
1361 if x > 0 then
1362 begin
1363 Result := Copy(s, 1, x - 1);
1364 System.Delete(s, 1, x + tl - 1);
1365 end;
1366 FBuffer := s;
1367 ExceptCheck;
1368 end;
1369
1370
RecvStringnull1371 function TBlockSerial.RecvString(Timeout: Integer): AnsiString;
1372 var
1373 s: AnsiString;
1374 begin
1375 Result := '';
1376 s := RecvTerminated(Timeout, #13 + #10);
1377 if FLastError = sOK then
1378 Result := s;
1379 end;
1380
RecvIntegernull1381 function TBlockSerial.RecvInteger(Timeout: Integer): Integer;
1382 var
1383 s: AnsiString;
1384 begin
1385 Result := 0;
1386 s := RecvBufferStr(4, Timeout);
1387 if FLastError = 0 then
1388 Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536;
1389 end;
1390
RecvBlocknull1391 function TBlockSerial.RecvBlock(Timeout: Integer): AnsiString;
1392 var
1393 x: integer;
1394 begin
1395 Result := '';
1396 x := RecvInteger(Timeout);
1397 if FLastError = 0 then
1398 Result := RecvBufferStr(x, Timeout);
1399 end;
1400
1401 procedure TBlockSerial.RecvStreamRaw(const Stream: TStream; Timeout: Integer);
1402 var
1403 s: AnsiString;
1404 begin
1405 repeat
1406 s := RecvPacket(Timeout);
1407 if FLastError = 0 then
1408 WriteStrToStream(Stream, s);
1409 until FLastError <> 0;
1410 end;
1411
1412 procedure TBlockSerial.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
1413 var
1414 s: AnsiString;
1415 n: integer;
1416 begin
1417 for n := 1 to (Size div cSerialChunk) do
1418 begin
1419 s := RecvBufferStr(cSerialChunk, Timeout);
1420 if FLastError <> 0 then
1421 Exit;
1422 Stream.Write(PAnsichar(s)^, cSerialChunk);
1423 end;
1424 n := Size mod cSerialChunk;
1425 if n > 0 then
1426 begin
1427 s := RecvBufferStr(n, Timeout);
1428 if FLastError <> 0 then
1429 Exit;
1430 Stream.Write(PAnsichar(s)^, n);
1431 end;
1432 end;
1433
1434 procedure TBlockSerial.RecvStreamIndy(const Stream: TStream; Timeout: Integer);
1435 var
1436 x: integer;
1437 begin
1438 x := RecvInteger(Timeout);
1439 x := SwapBytes(x);
1440 if FLastError = 0 then
1441 RecvStreamSize(Stream, Timeout, x);
1442 end;
1443
1444 procedure TBlockSerial.RecvStream(const Stream: TStream; Timeout: Integer);
1445 var
1446 x: integer;
1447 begin
1448 x := RecvInteger(Timeout);
1449 if FLastError = 0 then
1450 RecvStreamSize(Stream, Timeout, x);
1451 end;
1452
1453 {$IFNDEF MSWINDOWS}
WaitingDatanull1454 function TBlockSerial.WaitingData: integer;
1455 begin
1456 {$IFNDEF FPC}
1457 serialcheck(ioctl(FHandle, FIONREAD, @result));
1458 {$ELSE}
1459 serialcheck(fpIoctl(FHandle, FIONREAD, @result));
1460 {$ENDIF}
1461 if FLastError <> 0 then
1462 Result := 0;
1463 ExceptCheck;
1464 end;
1465 {$ELSE}
WaitingDatanull1466 function TBlockSerial.WaitingData: integer;
1467 var
1468 stat: TComStat;
1469 err: DWORD;
1470 begin
1471 err := 0;
1472 if ClearCommError(FHandle, err, @stat) then
1473 begin
1474 SetSynaError(sOK);
1475 Result := stat.cbInQue;
1476 end
1477 else
1478 begin
1479 SerialCheck(sErr);
1480 Result := 0;
1481 end;
1482 ExceptCheck;
1483 end;
1484 {$ENDIF}
1485
TBlockSerial.WaitingDataExnull1486 function TBlockSerial.WaitingDataEx: integer;
1487 begin
1488 if FBuffer <> '' then
1489 Result := Length(FBuffer)
1490 else
1491 Result := Waitingdata;
1492 end;
1493
1494 {$IFNDEF MSWINDOWS}
TBlockSerial.SendingDatanull1495 function TBlockSerial.SendingData: integer;
1496 begin
1497 SetSynaError(sOK);
1498 Result := 0;
1499 end;
1500 {$ELSE}
TBlockSerial.SendingDatanull1501 function TBlockSerial.SendingData: integer;
1502 var
1503 stat: TComStat;
1504 err: DWORD;
1505 begin
1506 SetSynaError(sOK);
1507 err := 0;
1508 if not ClearCommError(FHandle, err, @stat) then
1509 serialcheck(sErr);
1510 ExceptCheck;
1511 result := stat.cbOutQue;
1512 end;
1513 {$ENDIF}
1514
1515 {$IFNDEF MSWINDOWS}
1516 procedure TBlockSerial.DcbToTermios(const dcb: TDCB; var term: termios);
1517 var
1518 n: integer;
1519 x: cardinal;
1520 begin
1521 //others
1522 cfmakeraw(term);
1523 term.c_cflag := term.c_cflag or CREAD;
1524 term.c_cflag := term.c_cflag or CLOCAL;
1525 term.c_cflag := term.c_cflag or HUPCL;
1526 //hardware handshake
1527 if (dcb.flags and dcb_RtsControlHandshake) > 0 then
1528 term.c_cflag := term.c_cflag or CRTSCTS
1529 else
1530 term.c_cflag := term.c_cflag and (not CRTSCTS);
1531 //software handshake
1532 if (dcb.flags and dcb_OutX) > 0 then
1533 term.c_iflag := term.c_iflag or IXON or IXOFF or IXANY
1534 else
1535 term.c_iflag := term.c_iflag and (not (IXON or IXOFF or IXANY));
1536 //size of byte
1537 term.c_cflag := term.c_cflag and (not CSIZE);
1538 case dcb.bytesize of
1539 5:
1540 term.c_cflag := term.c_cflag or CS5;
1541 6:
1542 term.c_cflag := term.c_cflag or CS6;
1543 7:
1544 {$IFDEF FPC}
1545 term.c_cflag := term.c_cflag or CS7;
1546 {$ELSE}
1547 term.c_cflag := term.c_cflag or CS7fix;
1548 {$ENDIF}
1549 8:
1550 term.c_cflag := term.c_cflag or CS8;
1551 end;
1552 //parity
1553 if (dcb.flags and dcb_ParityCheck) > 0 then
1554 term.c_cflag := term.c_cflag or PARENB
1555 else
1556 term.c_cflag := term.c_cflag and (not PARENB);
1557 case dcb.parity of
1558 1: //'O'
1559 term.c_cflag := term.c_cflag or PARODD;
1560 2: //'E'
1561 term.c_cflag := term.c_cflag and (not PARODD);
1562 end;
1563 //stop bits
1564 if dcb.stopbits > 0 then
1565 term.c_cflag := term.c_cflag or CSTOPB
1566 else
1567 term.c_cflag := term.c_cflag and (not CSTOPB);
1568 //set baudrate;
1569 x := 0;
1570 for n := 0 to Maxrates do
1571 if rates[n, 0] = dcb.BaudRate then
1572 begin
1573 x := rates[n, 1];
1574 break;
1575 end;
1576 cfsetospeed(term, x);
1577 cfsetispeed(term, x);
1578 end;
1579
1580 procedure TBlockSerial.TermiosToDcb(const term: termios; var dcb: TDCB);
1581 var
1582 n: integer;
1583 x: cardinal;
1584 begin
1585 //set baudrate;
1586 dcb.baudrate := 0;
1587 {$IFDEF FPC}
1588 //why FPC not have cfgetospeed???
1589 x := term.c_oflag and $0F;
1590 {$ELSE}
1591 x := cfgetospeed(term);
1592 {$ENDIF}
1593 for n := 0 to Maxrates do
1594 if rates[n, 1] = x then
1595 begin
1596 dcb.baudrate := rates[n, 0];
1597 break;
1598 end;
1599 //hardware handshake
1600 if (term.c_cflag and CRTSCTS) > 0 then
1601 dcb.flags := dcb.flags or dcb_RtsControlHandshake or dcb_OutxCtsFlow
1602 else
1603 dcb.flags := dcb.flags and (not (dcb_RtsControlHandshake or dcb_OutxCtsFlow));
1604 //software handshake
1605 if (term.c_cflag and IXOFF) > 0 then
1606 dcb.flags := dcb.flags or dcb_OutX or dcb_InX
1607 else
1608 dcb.flags := dcb.flags and (not (dcb_OutX or dcb_InX));
1609 //size of byte
1610 case term.c_cflag and CSIZE of
1611 CS5:
1612 dcb.bytesize := 5;
1613 CS6:
1614 dcb.bytesize := 6;
1615 CS7fix:
1616 dcb.bytesize := 7;
1617 CS8:
1618 dcb.bytesize := 8;
1619 end;
1620 //parity
1621 if (term.c_cflag and PARENB) > 0 then
1622 dcb.flags := dcb.flags or dcb_ParityCheck
1623 else
1624 dcb.flags := dcb.flags and (not dcb_ParityCheck);
1625 dcb.parity := 0;
1626 if (term.c_cflag and PARODD) > 0 then
1627 dcb.parity := 1
1628 else
1629 dcb.parity := 2;
1630 //stop bits
1631 if (term.c_cflag and CSTOPB) > 0 then
1632 dcb.stopbits := 2
1633 else
1634 dcb.stopbits := 0;
1635 end;
1636 {$ENDIF}
1637
1638 {$IFNDEF MSWINDOWS}
1639 procedure TBlockSerial.SetCommState;
1640 begin
1641 DcbToTermios(dcb, termiosstruc);
1642 SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc));
1643 ExceptCheck;
1644 end;
1645 {$ELSE}
1646 procedure TBlockSerial.SetCommState;
1647 begin
1648 SetSynaError(sOK);
1649 if not windows.SetCommState(Fhandle, dcb) then
1650 SerialCheck(sErr);
1651 ExceptCheck;
1652 end;
1653 {$ENDIF}
1654
1655 {$IFNDEF MSWINDOWS}
1656 procedure TBlockSerial.GetCommState;
1657 begin
1658 SerialCheck(tcgetattr(FHandle, termiosstruc));
1659 ExceptCheck;
1660 TermiostoDCB(termiosstruc, dcb);
1661 end;
1662 {$ELSE}
1663 procedure TBlockSerial.GetCommState;
1664 begin
1665 SetSynaError(sOK);
1666 if not windows.GetCommState(Fhandle, dcb) then
1667 SerialCheck(sErr);
1668 ExceptCheck;
1669 end;
1670 {$ENDIF}
1671
1672 procedure TBlockSerial.SetSizeRecvBuffer(size: integer);
1673 begin
1674 {$IFDEF MSWINDOWS}
1675 SetupComm(Fhandle, size, 0);
1676 GetCommState;
1677 dcb.XonLim := size div 4;
1678 dcb.XoffLim := size div 4;
1679 SetCommState;
1680 {$ENDIF}
1681 FRecvBuffer := size;
1682 end;
1683
GetDSRnull1684 function TBlockSerial.GetDSR: Boolean;
1685 begin
1686 ModemStatus;
1687 {$IFNDEF MSWINDOWS}
1688 Result := (FModemWord and TIOCM_DSR) > 0;
1689 {$ELSE}
1690 Result := (FModemWord and MS_DSR_ON) > 0;
1691 {$ENDIF}
1692 end;
1693
1694 procedure TBlockSerial.SetDTRF(Value: Boolean);
1695 begin
1696 {$IFNDEF MSWINDOWS}
1697 ModemStatus;
1698 if Value then
1699 FModemWord := FModemWord or TIOCM_DTR
1700 else
1701 FModemWord := FModemWord and not TIOCM_DTR;
1702 {$IFNDEF FPC}
1703 ioctl(FHandle, TIOCMSET, @FModemWord);
1704 {$ELSE}
1705 fpioctl(FHandle, TIOCMSET, @FModemWord);
1706 {$ENDIF}
1707 {$ELSE}
1708 if Value then
Handlenull1709 EscapeCommFunction(FHandle, SETDTR)
1710 else
1711 EscapeCommFunction(FHandle, CLRDTR);
1712 {$ENDIF}
1713 end;
1714
GetCTSnull1715 function TBlockSerial.GetCTS: Boolean;
1716 begin
1717 ModemStatus;
1718 {$IFNDEF MSWINDOWS}
1719 Result := (FModemWord and TIOCM_CTS) > 0;
1720 {$ELSE}
1721 Result := (FModemWord and MS_CTS_ON) > 0;
1722 {$ENDIF}
1723 end;
1724
1725 procedure TBlockSerial.SetRTSF(Value: Boolean);
1726 begin
1727 {$IFNDEF MSWINDOWS}
1728 ModemStatus;
1729 if Value then
1730 FModemWord := FModemWord or TIOCM_RTS
1731 else
1732 FModemWord := FModemWord and not TIOCM_RTS;
1733 {$IFNDEF FPC}
1734 ioctl(FHandle, TIOCMSET, @FModemWord);
1735 {$ELSE}
1736 fpioctl(FHandle, TIOCMSET, @FModemWord);
1737 {$ENDIF}
1738 {$ELSE}
1739 if Value then
Handlenull1740 EscapeCommFunction(FHandle, SETRTS)
1741 else
1742 EscapeCommFunction(FHandle, CLRRTS);
1743 {$ENDIF}
1744 end;
1745
TBlockSerial.GetCarriernull1746 function TBlockSerial.GetCarrier: Boolean;
1747 begin
1748 ModemStatus;
1749 {$IFNDEF MSWINDOWS}
1750 Result := (FModemWord and TIOCM_CAR) > 0;
1751 {$ELSE}
1752 Result := (FModemWord and MS_RLSD_ON) > 0;
1753 {$ENDIF}
1754 end;
1755
TBlockSerial.GetRingnull1756 function TBlockSerial.GetRing: Boolean;
1757 begin
1758 ModemStatus;
1759 {$IFNDEF MSWINDOWS}
1760 Result := (FModemWord and TIOCM_RNG) > 0;
1761 {$ELSE}
1762 Result := (FModemWord and MS_RING_ON) > 0;
1763 {$ENDIF}
1764 end;
1765
1766 {$IFDEF MSWINDOWS}
CanEventnull1767 function TBlockSerial.CanEvent(Event: dword; Timeout: integer): boolean;
1768 var
1769 ex: DWord;
1770 y: Integer;
1771 Overlapped: TOverlapped;
1772 begin
1773 FillChar(Overlapped, Sizeof(Overlapped), 0);
1774 Overlapped.hEvent := CreateEvent(nil, True, False, nil);
1775 try
1776 SetCommMask(FHandle, Event);
1777 SetSynaError(sOK);
1778 if (Event = EV_RXCHAR) and (Waitingdata > 0) then
1779 Result := True
1780 else
1781 begin
1782 y := 0;
1783 ex := 0;
1784 if not WaitCommEvent(FHandle, ex, @Overlapped) then
1785 y := GetLastError;
1786 if y = ERROR_IO_PENDING then
1787 begin
1788 //timedout
1789 WaitForSingleObject(Overlapped.hEvent, Timeout);
1790 SetCommMask(FHandle, 0);
1791 GetOverlappedResult(FHandle, Overlapped, DWord(y), True);
1792 end;
1793 Result := (ex and Event) = Event;
1794 end;
1795 finally
1796 SetCommMask(FHandle, 0);
1797 CloseHandle(Overlapped.hEvent);
1798 end;
1799 end;
1800 {$ENDIF}
1801
1802 {$IFNDEF MSWINDOWS}
TBlockSerial.CanReadnull1803 function TBlockSerial.CanRead(Timeout: integer): boolean;
1804 var
1805 FDSet: TFDSet;
1806 TimeVal: PTimeVal;
1807 TimeV: TTimeVal;
1808 x: Integer;
1809 begin
1810 TimeV.tv_usec := (Timeout mod 1000) * 1000;
1811 TimeV.tv_sec := Timeout div 1000;
1812 TimeVal := @TimeV;
1813 if Timeout = -1 then
1814 TimeVal := nil;
1815 {$IFNDEF FPC}
1816 FD_ZERO(FDSet);
1817 FD_SET(FHandle, FDSet);
1818 x := Select(FHandle + 1, @FDSet, nil, nil, TimeVal);
1819 {$ELSE}
1820 fpFD_ZERO(FDSet);
1821 fpFD_SET(FHandle, FDSet);
1822 x := fpSelect(FHandle + 1, @FDSet, nil, nil, TimeVal);
1823 {$ENDIF}
1824 SerialCheck(x);
1825 if FLastError <> sOK then
1826 x := 0;
1827 Result := x > 0;
1828 ExceptCheck;
1829 if Result then
1830 DoStatus(HR_CanRead, '');
1831 end;
1832 {$ELSE}
TBlockSerial.CanReadnull1833 function TBlockSerial.CanRead(Timeout: integer): boolean;
1834 begin
1835 Result := WaitingData > 0;
1836 if not Result then
1837 Result := CanEvent(EV_RXCHAR, Timeout) or (WaitingData > 0);
1838 //check WaitingData again due some broken virtual ports
1839 if Result then
1840 DoStatus(HR_CanRead, '');
1841 end;
1842 {$ENDIF}
1843
1844 {$IFNDEF MSWINDOWS}
CanWritenull1845 function TBlockSerial.CanWrite(Timeout: integer): boolean;
1846 var
1847 FDSet: TFDSet;
1848 TimeVal: PTimeVal;
1849 TimeV: TTimeVal;
1850 x: Integer;
1851 begin
1852 TimeV.tv_usec := (Timeout mod 1000) * 1000;
1853 TimeV.tv_sec := Timeout div 1000;
1854 TimeVal := @TimeV;
1855 if Timeout = -1 then
1856 TimeVal := nil;
1857 {$IFNDEF FPC}
1858 FD_ZERO(FDSet);
1859 FD_SET(FHandle, FDSet);
1860 x := Select(FHandle + 1, nil, @FDSet, nil, TimeVal);
1861 {$ELSE}
1862 fpFD_ZERO(FDSet);
1863 fpFD_SET(FHandle, FDSet);
1864 x := fpSelect(FHandle + 1, nil, @FDSet, nil, TimeVal);
1865 {$ENDIF}
1866 SerialCheck(x);
1867 if FLastError <> sOK then
1868 x := 0;
1869 Result := x > 0;
1870 ExceptCheck;
1871 if Result then
1872 DoStatus(HR_CanWrite, '');
1873 end;
1874 {$ELSE}
CanWritenull1875 function TBlockSerial.CanWrite(Timeout: integer): boolean;
1876 var
1877 t: LongWord;
1878 begin
1879 Result := SendingData = 0;
1880 if not Result then
1881 Result := CanEvent(EV_TXEMPTY, Timeout);
1882 {$IFDEF WIN32}
1883 if Result and (Win32Platform <> VER_PLATFORM_WIN32_NT) then
1884 begin
1885 t := GetTick;
1886 while not ReadTxEmpty(FPortAddr) do
1887 begin
1888 if TickDelta(t, GetTick) > 255 then
1889 Break;
1890 Sleep(0);
1891 end;
1892 end;
1893 {$ENDIF}
1894 if Result then
1895 DoStatus(HR_CanWrite, '');
1896 end;
1897 {$ENDIF}
1898
TBlockSerial.CanReadExnull1899 function TBlockSerial.CanReadEx(Timeout: integer): boolean;
1900 begin
1901 if Fbuffer <> '' then
1902 Result := True
1903 else
1904 Result := CanRead(Timeout);
1905 end;
1906
1907 procedure TBlockSerial.EnableRTSToggle(Value: boolean);
1908 begin
1909 SetSynaError(sOK);
1910 {$IFNDEF MSWINDOWS}
1911 FRTSToggle := Value;
1912 if Value then
1913 RTS:=False;
1914 {$ELSE}
1915 if Win32Platform = VER_PLATFORM_WIN32_NT then
1916 begin
1917 GetCommState;
1918 if value then
1919 dcb.Flags := dcb.Flags or dcb_RtsControlToggle
1920 else
1921 dcb.flags := dcb.flags and (not dcb_RtsControlToggle);
1922 SetCommState;
1923 end
1924 else
1925 begin
1926 FRTSToggle := Value;
1927 if Value then
1928 RTS:=False;
1929 end;
1930 {$ENDIF}
1931 end;
1932
1933 procedure TBlockSerial.Flush;
1934 begin
1935 {$IFNDEF MSWINDOWS}
1936 SerialCheck(tcdrain(FHandle));
1937 {$ELSE}
1938 SetSynaError(sOK);
1939 if not Flushfilebuffers(FHandle) then
1940 SerialCheck(sErr);
1941 {$ENDIF}
1942 ExceptCheck;
1943 end;
1944
1945 {$IFNDEF MSWINDOWS}
1946 procedure TBlockSerial.Purge;
1947 begin
1948 {$IFNDEF FPC}
1949 SerialCheck(ioctl(FHandle, TCFLSH, TCIOFLUSH));
1950 {$ELSE}
1951 {$IFDEF DARWIN}
1952 SerialCheck(fpioctl(FHandle, TCIOflush, Pointer(PtrInt(TCIOFLUSH))));
1953 {$ELSE}
1954 SerialCheck(fpioctl(FHandle, {$IFDEF DragonFly}TCIOFLUSH{$ELSE}TCFLSH{$ENDIF}, Pointer(PtrInt(TCIOFLUSH))));
1955 {$ENDIF}
1956 {$ENDIF}
1957 FBuffer := '';
1958 ExceptCheck;
1959 end;
1960 {$ELSE}
1961 procedure TBlockSerial.Purge;
1962 var
1963 x: integer;
1964 begin
1965 SetSynaError(sOK);
1966 x := PURGE_TXABORT or PURGE_TXCLEAR or PURGE_RXABORT or PURGE_RXCLEAR;
1967 if not PurgeComm(FHandle, x) then
1968 SerialCheck(sErr);
1969 FBuffer := '';
1970 ExceptCheck;
1971 end;
1972 {$ENDIF}
1973
ModemStatusnull1974 function TBlockSerial.ModemStatus: integer;
1975 begin
1976 Result := 0;
1977 {$IFNDEF MSWINDOWS}
1978 {$IFNDEF FPC}
1979 SerialCheck(ioctl(FHandle, TIOCMGET, @Result));
1980 {$ELSE}
1981 SerialCheck(fpioctl(FHandle, TIOCMGET, @Result));
1982 {$ENDIF}
1983 {$ELSE}
1984 SetSynaError(sOK);
1985 if not GetCommModemStatus(FHandle, dword(Result)) then
1986 SerialCheck(sErr);
1987 {$ENDIF}
1988 ExceptCheck;
1989 FModemWord := Result;
1990 end;
1991
1992 procedure TBlockSerial.SetBreak(Duration: integer);
1993 begin
1994 {$IFNDEF MSWINDOWS}
1995 SerialCheck(tcsendbreak(FHandle, Duration));
1996 {$ELSE}
1997 SetCommBreak(FHandle);
1998 Sleep(Duration);
1999 SetSynaError(sOK);
2000 if not ClearCommBreak(FHandle) then
2001 SerialCheck(sErr);
2002 {$ENDIF}
2003 end;
2004
2005 {$IFDEF MSWINDOWS}
2006 procedure TBlockSerial.DecodeCommError(Error: DWord);
2007 begin
2008 if (Error and DWord(CE_FRAME)) > 1 then
2009 FLastError := ErrFrame;
2010 if (Error and DWord(CE_OVERRUN)) > 1 then
2011 FLastError := ErrOverrun;
2012 if (Error and DWord(CE_RXOVER)) > 1 then
2013 FLastError := ErrRxOver;
2014 if (Error and DWord(CE_RXPARITY)) > 1 then
2015 FLastError := ErrRxParity;
2016 if (Error and DWord(CE_TXFULL)) > 1 then
2017 FLastError := ErrTxFull;
2018 end;
2019 {$ENDIF}
2020
2021 //HGJ
PreTestFailingnull2022 function TBlockSerial.PreTestFailing: Boolean;
2023 begin
2024 if not FInstanceActive then
2025 begin
2026 RaiseSynaError(ErrPortNotOpen);
2027 result:= true;
2028 Exit;
2029 end;
2030 Result := not TestCtrlLine;
2031 if result then
2032 RaiseSynaError(ErrNoDeviceAnswer)
2033 end;
2034
TestCtrlLinenull2035 function TBlockSerial.TestCtrlLine: Boolean;
2036 begin
2037 result := ((not FTestDSR) or DSR) and ((not FTestCTS) or CTS);
2038 end;
2039
ATCommandnull2040 function TBlockSerial.ATCommand(value: AnsiString): AnsiString;
2041 var
2042 s: AnsiString;
2043 ConvSave: Boolean;
2044 begin
2045 result := '';
2046 FAtResult := False;
2047 ConvSave := FConvertLineEnd;
2048 try
2049 FConvertLineEnd := True;
2050 SendString(value + #$0D);
2051 repeat
2052 s := RecvString(FAtTimeout);
2053 if s <> Value then
2054 result := result + s + CRLF;
2055 if s = 'OK' then
2056 begin
2057 FAtResult := True;
2058 break;
2059 end;
2060 if s = 'ERROR' then
2061 break;
2062 until FLastError <> sOK;
2063 finally
2064 FConvertLineEnd := Convsave;
2065 end;
2066 end;
2067
2068
ATConnectnull2069 function TBlockSerial.ATConnect(value: AnsiString): AnsiString;
2070 var
2071 s: AnsiString;
2072 ConvSave: Boolean;
2073 begin
2074 result := '';
2075 FAtResult := False;
2076 ConvSave := FConvertLineEnd;
2077 try
2078 FConvertLineEnd := True;
2079 SendString(value + #$0D);
2080 repeat
2081 s := RecvString(90 * FAtTimeout);
2082 if s <> Value then
2083 result := result + s + CRLF;
2084 if s = 'NO CARRIER' then
2085 break;
2086 if s = 'ERROR' then
2087 break;
2088 if s = 'BUSY' then
2089 break;
2090 if s = 'NO DIALTONE' then
2091 break;
2092 if Pos('CONNECT', s) = 1 then
2093 begin
2094 FAtResult := True;
2095 break;
2096 end;
2097 until FLastError <> sOK;
2098 finally
2099 FConvertLineEnd := Convsave;
2100 end;
2101 end;
2102
TBlockSerial.SerialChecknull2103 function TBlockSerial.SerialCheck(SerialResult: integer): integer;
2104 begin
2105 if SerialResult = integer(INVALID_HANDLE_VALUE) then
2106 {$IFDEF MSWINDOWS}
2107 result := GetLastError
2108 {$ELSE}
2109 {$IFNDEF FPC}
2110 result := GetLastError
2111 {$ELSE}
2112 result := fpGetErrno
2113 {$ENDIF}
2114 {$ENDIF}
2115 else
2116 result := sOK;
2117 FLastError := result;
2118 FLastErrorDesc := GetErrorDesc(FLastError);
2119 end;
2120
2121 procedure TBlockSerial.ExceptCheck;
2122 var
2123 e: ESynaSerError;
2124 s: string;
2125 begin
2126 if FRaiseExcept and (FLastError <> sOK) then
2127 begin
2128 s := GetErrorDesc(FLastError);
2129 e := ESynaSerError.CreateFmt('Communication error %d: %s', [FLastError, s]);
2130 e.ErrorCode := FLastError;
2131 e.ErrorMessage := s;
2132 raise e;
2133 end;
2134 end;
2135
2136 procedure TBlockSerial.SetSynaError(ErrNumber: integer);
2137 begin
2138 FLastError := ErrNumber;
2139 FLastErrorDesc := GetErrorDesc(FLastError);
2140 end;
2141
2142 procedure TBlockSerial.RaiseSynaError(ErrNumber: integer);
2143 begin
2144 SetSynaError(ErrNumber);
2145 ExceptCheck;
2146 end;
2147
2148 procedure TBlockSerial.DoStatus(Reason: THookSerialReason; const Value: string);
2149 begin
2150 if assigned(OnStatus) then
2151 OnStatus(Self, Reason, Value);
2152 end;
2153
2154 {======================================================================}
2155
TBlockSerial.GetErrorDescnull2156 class function TBlockSerial.GetErrorDesc(ErrorCode: integer): string;
2157 begin
2158 Result:= '';
2159 case ErrorCode of
2160 sOK: Result := 'OK';
2161 ErrAlreadyOwned: Result := 'Port owned by other process';{HGJ}
2162 ErrAlreadyInUse: Result := 'Instance already in use'; {HGJ}
2163 ErrWrongParameter: Result := 'Wrong parameter at call'; {HGJ}
2164 ErrPortNotOpen: Result := 'Instance not yet connected'; {HGJ}
2165 ErrNoDeviceAnswer: Result := 'No device answer detected'; {HGJ}
2166 ErrMaxBuffer: Result := 'Maximal buffer length exceeded';
2167 ErrTimeout: Result := 'Timeout during operation';
2168 ErrNotRead: Result := 'Reading of data failed';
2169 ErrFrame: Result := 'Receive framing error';
2170 ErrOverrun: Result := 'Receive Overrun Error';
2171 ErrRxOver: Result := 'Receive Queue overflow';
2172 ErrRxParity: Result := 'Receive Parity Error';
2173 ErrTxFull: Result := 'Tranceive Queue is full';
2174 end;
2175 if Result = '' then
2176 begin
2177 Result := SysErrorMessage(ErrorCode);
2178 end;
2179 end;
2180
2181
2182 {---------- cpom Comport Ownership Manager Routines -------------
2183 by Hans-Georg Joepgen of Stuttgart, Germany.
2184 Copyright (c) 2002, by Hans-Georg Joepgen
2185
2186 Stefan Krauss of Stuttgart, Germany, contributed literature and Internet
2187 research results, invaluable advice and excellent answers to the Comport
2188 Ownership Manager.
2189 }
2190
2191 {$IFDEF UNIX}
2192
TBlockSerial.LockfileNamenull2193 function TBlockSerial.LockfileName: String;
2194 var
2195 s: string;
2196 begin
2197 s := SeparateRight(FDevice, '/dev/');
2198 result := LockfileDirectory + '/LCK..' + s;
2199 end;
2200
2201 procedure TBlockSerial.CreateLockfile(PidNr: integer);
2202 var
2203 f: TextFile;
2204 s: string;
2205 begin
2206 // Create content for file
2207 s := IntToStr(PidNr);
2208 while length(s) < 10 do
2209 s := ' ' + s;
2210 // Create file
2211 try
2212 AssignFile(f, LockfileName);
2213 try
2214 Rewrite(f);
2215 writeln(f, s);
2216 finally
2217 CloseFile(f);
2218 end;
2219 // Allow all users to enjoy the benefits of cpom
2220 s := 'chmod a+rw ' + LockfileName;
2221 {$IFNDEF FPC}
2222 FileSetReadOnly( LockfileName, False ) ;
2223 // Libc.system(pchar(s));
2224 {$ELSE}
2225 fpSystem(s);
2226 {$ENDIF}
2227 except
2228 // not raise exception, if you not have write permission for lock.
2229 on Exception do
2230 ;
2231 end;
2232 end;
2233
TBlockSerial.ReadLockfilenull2234 function TBlockSerial.ReadLockfile: integer;
2235 {Returns PID from Lockfile. Lockfile must exist.}
2236 var
2237 f: TextFile;
2238 s: string;
2239 begin
2240 AssignFile(f, LockfileName);
2241 Reset(f);
2242 try
2243 readln(f, s);
2244 finally
2245 CloseFile(f);
2246 end;
2247 Result := StrToIntDef(s, -1)
2248 end;
2249
cpomComportAccessiblenull2250 function TBlockSerial.cpomComportAccessible: boolean;
2251 var
2252 MyPid: integer;
2253 Filename: string;
2254 begin
2255 Filename := LockfileName;
2256 {$IFNDEF FPC}
2257 MyPid := Libc.getpid;
2258 {$ELSE}
2259 MyPid := fpGetPid;
2260 {$ENDIF}
2261 // Make sure, the Lock Files Directory exists. We need it.
2262 if not DirectoryExists(LockfileDirectory) then
2263 CreateDir(LockfileDirectory);
2264 // Check the Lockfile
2265 if not FileExists (Filename) then
2266 begin // comport is not locked. Lock it for us.
2267 CreateLockfile(MyPid);
2268 result := true;
2269 exit; // done.
2270 end;
2271 // Is port owned by orphan? Then it's time for error recovery.
2272 //FPC forgot to add getsid.. :-(
2273 {$IFNDEF FPC}
2274 if Libc.getsid(ReadLockfile) = -1 then
2275 begin // Lockfile was left from former desaster
2276 DeleteFile(Filename); // error recovery
2277 CreateLockfile(MyPid);
2278 result := true;
2279 exit;
2280 end;
2281 {$ENDIF}
2282 result := false // Sorry, port is owned by living PID and locked
2283 end;
2284
2285 procedure TBlockSerial.cpomReleaseComport;
2286 begin
2287 DeleteFile(LockfileName);
2288 end;
2289
2290 {$ENDIF}
2291 {----------------------------------------------------------------}
2292
2293 {$IFDEF MSWINDOWS}
2294 function GetSerialPortNames: string;
2295 var
2296 reg: TRegistry;
2297 l, v: TStringList;
2298 n: integer;
2299 begin
2300 l := TStringList.Create;
2301 v := TStringList.Create;
2302 reg := TRegistry.Create;
2303 try
2304 {$IFNDEF VER100}
2305 {$IFNDEF VER120}
2306 reg.Access := KEY_READ;
2307 {$ENDIF}
2308 {$ENDIF}
2309 reg.RootKey := HKEY_LOCAL_MACHINE;
2310 reg.OpenKey('\HARDWARE\DEVICEMAP\SERIALCOMM', false);
2311 reg.GetValueNames(l);
2312 for n := 0 to l.Count - 1 do
2313 v.Add(PChar(reg.ReadString(l[n])));
2314 Result := v.CommaText;
2315 finally
2316 reg.Free;
2317 l.Free;
2318 v.Free;
2319 end;
2320 end;
2321 {$ENDIF}
2322 {$IFNDEF MSWINDOWS}
2323 function GetSerialPortNames: string;
2324 var
2325 sr : TSearchRec;
2326 begin
2327 Result := '';
2328 if FindFirst('/dev/ttyS*', $FFFFFFFF, sr) = 0 then
2329 repeat
2330 if (sr.Attr and $FFFFFFFF) = Sr.Attr then
2331 begin
2332 if Result <> '' then
2333 Result := Result + ',';
2334 Result := Result + '/dev/' + sr.Name;
2335 end;
2336 until FindNext(sr) <> 0;
2337 FindClose(sr);
2338 if FindFirst('/dev/ttyUSB*', $FFFFFFFF, sr) = 0 then begin
2339 repeat
2340 if (sr.Attr and $FFFFFFFF) = Sr.Attr then begin
2341 if Result <> '' then Result := Result + ',';
2342 Result := Result + '/dev/' + sr.Name;
2343 end;
2344 until FindNext(sr) <> 0;
2345 end;
2346 FindClose(sr);
2347 if FindFirst('/dev/ttyAM*', $FFFFFFFF, sr) = 0 then begin
2348 repeat
2349 if (sr.Attr and $FFFFFFFF) = Sr.Attr then begin
2350 if Result <> '' then Result := Result + ',';
2351 Result := Result + '/dev/' + sr.Name;
2352 end;
2353 until FindNext(sr) <> 0;
2354 end;
2355 FindClose(sr);
2356 end;
2357 {$ENDIF}
2358
2359 end.