Программа для прослушивания журнала АРК Томск http://blindage.org/?p=6627
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

synaser.pas 67KB

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