Details | Last modification | View Log | RSS feed
Rev | Author | Line No. | Line |
---|---|---|---|
746 | rain-er | 1 | # This part includes the low-level API calls |
2 | package Win32API::CommPort; |
||
3 | |||
4 | use Win32; |
||
5 | use Win32::API 0.01; |
||
6 | if ( $] < 5.004 ) { |
||
7 | my $no_silly_warning = $Win32::API::VERSION; |
||
8 | $no_silly_warning = $Win32::API::pack; |
||
9 | } |
||
10 | |||
11 | use Carp; |
||
12 | use strict; |
||
13 | |||
14 | #### API declarations #### |
||
15 | no strict 'subs'; # these may be imported someday |
||
16 | |||
17 | use vars qw( |
||
18 | $_CloseHandle $_CreateFile $_GetCommState |
||
19 | $_ReadFile $_SetCommState $_SetupComm |
||
20 | $_PurgeComm $_CreateEvent $_GetCommTimeouts |
||
21 | $_SetCommTimeouts $_GetCommProperties $_ClearCommBreak |
||
22 | $_ClearCommError $_EscapeCommFunction $_GetCommConfig |
||
23 | $_GetCommMask $_GetCommModemStatus $_SetCommBreak |
||
24 | $_SetCommConfig $_SetCommMask $_TransmitCommChar |
||
25 | $_WaitCommEvent $_WriteFile $_ResetEvent |
||
26 | $_GetOverlappedResult |
||
27 | ); |
||
28 | |||
29 | $_CreateFile = new Win32::API("kernel32", "CreateFile", |
||
30 | [P, N, N, N, N, N, N], N); |
||
31 | $_CloseHandle = new Win32::API("kernel32", "CloseHandle", [N], N); |
||
32 | $_GetCommState = new Win32::API("kernel32", "GetCommState", [N, P], I); |
||
33 | $_SetCommState = new Win32::API("kernel32", "SetCommState", [N, P], I); |
||
34 | $_SetupComm = new Win32::API("kernel32", "SetupComm", [N, N, N], I); |
||
35 | $_PurgeComm = new Win32::API("kernel32", "PurgeComm", [N, N], I); |
||
36 | $_CreateEvent = new Win32::API("kernel32", "CreateEvent", [P, I, I, P], N); |
||
37 | $_GetCommTimeouts = new Win32::API("kernel32", "GetCommTimeouts", |
||
38 | [N, P], I); |
||
39 | $_SetCommTimeouts = new Win32::API("kernel32", "SetCommTimeouts", |
||
40 | [N, P], I); |
||
41 | $_GetCommProperties = new Win32::API("kernel32", "GetCommProperties", |
||
42 | [N, P], I); |
||
43 | $_ReadFile = new Win32::API("kernel32", "ReadFile", [N, P, N, P, P], I); |
||
44 | $_WriteFile = new Win32::API("kernel32", "WriteFile", [N, P, N, P, P], I); |
||
45 | $_TransmitCommChar = new Win32::API("kernel32", "TransmitCommChar", [N, I], I); |
||
46 | $_ClearCommBreak = new Win32::API("kernel32", "ClearCommBreak", [N], I); |
||
47 | $_SetCommBreak = new Win32::API("kernel32", "SetCommBreak", [N], I); |
||
48 | $_ClearCommError = new Win32::API("kernel32", "ClearCommError", [N, P, P], I); |
||
49 | $_EscapeCommFunction = new Win32::API("kernel32", "EscapeCommFunction", |
||
50 | [N, N], I); |
||
51 | $_GetCommModemStatus = new Win32::API("kernel32", "GetCommModemStatus", |
||
52 | [N, P], I); |
||
53 | $_GetOverlappedResult = new Win32::API("kernel32", "GetOverlappedResult", |
||
54 | [N, P, P, I], I); |
||
55 | |||
56 | #### these are not used yet |
||
57 | |||
58 | $_GetCommConfig = new Win32::API("kernel32", "GetCommConfig", [N, P, P], I); |
||
59 | $_GetCommMask = new Win32::API("kernel32", "GetCommMask", [N, P], I); |
||
60 | $_SetCommConfig = new Win32::API("kernel32", "SetCommConfig", [N, P, N], I); |
||
61 | $_SetCommMask = new Win32::API("kernel32", "SetCommMask", [N, N], I); |
||
62 | $_WaitCommEvent = new Win32::API("kernel32", "WaitCommEvent", [N, P, P], I); |
||
63 | $_ResetEvent = new Win32::API("kernel32", "ResetEvent", [N], I); |
||
64 | |||
65 | use strict; |
||
66 | |||
67 | use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $RBUF_Size); |
||
68 | $VERSION = '0.19'; |
||
69 | $RBUF_Size = 4096; |
||
70 | |||
71 | require Exporter; |
||
72 | ## require AutoLoader; |
||
73 | |||
74 | @ISA = qw(Exporter); |
||
75 | # Items to export into callers namespace by default. Note: do not export |
||
76 | # names by default without a very good reason. Use EXPORT_OK instead. |
||
77 | # Do not simply export all your public functions/methods/constants. |
||
78 | |||
79 | @EXPORT= qw(); |
||
80 | @EXPORT_OK= qw(); |
||
81 | %EXPORT_TAGS = (STAT => [qw( BM_fCtsHold BM_fDsrHold |
||
82 | BM_fRlsdHold BM_fXoffHold |
||
83 | BM_fXoffSent BM_fEof |
||
84 | BM_fTxim BM_AllBits |
||
85 | MS_CTS_ON MS_DSR_ON |
||
86 | MS_RING_ON MS_RLSD_ON |
||
87 | CE_RXOVER CE_OVERRUN |
||
88 | CE_RXPARITY CE_FRAME |
||
89 | CE_BREAK CE_TXFULL |
||
90 | CE_MODE ST_BLOCK |
||
91 | ST_INPUT ST_OUTPUT |
||
92 | ST_ERROR )], |
||
93 | |||
94 | RAW => [qw( CloseHandle CreateFile |
||
95 | GetCommState ReadFile |
||
96 | SetCommState SetupComm |
||
97 | PurgeComm CreateEvent |
||
98 | GetCommTimeouts SetCommTimeouts |
||
99 | GetCommProperties ClearCommBreak |
||
100 | ClearCommError EscapeCommFunction |
||
101 | GetCommConfig GetCommMask |
||
102 | GetCommModemStatus SetCommBreak |
||
103 | SetCommConfig SetCommMask |
||
104 | TransmitCommChar WaitCommEvent |
||
105 | WriteFile ResetEvent |
||
106 | GetOverlappedResult |
||
107 | PURGE_TXABORT PURGE_RXABORT |
||
108 | PURGE_TXCLEAR PURGE_RXCLEAR |
||
109 | SETXOFF SETXON |
||
110 | SETRTS CLRRTS |
||
111 | SETDTR CLRDTR |
||
112 | SETBREAK CLRBREAK |
||
113 | EV_RXCHAR EV_RXFLAG |
||
114 | EV_TXEMPTY EV_CTS |
||
115 | EV_DSR EV_RLSD |
||
116 | EV_BREAK EV_ERR |
||
117 | EV_RING EV_PERR |
||
118 | EV_RX80FULL EV_EVENT1 |
||
119 | EV_EVENT2 ERROR_IO_INCOMPLETE |
||
120 | ERROR_IO_PENDING )], |
||
121 | |||
122 | COMMPROP => [qw( BAUD_USER BAUD_075 BAUD_110 |
||
123 | BAUD_134_5 BAUD_150 BAUD_300 |
||
124 | BAUD_600 BAUD_1200 BAUD_1800 |
||
125 | BAUD_2400 BAUD_4800 BAUD_7200 |
||
126 | BAUD_9600 BAUD_14400 BAUD_19200 |
||
127 | BAUD_38400 BAUD_56K BAUD_57600 |
||
128 | BAUD_115200 BAUD_128K |
||
129 | |||
130 | PST_FAX PST_LAT PST_MODEM |
||
131 | PST_RS232 PST_RS422 PST_RS423 |
||
132 | PST_RS449 PST_SCANNER PST_X25 |
||
133 | PST_NETWORK_BRIDGE PST_PARALLELPORT |
||
134 | PST_TCPIP_TELNET PST_UNSPECIFIED |
||
135 | |||
136 | PCF_INTTIMEOUTS PCF_PARITY_CHECK |
||
137 | PCF_16BITMODE PCF_DTRDSR |
||
138 | PCF_SPECIALCHARS PCF_RLSD |
||
139 | PCF_RTSCTS PCF_SETXCHAR |
||
140 | PCF_TOTALTIMEOUTS PCF_XONXOFF |
||
141 | |||
142 | SP_BAUD SP_DATABITS SP_HANDSHAKING |
||
143 | SP_PARITY SP_PARITY_CHECK SP_RLSD |
||
144 | SP_STOPBITS SP_SERIALCOMM |
||
145 | |||
146 | DATABITS_5 DATABITS_6 DATABITS_7 |
||
147 | DATABITS_8 DATABITS_16 DATABITS_16X |
||
148 | |||
149 | STOPBITS_10 STOPBITS_15 STOPBITS_20 |
||
150 | PARITY_SPACE PARITY_NONE PARITY_ODD |
||
151 | PARITY_EVEN PARITY_MARK |
||
152 | COMMPROP_INITIALIZED )], |
||
153 | |||
154 | DCB => [qw( CBR_110 CBR_300 CBR_600 |
||
155 | CBR_1200 CBR_2400 CBR_4800 |
||
156 | CBR_9600 CBR_14400 CBR_19200 |
||
157 | CBR_38400 CBR_56000 CBR_57600 |
||
158 | CBR_115200 CBR_128000 CBR_256000 |
||
159 | |||
160 | DTR_CONTROL_DISABLE DTR_CONTROL_ENABLE |
||
161 | DTR_CONTROL_HANDSHAKE RTS_CONTROL_DISABLE |
||
162 | RTS_CONTROL_ENABLE RTS_CONTROL_HANDSHAKE |
||
163 | RTS_CONTROL_TOGGLE |
||
164 | |||
165 | EVENPARITY MARKPARITY NOPARITY |
||
166 | ODDPARITY SPACEPARITY |
||
167 | |||
168 | ONESTOPBIT ONE5STOPBITS TWOSTOPBITS |
||
169 | |||
170 | FM_fBinary FM_fParity |
||
171 | FM_fOutxCtsFlow FM_fOutxDsrFlow |
||
172 | FM_fDtrControl FM_fDsrSensitivity |
||
173 | FM_fTXContinueOnXoff FM_fOutX |
||
174 | FM_fInX FM_fErrorChar |
||
175 | FM_fNull FM_fRtsControl |
||
176 | FM_fAbortOnError FM_fDummy2 )], |
||
177 | |||
178 | PARAM => [qw( LONGsize SHORTsize OS_Error |
||
179 | nocarp internal_buffer yes_true )]); |
||
180 | |||
181 | |||
182 | Exporter::export_ok_tags('STAT', 'RAW', 'COMMPROP', 'DCB', 'PARAM'); |
||
183 | |||
184 | $EXPORT_TAGS{ALL} = \@EXPORT_OK; |
||
185 | |||
186 | #### subroutine wrappers for API calls |
||
187 | |||
188 | sub CloseHandle { |
||
189 | return unless ( 1 == @_ ); |
||
190 | return $_CloseHandle->Call( shift ); |
||
191 | } |
||
192 | |||
193 | sub CreateFile { |
||
194 | return $_CreateFile->Call( @_ ); |
||
195 | # returns handle |
||
196 | } |
||
197 | |||
198 | sub GetCommState { |
||
199 | return $_GetCommState->Call( @_ ); |
||
200 | } |
||
201 | |||
202 | sub SetCommState { |
||
203 | return $_SetCommState->Call( @_ ); |
||
204 | } |
||
205 | |||
206 | sub SetupComm { |
||
207 | return $_SetupComm->Call( @_ ); |
||
208 | } |
||
209 | |||
210 | sub PurgeComm { |
||
211 | return $_PurgeComm->Call( @_ ); |
||
212 | } |
||
213 | |||
214 | sub CreateEvent { |
||
215 | return $_CreateEvent->Call( @_ ); |
||
216 | } |
||
217 | |||
218 | sub GetCommTimeouts { |
||
219 | return $_GetCommTimeouts->Call( @_ ); |
||
220 | } |
||
221 | |||
222 | sub SetCommTimeouts { |
||
223 | return $_SetCommTimeouts->Call( @_ ); |
||
224 | } |
||
225 | |||
226 | sub GetCommProperties { |
||
227 | return $_GetCommProperties->Call( @_ ); |
||
228 | } |
||
229 | |||
230 | sub ReadFile { |
||
231 | return $_ReadFile->Call( @_ ); |
||
232 | } |
||
233 | |||
234 | sub WriteFile { |
||
235 | return $_WriteFile->Call( @_ ); |
||
236 | } |
||
237 | |||
238 | sub TransmitCommChar { |
||
239 | return $_TransmitCommChar->Call( @_ ); |
||
240 | } |
||
241 | |||
242 | sub ClearCommBreak { |
||
243 | return unless ( 1 == @_ ); |
||
244 | return $_ClearCommBreak->Call( shift ); |
||
245 | } |
||
246 | |||
247 | sub SetCommBreak { |
||
248 | return unless ( 1 == @_ ); |
||
249 | return $_SetCommBreak->Call( shift ); |
||
250 | } |
||
251 | |||
252 | sub ClearCommError { |
||
253 | return $_ClearCommError->Call( @_ ); |
||
254 | } |
||
255 | |||
256 | sub EscapeCommFunction { |
||
257 | return $_EscapeCommFunction->Call( @_ ); |
||
258 | } |
||
259 | |||
260 | sub GetCommModemStatus { |
||
261 | return $_GetCommModemStatus->Call( @_ ); |
||
262 | } |
||
263 | |||
264 | sub GetOverlappedResult { |
||
265 | return $_GetOverlappedResult->Call( @_ ); |
||
266 | } |
||
267 | |||
268 | sub GetCommConfig { |
||
269 | return $_GetCommConfig->Call( @_ ); |
||
270 | } |
||
271 | |||
272 | sub GetCommMask { |
||
273 | return $_GetCommMask->Call( @_ ); |
||
274 | } |
||
275 | |||
276 | sub SetCommConfig { |
||
277 | return $_SetCommConfig->Call( @_ ); |
||
278 | } |
||
279 | |||
280 | sub SetCommMask { |
||
281 | return $_SetCommMask->Call( @_ ); |
||
282 | } |
||
283 | |||
284 | sub WaitCommEvent { |
||
285 | return $_WaitCommEvent->Call( @_ ); |
||
286 | } |
||
287 | |||
288 | sub ResetEvent { |
||
289 | return unless ( 1 == @_ ); |
||
290 | return $_ResetEvent->Call( shift ); |
||
291 | } |
||
292 | |||
293 | #### "constant" declarations from Win32 header files #### |
||
294 | #### compatible with ActiveState #### |
||
295 | |||
296 | ## COMMPROP structure |
||
297 | sub SP_SERIALCOMM { 0x1 } |
||
298 | sub BAUD_075 { 0x1 } |
||
299 | sub BAUD_110 { 0x2 } |
||
300 | sub BAUD_134_5 { 0x4 } |
||
301 | sub BAUD_150 { 0x8 } |
||
302 | sub BAUD_300 { 0x10 } |
||
303 | sub BAUD_600 { 0x20 } |
||
304 | sub BAUD_1200 { 0x40 } |
||
305 | sub BAUD_1800 { 0x80 } |
||
306 | sub BAUD_2400 { 0x100 } |
||
307 | sub BAUD_4800 { 0x200 } |
||
308 | sub BAUD_7200 { 0x400 } |
||
309 | sub BAUD_9600 { 0x800 } |
||
310 | sub BAUD_14400 { 0x1000 } |
||
311 | sub BAUD_19200 { 0x2000 } |
||
312 | sub BAUD_38400 { 0x4000 } |
||
313 | sub BAUD_56K { 0x8000 } |
||
314 | sub BAUD_57600 { 0x40000 } |
||
315 | sub BAUD_115200 { 0x20000 } |
||
316 | sub BAUD_128K { 0x10000 } |
||
317 | sub BAUD_USER { 0x10000000 } |
||
318 | sub PST_FAX { 0x21 } |
||
319 | sub PST_LAT { 0x101 } |
||
320 | sub PST_MODEM { 0x6 } |
||
321 | sub PST_NETWORK_BRIDGE { 0x100 } |
||
322 | sub PST_PARALLELPORT { 0x2 } |
||
323 | sub PST_RS232 { 0x1 } |
||
324 | sub PST_RS422 { 0x3 } |
||
325 | sub PST_RS423 { 0x4 } |
||
326 | sub PST_RS449 { 0x5 } |
||
327 | sub PST_SCANNER { 0x22 } |
||
328 | sub PST_TCPIP_TELNET { 0x102 } |
||
329 | sub PST_UNSPECIFIED { 0 } |
||
330 | sub PST_X25 { 0x103 } |
||
331 | sub PCF_16BITMODE { 0x200 } |
||
332 | sub PCF_DTRDSR { 0x1 } |
||
333 | sub PCF_INTTIMEOUTS { 0x80 } |
||
334 | sub PCF_PARITY_CHECK { 0x8 } |
||
335 | sub PCF_RLSD { 0x4 } |
||
336 | sub PCF_RTSCTS { 0x2 } |
||
337 | sub PCF_SETXCHAR { 0x20 } |
||
338 | sub PCF_SPECIALCHARS { 0x100 } |
||
339 | sub PCF_TOTALTIMEOUTS { 0x40 } |
||
340 | sub PCF_XONXOFF { 0x10 } |
||
341 | sub SP_BAUD { 0x2 } |
||
342 | sub SP_DATABITS { 0x4 } |
||
343 | sub SP_HANDSHAKING { 0x10 } |
||
344 | sub SP_PARITY { 0x1 } |
||
345 | sub SP_PARITY_CHECK { 0x20 } |
||
346 | sub SP_RLSD { 0x40 } |
||
347 | sub SP_STOPBITS { 0x8 } |
||
348 | sub DATABITS_5 { 1 } |
||
349 | sub DATABITS_6 { 2 } |
||
350 | sub DATABITS_7 { 4 } |
||
351 | sub DATABITS_8 { 8 } |
||
352 | sub DATABITS_16 { 16 } |
||
353 | sub DATABITS_16X { 32 } |
||
354 | sub STOPBITS_10 { 1 } |
||
355 | sub STOPBITS_15 { 2 } |
||
356 | sub STOPBITS_20 { 4 } |
||
357 | sub PARITY_NONE { 256 } |
||
358 | sub PARITY_ODD { 512 } |
||
359 | sub PARITY_EVEN { 1024 } |
||
360 | sub PARITY_MARK { 2048 } |
||
361 | sub PARITY_SPACE { 4096 } |
||
362 | sub COMMPROP_INITIALIZED { 0xe73cf52e } |
||
363 | |||
364 | ## DCB structure |
||
365 | sub CBR_110 { 110 } |
||
366 | sub CBR_300 { 300 } |
||
367 | sub CBR_600 { 600 } |
||
368 | sub CBR_1200 { 1200 } |
||
369 | sub CBR_2400 { 2400 } |
||
370 | sub CBR_4800 { 4800 } |
||
371 | sub CBR_9600 { 9600 } |
||
372 | sub CBR_14400 { 14400 } |
||
373 | sub CBR_19200 { 19200 } |
||
374 | sub CBR_38400 { 38400 } |
||
375 | sub CBR_56000 { 56000 } |
||
376 | sub CBR_57600 { 57600 } |
||
377 | sub CBR_115200 { 115200 } |
||
378 | sub CBR_128000 { 128000 } |
||
379 | sub CBR_256000 { 256000 } |
||
380 | sub DTR_CONTROL_DISABLE { 0 } |
||
381 | sub DTR_CONTROL_ENABLE { 1 } |
||
382 | sub DTR_CONTROL_HANDSHAKE { 2 } |
||
383 | sub RTS_CONTROL_DISABLE { 0 } |
||
384 | sub RTS_CONTROL_ENABLE { 1 } |
||
385 | sub RTS_CONTROL_HANDSHAKE { 2 } |
||
386 | sub RTS_CONTROL_TOGGLE { 3 } |
||
387 | sub EVENPARITY { 2 } |
||
388 | sub MARKPARITY { 3 } |
||
389 | sub NOPARITY { 0 } |
||
390 | sub ODDPARITY { 1 } |
||
391 | sub SPACEPARITY { 4 } |
||
392 | sub ONESTOPBIT { 0 } |
||
393 | sub ONE5STOPBITS { 1 } |
||
394 | sub TWOSTOPBITS { 2 } |
||
395 | |||
396 | ## Flowcontrol bit mask in DCB |
||
397 | sub FM_fBinary { 0x1 } |
||
398 | sub FM_fParity { 0x2 } |
||
399 | sub FM_fOutxCtsFlow { 0x4 } |
||
400 | sub FM_fOutxDsrFlow { 0x8 } |
||
401 | sub FM_fDtrControl { 0x30 } |
||
402 | sub FM_fDsrSensitivity { 0x40 } |
||
403 | sub FM_fTXContinueOnXoff { 0x80 } |
||
404 | sub FM_fOutX { 0x100 } |
||
405 | sub FM_fInX { 0x200 } |
||
406 | sub FM_fErrorChar { 0x400 } |
||
407 | sub FM_fNull { 0x800 } |
||
408 | sub FM_fRtsControl { 0x3000 } |
||
409 | sub FM_fAbortOnError { 0x4000 } |
||
410 | sub FM_fDummy2 { 0xffff8000 } |
||
411 | |||
412 | ## COMSTAT bit mask |
||
413 | sub BM_fCtsHold { 0x1 } |
||
414 | sub BM_fDsrHold { 0x2 } |
||
415 | sub BM_fRlsdHold { 0x4 } |
||
416 | sub BM_fXoffHold { 0x8 } |
||
417 | sub BM_fXoffSent { 0x10 } |
||
418 | sub BM_fEof { 0x20 } |
||
419 | sub BM_fTxim { 0x40 } |
||
420 | sub BM_AllBits { 0x7f } |
||
421 | |||
422 | ## PurgeComm bit mask |
||
423 | sub PURGE_TXABORT { 0x1 } |
||
424 | sub PURGE_RXABORT { 0x2 } |
||
425 | sub PURGE_TXCLEAR { 0x4 } |
||
426 | sub PURGE_RXCLEAR { 0x8 } |
||
427 | |||
428 | ## GetCommModemStatus bit mask |
||
429 | sub MS_CTS_ON { 0x10 } |
||
430 | sub MS_DSR_ON { 0x20 } |
||
431 | sub MS_RING_ON { 0x40 } |
||
432 | sub MS_RLSD_ON { 0x80 } |
||
433 | |||
434 | ## EscapeCommFunction operations |
||
435 | sub SETXOFF { 0x1 } |
||
436 | sub SETXON { 0x2 } |
||
437 | sub SETRTS { 0x3 } |
||
438 | sub CLRRTS { 0x4 } |
||
439 | sub SETDTR { 0x5 } |
||
440 | sub CLRDTR { 0x6 } |
||
441 | sub SETBREAK { 0x8 } |
||
442 | sub CLRBREAK { 0x9 } |
||
443 | |||
444 | ## ClearCommError bit mask |
||
445 | sub CE_RXOVER { 0x1 } |
||
446 | sub CE_OVERRUN { 0x2 } |
||
447 | sub CE_RXPARITY { 0x4 } |
||
448 | sub CE_FRAME { 0x8 } |
||
449 | sub CE_BREAK { 0x10 } |
||
450 | sub CE_TXFULL { 0x100 } |
||
451 | #### LPT only |
||
452 | # sub CE_PTO { 0x200 } |
||
453 | # sub CE_IOE { 0x400 } |
||
454 | # sub CE_DNS { 0x800 } |
||
455 | # sub CE_OOP { 0x1000 } |
||
456 | #### LPT only |
||
457 | sub CE_MODE { 0x8000 } |
||
458 | |||
459 | ## GetCommMask bits |
||
460 | sub EV_RXCHAR { 0x1 } |
||
461 | sub EV_RXFLAG { 0x2 } |
||
462 | sub EV_TXEMPTY { 0x4 } |
||
463 | sub EV_CTS { 0x8 } |
||
464 | sub EV_DSR { 0x10 } |
||
465 | sub EV_RLSD { 0x20 } |
||
466 | sub EV_BREAK { 0x40 } |
||
467 | sub EV_ERR { 0x80 } |
||
468 | sub EV_RING { 0x100 } |
||
469 | sub EV_PERR { 0x200 } |
||
470 | sub EV_RX80FULL { 0x400 } |
||
471 | sub EV_EVENT1 { 0x800 } |
||
472 | sub EV_EVENT2 { 0x1000 } |
||
473 | |||
474 | ## Allowed OVERLAP errors |
||
475 | sub ERROR_IO_INCOMPLETE { 996 } |
||
476 | sub ERROR_IO_PENDING { 997 } |
||
477 | |||
478 | #### "constant" declarations compatible with ActiveState #### |
||
479 | |||
480 | my $DCBformat="LLLSSSCCCCCCCCS"; |
||
481 | my $CP_format1="SSLLLLLLLLLSSLLLLSA*"; # rs232 |
||
482 | my $CP_format6="SSLLLLLLLLLSSLLLLLLLLLLLLLLLLLLLLLLLA*"; # modem |
||
483 | my $CP_format0="SA50LA244"; # pre-read |
||
484 | |||
485 | my $OVERLAPPEDformat="LLLLL"; |
||
486 | my $TIMEOUTformat="LLLLL"; |
||
487 | my $COMSTATformat="LLL"; |
||
488 | my $cfg_file_sig="Win32API::SerialPort_Configuration_File -- DO NOT EDIT --\n"; |
||
489 | |||
490 | sub SHORTsize { 0xffff; } |
||
491 | sub LONGsize { 0xffffffff; } |
||
492 | |||
493 | sub ST_BLOCK {0} # status offsets for caller |
||
494 | sub ST_INPUT {1} |
||
495 | sub ST_OUTPUT {2} |
||
496 | sub ST_ERROR {3} # latched |
||
497 | |||
498 | |||
499 | #### Package variable declarations #### |
||
500 | |||
501 | my @Yes_resp = ( |
||
502 | "YES","Y", |
||
503 | "ON", |
||
504 | "TRUE","T", |
||
505 | "1" |
||
506 | ); |
||
507 | |||
508 | my @binary_opt = (0, 1); |
||
509 | my @byte_opt = (0, 255); |
||
510 | |||
511 | my $Babble = 0; |
||
512 | my $testactive = 0; # test mode active |
||
513 | |||
514 | ## my $null=[]; |
||
515 | my $null=0; |
||
516 | my $zero=0; |
||
517 | |||
518 | # Preloaded methods go here. |
||
519 | |||
520 | sub OS_Error { print Win32::FormatMessage ( Win32::GetLastError() ); } |
||
521 | |||
522 | sub get_tick_count { return Win32::GetTickCount(); } |
||
523 | |||
524 | # test*.t only - suppresses default messages |
||
525 | sub set_no_messages { |
||
526 | return unless (@_ == 2); |
||
527 | $testactive = yes_true($_[1]); |
||
528 | } |
||
529 | |||
530 | sub nocarp { return $testactive } |
||
531 | |||
532 | sub internal_buffer { return $RBUF_Size } |
||
533 | |||
534 | sub yes_true { |
||
535 | my $choice = uc shift; |
||
536 | my $ans = 0; |
||
537 | foreach (@Yes_resp) { $ans = 1 if ( $choice eq $_ ) } |
||
538 | return $ans; |
||
539 | } |
||
540 | |||
541 | sub new { |
||
542 | my $proto = shift; |
||
543 | my $class = ref($proto) || $proto; |
||
544 | my $self = {}; |
||
545 | my $ok = 0; # API return value |
||
546 | my $hr = 0; # temporary hashref |
||
547 | my $fmask = 0; # temporary for bit banging |
||
548 | my $fix_baud = 0; |
||
549 | my $key; |
||
550 | my $value; |
||
551 | my $CommPropBlank = " "; |
||
552 | |||
553 | # COMMPROP only used during new |
||
554 | my $CommProperties = " "x300; # extra buffer for modems |
||
555 | my $CP_Length = 0; |
||
556 | my $CP_Version = 0; |
||
557 | my $CP_ServiceMask = 0; |
||
558 | my $CP_Reserved1 = 0; |
||
559 | my $CP_MaxBaud = 0; |
||
560 | my $CP_ProvCapabilities = 0; |
||
561 | my $CP_SettableParams = 0; |
||
562 | my $CP_SettableBaud = 0; |
||
563 | my $CP_SettableData = 0; |
||
564 | my $CP_SettableStopParity = 0; |
||
565 | my $CP_ProvSpec1 = 0; |
||
566 | my $CP_ProvSpec2 = 0; |
||
567 | my $CP_ProvChar_start = 0; |
||
568 | my $CP_Filler = 0; |
||
569 | |||
570 | # MODEMDEVCAPS |
||
571 | my $MC_ReqSize = 0; |
||
572 | my $MC_SpecOffset = 0; |
||
573 | my $MC_SpecSize = 0; |
||
574 | my $MC_ProvVersion = 0; |
||
575 | my $MC_ManfOffset = 0; |
||
576 | my $MC_ManfSize = 0; |
||
577 | my $MC_ModOffset = 0; |
||
578 | my $MC_ModSize = 0; |
||
579 | my $MC_VerOffset = 0; |
||
580 | my $MC_VerSize = 0; |
||
581 | my $MC_DialOpt = 0; |
||
582 | my $MC_CallFailTime = 0; |
||
583 | my $MC_IdleTime = 0; |
||
584 | my $MC_SpkrVol = 0; |
||
585 | my $MC_SpkrMode = 0; |
||
586 | my $MC_ModOpt = 0; |
||
587 | my $MC_MaxDTE = 0; |
||
588 | my $MC_MaxDCE = 0; |
||
589 | my $MC_Filler = 0; |
||
590 | |||
591 | $self->{NAME} = shift; |
||
592 | my $quiet = shift; |
||
593 | |||
594 | $self->{"_HANDLE"}=CreateFile("$self->{NAME}", |
||
595 | 0xc0000000, |
||
596 | 0, |
||
597 | $null, |
||
598 | 3, |
||
599 | 0x40000000, |
||
600 | $null); |
||
601 | # device name |
||
602 | # GENERIC_READ | GENERIC_WRITE |
||
603 | # no FILE_SHARE_xx |
||
604 | # no SECURITY_xx |
||
605 | # OPEN_EXISTING |
||
606 | # FILE_FLAG_OVERLAPPED |
||
607 | # template file |
||
608 | |||
609 | unless ($self->{"_HANDLE"} >= 1) { |
||
610 | $self->{"_HANDLE"} = 0; |
||
611 | return 0 if ($quiet); |
||
612 | return if (nocarp); |
||
613 | OS_Error; |
||
614 | carp "can't open device: $self->{NAME}\n"; |
||
615 | return; |
||
616 | } |
||
617 | |||
618 | # let Win32 know we allowed room for modem properties |
||
619 | $CP_Length = 300; |
||
620 | $CP_ProvSpec1 = COMMPROP_INITIALIZED; |
||
621 | $CommProperties = pack($CP_format0, |
||
622 | $CP_Length, |
||
623 | $CommPropBlank, |
||
624 | $CP_ProvSpec1, |
||
625 | $CommPropBlank); |
||
626 | |||
627 | $ok=GetCommProperties($self->{"_HANDLE"}, $CommProperties); |
||
628 | |||
629 | unless ( $ok ) { |
||
630 | OS_Error; |
||
631 | carp "can't get COMMPROP block"; |
||
632 | undef $self; |
||
633 | return; |
||
634 | } |
||
635 | |||
636 | ($CP_Length, |
||
637 | $CP_Version, |
||
638 | $CP_ServiceMask, |
||
639 | $CP_Reserved1, |
||
640 | $self->{"_MaxTxQueue"}, |
||
641 | $self->{"_MaxRxQueue"}, |
||
642 | $CP_MaxBaud, |
||
643 | $self->{"_TYPE"}, |
||
644 | $CP_ProvCapabilities, |
||
645 | $CP_SettableParams, |
||
646 | $CP_SettableBaud, |
||
647 | $CP_SettableData, |
||
648 | $CP_SettableStopParity, |
||
649 | $self->{WRITEBUF}, |
||
650 | $self->{READBUF}, |
||
651 | $CP_ProvSpec1, |
||
652 | $CP_ProvSpec2, |
||
653 | $CP_ProvChar_start, |
||
654 | $CP_Filler)= unpack($CP_format1, $CommProperties); |
||
655 | |||
656 | if (($CP_Length > 66) and ($self->{"_TYPE"} == PST_RS232)) { |
||
657 | carp "invalid COMMPROP block length= $CP_Length"; |
||
658 | undef $self; |
||
659 | return; |
||
660 | } |
||
661 | if ($CP_ServiceMask != SP_SERIALCOMM) { |
||
662 | carp "doesn't claim to be a serial port\n"; |
||
663 | undef $self; |
||
664 | return; |
||
665 | } |
||
666 | if ($self->{"_TYPE"} == PST_MODEM) { |
||
667 | ($CP_Length, |
||
668 | $CP_Version, |
||
669 | $CP_ServiceMask, |
||
670 | $CP_Reserved1, |
||
671 | $self->{"_MaxTxQueue"}, |
||
672 | $self->{"_MaxRxQueue"}, |
||
673 | $CP_MaxBaud, |
||
674 | $self->{"_TYPE"}, |
||
675 | $CP_ProvCapabilities, |
||
676 | $CP_SettableParams, |
||
677 | $CP_SettableBaud, |
||
678 | $CP_SettableData, |
||
679 | $CP_SettableStopParity, |
||
680 | $self->{WRITEBUF}, |
||
681 | $self->{READBUF}, |
||
682 | $CP_ProvSpec1, |
||
683 | $CP_ProvSpec2, |
||
684 | $CP_ProvChar_start, |
||
685 | $MC_ReqSize, |
||
686 | $MC_SpecOffset, |
||
687 | $MC_SpecSize, |
||
688 | $MC_ProvVersion, |
||
689 | $MC_ManfOffset, |
||
690 | $MC_ManfSize, |
||
691 | $MC_ModOffset, |
||
692 | $MC_ModSize, |
||
693 | $MC_VerOffset, |
||
694 | $MC_VerSize, |
||
695 | $MC_DialOpt, |
||
696 | $MC_CallFailTime, |
||
697 | $MC_IdleTime, |
||
698 | $MC_SpkrVol, |
||
699 | $MC_SpkrMode, |
||
700 | $MC_ModOpt, |
||
701 | $MC_MaxDTE, |
||
702 | $MC_MaxDCE, |
||
703 | $MC_Filler)= unpack($CP_format6, $CommProperties); |
||
704 | |||
705 | if ($Babble) { |
||
706 | printf "\nMODEMDEVCAPS:\n"; |
||
707 | printf "\$MC_ActualSize= %d\n", $CP_ProvChar_start; |
||
708 | printf "\$MC_ReqSize= %d\n", $MC_ReqSize; |
||
709 | printf "\$MC_SpecOffset= %d\n", $MC_SpecOffset; |
||
710 | printf "\$MC_SpecSize= %d\n", $MC_SpecSize; |
||
711 | if ($MC_SpecOffset) { |
||
712 | printf " DeviceSpecificData= %s\n", substr ($CommProperties, |
||
713 | 60+$MC_SpecOffset, $MC_SpecSize); |
||
714 | } |
||
715 | printf "\$MC_ProvVersion= %d\n", $MC_ProvVersion; |
||
716 | printf "\$MC_ManfOffset= %d\n", $MC_ManfOffset; |
||
717 | printf "\$MC_ManfSize= %d\n", $MC_ManfSize; |
||
718 | if ($MC_ManfOffset) { |
||
719 | printf " Manufacturer= %s\n", substr ($CommProperties, |
||
720 | 60+$MC_ManfOffset, $MC_ManfSize); |
||
721 | } |
||
722 | printf "\$MC_ModOffset= %d\n", $MC_ModOffset; |
||
723 | printf "\$MC_ModSize= %d\n", $MC_ModSize; |
||
724 | if ($MC_ModOffset) { |
||
725 | printf " Model= %s\n", substr ($CommProperties, |
||
726 | 60+$MC_ModOffset, $MC_ModSize); |
||
727 | } |
||
728 | printf "\$MC_VerOffset= %d\n", $MC_VerOffset; |
||
729 | printf "\$MC_VerSize= %d\n", $MC_VerSize; |
||
730 | if ($MC_VerOffset) { |
||
731 | printf " Version= %s\n", substr ($CommProperties, |
||
732 | 60+$MC_VerOffset, $MC_VerSize); |
||
733 | } |
||
734 | printf "\$MC_DialOpt= %lx\n", $MC_DialOpt; |
||
735 | printf "\$MC_CallFailTime= %d\n", $MC_CallFailTime; |
||
736 | printf "\$MC_IdleTime= %d\n", $MC_IdleTime; |
||
737 | printf "\$MC_SpkrVol= %d\n", $MC_SpkrVol; |
||
738 | printf "\$MC_SpkrMode= %d\n", $MC_SpkrMode; |
||
739 | printf "\$MC_ModOpt= %lx\n", $MC_ModOpt; |
||
740 | printf "\$MC_MaxDTE= %d\n", $MC_MaxDTE; |
||
741 | printf "\$MC_MaxDCE= %d\n", $MC_MaxDCE; |
||
742 | $MC_Filler= $MC_Filler; # for -w |
||
743 | } |
||
744 | ## $MC_ReqSize = 250; |
||
745 | if ($CP_ProvChar_start != $MC_ReqSize) { |
||
746 | printf "\nARGH, a Bug! The \$CommProperties buffer must be "; |
||
747 | printf "at least %d bytes.\n", $MC_ReqSize+60; |
||
748 | } |
||
749 | } |
||
750 | |||
751 | ## if (1 | $Babble) { |
||
752 | if ($Babble) { |
||
753 | printf "\$CP_Length= %d\n", $CP_Length; |
||
754 | printf "\$CP_Version= %d\n", $CP_Version; |
||
755 | printf "\$CP_ServiceMask= %lx\n", $CP_ServiceMask; |
||
756 | printf "\$CP_Reserved1= %lx\n", $CP_Reserved1; |
||
757 | printf "\$CP_MaxTxQueue= %lx\n", $self->{"_MaxTxQueue"}; |
||
758 | printf "\$CP_MaxRxQueue= %lx\n", $self->{"_MaxRxQueue"}; |
||
759 | printf "\$CP_MaxBaud= %lx\n", $CP_MaxBaud; |
||
760 | printf "\$CP_ProvSubType= %lx\n", $self->{"_TYPE"}; |
||
761 | printf "\$CP_ProvCapabilities= %lx\n", $CP_ProvCapabilities; |
||
762 | printf "\$CP_SettableParams= %lx\n", $CP_SettableParams; |
||
763 | printf "\$CP_SettableBaud= %lx\n", $CP_SettableBaud; |
||
764 | printf "\$CP_SettableData= %x\n", $CP_SettableData; |
||
765 | printf "\$CP_SettableStopParity= %x\n", $CP_SettableStopParity; |
||
766 | printf "\$CP_CurrentTxQueue= %lx\n", $self->{WRITEBUF}; |
||
767 | printf "\$CP_CurrentRxQueue= %lx\n", $self->{READBUF}; |
||
768 | printf "\$CP_ProvSpec1= %lx\n", $CP_ProvSpec1; |
||
769 | printf "\$CP_ProvSpec2= %lx\n", $CP_ProvSpec2; |
||
770 | } |
||
771 | |||
772 | # "private" data |
||
773 | $self->{"_INIT"} = undef; |
||
774 | $self->{"_DEBUG_C"} = 0; |
||
775 | $self->{"_LATCH"} = 0; |
||
776 | $self->{"_W_BUSY"} = 0; |
||
777 | $self->{"_R_BUSY"} = 0; |
||
778 | |||
779 | $self->{"_TBUFMAX"} = $self->{"_MaxTxQueue"} ? |
||
780 | $self->{"_MaxTxQueue"} : LONGsize; |
||
781 | $self->{"_RBUFMAX"} = $self->{"_MaxRxQueue"} ? |
||
782 | $self->{"_MaxRxQueue"} : LONGsize; |
||
783 | |||
784 | # buffers |
||
785 | $self->{"_R_OVERLAP"} = " "x24; |
||
786 | $self->{"_W_OVERLAP"} = " "x24; |
||
787 | $self->{"_TIMEOUT"} = " "x24; |
||
788 | $self->{"_RBUF"} = " "x $RBUF_Size; |
||
789 | |||
790 | # allowed setting hashes |
||
791 | $self->{"_L_BAUD"} = {}; |
||
792 | $self->{"_L_STOP"} = {}; |
||
793 | $self->{"_L_PARITY"} = {}; |
||
794 | $self->{"_L_DATA"} = {}; |
||
795 | $self->{"_L_HSHAKE"} = {}; |
||
796 | |||
797 | # capability flags |
||
798 | |||
799 | $fmask = $CP_SettableParams; |
||
800 | $self->{"_C_BAUD"} = $fmask & SP_BAUD; |
||
801 | $self->{"_C_DATA"} = $fmask & SP_DATABITS; |
||
802 | $self->{"_C_STOP"} = $fmask & SP_STOPBITS; |
||
803 | $self->{"_C_HSHAKE"} = $fmask & SP_HANDSHAKING; |
||
804 | $self->{"_C_PARITY_CFG"} = $fmask & SP_PARITY; |
||
805 | $self->{"_C_PARITY_EN"} = $fmask & SP_PARITY_CHECK; |
||
806 | $self->{"_C_RLSD_CFG"} = $fmask & SP_RLSD; |
||
807 | |||
808 | $fmask = $CP_ProvCapabilities; |
||
809 | $self->{"_C_RLSD"} = $fmask & PCF_RLSD; |
||
810 | $self->{"_C_PARITY_CK"} = $fmask & PCF_PARITY_CHECK; |
||
811 | $self->{"_C_DTRDSR"} = $fmask & PCF_DTRDSR; |
||
812 | $self->{"_C_16BITMODE"} = $fmask & PCF_16BITMODE; |
||
813 | $self->{"_C_RTSCTS"} = $fmask & PCF_RTSCTS; |
||
814 | $self->{"_C_XONXOFF"} = $fmask & PCF_XONXOFF; |
||
815 | $self->{"_C_XON_CHAR"} = $fmask & PCF_SETXCHAR; |
||
816 | $self->{"_C_SPECHAR"} = $fmask & PCF_SPECIALCHARS; |
||
817 | $self->{"_C_INT_TIME"} = $fmask & PCF_INTTIMEOUTS; |
||
818 | $self->{"_C_TOT_TIME"} = $fmask & PCF_TOTALTIMEOUTS; |
||
819 | |||
820 | if ($self->{"_C_INT_TIME"}) { |
||
821 | $self->{"_N_RINT"} = LONGsize; # min interval default |
||
822 | } |
||
823 | else { |
||
824 | $self->{"_N_RINT"} = 0; |
||
825 | } |
||
826 | $self->{"_N_RTOT"} = 0; |
||
827 | $self->{"_N_RCONST"} = 0; |
||
828 | |||
829 | if ($self->{"_C_TOT_TIME"}) { |
||
830 | $self->{"_N_WCONST"} = 201; # startup overhead + 1 |
||
831 | $self->{"_N_WTOT"} = 11; # per char out + 1 |
||
832 | } |
||
833 | else { |
||
834 | $self->{"_N_WTOT"} = 0; |
||
835 | $self->{"_N_WCONST"} = 0; |
||
836 | } |
||
837 | |||
838 | $hr = \%{$self->{"_L_HSHAKE"}}; |
||
839 | |||
840 | if ($self->{"_C_HSHAKE"}) { |
||
841 | ${$hr}{"xoff"} = "xoff" if ($fmask & PCF_XONXOFF); |
||
842 | ${$hr}{"rts"} = "rts" if ($fmask & PCF_RTSCTS); |
||
843 | ${$hr}{"dtr"} = "dtr" if ($fmask & PCF_DTRDSR); |
||
844 | ${$hr}{"none"} = "none"; |
||
845 | } |
||
846 | else { $self->{"_N_HSHAKE"} = undef; } |
||
847 | |||
848 | #### really just using the keys here, so value = Win32_definition |
||
849 | #### in case we ever need it for something else |
||
850 | |||
851 | # first check for programmable baud |
||
852 | |||
853 | $hr = \%{$self->{"_L_BAUD"}}; |
||
854 | |||
855 | if ($CP_MaxBaud & BAUD_USER) { |
||
856 | $fmask = $CP_SettableBaud; |
||
857 | ${$hr}{110} = CBR_110 if ($fmask & BAUD_110); |
||
858 | ${$hr}{300} = CBR_300 if ($fmask & BAUD_300); |
||
859 | ${$hr}{600} = CBR_600 if ($fmask & BAUD_600); |
||
860 | ${$hr}{1200} = CBR_1200 if ($fmask & BAUD_1200); |
||
861 | ${$hr}{2400} = CBR_2400 if ($fmask & BAUD_2400); |
||
862 | ${$hr}{4800} = CBR_4800 if ($fmask & BAUD_4800); |
||
863 | ${$hr}{9600} = CBR_9600 if ($fmask & BAUD_9600); |
||
864 | ${$hr}{14400} = CBR_14400 if ($fmask & BAUD_14400); |
||
865 | ${$hr}{19200} = CBR_19200 if ($fmask & BAUD_19200); |
||
866 | ${$hr}{38400} = CBR_38400 if ($fmask & BAUD_38400); |
||
867 | ${$hr}{56000} = CBR_56000 if ($fmask & BAUD_56K); |
||
868 | ${$hr}{57600} = CBR_57600 if ($fmask & BAUD_57600); |
||
869 | ${$hr}{115200} = CBR_115200 if ($fmask & BAUD_115200); |
||
870 | ${$hr}{128000} = CBR_128000 if ($fmask & BAUD_128K); |
||
871 | ${$hr}{256000} = CBR_256000 if (0); # reserved ?? |
||
872 | } |
||
873 | else { |
||
874 | # get fixed baud from CP_MaxBaud |
||
875 | $fmask = $CP_MaxBaud; |
||
876 | $fix_baud = 75 if ($fmask & BAUD_075); |
||
877 | $fix_baud = 110 if ($fmask & BAUD_110); |
||
878 | $fix_baud = 134.5 if ($fmask & BAUD_134_5); |
||
879 | $fix_baud = 150 if ($fmask & BAUD_150); |
||
880 | $fix_baud = 300 if ($fmask & BAUD_300); |
||
881 | $fix_baud = 600 if ($fmask & BAUD_600); |
||
882 | $fix_baud = 1200 if ($fmask & BAUD_1200); |
||
883 | $fix_baud = 1800 if ($fmask & BAUD_1800); |
||
884 | $fix_baud = 2400 if ($fmask & BAUD_2400); |
||
885 | $fix_baud = 4800 if ($fmask & BAUD_4800); |
||
886 | $fix_baud = 7200 if ($fmask & BAUD_7200); |
||
887 | $fix_baud = 9600 if ($fmask & BAUD_9600); |
||
888 | $fix_baud = 14400 if ($fmask & BAUD_14400); |
||
889 | $fix_baud = 19200 if ($fmask & BAUD_19200); |
||
890 | $fix_baud = 34800 if ($fmask & BAUD_38400); |
||
891 | $fix_baud = 56000 if ($fmask & BAUD_56K); |
||
892 | $fix_baud = 57600 if ($fmask & BAUD_57600); |
||
893 | $fix_baud = 115200 if ($fmask & BAUD_115200); |
||
894 | $fix_baud = 128000 if ($fmask & BAUD_128K); |
||
895 | ${$hr}{$fix_baud} = $fix_baud; |
||
896 | $self->{"_N_BAUD"} = undef; |
||
897 | } |
||
898 | |||
899 | #### data bits |
||
900 | |||
901 | $fmask = $CP_SettableData; |
||
902 | |||
903 | if ($self->{"_C_DATA"}) { |
||
904 | |||
905 | $hr = \%{$self->{"_L_DATA"}}; |
||
906 | |||
907 | ${$hr}{5} = 5 if ($fmask & DATABITS_5); |
||
908 | ${$hr}{6} = 6 if ($fmask & DATABITS_6); |
||
909 | ${$hr}{7} = 7 if ($fmask & DATABITS_7); |
||
910 | ${$hr}{8} = 8 if ($fmask & DATABITS_8); |
||
911 | ${$hr}{16} = 16 if ($fmask & DATABITS_16); |
||
912 | ## ${$hr}{16X} = 16 if ($fmask & DATABITS_16X); |
||
913 | } |
||
914 | else { $self->{"_N_DATA"} = undef; } |
||
915 | |||
916 | #### value = (DCB Win32_definition + 1) so 0 means unchanged |
||
917 | |||
918 | $fmask = $CP_SettableStopParity; |
||
919 | |||
920 | if ($self->{"_C_STOP"}) { |
||
921 | |||
922 | $hr = \%{$self->{"_L_STOP"}}; |
||
923 | |||
924 | ${$hr}{1} = 1 + ONESTOPBIT if ($fmask & STOPBITS_10); |
||
925 | ${$hr}{1.5} = 1 + ONE5STOPBITS if ($fmask & STOPBITS_15); |
||
926 | ${$hr}{2} = 1 + TWOSTOPBITS if ($fmask & STOPBITS_20); |
||
927 | } |
||
928 | else { $self->{"_N_STOP"} = undef; } |
||
929 | |||
930 | if ($self->{"_C_PARITY_CFG"}) { |
||
931 | |||
932 | $hr = \%{$self->{"_L_PARITY"}}; |
||
933 | |||
934 | ${$hr}{"none"} = 1 + NOPARITY if ($fmask & PARITY_NONE); |
||
935 | ${$hr}{"even"} = 1 + EVENPARITY if ($fmask & PARITY_EVEN); |
||
936 | ${$hr}{"odd"} = 1 + ODDPARITY if ($fmask & PARITY_ODD); |
||
937 | ${$hr}{"mark"} = 1 + MARKPARITY if ($fmask & PARITY_MARK); |
||
938 | ${$hr}{"space"} = 1 + SPACEPARITY if ($fmask & PARITY_SPACE); |
||
939 | } |
||
940 | else { $self->{"_N_PARITY"} = undef; } |
||
941 | |||
942 | $hr = 0; # no loops |
||
943 | |||
944 | # changable dcb parameters |
||
945 | # 0 = no change requested |
||
946 | # mask_on: requested value for OR |
||
947 | # mask_off: complement of requested value for AND |
||
948 | |||
949 | $self->{"_N_FM_ON"} = 0; |
||
950 | $self->{"_N_FM_OFF"} = 0; |
||
951 | |||
952 | $self->{"_N_AUX_ON"} = 0; |
||
953 | $self->{"_N_AUX_OFF"} = 0; |
||
954 | |||
955 | ### "VALUE" is initialized from DCB by default (but also in %validate) |
||
956 | |||
957 | # 0 = no change requested |
||
958 | # integer: requested value or (value+1 if 0 is a legal value) |
||
959 | # binary: 1=false requested, 2=true requested |
||
960 | |||
961 | $self->{"_N_XONLIM"} = 0; |
||
962 | $self->{"_N_XOFFLIM"} = 0; |
||
963 | $self->{"_N_XOFFCHAR"} = 0; |
||
964 | $self->{"_N_XONCHAR"} = 0; |
||
965 | $self->{"_N_ERRCHAR"} = 0; |
||
966 | $self->{"_N_EOFCHAR"} = 0; |
||
967 | $self->{"_N_EVTCHAR"} = 0; |
||
968 | $self->{"_N_BINARY"} = 0; |
||
969 | $self->{"_N_PARITY_EN"} = 0; |
||
970 | |||
971 | ### "_N_items" for save/start |
||
972 | |||
973 | $self->{"_N_READBUF"} = 0; |
||
974 | $self->{"_N_WRITEBUF"} = 0; |
||
975 | $self->{"_N_HSHAKE"} = 0; |
||
976 | |||
977 | ### The "required" DCB values are deliberately NOT defined. That way, |
||
978 | ### write_settings can verify they "exist" to assure they got set. |
||
979 | ### $self->{"_N_BAUD"} |
||
980 | ### $self->{"_N_DATA"} |
||
981 | ### $self->{"_N_STOP"} |
||
982 | ### $self->{"_N_PARITY"} |
||
983 | |||
984 | |||
985 | $self->{"_R_EVENT"} = CreateEvent($null, # no security |
||
986 | 1, # explicit reset req |
||
987 | 0, # initial event reset |
||
988 | $null); # no name |
||
989 | unless ($self->{"_R_EVENT"}) { |
||
990 | OS_Error; |
||
991 | carp "could not create required read event"; |
||
992 | undef $self; |
||
993 | return; |
||
994 | } |
||
995 | |||
996 | $self->{"_W_EVENT"} = CreateEvent($null, # no security |
||
997 | 1, # explicit reset req |
||
998 | 0, # initial event reset |
||
999 | $null); # no name |
||
1000 | unless ($self->{"_W_EVENT"}) { |
||
1001 | OS_Error; |
||
1002 | carp "could not create required write event"; |
||
1003 | undef $self; |
||
1004 | return; |
||
1005 | } |
||
1006 | $self->{"_R_OVERLAP"} = pack($OVERLAPPEDformat, |
||
1007 | $zero, # osRead_Internal, |
||
1008 | $zero, # osRead_InternalHigh, |
||
1009 | $zero, # osRead_Offset, |
||
1010 | $zero, # osRead_OffsetHigh, |
||
1011 | $self->{"_R_EVENT"}); |
||
1012 | |||
1013 | $self->{"_W_OVERLAP"} = pack($OVERLAPPEDformat, |
||
1014 | $zero, # osWrite_Internal, |
||
1015 | $zero, # osWrite_InternalHigh, |
||
1016 | $zero, # osWrite_Offset, |
||
1017 | $zero, # osWrite_OffsetHigh, |
||
1018 | $self->{"_W_EVENT"}); |
||
1019 | |||
1020 | # Device Control Block (DCB) |
||
1021 | unless ( fetch_DCB ($self) ) { |
||
1022 | carp "can't read Device Control Block for $self->{NAME}\n"; |
||
1023 | undef $self; |
||
1024 | return; |
||
1025 | } |
||
1026 | $self->{"_L_BAUD"}{$self->{BAUD}} = $self->{BAUD}; # actual must be ok |
||
1027 | |||
1028 | # Read Timeouts |
||
1029 | unless ( GetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) { |
||
1030 | carp "Error in GetCommTimeouts"; |
||
1031 | undef $self; |
||
1032 | return; |
||
1033 | } |
||
1034 | |||
1035 | ($self->{RINT}, |
||
1036 | $self->{RTOT}, |
||
1037 | $self->{RCONST}, |
||
1038 | $self->{WTOT}, |
||
1039 | $self->{WCONST})= unpack($TIMEOUTformat, $self->{"_TIMEOUT"}); |
||
1040 | |||
1041 | bless ($self, $class); |
||
1042 | return $self; |
||
1043 | } |
||
1044 | |||
1045 | sub fetch_DCB { |
||
1046 | my $self = shift; |
||
1047 | my $ok; |
||
1048 | my $hr; |
||
1049 | my $fmask; |
||
1050 | my $key; |
||
1051 | my $value; |
||
1052 | my $dcb = " "x32; |
||
1053 | |||
1054 | GetCommState($self->{"_HANDLE"}, $dcb) or return; |
||
1055 | |||
1056 | ($self->{"_DCBLength"}, |
||
1057 | $self->{BAUD}, |
||
1058 | $self->{"_BitMask"}, |
||
1059 | $self->{"_ResvWORD"}, |
||
1060 | $self->{XONLIM}, |
||
1061 | $self->{XOFFLIM}, |
||
1062 | $self->{DATA}, |
||
1063 | $self->{"_Parity"}, |
||
1064 | $self->{"_StopBits"}, |
||
1065 | $self->{XONCHAR}, |
||
1066 | $self->{XOFFCHAR}, |
||
1067 | $self->{ERRCHAR}, |
||
1068 | $self->{EOFCHAR}, |
||
1069 | $self->{EVTCHAR}, |
||
1070 | $self->{"_PackWORD"})= unpack($DCBformat, $dcb); |
||
1071 | |||
1072 | if ($self->{"_DCBLength"} > 32) { |
||
1073 | carp "invalid DCB block length"; |
||
1074 | return; |
||
1075 | } |
||
1076 | |||
1077 | if ($Babble) { |
||
1078 | printf "DCBLength= %d\n", $self->{"_DCBLength"}; |
||
1079 | printf "BaudRate= %d\n", $self->{BAUD}; |
||
1080 | printf "BitMask= %lx\n", $self->{"_BitMask"}; |
||
1081 | printf "ResvWORD= %x\n", $self->{"_ResvWORD"}; |
||
1082 | printf "XonLim= %x\n", $self->{XONLIM}; |
||
1083 | printf "XoffLim= %x\n", $self->{XOFFLIM}; |
||
1084 | printf "ByteSize= %d\n", $self->{DATA}; |
||
1085 | printf "Parity= %d\n", $self->{"_Parity"}; |
||
1086 | printf "StopBits= %d\n", $self->{"_StopBits"}; |
||
1087 | printf "XonChar= %x\n", $self->{XONCHAR}; |
||
1088 | printf "XoffChar= %x\n", $self->{XOFFCHAR}; |
||
1089 | printf "ErrorChar= %x\n", $self->{ERRCHAR}; |
||
1090 | printf "EofChar= %x\n", $self->{EOFCHAR}; |
||
1091 | printf "EvtChar= %x\n", $self->{EVTCHAR}; |
||
1092 | printf "PackWORD= %x\n", $self->{"_PackWORD"}; |
||
1093 | printf "handle= %d\n\n", $self->{"_HANDLE"}; |
||
1094 | } |
||
1095 | |||
1096 | $fmask = 1 + $self->{"_StopBits"}; |
||
1097 | while (($key, $value) = each %{ $self->{"_L_STOP"} }) { |
||
1098 | if ($value == $fmask) { |
||
1099 | $self->{STOP} = $key; |
||
1100 | } |
||
1101 | } |
||
1102 | |||
1103 | $fmask = 1 + $self->{"_Parity"}; |
||
1104 | while (($key, $value) = each %{ $self->{"_L_PARITY"} }) { |
||
1105 | if ($value == $fmask) { |
||
1106 | $self->{PARITY} = $key; |
||
1107 | } |
||
1108 | } |
||
1109 | |||
1110 | $fmask = $self->{"_BitMask"}; |
||
1111 | |||
1112 | $hr = DTR_CONTROL_HANDSHAKE; |
||
1113 | $ok = RTS_CONTROL_HANDSHAKE; |
||
1114 | |||
1115 | if ($fmask & ( $hr << 4) ) { |
||
1116 | $self->{HSHAKE} = "dtr"; |
||
1117 | } |
||
1118 | elsif ($fmask & ( $ok << 12) ) { |
||
1119 | $self->{HSHAKE} = "rts"; |
||
1120 | } |
||
1121 | elsif ($fmask & ( FM_fOutX | FM_fInX ) ) { |
||
1122 | $self->{HSHAKE} = "xoff"; |
||
1123 | } |
||
1124 | else { |
||
1125 | $self->{HSHAKE} = "none"; |
||
1126 | } |
||
1127 | |||
1128 | $self->{BINARY} = ($fmask & FM_fBinary); |
||
1129 | $self->{PARITY_EN} = ($fmask & FM_fParity); |
||
1130 | |||
1131 | if ($fmask & FM_fDummy2) { |
||
1132 | carp "Unknown DCB Flow Mask Bit in $self->{NAME}"; |
||
1133 | } |
||
1134 | 1; |
||
1135 | } |
||
1136 | |||
1137 | sub init_done { |
||
1138 | my $self = shift; |
||
1139 | return 0 unless (defined $self->{"_INIT"}); |
||
1140 | return $self->{"_INIT"}; |
||
1141 | } |
||
1142 | |||
1143 | |||
1144 | sub update_DCB { |
||
1145 | my $self = shift; |
||
1146 | my $ok = 0; |
||
1147 | |||
1148 | return unless (defined $self->{"_INIT"}); |
||
1149 | |||
1150 | fetch_DCB ($self); |
||
1151 | |||
1152 | if ($self->{"_N_HSHAKE"}) { |
||
1153 | $self->{HSHAKE} = $self->{"_N_HSHAKE"}; |
||
1154 | if ($self->{HSHAKE} eq "dtr" ) { |
||
1155 | $self->{"_N_FM_ON"} = 0x1028; |
||
1156 | $self->{"_N_FM_OFF"} = 0xffffdceb; |
||
1157 | } |
||
1158 | elsif ($self->{HSHAKE} eq "rts" ) { |
||
1159 | $self->{"_N_FM_ON"} = 0x2014; |
||
1160 | $self->{"_N_FM_OFF"} = 0xffffecd7; |
||
1161 | } |
||
1162 | elsif ($self->{HSHAKE} eq "xoff" ) { |
||
1163 | $self->{"_N_FM_ON"} = 0x1310; |
||
1164 | $self->{"_N_FM_OFF"} = 0xffffdfd3; |
||
1165 | } |
||
1166 | else { |
||
1167 | $self->{"_N_FM_ON"} = 0x1010; |
||
1168 | $self->{"_N_FM_OFF"} = 0xffffdcd3; |
||
1169 | } |
||
1170 | $self->{"_N_HSHAKE"} = 0; |
||
1171 | } |
||
1172 | |||
1173 | if ($self->{"_N_PARITY_EN"}) { |
||
1174 | if (2 == $self->{"_N_PARITY_EN"}) { |
||
1175 | $self->{"_N_FM_ON"} |= FM_fParity; # enable |
||
1176 | if ($self->{"_N_FM_OFF"}) { |
||
1177 | $self->{"_N_FM_OFF"} |= FM_fParity; |
||
1178 | } |
||
1179 | else { $self->{"_N_FM_OFF"} = LONGsize; } |
||
1180 | } |
||
1181 | else { |
||
1182 | if ($self->{"_N_FM_ON"}) { |
||
1183 | $self->{"_N_FM_ON"} &= ~FM_fParity; # disable |
||
1184 | } |
||
1185 | if ($self->{"_N_FM_OFF"}) { |
||
1186 | $self->{"_N_FM_OFF"} &= ~FM_fParity; |
||
1187 | } |
||
1188 | else { $self->{"_N_FM_OFF"} = ~FM_fParity; } |
||
1189 | } |
||
1190 | ## DEBUG ## |
||
1191 | ## printf "_N_FM_ON=%lx\n", $self->{"_N_FM_ON"}; ## DEBUG ## |
||
1192 | ## printf "_N_FM_OFF=%lx\n", $self->{"_N_FM_OFF"}; ## DEBUG ## |
||
1193 | ## DEBUG ## |
||
1194 | $self->{"_N_PARITY_EN"} = 0; |
||
1195 | } |
||
1196 | |||
1197 | ## DEBUG ## |
||
1198 | ## printf "_N_AUX_ON=%lx\n", $self->{"_N_AUX_ON"}; ## DEBUG ## |
||
1199 | ## printf "_N_AUX_OFF=%lx\n", $self->{"_N_AUX_OFF"}; ## DEBUG ## |
||
1200 | ## DEBUG ## |
||
1201 | |||
1202 | if ( $self->{"_N_AUX_ON"} or $self->{"_N_AUX_OFF"} ) { |
||
1203 | if ( $self->{"_N_FM_OFF"} ) { |
||
1204 | $self->{"_N_FM_OFF"} &= $self->{"_N_AUX_OFF"}; |
||
1205 | } |
||
1206 | else { |
||
1207 | $self->{"_N_FM_OFF"} = $self->{"_N_AUX_OFF"}; |
||
1208 | } |
||
1209 | $self->{"_N_FM_ON"} |= $self->{"_N_AUX_ON"}; |
||
1210 | $self->{"_N_AUX_ON"} = 0; |
||
1211 | $self->{"_N_AUX_OFF"} = 0; |
||
1212 | } |
||
1213 | ## DEBUG ## |
||
1214 | ## printf "_N_FM_ON=%lx\n", $self->{"_N_FM_ON"}; ## DEBUG ## |
||
1215 | ## printf "_N_FM_OFF=%lx\n", $self->{"_N_FM_OFF"}; ## DEBUG ## |
||
1216 | ## DEBUG ## |
||
1217 | |||
1218 | if ( $self->{"_N_FM_ON"} or $self->{"_N_FM_OFF"} ) { |
||
1219 | $self->{"_BitMask"} &= $self->{"_N_FM_OFF"}; |
||
1220 | $self->{"_BitMask"} |= $self->{"_N_FM_ON"}; |
||
1221 | $self->{"_N_FM_ON"} = 0; |
||
1222 | $self->{"_N_FM_OFF"} = 0; |
||
1223 | } |
||
1224 | |||
1225 | if ($self->{"_N_XONLIM"}) { |
||
1226 | $self->{XONLIM} = $self->{"_N_XONLIM"} - 1; |
||
1227 | $self->{"_N_XONLIM"} = 0; |
||
1228 | } |
||
1229 | |||
1230 | if ($self->{"_N_XOFFLIM"}) { |
||
1231 | $self->{XOFFLIM} = $self->{"_N_XOFFLIM"} - 1; |
||
1232 | $self->{"_N_XOFFLIM"} = 0; |
||
1233 | } |
||
1234 | |||
1235 | if ($self->{"_N_BAUD"}) { |
||
1236 | $self->{BAUD} = $self->{"_N_BAUD"}; |
||
1237 | $self->{"_N_BAUD"} = 0; |
||
1238 | } |
||
1239 | |||
1240 | if ($self->{"_N_DATA"}) { |
||
1241 | $self->{DATA} = $self->{"_N_DATA"}; |
||
1242 | $self->{"_N_DATA"} = 0; |
||
1243 | } |
||
1244 | |||
1245 | if ($self->{"_N_STOP"}) { |
||
1246 | $self->{"_StopBits"} = $self->{"_N_STOP"} - 1; |
||
1247 | $self->{"_N_STOP"} = 0; |
||
1248 | } |
||
1249 | |||
1250 | if ($self->{"_N_PARITY"}) { |
||
1251 | $self->{"_Parity"} = $self->{"_N_PARITY"} - 1; |
||
1252 | $self->{"_N_PARITY"} = 0; |
||
1253 | } |
||
1254 | |||
1255 | if ($self->{"_N_XONCHAR"}) { |
||
1256 | $self->{XONCHAR} = $self->{"_N_XONCHAR"} - 1; |
||
1257 | $self->{"_N_XONCHAR"} = 0; |
||
1258 | } |
||
1259 | |||
1260 | if ($self->{"_N_XOFFCHAR"}) { |
||
1261 | $self->{XOFFCHAR} = $self->{"_N_XOFFCHAR"} - 1; |
||
1262 | $self->{"_N_XOFFCHAR"} = 0; |
||
1263 | } |
||
1264 | |||
1265 | if ($self->{"_N_ERRCHAR"}) { |
||
1266 | $self->{ERRCHAR} = $self->{"_N_ERRCHAR"} - 1; |
||
1267 | $self->{"_N_ERRCHAR"} = 0; |
||
1268 | } |
||
1269 | |||
1270 | if ($self->{"_N_EOFCHAR"}) { |
||
1271 | $self->{EOFCHAR} = $self->{"_N_EOFCHAR"} - 1; |
||
1272 | $self->{"_N_EOFCHAR"} = 0; |
||
1273 | } |
||
1274 | |||
1275 | if ($self->{"_N_EVTCHAR"}) { |
||
1276 | $self->{EVTCHAR} = $self->{"_N_EVTCHAR"} - 1; |
||
1277 | $self->{"_N_EVTCHAR"} = 0; |
||
1278 | } |
||
1279 | |||
1280 | my $dcb = pack($DCBformat, |
||
1281 | $self->{"_DCBLength"}, |
||
1282 | $self->{BAUD}, |
||
1283 | $self->{"_BitMask"}, |
||
1284 | $self->{"_ResvWORD"}, |
||
1285 | $self->{XONLIM}, |
||
1286 | $self->{XOFFLIM}, |
||
1287 | $self->{DATA}, |
||
1288 | $self->{"_Parity"}, |
||
1289 | $self->{"_StopBits"}, |
||
1290 | $self->{XONCHAR}, |
||
1291 | $self->{XOFFCHAR}, |
||
1292 | $self->{ERRCHAR}, |
||
1293 | $self->{EOFCHAR}, |
||
1294 | $self->{EVTCHAR}, |
||
1295 | $self->{"_PackWORD"}); |
||
1296 | |||
1297 | if ( SetCommState($self->{"_HANDLE"}, $dcb) ) { |
||
1298 | print "updated DCB for $self->{NAME}\n" if ($Babble); |
||
1299 | ## DEBUG ## |
||
1300 | ## printf "DEBUG BitMask= %lx\n", $self->{"_BitMask"}; ## DEBUG ## |
||
1301 | ## DEBUG ## |
||
1302 | } |
||
1303 | else { |
||
1304 | carp "SetCommState failed"; |
||
1305 | OS_Error; |
||
1306 | if ($Babble) { |
||
1307 | printf "\ntried to write:\n"; |
||
1308 | printf "DCBLength= %d\n", $self->{"_DCBLength"}; |
||
1309 | printf "BaudRate= %d\n", $self->{BAUD}; |
||
1310 | printf "BitMask= %lx\n", $self->{"_BitMask"}; |
||
1311 | printf "ResvWORD= %x\n", $self->{"_ResvWORD"}; |
||
1312 | printf "XonLim= %x\n", $self->{XONLIM}; |
||
1313 | printf "XoffLim= %x\n", $self->{XOFFLIM}; |
||
1314 | printf "ByteSize= %d\n", $self->{DATA}; |
||
1315 | printf "Parity= %d\n", $self->{"_Parity"}; |
||
1316 | printf "StopBits= %d\n", $self->{"_StopBits"}; |
||
1317 | printf "XonChar= %x\n", $self->{XONCHAR}; |
||
1318 | printf "XoffChar= %x\n", $self->{XOFFCHAR}; |
||
1319 | printf "ErrorChar= %x\n", $self->{ERRCHAR}; |
||
1320 | printf "EofChar= %x\n", $self->{EOFCHAR}; |
||
1321 | printf "EvtChar= %x\n", $self->{EVTCHAR}; |
||
1322 | printf "PackWORD= %x\n", $self->{"_PackWORD"}; |
||
1323 | printf "handle= %d\n", $self->{"_HANDLE"}; |
||
1324 | } |
||
1325 | } |
||
1326 | } |
||
1327 | |||
1328 | sub initialize { |
||
1329 | my $self = shift; |
||
1330 | my $item; |
||
1331 | my $fault = 0; |
||
1332 | foreach $item (@_) { |
||
1333 | unless (exists $self->{"_N_$item"}) { |
||
1334 | # must be "exists" so undef=not_settable |
||
1335 | $fault++; |
||
1336 | nocarp or carp "Missing REQUIRED setting for $item"; |
||
1337 | } |
||
1338 | } |
||
1339 | unless ($self->{"_INIT"}) { |
||
1340 | $self->{"_INIT"} = 1 unless ($fault); |
||
1341 | $self->{"_BitMask"} = 0x1011; |
||
1342 | $self->{XONLIM} = 100 unless ($self->{"_N_XONLIM"}); |
||
1343 | $self->{XOFFLIM} = 100 unless ($self->{"_N_XOFFLIM"}); |
||
1344 | $self->{XONCHAR} = 0x11 unless ($self->{"_N_XONCHAR"}); |
||
1345 | $self->{XOFFCHAR} = 0x13 unless ($self->{"_N_XOFFCHAR"}); |
||
1346 | $self->{ERRCHAR} = 0 unless ($self->{"_N_ERRCHAR"}); |
||
1347 | $self->{EOFCHAR} = 0 unless ($self->{"_N_EOFCHAR"}); |
||
1348 | $self->{EVTCHAR} = 0 unless ($self->{"_N_EVTCHAR"}); |
||
1349 | |||
1350 | update_timeouts($self); |
||
1351 | } |
||
1352 | |||
1353 | if ($self->{"_N_READBUF"} or $self->{"_N_WRITEBUF"}) { |
||
1354 | if ($self->{"_N_READBUF"}) { |
||
1355 | $self->{READBUF} = $self->{"_N_READBUF"}; |
||
1356 | } |
||
1357 | if ($self->{"_N_WRITEBUF"}) { |
||
1358 | $self->{WRITEBUF} = $self->{"_N_WRITEBUF"}; |
||
1359 | } |
||
1360 | $self->{"_N_READBUF"} = 0; |
||
1361 | $self->{"_N_WRITEBUF"} = 0; |
||
1362 | SetupComm($self->{"_HANDLE"}, $self->{READBUF}, $self->{WRITEBUF}); |
||
1363 | } |
||
1364 | purge_all($self); |
||
1365 | return $fault; |
||
1366 | } |
||
1367 | |||
1368 | sub is_status { |
||
1369 | my $self = shift; |
||
1370 | my $ok = 0; |
||
1371 | my $error_p = " "x4; |
||
1372 | my $CommStatus = " "x12; |
||
1373 | |||
1374 | if (@_ and $testactive) { |
||
1375 | $self->{"_LATCH"} |= shift; |
||
1376 | } |
||
1377 | |||
1378 | $ok=ClearCommError($self->{"_HANDLE"}, $error_p, $CommStatus); |
||
1379 | |||
1380 | my $Error_BitMask = unpack("L", $error_p); |
||
1381 | $self->{"_LATCH"} |= $Error_BitMask; |
||
1382 | my @stat = unpack($COMSTATformat, $CommStatus); |
||
1383 | push @stat, $self->{"_LATCH"}; |
||
1384 | |||
1385 | $stat[ST_BLOCK] &= BM_AllBits; |
||
1386 | if ( $Babble or $self->{"_DEBUG_C"} ) { |
||
1387 | printf "Blocking Bits= %d\n", $stat[ST_BLOCK]; |
||
1388 | printf "Input Queue= %d\n", $stat[ST_INPUT]; |
||
1389 | printf "Output Queue= %d\n", $stat[ST_OUTPUT]; |
||
1390 | printf "Latched Errors= %d\n", $stat[ST_ERROR]; |
||
1391 | printf "ok= %d\n", $ok; |
||
1392 | } |
||
1393 | return ($ok ? @stat : undef); |
||
1394 | } |
||
1395 | |||
1396 | sub reset_error { |
||
1397 | my $self = shift; |
||
1398 | my $was = $self->{"_LATCH"}; |
||
1399 | $self->{"_LATCH"} = 0; |
||
1400 | return $was; |
||
1401 | } |
||
1402 | |||
1403 | sub can_baud { |
||
1404 | my $self = shift; |
||
1405 | return $self->{"_C_BAUD"}; |
||
1406 | } |
||
1407 | |||
1408 | sub can_databits { |
||
1409 | my $self = shift; |
||
1410 | return $self->{"_C_DATA"}; |
||
1411 | } |
||
1412 | |||
1413 | sub can_stopbits { |
||
1414 | my $self = shift; |
||
1415 | return $self->{"_C_STOP"}; |
||
1416 | } |
||
1417 | |||
1418 | sub can_dtrdsr { |
||
1419 | my $self = shift; |
||
1420 | return $self->{"_C_DTRDSR"}; |
||
1421 | } |
||
1422 | |||
1423 | sub can_handshake { |
||
1424 | my $self = shift; |
||
1425 | return $self->{"_C_HSHAKE"}; |
||
1426 | } |
||
1427 | |||
1428 | sub can_parity_check { |
||
1429 | my $self = shift; |
||
1430 | return $self->{"_C_PARITY_CK"}; |
||
1431 | } |
||
1432 | |||
1433 | sub can_parity_config { |
||
1434 | my $self = shift; |
||
1435 | return $self->{"_C_PARITY_CFG"}; |
||
1436 | } |
||
1437 | |||
1438 | sub can_parity_enable { |
||
1439 | my $self = shift; |
||
1440 | return $self->{"_C_PARITY_EN"}; |
||
1441 | } |
||
1442 | |||
1443 | sub can_rlsd_config { |
||
1444 | my $self = shift; |
||
1445 | return $self->{"_C_RLSD_CFG"}; |
||
1446 | } |
||
1447 | |||
1448 | sub can_rlsd { |
||
1449 | my $self = shift; |
||
1450 | return $self->{"_C_RLSD"}; |
||
1451 | } |
||
1452 | |||
1453 | sub can_16bitmode { |
||
1454 | my $self = shift; |
||
1455 | return $self->{"_C_16BITMODE"}; |
||
1456 | } |
||
1457 | |||
1458 | sub is_rs232 { |
||
1459 | my $self = shift; |
||
1460 | return ($self->{"_TYPE"} == PST_RS232); |
||
1461 | } |
||
1462 | |||
1463 | sub is_modem { |
||
1464 | my $self = shift; |
||
1465 | return ($self->{"_TYPE"} == PST_MODEM); |
||
1466 | } |
||
1467 | |||
1468 | sub can_rtscts { |
||
1469 | my $self = shift; |
||
1470 | return $self->{"_C_RTSCTS"}; |
||
1471 | } |
||
1472 | |||
1473 | sub can_xonxoff { |
||
1474 | my $self = shift; |
||
1475 | return $self->{"_C_XONXOFF"}; |
||
1476 | } |
||
1477 | |||
1478 | sub can_xon_char { |
||
1479 | my $self = shift; |
||
1480 | return $self->{"_C_XON_CHAR"}; |
||
1481 | } |
||
1482 | |||
1483 | sub can_spec_char { |
||
1484 | my $self = shift; |
||
1485 | return $self->{"_C_SPECHAR"}; |
||
1486 | } |
||
1487 | |||
1488 | sub can_interval_timeout { |
||
1489 | my $self = shift; |
||
1490 | return $self->{"_C_INT_TIME"}; |
||
1491 | } |
||
1492 | |||
1493 | sub can_total_timeout { |
||
1494 | my $self = shift; |
||
1495 | return $self->{"_C_TOT_TIME"}; |
||
1496 | } |
||
1497 | |||
1498 | sub is_handshake { |
||
1499 | my $self = shift; |
||
1500 | if (@_) { |
||
1501 | return unless $self->{"_C_HSHAKE"}; |
||
1502 | return unless (defined $self->{"_L_HSHAKE"}{$_[0]}); |
||
1503 | $self->{"_N_HSHAKE"} = $self->{"_L_HSHAKE"}{$_[0]}; |
||
1504 | update_DCB ($self); |
||
1505 | } |
||
1506 | return unless fetch_DCB ($self); |
||
1507 | return $self->{HSHAKE}; |
||
1508 | } |
||
1509 | |||
1510 | sub are_handshake { |
||
1511 | my $self = shift; |
||
1512 | return unless $self->{"_C_HSHAKE"}; |
||
1513 | return if (@_); |
||
1514 | return keys(%{$self->{"_L_HSHAKE"}}); |
||
1515 | } |
||
1516 | |||
1517 | sub is_baudrate { |
||
1518 | my $self = shift; |
||
1519 | if (@_) { |
||
1520 | return unless $self->{"_C_BAUD"}; |
||
1521 | return unless (defined $self->{"_L_BAUD"}{$_[0]}); |
||
1522 | $self->{"_N_BAUD"} = int shift; |
||
1523 | update_DCB ($self); |
||
1524 | } |
||
1525 | return unless fetch_DCB ($self); |
||
1526 | return $self->{BAUD}; |
||
1527 | } |
||
1528 | |||
1529 | sub are_baudrate { |
||
1530 | my $self = shift; |
||
1531 | return unless $self->{"_C_BAUD"}; |
||
1532 | return if (@_); |
||
1533 | return keys(%{$self->{"_L_BAUD"}}); |
||
1534 | } |
||
1535 | |||
1536 | sub is_parity { |
||
1537 | my $self = shift; |
||
1538 | if (@_) { |
||
1539 | return unless $self->{"_C_PARITY_CFG"}; |
||
1540 | return unless (defined $self->{"_L_PARITY"}{$_[0]}); |
||
1541 | $self->{"_N_PARITY"} = $self->{"_L_PARITY"}{$_[0]}; |
||
1542 | update_DCB ($self); |
||
1543 | } |
||
1544 | return unless fetch_DCB ($self); |
||
1545 | return $self->{PARITY}; |
||
1546 | } |
||
1547 | |||
1548 | sub are_parity { |
||
1549 | my $self = shift; |
||
1550 | return unless $self->{"_C_PARITY_CFG"}; |
||
1551 | return if (@_); |
||
1552 | return keys(%{$self->{"_L_PARITY"}}); |
||
1553 | } |
||
1554 | |||
1555 | sub is_databits { |
||
1556 | my $self = shift; |
||
1557 | if (@_) { |
||
1558 | return unless $self->{"_C_DATA"}; |
||
1559 | return unless (defined $self->{"_L_DATA"}{$_[0]}); |
||
1560 | $self->{"_N_DATA"} = $self->{"_L_DATA"}{$_[0]}; |
||
1561 | update_DCB ($self); |
||
1562 | } |
||
1563 | return unless fetch_DCB ($self); |
||
1564 | return $self->{DATA}; |
||
1565 | } |
||
1566 | |||
1567 | sub are_databits { |
||
1568 | my $self = shift; |
||
1569 | return unless $self->{"_C_DATA"}; |
||
1570 | return if (@_); |
||
1571 | return keys(%{$self->{"_L_DATA"}}); |
||
1572 | } |
||
1573 | |||
1574 | sub is_stopbits { |
||
1575 | my $self = shift; |
||
1576 | if (@_) { |
||
1577 | return unless $self->{"_C_STOP"}; |
||
1578 | return unless (defined $self->{"_L_STOP"}{$_[0]}); |
||
1579 | $self->{"_N_STOP"} = $self->{"_L_STOP"}{$_[0]}; |
||
1580 | update_DCB ($self); |
||
1581 | } |
||
1582 | return unless fetch_DCB ($self); |
||
1583 | return $self->{STOP}; |
||
1584 | } |
||
1585 | |||
1586 | sub are_stopbits { |
||
1587 | my $self = shift; |
||
1588 | return unless $self->{"_C_STOP"}; |
||
1589 | return if (@_); |
||
1590 | return keys(%{$self->{"_L_STOP"}}); |
||
1591 | } |
||
1592 | |||
1593 | # single value for save/start |
||
1594 | sub is_read_buf { |
||
1595 | my $self = shift; |
||
1596 | if (@_) { $self->{"_N_READBUF"} = int shift; } |
||
1597 | return $self->{READBUF}; |
||
1598 | } |
||
1599 | |||
1600 | # single value for save/start |
||
1601 | sub is_write_buf { |
||
1602 | my $self = shift; |
||
1603 | if (@_) { $self->{"_N_WRITEBUF"} = int shift; } |
||
1604 | return $self->{WRITEBUF}; |
||
1605 | } |
||
1606 | |||
1607 | sub is_buffers { |
||
1608 | my $self = shift; |
||
1609 | |||
1610 | return unless (@_ == 2); |
||
1611 | my $rbuf = shift; |
||
1612 | my $wbuf = shift; |
||
1613 | SetupComm($self->{"_HANDLE"}, $rbuf, $wbuf) or return; |
||
1614 | $self->{"_N_READBUF"} = 0; |
||
1615 | $self->{"_N_WRITEBUF"} = 0; |
||
1616 | $self->{READBUF} = $rbuf; |
||
1617 | $self->{WRITEBUF} = $wbuf; |
||
1618 | 1; |
||
1619 | } |
||
1620 | |||
1621 | sub read_bg { |
||
1622 | return unless (@_ == 2); |
||
1623 | my $self = shift; |
||
1624 | my $wanted = shift; |
||
1625 | return unless ($wanted > 0); |
||
1626 | if ($self->{"_R_BUSY"}) { |
||
1627 | nocarp or carp "Second Read attempted before First is done"; |
||
1628 | return; |
||
1629 | } |
||
1630 | my $got_p = " "x4; |
||
1631 | my $ok; |
||
1632 | my $got = 0; |
||
1633 | if ($wanted > $RBUF_Size) { |
||
1634 | $wanted = $RBUF_Size; |
||
1635 | warn "read buffer limited to $RBUF_Size bytes at the moment"; |
||
1636 | } |
||
1637 | $self->{"_R_BUSY"} = 1; |
||
1638 | |||
1639 | $ok=ReadFile( $self->{"_HANDLE"}, |
||
1640 | $self->{"_RBUF"}, |
||
1641 | $wanted, |
||
1642 | $got_p, |
||
1643 | $self->{"_R_OVERLAP"}); |
||
1644 | |||
1645 | if ($ok) { |
||
1646 | $got = unpack("L", $got_p); |
||
1647 | $self->{"_R_BUSY"} = 0; |
||
1648 | } |
||
1649 | return $got; |
||
1650 | } |
||
1651 | |||
1652 | sub write_bg { |
||
1653 | return unless (@_ == 2); |
||
1654 | my $self = shift; |
||
1655 | my $wbuf = shift; |
||
1656 | if ($self->{"_W_BUSY"}) { |
||
1657 | nocarp or carp "Second Write attempted before First is done"; |
||
1658 | return; |
||
1659 | } |
||
1660 | my $ok; |
||
1661 | my $got_p = " "x4; |
||
1662 | return 0 if ($wbuf eq ""); |
||
1663 | my $lbuf = length ($wbuf); |
||
1664 | my $written = 0; |
||
1665 | $self->{"_W_BUSY"} = 1; |
||
1666 | |||
1667 | $ok=WriteFile( $self->{"_HANDLE"}, |
||
1668 | $wbuf, |
||
1669 | $lbuf, |
||
1670 | $got_p, |
||
1671 | $self->{"_W_OVERLAP"}); |
||
1672 | |||
1673 | if ($ok) { |
||
1674 | $written = unpack("L", $got_p); |
||
1675 | $self->{"_W_BUSY"} = 0; |
||
1676 | } |
||
1677 | if ($Babble) { |
||
1678 | print "error=$ok\n"; |
||
1679 | print "wbuf=$wbuf\n"; |
||
1680 | print "lbuf=$lbuf\n"; |
||
1681 | print "write_bg=$written\n"; |
||
1682 | } |
||
1683 | return $written; |
||
1684 | } |
||
1685 | |||
1686 | sub read_done { |
||
1687 | return unless (@_ == 2); |
||
1688 | my $self = shift; |
||
1689 | my $wait = yes_true ( shift ); |
||
1690 | my $ov; |
||
1691 | my $got_p = " "x4; |
||
1692 | my $wanted = 0; |
||
1693 | $self->{"_R_BUSY"} = 1; |
||
1694 | |||
1695 | $ov=GetOverlappedResult( $self->{"_HANDLE"}, |
||
1696 | $self->{"_R_OVERLAP"}, |
||
1697 | $got_p, |
||
1698 | $wait); |
||
1699 | if ($ov) { |
||
1700 | $wanted = unpack("L", $got_p); |
||
1701 | $self->{"_R_BUSY"} = 0; |
||
1702 | print "read_done=$wanted\n" if ($Babble); |
||
1703 | return (1, $wanted, substr($self->{"_RBUF"}, 0, $wanted)); |
||
1704 | } |
||
1705 | return (0, 0, ""); |
||
1706 | } |
||
1707 | |||
1708 | sub write_done { |
||
1709 | return unless (@_ == 2); |
||
1710 | my $self = shift; |
||
1711 | my $wait = yes_true ( shift ); |
||
1712 | my $ov; |
||
1713 | my $got_p = " "x4; |
||
1714 | my $written = 0; |
||
1715 | $self->{"_W_BUSY"} = 1; |
||
1716 | |||
1717 | $ov=GetOverlappedResult( $self->{"_HANDLE"}, |
||
1718 | $self->{"_W_OVERLAP"}, |
||
1719 | $got_p, |
||
1720 | $wait); |
||
1721 | if ($ov) { |
||
1722 | $written = unpack("L", $got_p); |
||
1723 | $self->{"_W_BUSY"} = 0; |
||
1724 | print "write_done=$written\n" if ($Babble); |
||
1725 | return (1, $written); |
||
1726 | } |
||
1727 | return (0, $written); |
||
1728 | } |
||
1729 | |||
1730 | sub purge_all { |
||
1731 | my $self = shift; |
||
1732 | return if (@_); |
||
1733 | |||
1734 | # PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR |
||
1735 | unless ( PurgeComm($self->{"_HANDLE"}, 0x0000000f) ) { |
||
1736 | carp "Error in PurgeComm"; |
||
1737 | OS_Error; |
||
1738 | return; |
||
1739 | } |
||
1740 | $self->{"_R_BUSY"} = 0; |
||
1741 | $self->{"_W_BUSY"} = 0; |
||
1742 | return 1; |
||
1743 | } |
||
1744 | |||
1745 | sub purge_rx { |
||
1746 | my $self = shift; |
||
1747 | return if (@_); |
||
1748 | |||
1749 | # PURGE_RXABORT | PURGE_RXCLEAR |
||
1750 | unless ( PurgeComm($self->{"_HANDLE"}, 0x0000000a) ) { |
||
1751 | OS_Error; |
||
1752 | carp "Error in PurgeComm"; |
||
1753 | return; |
||
1754 | } |
||
1755 | $self->{"_R_BUSY"} = 0; |
||
1756 | return 1; |
||
1757 | } |
||
1758 | |||
1759 | sub purge_tx { |
||
1760 | my $self = shift; |
||
1761 | return if (@_); |
||
1762 | |||
1763 | # PURGE_TXABORT | PURGE_TXCLEAR |
||
1764 | unless ( PurgeComm($self->{"_HANDLE"}, 0x00000005) ) { |
||
1765 | OS_Error; |
||
1766 | carp "Error in PurgeComm"; |
||
1767 | return; |
||
1768 | } |
||
1769 | $self->{"_W_BUSY"} = 0; |
||
1770 | return 1; |
||
1771 | } |
||
1772 | |||
1773 | sub are_buffers { |
||
1774 | my $self = shift; |
||
1775 | return if (@_); |
||
1776 | return ($self->{READBUF}, $self->{WRITEBUF}); |
||
1777 | } |
||
1778 | |||
1779 | sub buffer_max { |
||
1780 | my $self = shift; |
||
1781 | return if (@_); |
||
1782 | return ($self->{"_RBUFMAX"}, $self->{"_TBUFMAX"}); |
||
1783 | } |
||
1784 | |||
1785 | sub suspend_tx { |
||
1786 | my $self = shift; |
||
1787 | return if (@_); |
||
1788 | return SetCommBreak($self->{"_HANDLE"}); |
||
1789 | } |
||
1790 | |||
1791 | sub resume_tx { |
||
1792 | my $self = shift; |
||
1793 | return if (@_); |
||
1794 | return ClearCommBreak($self->{"_HANDLE"}); |
||
1795 | } |
||
1796 | |||
1797 | sub xmit_imm_char { |
||
1798 | my $self = shift; |
||
1799 | return unless (@_ == 1); |
||
1800 | my $v = int shift; |
||
1801 | unless ( TransmitCommChar($self->{"_HANDLE"}, $v) ) { |
||
1802 | carp "Can't transmit char: $v"; |
||
1803 | return; |
||
1804 | } |
||
1805 | 1; |
||
1806 | } |
||
1807 | |||
1808 | sub is_xon_char { |
||
1809 | my $self = shift; |
||
1810 | if ((@_ == 1) and $self->{"_C_XON_CHAR"}) { |
||
1811 | $self->{"_N_XONCHAR"} = 1 + shift; |
||
1812 | update_DCB ($self); |
||
1813 | } |
||
1814 | else { |
||
1815 | return unless fetch_DCB ($self); |
||
1816 | } |
||
1817 | return $self->{XONCHAR}; |
||
1818 | } |
||
1819 | |||
1820 | sub is_xoff_char { |
||
1821 | my $self = shift; |
||
1822 | if ((@_ == 1) and $self->{"_C_XON_CHAR"}) { |
||
1823 | $self->{"_N_XOFFCHAR"} = 1 + shift; |
||
1824 | update_DCB ($self); |
||
1825 | } |
||
1826 | else { |
||
1827 | return unless fetch_DCB ($self); |
||
1828 | } |
||
1829 | return $self->{XOFFCHAR}; |
||
1830 | } |
||
1831 | |||
1832 | sub is_eof_char { |
||
1833 | my $self = shift; |
||
1834 | if ((@_ == 1) and $self->{"_C_SPECHAR"}) { |
||
1835 | $self->{"_N_EOFCHAR"} = 1 + shift; |
||
1836 | update_DCB ($self); |
||
1837 | } |
||
1838 | else { |
||
1839 | return unless fetch_DCB ($self); |
||
1840 | } |
||
1841 | return $self->{EOFCHAR}; |
||
1842 | } |
||
1843 | |||
1844 | sub is_event_char { |
||
1845 | my $self = shift; |
||
1846 | if ((@_ == 1) and $self->{"_C_SPECHAR"}) { |
||
1847 | $self->{"_N_EVTCHAR"} = 1 + shift; |
||
1848 | update_DCB ($self); |
||
1849 | } |
||
1850 | else { |
||
1851 | return unless fetch_DCB ($self); |
||
1852 | } |
||
1853 | return $self->{EVTCHAR}; |
||
1854 | } |
||
1855 | |||
1856 | sub is_error_char { |
||
1857 | my $self = shift; |
||
1858 | if ((@_ == 1) and $self->{"_C_SPECHAR"}) { |
||
1859 | $self->{"_N_ERRCHAR"} = 1 + shift; |
||
1860 | update_DCB ($self); |
||
1861 | } |
||
1862 | else { |
||
1863 | return unless fetch_DCB ($self); |
||
1864 | } |
||
1865 | return $self->{ERRCHAR}; |
||
1866 | } |
||
1867 | |||
1868 | sub is_xon_limit { |
||
1869 | my $self = shift; |
||
1870 | if (@_) { |
||
1871 | return unless ($self->{"_C_XONXOFF"}); |
||
1872 | my $v = int shift; |
||
1873 | return if (($v < 0) or ($v > SHORTsize)); |
||
1874 | $self->{"_N_XONLIM"} = ++$v; |
||
1875 | update_DCB ($self); |
||
1876 | } |
||
1877 | else { |
||
1878 | return unless fetch_DCB ($self); |
||
1879 | } |
||
1880 | return $self->{XONLIM}; |
||
1881 | } |
||
1882 | |||
1883 | sub is_xoff_limit { |
||
1884 | my $self = shift; |
||
1885 | if (@_) { |
||
1886 | return unless ($self->{"_C_XONXOFF"}); |
||
1887 | my $v = int shift; |
||
1888 | return if (($v < 0) or ($v > SHORTsize)); |
||
1889 | $self->{"_N_XOFFLIM"} = ++$v; |
||
1890 | update_DCB ($self); |
||
1891 | } |
||
1892 | else { |
||
1893 | return unless fetch_DCB ($self); |
||
1894 | } |
||
1895 | return $self->{XOFFLIM}; |
||
1896 | } |
||
1897 | |||
1898 | sub is_read_interval { |
||
1899 | my $self = shift; |
||
1900 | if (@_) { |
||
1901 | return unless ($self->{"_C_INT_TIME"}); |
||
1902 | my $v = int shift; |
||
1903 | return if (($v < 0) or ($v > LONGsize)); |
||
1904 | if ($v == LONGsize) { |
||
1905 | $self->{"_N_RINT"} = $v; # Win32 uses as flag |
||
1906 | } |
||
1907 | else { |
||
1908 | $self->{"_N_RINT"} = ++$v; |
||
1909 | } |
||
1910 | return unless update_timeouts ($self); |
||
1911 | } |
||
1912 | return $self->{RINT}; |
||
1913 | } |
||
1914 | |||
1915 | sub is_read_char_time { |
||
1916 | my $self = shift; |
||
1917 | if (@_) { |
||
1918 | return unless ($self->{"_C_TOT_TIME"}); |
||
1919 | my $v = int shift; |
||
1920 | return if (($v < 0) or ($v >= LONGsize)); |
||
1921 | $self->{"_N_RTOT"} = ++$v; |
||
1922 | return unless update_timeouts ($self); |
||
1923 | } |
||
1924 | return $self->{RTOT}; |
||
1925 | } |
||
1926 | |||
1927 | sub is_read_const_time { |
||
1928 | my $self = shift; |
||
1929 | if (@_) { |
||
1930 | return unless ($self->{"_C_TOT_TIME"}); |
||
1931 | my $v = int shift; |
||
1932 | return if (($v < 0) or ($v >= LONGsize)); |
||
1933 | $self->{"_N_RCONST"} = ++$v; |
||
1934 | return unless update_timeouts ($self); |
||
1935 | } |
||
1936 | return $self->{RCONST}; |
||
1937 | } |
||
1938 | |||
1939 | sub is_write_const_time { |
||
1940 | my $self = shift; |
||
1941 | if (@_) { |
||
1942 | return unless ($self->{"_C_TOT_TIME"}); |
||
1943 | my $v = int shift; |
||
1944 | return if (($v < 0) or ($v >= LONGsize)); |
||
1945 | $self->{"_N_WCONST"} = ++$v; |
||
1946 | return unless update_timeouts ($self); |
||
1947 | } |
||
1948 | return $self->{WCONST}; |
||
1949 | } |
||
1950 | |||
1951 | sub is_write_char_time { |
||
1952 | my $self = shift; |
||
1953 | if (@_) { |
||
1954 | return unless ($self->{"_C_TOT_TIME"}); |
||
1955 | my $v = int shift; |
||
1956 | return if (($v < 0) or ($v >= LONGsize)); |
||
1957 | $self->{"_N_WTOT"} = ++$v; |
||
1958 | return unless update_timeouts ($self); |
||
1959 | } |
||
1960 | return $self->{WTOT}; |
||
1961 | } |
||
1962 | |||
1963 | sub update_timeouts { |
||
1964 | return unless (@_ == 1); |
||
1965 | my $self = shift; |
||
1966 | unless ( GetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) { |
||
1967 | carp "Error in GetCommTimeouts"; |
||
1968 | return; |
||
1969 | } |
||
1970 | |||
1971 | ($self->{RINT}, |
||
1972 | $self->{RTOT}, |
||
1973 | $self->{RCONST}, |
||
1974 | $self->{WTOT}, |
||
1975 | $self->{WCONST})= unpack($TIMEOUTformat, $self->{"_TIMEOUT"}); |
||
1976 | |||
1977 | if ($self->{"_N_RINT"}) { |
||
1978 | if ($self->{"_N_RINT"} == LONGsize) { |
||
1979 | $self->{RINT} = $self->{"_N_RINT"}; # Win32 uses as flag |
||
1980 | } |
||
1981 | else { |
||
1982 | $self->{RINT} = $self->{"_N_RINT"} -1; |
||
1983 | } |
||
1984 | $self->{"_N_RINT"} = 0; |
||
1985 | } |
||
1986 | |||
1987 | if ($self->{"_N_RTOT"}) { |
||
1988 | $self->{RTOT} = $self->{"_N_RTOT"} -1; |
||
1989 | $self->{"_N_RTOT"} = 0; |
||
1990 | } |
||
1991 | |||
1992 | if ($self->{"_N_RCONST"}) { |
||
1993 | $self->{RCONST} = $self->{"_N_RCONST"} -1; |
||
1994 | $self->{"_N_RCONST"} = 0; |
||
1995 | } |
||
1996 | |||
1997 | if ($self->{"_N_WTOT"}) { |
||
1998 | $self->{WTOT} = $self->{"_N_WTOT"} -1; |
||
1999 | $self->{"_N_WTOT"} = 0; |
||
2000 | } |
||
2001 | |||
2002 | if ($self->{"_N_WCONST"}) { |
||
2003 | $self->{WCONST} = $self->{"_N_WCONST"} -1; |
||
2004 | $self->{"_N_WCONST"} = 0; |
||
2005 | } |
||
2006 | |||
2007 | $self->{"_TIMEOUT"} = pack($TIMEOUTformat, |
||
2008 | $self->{RINT}, |
||
2009 | $self->{RTOT}, |
||
2010 | $self->{RCONST}, |
||
2011 | $self->{WTOT}, |
||
2012 | $self->{WCONST}); |
||
2013 | |||
2014 | if ( SetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) { |
||
2015 | return 1; |
||
2016 | } |
||
2017 | else { |
||
2018 | carp "Error in SetCommTimeouts"; |
||
2019 | return; |
||
2020 | } |
||
2021 | } |
||
2022 | |||
2023 | |||
2024 | # true/false parameters |
||
2025 | |||
2026 | sub is_binary { |
||
2027 | my $self = shift; |
||
2028 | if (@_) { |
||
2029 | $self->{"_N_BINARY"} = 1 + yes_true ( shift ); |
||
2030 | update_DCB ($self); |
||
2031 | } |
||
2032 | else { |
||
2033 | return unless fetch_DCB ($self); |
||
2034 | } |
||
2035 | ### printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
||
2036 | return ($self->{"_BitMask"} & FM_fBinary); |
||
2037 | } |
||
2038 | |||
2039 | sub is_parity_enable { |
||
2040 | my $self = shift; |
||
2041 | if (@_) { |
||
2042 | $self->{"_N_PARITY_EN"} = 1 + yes_true ( shift ); |
||
2043 | update_DCB ($self); |
||
2044 | } |
||
2045 | return unless fetch_DCB ($self); |
||
2046 | ## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ## DEBUG ## |
||
2047 | return ($self->{"_BitMask"} & FM_fParity); |
||
2048 | } |
||
2049 | |||
2050 | sub ignore_null { |
||
2051 | my $self = shift; |
||
2052 | if (@_) { |
||
2053 | if ($self->{"_N_AUX_OFF"}) { |
||
2054 | $self->{"_N_AUX_OFF"} &= ~FM_fNull; |
||
2055 | } |
||
2056 | else { |
||
2057 | $self->{"_N_AUX_OFF"} = ~FM_fNull; |
||
2058 | } |
||
2059 | if ( yes_true ( shift ) ) { |
||
2060 | $self->{"_N_AUX_ON"} |= FM_fNull; |
||
2061 | } |
||
2062 | update_DCB ($self); |
||
2063 | } |
||
2064 | else { |
||
2065 | return unless fetch_DCB ($self); |
||
2066 | } |
||
2067 | ## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
||
2068 | return ($self->{"_BitMask"} & FM_fNull); |
||
2069 | } |
||
2070 | |||
2071 | sub ignore_no_dsr { |
||
2072 | my $self = shift; |
||
2073 | if (@_) { |
||
2074 | if ($self->{"_N_AUX_OFF"}) { |
||
2075 | $self->{"_N_AUX_OFF"} &= ~FM_fDsrSensitivity; |
||
2076 | } |
||
2077 | else { |
||
2078 | $self->{"_N_AUX_OFF"} = ~FM_fDsrSensitivity; |
||
2079 | } |
||
2080 | if ( yes_true ( shift ) ) { |
||
2081 | $self->{"_N_AUX_ON"} |= FM_fDsrSensitivity; |
||
2082 | } |
||
2083 | update_DCB ($self); |
||
2084 | } |
||
2085 | else { |
||
2086 | return unless fetch_DCB ($self); |
||
2087 | } |
||
2088 | ## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
||
2089 | return ($self->{"_BitMask"} & FM_fDsrSensitivity); |
||
2090 | } |
||
2091 | |||
2092 | sub subst_pe_char { |
||
2093 | my $self = shift; |
||
2094 | if (@_) { |
||
2095 | if ($self->{"_N_AUX_OFF"}) { |
||
2096 | $self->{"_N_AUX_OFF"} &= ~FM_fErrorChar; |
||
2097 | } |
||
2098 | else { |
||
2099 | $self->{"_N_AUX_OFF"} = ~FM_fErrorChar; |
||
2100 | } |
||
2101 | if ( yes_true ( shift ) ) { |
||
2102 | $self->{"_N_AUX_ON"} |= FM_fErrorChar; |
||
2103 | } |
||
2104 | update_DCB ($self); |
||
2105 | } |
||
2106 | else { |
||
2107 | return unless fetch_DCB ($self); |
||
2108 | } |
||
2109 | ## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
||
2110 | return ($self->{"_BitMask"} & FM_fErrorChar); |
||
2111 | } |
||
2112 | |||
2113 | sub abort_on_error { |
||
2114 | my $self = shift; |
||
2115 | if (@_) { |
||
2116 | if ($self->{"_N_AUX_OFF"}) { |
||
2117 | $self->{"_N_AUX_OFF"} &= ~FM_fAbortOnError; |
||
2118 | } |
||
2119 | else { |
||
2120 | $self->{"_N_AUX_OFF"} = ~FM_fAbortOnError; |
||
2121 | } |
||
2122 | if ( yes_true ( shift ) ) { |
||
2123 | $self->{"_N_AUX_ON"} |= FM_fAbortOnError; |
||
2124 | } |
||
2125 | update_DCB ($self); |
||
2126 | } |
||
2127 | else { |
||
2128 | return unless fetch_DCB ($self); |
||
2129 | } |
||
2130 | ## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
||
2131 | return ($self->{"_BitMask"} & FM_fAbortOnError); |
||
2132 | } |
||
2133 | |||
2134 | sub output_dsr { |
||
2135 | my $self = shift; |
||
2136 | if (@_) { |
||
2137 | if ($self->{"_N_AUX_OFF"}) { |
||
2138 | $self->{"_N_AUX_OFF"} &= ~FM_fOutxDsrFlow; |
||
2139 | } |
||
2140 | else { |
||
2141 | $self->{"_N_AUX_OFF"} = ~FM_fOutxDsrFlow; |
||
2142 | } |
||
2143 | if ( yes_true ( shift ) ) { |
||
2144 | $self->{"_N_AUX_ON"} |= FM_fOutxDsrFlow; |
||
2145 | } |
||
2146 | update_DCB ($self); |
||
2147 | } |
||
2148 | else { |
||
2149 | return unless fetch_DCB ($self); |
||
2150 | } |
||
2151 | ## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
||
2152 | return ($self->{"_BitMask"} & FM_fOutxDsrFlow); |
||
2153 | } |
||
2154 | |||
2155 | sub output_cts { |
||
2156 | my $self = shift; |
||
2157 | if (@_) { |
||
2158 | if ($self->{"_N_AUX_OFF"}) { |
||
2159 | $self->{"_N_AUX_OFF"} &= ~FM_fOutxCtsFlow; |
||
2160 | } |
||
2161 | else { |
||
2162 | $self->{"_N_AUX_OFF"} = ~FM_fOutxCtsFlow; |
||
2163 | } |
||
2164 | if ( yes_true ( shift ) ) { |
||
2165 | $self->{"_N_AUX_ON"} |= FM_fOutxCtsFlow; |
||
2166 | } |
||
2167 | update_DCB ($self); |
||
2168 | } |
||
2169 | else { |
||
2170 | return unless fetch_DCB ($self); |
||
2171 | } |
||
2172 | ## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
||
2173 | return ($self->{"_BitMask"} & FM_fOutxCtsFlow); |
||
2174 | } |
||
2175 | |||
2176 | sub input_xoff { |
||
2177 | my $self = shift; |
||
2178 | if (@_) { |
||
2179 | if ($self->{"_N_AUX_OFF"}) { |
||
2180 | $self->{"_N_AUX_OFF"} &= ~FM_fInX; |
||
2181 | } |
||
2182 | else { |
||
2183 | $self->{"_N_AUX_OFF"} = ~FM_fInX; |
||
2184 | } |
||
2185 | if ( yes_true ( shift ) ) { |
||
2186 | $self->{"_N_AUX_ON"} |= FM_fInX; |
||
2187 | } |
||
2188 | update_DCB ($self); |
||
2189 | } |
||
2190 | else { |
||
2191 | return unless fetch_DCB ($self); |
||
2192 | } |
||
2193 | ## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
||
2194 | return ($self->{"_BitMask"} & FM_fInX); |
||
2195 | } |
||
2196 | |||
2197 | sub output_xoff { |
||
2198 | my $self = shift; |
||
2199 | if (@_) { |
||
2200 | if ($self->{"_N_AUX_OFF"}) { |
||
2201 | $self->{"_N_AUX_OFF"} &= ~FM_fOutX; |
||
2202 | } |
||
2203 | else { |
||
2204 | $self->{"_N_AUX_OFF"} = ~FM_fOutX; |
||
2205 | } |
||
2206 | if ( yes_true ( shift ) ) { |
||
2207 | $self->{"_N_AUX_ON"} |= FM_fOutX; |
||
2208 | } |
||
2209 | update_DCB ($self); |
||
2210 | } |
||
2211 | else { |
||
2212 | return unless fetch_DCB ($self); |
||
2213 | } |
||
2214 | ## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
||
2215 | return ($self->{"_BitMask"} & FM_fOutX); |
||
2216 | } |
||
2217 | |||
2218 | sub tx_on_xoff { |
||
2219 | my $self = shift; |
||
2220 | if (@_) { |
||
2221 | if ($self->{"_N_AUX_OFF"}) { |
||
2222 | $self->{"_N_AUX_OFF"} &= ~FM_fTXContinueOnXoff; |
||
2223 | } |
||
2224 | else { |
||
2225 | $self->{"_N_AUX_OFF"} = ~FM_fTXContinueOnXoff; |
||
2226 | } |
||
2227 | if ( yes_true ( shift ) ) { |
||
2228 | $self->{"_N_AUX_ON"} |= FM_fTXContinueOnXoff; |
||
2229 | } |
||
2230 | update_DCB ($self); |
||
2231 | } |
||
2232 | else { |
||
2233 | return unless fetch_DCB ($self); |
||
2234 | } |
||
2235 | ## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
||
2236 | return ($self->{"_BitMask"} & FM_fTXContinueOnXoff); |
||
2237 | } |
||
2238 | |||
2239 | sub dtr_active { |
||
2240 | return unless (@_ == 2); |
||
2241 | my $self = shift; |
||
2242 | my $onoff = yes_true ( shift ) ? SETDTR : CLRDTR ; |
||
2243 | return EscapeCommFunction($self->{"_HANDLE"}, $onoff); |
||
2244 | } |
||
2245 | |||
2246 | sub rts_active { |
||
2247 | return unless (@_ == 2); |
||
2248 | my $self = shift; |
||
2249 | my $onoff = yes_true ( shift ) ? SETRTS : CLRRTS ; |
||
2250 | return EscapeCommFunction($self->{"_HANDLE"}, $onoff); |
||
2251 | } |
||
2252 | |||
2253 | # pulse parameters |
||
2254 | |||
2255 | sub pulse_dtr_off { |
||
2256 | return unless (@_ == 2); |
||
2257 | if ( ($] < 5.005) and ($] >= 5.004) ) { |
||
2258 | nocarp or carp "\npulse_dtr_off not supported on version $]\n"; |
||
2259 | return; |
||
2260 | } |
||
2261 | my $self = shift; |
||
2262 | my $delay = shift; |
||
2263 | $self->dtr_active(0) or carp "Did not pulse DTR off"; |
||
2264 | Win32::Sleep($delay); |
||
2265 | $self->dtr_active(1) or carp "Did not restore DTR on"; |
||
2266 | Win32::Sleep($delay); |
||
2267 | } |
||
2268 | |||
2269 | sub pulse_rts_off { |
||
2270 | return unless (@_ == 2); |
||
2271 | if ( ($] < 5.005) and ($] >= 5.004) ) { |
||
2272 | nocarp or carp "\npulse_rts_off not supported on version $]\n"; |
||
2273 | return; |
||
2274 | } |
||
2275 | my $self = shift; |
||
2276 | my $delay = shift; |
||
2277 | $self->rts_active(0) or carp "Did not pulse RTS off"; |
||
2278 | Win32::Sleep($delay); |
||
2279 | $self->rts_active(1) or carp "Did not restore RTS on"; |
||
2280 | Win32::Sleep($delay); |
||
2281 | } |
||
2282 | |||
2283 | sub pulse_break_on { |
||
2284 | return unless (@_ == 2); |
||
2285 | if ( ($] < 5.005) and ($] >= 5.004) ) { |
||
2286 | nocarp or carp "\npulse_break_on not supported on version $]\n"; |
||
2287 | return; |
||
2288 | } |
||
2289 | my $self = shift; |
||
2290 | my $delay = shift; |
||
2291 | $self->break_active(1) or carp "Did not pulse BREAK on"; |
||
2292 | Win32::Sleep($delay); |
||
2293 | $self->break_active(0) or carp "Did not restore BREAK off"; |
||
2294 | Win32::Sleep($delay); |
||
2295 | } |
||
2296 | |||
2297 | sub pulse_dtr_on { |
||
2298 | return unless (@_ == 2); |
||
2299 | if ( ($] < 5.005) and ($] >= 5.004) ) { |
||
2300 | nocarp or carp "\npulse_dtr_on not supported on version $]\n"; |
||
2301 | return; |
||
2302 | } |
||
2303 | my $self = shift; |
||
2304 | my $delay = shift; |
||
2305 | $self->dtr_active(1) or carp "Did not pulse DTR on"; |
||
2306 | Win32::Sleep($delay); |
||
2307 | $self->dtr_active(0) or carp "Did not restore DTR off"; |
||
2308 | Win32::Sleep($delay); |
||
2309 | } |
||
2310 | |||
2311 | sub pulse_rts_on { |
||
2312 | return unless (@_ == 2); |
||
2313 | if ( ($] < 5.005) and ($] >= 5.004) ) { |
||
2314 | nocarp or carp "\npulse_rts_on not supported on version $]\n"; |
||
2315 | return; |
||
2316 | } |
||
2317 | my $self = shift; |
||
2318 | my $delay = shift; |
||
2319 | $self->rts_active(1) or carp "Did not pulse RTS on"; |
||
2320 | Win32::Sleep($delay); |
||
2321 | $self->rts_active(0) or carp "Did not restore RTS off"; |
||
2322 | Win32::Sleep($delay); |
||
2323 | } |
||
2324 | |||
2325 | sub break_active { |
||
2326 | return unless (@_ == 2); |
||
2327 | my $self = shift; |
||
2328 | my $onoff = yes_true ( shift ) ? SETBREAK : CLRBREAK ; |
||
2329 | return EscapeCommFunction($self->{"_HANDLE"}, $onoff); |
||
2330 | } |
||
2331 | |||
2332 | sub xon_active { |
||
2333 | return unless (@_ == 1); |
||
2334 | my $self = shift; |
||
2335 | return EscapeCommFunction($self->{"_HANDLE"}, SETXON); |
||
2336 | } |
||
2337 | |||
2338 | sub xoff_active { |
||
2339 | return unless (@_ == 1); |
||
2340 | my $self = shift; |
||
2341 | return EscapeCommFunction($self->{"_HANDLE"}, SETXOFF); |
||
2342 | } |
||
2343 | |||
2344 | sub is_modemlines { |
||
2345 | return unless (@_ == 1); |
||
2346 | my $self = shift; |
||
2347 | my $mstat = " " x4; |
||
2348 | unless ( GetCommModemStatus($self->{"_HANDLE"}, $mstat) ) { |
||
2349 | carp "Error in GetCommModemStatus"; |
||
2350 | return; |
||
2351 | } |
||
2352 | my $result = unpack ("L", $mstat); |
||
2353 | return $result; |
||
2354 | } |
||
2355 | |||
2356 | sub debug_comm { |
||
2357 | my $self = shift; |
||
2358 | if (ref($self)) { |
||
2359 | if (@_) { $self->{"_DEBUG_C"} = yes_true ( shift ); } |
||
2360 | else { |
||
2361 | nocarp or carp "Debug level: $self->{NAME} = $self->{\"_DEBUG_C\"}"; |
||
2362 | return $self->{"_DEBUG_C"}; |
||
2363 | } |
||
2364 | } else { |
||
2365 | $Babble = yes_true ($self); |
||
2366 | nocarp or carp "CommPort Debug Class = $Babble"; |
||
2367 | return $Babble; |
||
2368 | } |
||
2369 | } |
||
2370 | |||
2371 | sub close { |
||
2372 | my $self = shift; |
||
2373 | my $ok; |
||
2374 | my $success = 1; |
||
2375 | |||
2376 | return unless (defined $self->{NAME}); |
||
2377 | |||
2378 | if ($Babble) { |
||
2379 | carp "Closing $self " . $self->{NAME}; |
||
2380 | } |
||
2381 | if ($self->{"_HANDLE"}) { |
||
2382 | purge_all ($self); |
||
2383 | update_timeouts ($self); # if any running ?? |
||
2384 | $ok=CloseHandle($self->{"_HANDLE"}); |
||
2385 | if (! $ok) { |
||
2386 | print "Error Closing handle $self->{\"_HANDLE\"} for $self->{NAME}\n"; |
||
2387 | OS_Error; |
||
2388 | $success = 0; |
||
2389 | } |
||
2390 | elsif ($Babble) { |
||
2391 | print "Closing Device handle $self->{\"_HANDLE\"} for $self->{NAME}\n"; |
||
2392 | } |
||
2393 | $self->{"_HANDLE"} = undef; |
||
2394 | } |
||
2395 | if ($self->{"_R_EVENT"}) { |
||
2396 | $ok=CloseHandle($self->{"_R_EVENT"}); |
||
2397 | if (! $ok) { |
||
2398 | print "Error closing Read Event handle $self->{\"_R_EVENT\"} for $self->{NAME}\n"; |
||
2399 | OS_Error; |
||
2400 | $success = 0; |
||
2401 | } |
||
2402 | $self->{"_R_EVENT"} = undef; |
||
2403 | } |
||
2404 | if ($self->{"_W_EVENT"}) { |
||
2405 | $ok=CloseHandle($self->{"_W_EVENT"}); |
||
2406 | if (! $ok) { |
||
2407 | print "Error closing Write Event handle $self->{\"_W_EVENT\"} for $self->{NAME}\n"; |
||
2408 | OS_Error; |
||
2409 | $success = 0; |
||
2410 | } |
||
2411 | $self->{"_W_EVENT"} = undef; |
||
2412 | } |
||
2413 | $self->{NAME} = undef; |
||
2414 | if ($Babble) { |
||
2415 | printf "CommPort close result:%d\n", $success; |
||
2416 | } |
||
2417 | return $success; |
||
2418 | } |
||
2419 | |||
2420 | sub DESTROY { |
||
2421 | my $self = shift; |
||
2422 | return unless (defined $self->{NAME}); |
||
2423 | |||
2424 | if ($Babble or $self->{"_DEBUG_C"}) { |
||
2425 | print "Destroying $self->{NAME}\n" if (defined $self->{NAME}); |
||
2426 | } |
||
2427 | $self->close; |
||
2428 | } |
||
2429 | |||
2430 | 1; # so the require or use succeeds |
||
2431 | |||
2432 | # Autoload methods go after =cut, and are processed by the autosplit program. |
||
2433 | |||
2434 | __END__ |
||
2435 | |||
2436 | =pod |
||
2437 | |||
2438 | =head1 NAME |
||
2439 | |||
2440 | Win32API::CommPort - Raw Win32 system API calls for serial communications. |
||
2441 | |||
2442 | =head1 SYNOPSIS |
||
2443 | |||
2444 | use Win32; ## not required under all circumstances |
||
2445 | require 5.003; |
||
2446 | use Win32API::CommPort qw( :PARAM :STAT 0.19 ); |
||
2447 | |||
2448 | ## when available ## use Win32API::File 0.07 qw( :ALL ); |
||
2449 | |||
2450 | =head2 Constructors |
||
2451 | |||
2452 | $PortObj = new Win32API::CommPort ($PortName, $quiet) |
||
2453 | || die "Can't open $PortName: $^E\n"; # $quiet is optional |
||
2454 | |||
2455 | @required = qw( BAUD DATA STOP ); |
||
2456 | $faults = $PortObj->initialize(@required); |
||
2457 | if ($faults) { die "Required parameters not set before initialize\n"; } |
||
2458 | |||
2459 | =head2 Configuration Utility Methods |
||
2460 | |||
2461 | set_no_messages(1); # test suite use |
||
2462 | |||
2463 | # exported by :PARAM |
||
2464 | nocarp || carp "Something fishy"; |
||
2465 | $a = SHORTsize; # 0xffff |
||
2466 | $a = LONGsize; # 0xffffffff |
||
2467 | $answer = yes_true("choice"); # 1 or 0 |
||
2468 | OS_Error unless ($API_Call_OK); # prints error |
||
2469 | |||
2470 | $PortObj->init_done || die "Not done"; |
||
2471 | |||
2472 | $PortObj->fetch_DCB || die "Not done"; |
||
2473 | $PortObj->update_DCB || die "Not done"; |
||
2474 | |||
2475 | $milliseconds = $PortObj->get_tick_count; |
||
2476 | |||
2477 | =head2 Capability Methods (read only) |
||
2478 | |||
2479 | # true/false capabilities |
||
2480 | $a = $PortObj->can_baud; # else fixed |
||
2481 | $a = $PortObj->can_databits; |
||
2482 | $a = $PortObj->can_stopbits; |
||
2483 | $a = $PortObj->can_dtrdsr; |
||
2484 | $a = $PortObj->can_handshake; |
||
2485 | $a = $PortObj->can_parity_check; |
||
2486 | $a = $PortObj->can_parity_config; |
||
2487 | $a = $PortObj->can_parity_enable; |
||
2488 | $a = $PortObj->can_rlsd; # receive line signal detect (carrier) |
||
2489 | $a = $PortObj->can_rlsd_config; |
||
2490 | $a = $PortObj->can_16bitmode; |
||
2491 | $a = $PortObj->is_rs232; |
||
2492 | $a = $PortObj->is_modem; |
||
2493 | $a = $PortObj->can_rtscts; |
||
2494 | $a = $PortObj->can_xonxoff; |
||
2495 | $a = $PortObj->can_xon_char; |
||
2496 | $a = $PortObj->can_spec_char; |
||
2497 | $a = $PortObj->can_interval_timeout; |
||
2498 | $a = $PortObj->can_total_timeout; |
||
2499 | |||
2500 | # list output capabilities |
||
2501 | ($rmax, $wmax) = $PortObj->buffer_max; |
||
2502 | ($rbuf, $wbuf) = $PortObj->are_buffers; # current |
||
2503 | @choices = $PortObj->are_baudrate; # legal values |
||
2504 | @choices = $PortObj->are_handshake; |
||
2505 | @choices = $PortObj->are_parity; |
||
2506 | @choices = $PortObj->are_databits; |
||
2507 | @choices = $PortObj->are_stopbits; |
||
2508 | |||
2509 | =head2 Configuration Methods |
||
2510 | |||
2511 | # most methods can be called two ways: |
||
2512 | $PortObj->is_handshake("xoff"); # set parameter |
||
2513 | $flowcontrol = $PortObj->is_handshake; # current value (scalar) |
||
2514 | |||
2515 | # similar |
||
2516 | $PortObj->is_baudrate(9600); |
||
2517 | $PortObj->is_parity("odd"); |
||
2518 | $PortObj->is_databits(8); |
||
2519 | $PortObj->is_stopbits(1); |
||
2520 | $PortObj->debug_comm(0); |
||
2521 | $PortObj->is_xon_limit(100); # bytes left in buffer |
||
2522 | $PortObj->is_xoff_limit(100); # space left in buffer |
||
2523 | $PortObj->is_xon_char(0x11); |
||
2524 | $PortObj->is_xoff_char(0x13); |
||
2525 | $PortObj->is_eof_char(0x0); |
||
2526 | $PortObj->is_event_char(0x0); |
||
2527 | $PortObj->is_error_char(0); # for parity errors |
||
2528 | |||
2529 | $rbuf = $PortObj->is_read_buf; # read_only except internal use |
||
2530 | $wbuf = $PortObj->is_write_buf; |
||
2531 | $size = $PortObj->internal_buffer; |
||
2532 | |||
2533 | $PortObj->is_buffers(4096, 4096); # read, write |
||
2534 | # returns current in list context |
||
2535 | |||
2536 | $PortObj->is_read_interval(100); # max time between read char (millisec) |
||
2537 | $PortObj->is_read_char_time(5); # avg time between read char |
||
2538 | $PortObj->is_read_const_time(100); # total = (avg * bytes) + const |
||
2539 | $PortObj->is_write_char_time(5); |
||
2540 | $PortObj->is_write_const_time(100); |
||
2541 | |||
2542 | $PortObj->is_binary(T); # just say Yes (Win 3.x option) |
||
2543 | $PortObj->is_parity_enable(F); # faults during input |
||
2544 | |||
2545 | =head2 Operating Methods |
||
2546 | |||
2547 | ($BlockingFlags, $InBytes, $OutBytes, $LatchErrorFlags) = $PortObj->is_status |
||
2548 | || warn "could not get port status\n"; |
||
2549 | |||
2550 | $ClearedErrorFlags = $PortObj->reset_error; |
||
2551 | # The API resets errors when reading status, $LatchErrorFlags |
||
2552 | # is all $ErrorFlags since they were last explicitly cleared |
||
2553 | |||
2554 | if ($BlockingFlags) { warn "Port is blocked"; } |
||
2555 | if ($BlockingFlags & BM_fCtsHold) { warn "Waiting for CTS"; } |
||
2556 | if ($LatchErrorFlags & CE_FRAME) { warn "Framing Error"; } |
||
2557 | |||
2558 | Additional useful constants may be exported eventually. |
||
2559 | |||
2560 | $count_in = $PortObj->read_bg($InBytes); |
||
2561 | ($done, $count_in, $string_in) = $PortObj->read_done(1); |
||
2562 | # background read with wait until done |
||
2563 | |||
2564 | $count_out = $PortObj->write_bg($output_string); # background write |
||
2565 | ($done, $count_out) = $PortObj->write_done(0); |
||
2566 | |||
2567 | $PortObj->suspend_tx; # output from write buffer |
||
2568 | $PortObj->resume_tx; |
||
2569 | $PortObj->xmit_imm_char(0x03); # bypass buffer (and suspend) |
||
2570 | |||
2571 | $PortObj->xoff_active; # simulate received xoff |
||
2572 | $PortObj->xon_active; # simulate received xon |
||
2573 | |||
2574 | $PortObj->purge_all; |
||
2575 | $PortObj->purge_rx; |
||
2576 | $PortObj->purge_tx; |
||
2577 | |||
2578 | # controlling outputs from the port |
||
2579 | $PortObj->dtr_active(T); # sends outputs direct to hardware |
||
2580 | $PortObj->rts_active(Yes); # returns status of API call |
||
2581 | $PortObj->break_active(N); # NOT state of bit |
||
2582 | |||
2583 | $PortObj->pulse_break_on($milliseconds); # off version is implausible |
||
2584 | $PortObj->pulse_rts_on($milliseconds); |
||
2585 | $PortObj->pulse_rts_off($milliseconds); |
||
2586 | $PortObj->pulse_dtr_on($milliseconds); |
||
2587 | $PortObj->pulse_dtr_off($milliseconds); |
||
2588 | # sets_bit, delays, resets_bit, delays |
||
2589 | # pulse_xxx methods not supported on Perl 5.004 |
||
2590 | |||
2591 | $ModemStatus = $PortObj->is_modemlines; |
||
2592 | if ($ModemStatus & $PortObj->MS_RLSD_ON) { print "carrier detected"; } |
||
2593 | |||
2594 | $PortObj->close || die; |
||
2595 | # "undef $PortObj" preferred unless reopening port |
||
2596 | # "close" should precede "undef" if both used |
||
2597 | |||
2598 | =head1 DESCRIPTION |
||
2599 | |||
2600 | This provides fairly low-level access to the Win32 System API calls |
||
2601 | dealing with serial ports. |
||
2602 | |||
2603 | Uses features of the Win32 API to implement non-blocking I/O, serial |
||
2604 | parameter setting, event-loop operation, and enhanced error handling. |
||
2605 | |||
2606 | To pass in C<NULL> as the pointer to an optional buffer, pass in C<$null=0>. |
||
2607 | This is expected to change to an empty list reference, C<[]>, when Perl |
||
2608 | supports that form in this usage. |
||
2609 | |||
2610 | Beyond raw access to the API calls and related constants, this module |
||
2611 | will eventually handle smart buffer allocation and translation of return |
||
2612 | codes. |
||
2613 | |||
2614 | =head2 Initialization |
||
2615 | |||
2616 | The constructor is B<new> with a F<PortName> (as the Registry |
||
2617 | knows it) specified. This will do a B<CreateFile>, get the available |
||
2618 | options and capabilities via the Win32 API, and create the object. |
||
2619 | The port is not yet ready for read/write access. First, the desired |
||
2620 | I<parameter settings> must be established. Since these are tuning |
||
2621 | constants for an underlying hardware driver in the Operating System, |
||
2622 | they should all checked for validity by the method calls that set them. |
||
2623 | The B<initialize> method takes a list of required parameters and confirms |
||
2624 | they have been set. For others, it will attempt to deduce defaults from |
||
2625 | the hardware or from other parameters. The B<initialize> method returns |
||
2626 | the number of faults (zero if the port is setup ok). The B<update_DCB> |
||
2627 | method writes a new I<Device Control Block> to complete the startup and |
||
2628 | allow the port to be used. Ports are opened for binary transfers. A |
||
2629 | separate C<binmode> is not needed. The USER must release the object |
||
2630 | if B<initialize> or B<update_DCB> does not succeed. |
||
2631 | |||
2632 | Version 0.15 adds an optional C<$quiet> parameter to B<new>. Failure |
||
2633 | to open a port prints a error message to STDOUT by default. Since only |
||
2634 | one application at a time can "own" the port, one source of failure was |
||
2635 | "port in use". There was previously no way to check this without getting |
||
2636 | a "fail message". Setting C<$quiet> disables this built-in message. It |
||
2637 | also returns 0 instead of C<undef> if the port is unavailable (still FALSE, |
||
2638 | used for testing this condition - other faults may still return C<undef>). |
||
2639 | Use of C<$quiet> only applies to B<new>. |
||
2640 | |||
2641 | The fault checking in B<initialize> consists in verifying an I<_N_$item> |
||
2642 | internal variable exists for each I<$item> in the input list. The |
||
2643 | I<_N_$item> is created for each parameter that is set either directly |
||
2644 | or by default. A derived class must create the I<_N_$items> for any |
||
2645 | varibles it adds to the base class if it wants B<initialize> to check |
||
2646 | them. Win32API::CommPort supports the following: |
||
2647 | |||
2648 | $item _N_$item setting method |
||
2649 | ------ --------- -------------- |
||
2650 | BAUD "_N_BAUD" is_baudrate |
||
2651 | BINARY "_N_BINARY" is_binary |
||
2652 | DATA "_N_DATA" is_databits |
||
2653 | EOFCHAR "_N_EOFCHAR" is_eof_char |
||
2654 | ERRCHAR "_N_ERRCHAR" is_error_char |
||
2655 | EVTCHAR "_N_EVTCHAR" is_event_char |
||
2656 | HSHAKE "_N_HSHAKE" is_handshake |
||
2657 | PARITY "_N_PARITY" is_parity |
||
2658 | PARITY_EN "_N_PARITY_EN" is_parity_enable |
||
2659 | RCONST "_N_RCONST" is_read_const_time |
||
2660 | READBUF "_N_READBUF" is_read_buf |
||
2661 | RINT "_N_RINT" is_read_interval |
||
2662 | RTOT "_N_RTOT" is_read_char_time |
||
2663 | STOP "_N_STOP" is_stopbits |
||
2664 | WCONST "_N_WCONST" is_write_const_time |
||
2665 | WRITEBUF "_N_WRITEBUF" is_write_buf |
||
2666 | WTOT "_N_WTOT" is_write_char_time |
||
2667 | XOFFCHAR "_N_XOFFCHAR" is_xoff_char |
||
2668 | XOFFLIM "_N_XOFFLIM" is_xoff_limit |
||
2669 | XONCHAR "_N_XONCHAR" is_xon_char |
||
2670 | XONLIM "_N_XONLIM" is_xon_limit |
||
2671 | |||
2672 | Some individual parameters (eg. baudrate) can be changed after the |
||
2673 | initialization is completed. These will automatically update the |
||
2674 | I<Device Control Block> as required. The I<init_done> method indicates |
||
2675 | when I<initialize> has completed successfully. |
||
2676 | |||
2677 | |||
2678 | $PortObj = new Win32API::CommPort ($PortName, $quiet) |
||
2679 | || die "Can't open $PortName: $^E\n"; # $quiet is optional |
||
2680 | |||
2681 | if $PortObj->can_databits { $PortObj->is_databits(8) }; |
||
2682 | $PortObj->is_baudrate(9600); |
||
2683 | $PortObj->is_parity("none"); |
||
2684 | $PortObj->is_stopbits(1); |
||
2685 | $PortObj->is_handshake("rts"); |
||
2686 | $PortObj->is_buffers(4096, 4096); |
||
2687 | $PortObj->dtr_active(T); |
||
2688 | |||
2689 | @required = qw( BAUD DATA STOP PARITY ); |
||
2690 | $PortObj->initialize(@required) || undef $PortObj; |
||
2691 | |||
2692 | $PortObj->dtr_active(f); |
||
2693 | $PortObj->is_baudrate(300); |
||
2694 | |||
2695 | $PortObj->close || die; |
||
2696 | # "undef $PortObj" preferred unless reopening port |
||
2697 | # "close" should precede "undef" if both used |
||
2698 | |||
2699 | undef $PortObj; # closes port AND frees memory in perl |
||
2700 | |||
2701 | The F<PortName> maps to both the Registry I<Device Name> and the |
||
2702 | I<Properties> associated with that device. A single I<Physical> port |
||
2703 | can be accessed using two or more I<Device Names>. But the options |
||
2704 | and setup data will differ significantly in the two cases. A typical |
||
2705 | example is a Modem on port "COM2". Both of these F<PortNames> open |
||
2706 | the same I<Physical> hardware: |
||
2707 | |||
2708 | $P1 = new Win32API::CommPort ("COM2"); |
||
2709 | |||
2710 | $P2 = new Win32API::CommPort ("\\\\.\\Nanohertz Modem model K-9"); |
||
2711 | |||
2712 | $P1 is a "generic" serial port. $P2 includes all of $P1 plus a variety |
||
2713 | of modem-specific added options and features. The "raw" API calls return |
||
2714 | different size configuration structures in the two cases. Win32 uses the |
||
2715 | "\\.\" prefix to identify "named" devices. Since both names use the same |
||
2716 | I<Physical> hardware, they can not both be used at the same time. The OS |
||
2717 | will complain. Consider this A Good Thing. |
||
2718 | |||
2719 | Version 0.16 adds B<pulse> methods for the I<RTS, BREAK, and DTR> bits. The |
||
2720 | B<pulse> methods assume the bit is in the opposite state when the method |
||
2721 | is called. They set the requested state, delay the specified number of |
||
2722 | milliseconds, set the opposite state, and again delay the specified time. |
||
2723 | These methods are designed to support devices, such as the X10 "FireCracker" |
||
2724 | control and some modems, which require pulses on these lines to signal |
||
2725 | specific events or data. Since the 5.00402 Perl distribution from CPAN does |
||
2726 | not support sub-second time delays readily, these methods are not supported |
||
2727 | on that version of Perl. |
||
2728 | |||
2729 | $PortObj->pulse_break_on($milliseconds); |
||
2730 | $PortObj->pulse_rts_on($milliseconds); |
||
2731 | $PortObj->pulse_rts_off($milliseconds); |
||
2732 | $PortObj->pulse_dtr_on($milliseconds); |
||
2733 | $PortObj->pulse_dtr_off($milliseconds); |
||
2734 | |||
2735 | Version 0.16 also adds I<experimental> support for the rest of the option bits |
||
2736 | available through the I<Device Control Block>. They have not been extensively |
||
2737 | tested and these settings are NOT saved in the B<configuration file> by |
||
2738 | I<Win32::SerialPort>. Please let me know if one does not work as advertised. |
||
2739 | [Win32 API bit designation] |
||
2740 | |||
2741 | $PortObj->ignore_null(0); # discard \000 bytes on input [fNull] |
||
2742 | |||
2743 | $PortObj->ignore_no_dsr(0); # discard input bytes unless DSR |
||
2744 | # [fDsrSensitivity] |
||
2745 | |||
2746 | $PortObj->subst_pe_char(0); # replace parity errors with B<is_error_char> |
||
2747 | # when B<is_parity_enable> [fErrorChar] |
||
2748 | |||
2749 | $PortObj->abort_on_error(0); # cancel read/write [fAbortOnError] |
||
2750 | |||
2751 | # next one set by $PortObj->is_handshake("dtr"); |
||
2752 | $PortObj->output_dsr(0); # use DSR handshake on output [fOutxDsrFlow] |
||
2753 | |||
2754 | # next one set by $PortObj->is_handshake("rts"); |
||
2755 | $PortObj->output_cts(0); # use CTS handshake on output [fOutxCtsFlow] |
||
2756 | |||
2757 | # next two set by $PortObj->is_handshake("xoff"); |
||
2758 | $PortObj->input_xoff(0); # use Xon/Xoff handshake on input [fInX] |
||
2759 | $PortObj->output_xoff(0); # use Xon/Xoff handshake on output [fOutX] |
||
2760 | |||
2761 | $PortObj->tx_on_xoff(0); # continue output even after input xoff sent |
||
2762 | # [fTXContinueOnXoff] |
||
2763 | |||
2764 | The B<get_tick_count> method is a wrapper around the I<Win32::GetTickCount()> |
||
2765 | function. It matches a corresponding method in I<Device::SerialPort> which |
||
2766 | does not have access to the I<Win32::> namespace. It still returns time |
||
2767 | in milliseconds - but can be used in cross-platform scripts. |
||
2768 | |||
2769 | =head2 Configuration and Capability Methods |
||
2770 | |||
2771 | The Win32 Serial Comm API provides extensive information concerning |
||
2772 | the capabilities and options available for a specific port (and |
||
2773 | instance). "Modem" ports have different capabilties than "RS-232" |
||
2774 | ports - even if they share the same Hardware. Many traditional modem |
||
2775 | actions are handled via TAPI. "Fax" ports have another set of options - |
||
2776 | and are accessed via MAPI. Yet many of the same low-level API commands |
||
2777 | and data structures are "common" to each type ("Modem" is implemented |
||
2778 | as an "RS-232" superset). In addition, Win95 supports a variety of |
||
2779 | legacy hardware (e.g fixed 134.5 baud) while WinNT has hooks for ISDN, |
||
2780 | 16-data-bit paths, and 256Kbaud. |
||
2781 | |||
2782 | =over 8 |
||
2783 | |||
2784 | Binary selections will accept as I<true> any of the following: |
||
2785 | C<("YES", "Y", "ON", "TRUE", "T", "1", 1)> (upper/lower/mixed case) |
||
2786 | Anything else is I<false>. |
||
2787 | |||
2788 | There are a large number of possible configuration and option parameters. |
||
2789 | To facilitate checking option validity in scripts, most configuration |
||
2790 | methods can be used in two different ways: |
||
2791 | |||
2792 | =item method called with an argument |
||
2793 | |||
2794 | The parameter is set to the argument, if valid. An invalid argument |
||
2795 | returns I<false> (undef) and the parameter is unchanged. After B<init_done>, |
||
2796 | the port will be updated immediately if allowed. Otherwise, the value |
||
2797 | will be applied when B<update_DCB> is called. |
||
2798 | |||
2799 | =item method called with no argument in scalar context |
||
2800 | |||
2801 | The current value is returned. If the value is not initialized either |
||
2802 | directly or by default, return "undef" which will parse to I<false>. |
||
2803 | For binary selections (true/false), return the current value. All |
||
2804 | current values from "multivalue" selections will parse to I<true>. |
||
2805 | Current values may differ from requested values until B<init_done>. |
||
2806 | There is no way to see requests which have not yet been applied. |
||
2807 | Setting the same parameter again overwrites the first request. Test |
||
2808 | the return value of the setting method to check "success". |
||
2809 | |||
2810 | =item Asynchronous (Background) I/O |
||
2811 | |||
2812 | This version now handles Polling (do if Ready), Synchronous (block until |
||
2813 | Ready), and Asynchronous Modes (begin and test if Ready) with the timeout |
||
2814 | choices provided by the API. No effort has yet been made to interact with |
||
2815 | Windows events. But background I/O has been used successfully with the |
||
2816 | Perl Tk modules and callbacks from the event loop. |
||
2817 | |||
2818 | =item Timeouts |
||
2819 | |||
2820 | The API provides two timing models. The first applies only to reading and |
||
2821 | essentially determines I<Read Not Ready> by checking the time between |
||
2822 | consecutive characters. The B<ReadFile> operation returns if that time |
||
2823 | exceeds the value set by B<is_read_interval>. It does this by timestamping |
||
2824 | each character. It appears that at least one character must by received in |
||
2825 | I<every> B<read> I<call to the API> to initialize the mechanism. The timer |
||
2826 | is then reset by each succeeding character. If no characters are received, |
||
2827 | the read will block indefinitely. |
||
2828 | |||
2829 | Setting B<is_read_interval> to C<0xffffffff> will do a non-blocking read. |
||
2830 | The B<ReadFile> returns immediately whether or not any characters are |
||
2831 | actually read. This replicates the behavior of the API. |
||
2832 | |||
2833 | The other model defines the total time allowed to complete the operation. |
||
2834 | A fixed overhead time is added to the product of bytes and per_byte_time. |
||
2835 | A wide variety of timeout options can be defined by selecting the three |
||
2836 | parameters: fixed, each, and size. |
||
2837 | |||
2838 | Read_Total = B<is_read_const_time> + (B<is_read_char_time> * bytes_to_read) |
||
2839 | |||
2840 | Write_Total = B<is_write_const_time> + (B<is_write_char_time> * bytes_to_write) |
||
2841 | |||
2842 | When reading a known number of characters, the I<Read_Total> mechanism is |
||
2843 | recommended. This mechanism I<MUST> be used with |
||
2844 | I<Win32::SerialPort tied FileHandles> because the tie methods can make |
||
2845 | multiple internal API calls. The I<Read_Interval> mechanism is suitable for |
||
2846 | a B<read_bg> method that expects a response of variable or unknown size. You |
||
2847 | should then also set a long I<Read_Total> timeout as a "backup" in case |
||
2848 | no bytes are received. |
||
2849 | |||
2850 | =back |
||
2851 | |||
2852 | =head2 Exports |
||
2853 | |||
2854 | Nothing is exported by default. The following tags can be used to have |
||
2855 | large sets of symbols exported: |
||
2856 | |||
2857 | =over 4 |
||
2858 | |||
2859 | =item :PARAM |
||
2860 | |||
2861 | Utility subroutines and constants for parameter setting and test: |
||
2862 | |||
2863 | LONGsize SHORTsize nocarp yes_true |
||
2864 | OS_Error internal_buffer |
||
2865 | |||
2866 | =item :STAT |
||
2867 | |||
2868 | Serial communications status constants. Included are the constants for |
||
2869 | ascertaining why a transmission is blocked: |
||
2870 | |||
2871 | BM_fCtsHold BM_fDsrHold BM_fRlsdHold BM_fXoffHold |
||
2872 | BM_fXoffSent BM_fEof BM_fTxim BM_AllBits |
||
2873 | |||
2874 | Which incoming bits are active: |
||
2875 | |||
2876 | MS_CTS_ON MS_DSR_ON MS_RING_ON MS_RLSD_ON |
||
2877 | |||
2878 | What hardware errors have been detected: |
||
2879 | |||
2880 | CE_RXOVER CE_OVERRUN CE_RXPARITY CE_FRAME |
||
2881 | CE_BREAK CE_TXFULL CE_MODE |
||
2882 | |||
2883 | Offsets into the array returned by B<status:> |
||
2884 | |||
2885 | ST_BLOCK ST_INPUT ST_OUTPUT ST_ERROR |
||
2886 | |||
2887 | =item :RAW |
||
2888 | |||
2889 | The constants and wrapper methods for low-level API calls. Details of |
||
2890 | these methods may change with testing. Some may be inherited from |
||
2891 | Win32API::File when that becomes available. |
||
2892 | |||
2893 | $result=ClearCommError($handle, $Error_BitMask_p, $CommStatus); |
||
2894 | $result=ClearCommBreak($handle); |
||
2895 | $result=SetCommBreak($handle); |
||
2896 | $result=GetCommModemStatus($handle, $ModemStatus); |
||
2897 | $result=GetCommProperties($handle, $CommProperties); |
||
2898 | $result=GetCommState($handle, $DCB_Buffer); |
||
2899 | $result=SetCommState($handle, $DCB_Buffer); |
||
2900 | $result=SetupComm($handle, $in_buf_size, $out_buf_size); |
||
2901 | $result=ReadFile($handle, $buffer, $wanted, $got, $template); |
||
2902 | $result=WriteFile($handle, $buffer, $size, $count, $template); |
||
2903 | |||
2904 | $result=GetCommTimeouts($handle, $CommTimeOuts); |
||
2905 | $result=SetCommTimeouts($handle, $CommTimeOuts); |
||
2906 | $result=EscapeCommFunction($handle, $Func_ID); |
||
2907 | $result=GetCommConfig($handle, $CommConfig, $Size); |
||
2908 | $result=SetCommConfig($handle, $CommConfig, $Size); |
||
2909 | $result=PurgeComm($handle, $flags); |
||
2910 | |||
2911 | $result=GetCommMask($handle, $Event_Bitmask); |
||
2912 | $result=SetCommMask($handle, $Event_Bitmask); |
||
2913 | $hEvent=CreateEvent($security, $reset_req, $initial, $name); |
||
2914 | $handle=CreateFile($file, $access, $share, $security, |
||
2915 | $creation, $flags, $template); |
||
2916 | $result=CloseHandle($handle); |
||
2917 | $result=ResetEvent($hEvent); |
||
2918 | $result=TransmitCommChar($handle, $char); |
||
2919 | $result=WaitCommEvent($handle, $Event_Bitmask, $lpOverlapped); |
||
2920 | $result=GetOverlappedResult($handle, $lpOverlapped, $count, $bool); |
||
2921 | |||
2922 | Flags used by B<PurgeComm:> |
||
2923 | |||
2924 | PURGE_TXABORT PURGE_RXABORT PURGE_TXCLEAR PURGE_RXCLEAR |
||
2925 | |||
2926 | Function IDs used by EscapeCommFunction: |
||
2927 | |||
2928 | SETXOFF SETXON SETRTS CLRRTS |
||
2929 | SETDTR CLRDTR SETBREAK CLRBREAK |
||
2930 | |||
2931 | Events used by B<WaitCommEvent:> |
||
2932 | |||
2933 | EV_RXCHAR EV_RXFLAG EV_TXEMPTY EV_CTS |
||
2934 | EV_DSR EV_RLSD EV_BREAK EV_ERR |
||
2935 | EV_RING EV_PERR EV_RX80FULL EV_EVENT1 |
||
2936 | EV_EVENT2 |
||
2937 | |||
2938 | Errors specific to B<GetOverlappedResult:> |
||
2939 | |||
2940 | ERROR_IO_INCOMPLETE ERROR_IO_PENDING |
||
2941 | |||
2942 | =item :COMMPROP |
||
2943 | |||
2944 | The constants for the I<CommProperties structure> returned by |
||
2945 | B<GetCommProperties>. Included mostly for completeness. |
||
2946 | |||
2947 | BAUD_USER BAUD_075 BAUD_110 BAUD_134_5 |
||
2948 | BAUD_150 BAUD_300 BAUD_600 BAUD_1200 |
||
2949 | BAUD_1800 BAUD_2400 BAUD_4800 BAUD_7200 |
||
2950 | BAUD_9600 BAUD_14400 BAUD_19200 BAUD_38400 |
||
2951 | BAUD_56K BAUD_57600 BAUD_115200 BAUD_128K |
||
2952 | |||
2953 | PST_FAX PST_LAT PST_MODEM PST_PARALLELPORT |
||
2954 | PST_RS232 PST_RS422 PST_X25 PST_NETWORK_BRIDGE |
||
2955 | PST_RS423 PST_RS449 PST_SCANNER PST_TCPIP_TELNET |
||
2956 | PST_UNSPECIFIED |
||
2957 | |||
2958 | PCF_INTTIMEOUTS PCF_PARITY_CHECK PCF_16BITMODE |
||
2959 | PCF_DTRDSR PCF_SPECIALCHARS PCF_RLSD |
||
2960 | PCF_RTSCTS PCF_SETXCHAR PCF_TOTALTIMEOUTS |
||
2961 | PCF_XONXOFF |
||
2962 | |||
2963 | SP_BAUD SP_DATABITS SP_HANDSHAKING SP_PARITY |
||
2964 | SP_RLSD SP_STOPBITS SP_SERIALCOMM SP_PARITY_CHECK |
||
2965 | |||
2966 | DATABITS_5 DATABITS_6 DATABITS_7 DATABITS_8 |
||
2967 | DATABITS_16 DATABITS_16X |
||
2968 | |||
2969 | STOPBITS_10 STOPBITS_15 STOPBITS_20 |
||
2970 | |||
2971 | PARITY_SPACE PARITY_NONE PARITY_ODD PARITY_EVEN |
||
2972 | PARITY_MARK |
||
2973 | |||
2974 | COMMPROP_INITIALIZED |
||
2975 | |||
2976 | =item :DCB |
||
2977 | |||
2978 | The constants for the I<Device Control Block> returned by B<GetCommState> |
||
2979 | and updated by B<SetCommState>. Again, included mostly for completeness. |
||
2980 | But there are some combinations of "FM_f" settings which are not currently |
||
2981 | supported by high-level commands. If you need one of those, please report |
||
2982 | the lack as a bug. |
||
2983 | |||
2984 | CBR_110 CBR_300 CBR_600 CBR_1200 |
||
2985 | CBR_2400 CBR_4800 CBR_9600 CBR_14400 |
||
2986 | CBR_19200 CBR_38400 CBR_56000 CBR_57600 |
||
2987 | CBR_115200 CBR_128000 CBR_256000 |
||
2988 | |||
2989 | DTR_CONTROL_DISABLE DTR_CONTROL_ENABLE DTR_CONTROL_HANDSHAKE |
||
2990 | RTS_CONTROL_DISABLE RTS_CONTROL_ENABLE RTS_CONTROL_HANDSHAKE |
||
2991 | RTS_CONTROL_TOGGLE |
||
2992 | |||
2993 | EVENPARITY MARKPARITY NOPARITY ODDPARITY |
||
2994 | SPACEPARITY |
||
2995 | |||
2996 | ONESTOPBIT ONE5STOPBITS TWOSTOPBITS |
||
2997 | |||
2998 | FM_fBinary FM_fParity FM_fOutxCtsFlow |
||
2999 | FM_fOutxDsrFlow FM_fDtrControl FM_fDsrSensitivity |
||
3000 | FM_fTXContinueOnXoff FM_fOutX FM_fInX |
||
3001 | FM_fErrorChar FM_fNull FM_fRtsControl |
||
3002 | FM_fAbortOnError FM_fDummy2 |
||
3003 | |||
3004 | =item :ALL |
||
3005 | |||
3006 | All of the above. Except for the I<test suite>, there is not really a good |
||
3007 | reason to do this. |
||
3008 | |||
3009 | =back |
||
3010 | |||
3011 | =head1 NOTES |
||
3012 | |||
3013 | The object returned by B<new> is NOT a I<Filehandle>. You |
||
3014 | will be disappointed if you try to use it as one. |
||
3015 | |||
3016 | e.g. the following is WRONG!!____C<print $PortObj "some text";> |
||
3017 | |||
3018 | I<Win32::SerialPort> supports accessing ports via I<Tied Filehandles>. |
||
3019 | |||
3020 | An important note about Win32 filenames. The reserved device names such |
||
3021 | as C< COM1, AUX, LPT1, CON, PRN > can NOT be used as filenames. Hence |
||
3022 | I<"COM2.cfg"> would not be usable for B<$Configuration_File_Name>. |
||
3023 | |||
3024 | This module uses Win32::API extensively. The raw API calls are B<very> |
||
3025 | unforgiving. You will certainly want to start perl with the B<-w> switch. |
||
3026 | If you can, B<use strict> as well. Try to ferret out all the syntax and |
||
3027 | usage problems BEFORE issuing the API calls (many of which modify tuning |
||
3028 | constants in hardware device drivers....not where you want to look for bugs). |
||
3029 | |||
3030 | Thanks to Ken White for testing on NT. |
||
3031 | |||
3032 | =head1 KNOWN LIMITATIONS |
||
3033 | |||
3034 | The current version of the module has been designed for testing using |
||
3035 | the ActiveState and Core (GS 5.004_02) ports of Perl for Win32 without |
||
3036 | requiring a compiler or using XS. In every case, compatibility has been |
||
3037 | selected over performance. Since everything is (sometimes convoluted but |
||
3038 | still pure) Perl, you can fix flaws and change limits if required. But |
||
3039 | please file a bug report if you do. This module has been tested with |
||
3040 | each of the binary perl versions for which Win32::API is supported: AS |
||
3041 | builds 315, 316, and 500-509 and GS 5.004_02. It has only been tested on |
||
3042 | Intel hardware. |
||
3043 | |||
3044 | =over 4 |
||
3045 | |||
3046 | =item Tutorial |
||
3047 | |||
3048 | With all the options, this module needs a good tutorial. It doesn't |
||
3049 | have a complete one yet. A I<"How to get started"> tutorial appeared |
||
3050 | B<The Perl Journal #13> (March 1999). The demo programs are a good |
||
3051 | starting point for additional examples. |
||
3052 | |||
3053 | =item Buffers |
||
3054 | |||
3055 | The size of the Win32 buffers are selectable with B<is_buffers>. But each read |
||
3056 | method currently uses a fixed internal buffer of 4096 bytes. This can be |
||
3057 | changed in the module source. The read-only B<internal_buffer> method will |
||
3058 | give the current size. There are other fixed internal buffers as well. But |
||
3059 | no one has needed to change those. The XS version will support dynamic buffer |
||
3060 | sizing. |
||
3061 | |||
3062 | =item Modems |
||
3063 | |||
3064 | Lots of modem-specific options are not supported. The same is true of |
||
3065 | TAPI, MAPI. I<API Wizards> are welcome to contribute. |
||
3066 | |||
3067 | =item API Options |
||
3068 | |||
3069 | Lots of options are just "passed through from the API". Some probably |
||
3070 | shouldn't be used together. The module validates the obvious choices when |
||
3071 | possible. For something really fancy, you may need additional API |
||
3072 | documentation. Available from I<Micro$oft Pre$$>. |
||
3073 | |||
3074 | =back |
||
3075 | |||
3076 | =head1 BUGS |
||
3077 | |||
3078 | ActiveState ports of Perl for Win32 before build 500 do not support the |
||
3079 | tools for building extensions and so will not support later versions of |
||
3080 | this extension. In particular, the automated install and test scripts in |
||
3081 | this distribution work differently with ActiveState builds 3xx. |
||
3082 | |||
3083 | There is no parameter checking on the "raw" API calls. You probably should |
||
3084 | be familiar with using the calls in "C" before doing much experimenting. |
||
3085 | |||
3086 | On Win32, a port must B<close> before it can be reopened again by the same |
||
3087 | process. If a physical port can be accessed using more than one name (see |
||
3088 | above), all names are treated as one. The perl script can also be run |
||
3089 | multiple times within a single batch file or shell script. The I<Makefile.PL> |
||
3090 | spawns subshells with backticks to run the test suite on Perl 5.003 - ugly, |
||
3091 | but it works. |
||
3092 | |||
3093 | On NT, a B<read_done> or B<write_done> returns I<False> if a background |
||
3094 | operation is aborted by a purge. Win95 returns I<True>. |
||
3095 | |||
3096 | EXTENDED_OS_ERROR ($^E) is not supported by the binary ports before 5.005. |
||
3097 | It "sort-of-tracks" B<$!> in 5.003 and 5.004, but YMMV. |
||
3098 | |||
3099 | A few NT systems seem to set B<can_parity_enable> true, but do not actually |
||
3100 | support setting B<is_parity_enable>. This may be a characteristic of certain |
||
3101 | third-party serial drivers. Or a Microsoft bug. I have not been able to |
||
3102 | reproduce it on my system. |
||
3103 | |||
3104 | __Please send comments and bug reports to wcbirthisel@alum.mit.edu. |
||
3105 | |||
3106 | =head1 AUTHORS |
||
3107 | |||
3108 | Bill Birthisel, wcbirthisel@alum.mit.edu, http://members.aol.com/Bbirthisel/. |
||
3109 | |||
3110 | Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/. |
||
3111 | |||
3112 | =head1 SEE ALSO |
||
3113 | |||
3114 | Wi32::SerialPort - High-level user interface/front-end for this module |
||
3115 | |||
3116 | Win32API::File I<when available> |
||
3117 | |||
3118 | Win32::API - Aldo Calpini's "Magic", http://www.divinf.it/dada/perl/ |
||
3119 | |||
3120 | Perltoot.xxx - Tom (Christiansen)'s Object-Oriented Tutorial |
||
3121 | |||
3122 | =head1 COPYRIGHT |
||
3123 | |||
3124 | Copyright (C) 1999, Bill Birthisel. All rights reserved. |
||
3125 | |||
3126 | This module is free software; you can redistribute it and/or modify it |
||
3127 | under the same terms as Perl itself. |
||
3128 | |||
3129 | =head2 COMPATIBILITY |
||
3130 | |||
3131 | Most of the code in this module has been stable since version 0.12. |
||
3132 | Except for items indicated as I<Experimental>, I do not expect functional |
||
3133 | changes which are not fully backwards compatible. However, Version 0.16 |
||
3134 | removes the "dummy (0, 1) list" which was returned by many binary methods |
||
3135 | in case they were called in list context. I do not know of any use outside |
||
3136 | the test suite for that feature. |
||
3137 | |||
3138 | Version 0.12 added an I<Install.PL> script to put modules into the documented |
||
3139 | Namespaces. The script uses I<MakeMaker> tools not available in |
||
3140 | ActiveState 3xx builds. Users of those builds will need to install |
||
3141 | differently (see README). Programs in the test suite are modified for |
||
3142 | the current version. Additions to the configurtion files generated by |
||
3143 | B<save> prevent those created by Version 0.15 from being used by earlier |
||
3144 | Versions. 4 November 1999. |
||
3145 | |||
3146 | =cut |