source: Network/synapse/synaser.pas

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