Details | Last modification | View Log | RSS feed
Rev | Author | Line No. | Line |
---|---|---|---|
365 | rain-er | 1 | package Win32::SerialPort; |
2 | |||
3 | use Win32; |
||
4 | use Win32API::CommPort qw( :STAT :PARAM 0.17 ); |
||
5 | |||
6 | use Carp; |
||
7 | use strict; |
||
8 | |||
9 | use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); |
||
10 | $VERSION = '0.19'; |
||
11 | |||
12 | require Exporter; |
||
13 | ## require AutoLoader; |
||
14 | |||
15 | @ISA = qw( Exporter Win32API::CommPort ); |
||
16 | # Items to export into callers namespace by default. Note: do not export |
||
17 | # names by default without a very good reason. Use EXPORT_OK instead. |
||
18 | # Do not simply export all your public functions/methods/constants. |
||
19 | |||
20 | @EXPORT= qw(); |
||
21 | @EXPORT_OK= @Win32API::CommPort::EXPORT_OK; |
||
22 | %EXPORT_TAGS = %Win32API::CommPort::EXPORT_TAGS; |
||
23 | |||
24 | # parameters that must be included in a "save" and "checking subs" |
||
25 | |||
26 | my %validate = ( |
||
27 | ALIAS => "alias", |
||
28 | BAUD => "baudrate", |
||
29 | BINARY => "binary", |
||
30 | DATA => "databits", |
||
31 | E_MSG => "error_msg", |
||
32 | EOFCHAR => "eof_char", |
||
33 | ERRCHAR => "error_char", |
||
34 | EVTCHAR => "event_char", |
||
35 | HSHAKE => "handshake", |
||
36 | PARITY => "parity", |
||
37 | PARITY_EN => "parity_enable", |
||
38 | RCONST => "read_const_time", |
||
39 | READBUF => "set_read_buf", |
||
40 | RINT => "read_interval", |
||
41 | RTOT => "read_char_time", |
||
42 | STOP => "stopbits", |
||
43 | U_MSG => "user_msg", |
||
44 | WCONST => "write_const_time", |
||
45 | WRITEBUF => "set_write_buf", |
||
46 | WTOT => "write_char_time", |
||
47 | XOFFCHAR => "xoff_char", |
||
48 | XOFFLIM => "xoff_limit", |
||
49 | XONCHAR => "xon_char", |
||
50 | XONLIM => "xon_limit", |
||
51 | intr => "is_stty_intr", |
||
52 | quit => "is_stty_quit", |
||
53 | s_eof => "is_stty_eof", |
||
54 | eol => "is_stty_eol", |
||
55 | erase => "is_stty_erase", |
||
56 | s_kill => "is_stty_kill", |
||
57 | bsdel => "stty_bsdel", |
||
58 | clear => "is_stty_clear", |
||
59 | echo => "stty_echo", |
||
60 | echoe => "stty_echoe", |
||
61 | echok => "stty_echok", |
||
62 | echonl => "stty_echonl", |
||
63 | echoke => "stty_echoke", |
||
64 | echoctl => "stty_echoctl", |
||
65 | istrip => "stty_istrip", |
||
66 | icrnl => "stty_icrnl", |
||
67 | ocrnl => "stty_ocrnl", |
||
68 | opost => "stty_opost", |
||
69 | igncr => "stty_igncr", |
||
70 | inlcr => "stty_inlcr", |
||
71 | onlcr => "stty_onlcr", |
||
72 | isig => "stty_isig", |
||
73 | icanon => "stty_icanon", |
||
74 | DVTYPE => "devicetype", |
||
75 | HNAME => "hostname", |
||
76 | HADDR => "hostaddr", |
||
77 | DATYPE => "datatype", |
||
78 | CFG_1 => "cfg_param_1", |
||
79 | CFG_2 => "cfg_param_2", |
||
80 | CFG_3 => "cfg_param_3", |
||
81 | ); |
||
82 | |||
83 | # parameters supported by the stty method |
||
84 | |||
85 | my %opts = ( "intr" => "is_stty_intr:argv_char", |
||
86 | "quit" => "is_stty_quit:argv_char", |
||
87 | "eof" => "is_stty_eof:argv_char", |
||
88 | "eol" => "is_stty_eol:argv_char", |
||
89 | "erase" => "is_stty_erase:argv_char", |
||
90 | "kill" => "is_stty_kill:argv_char", |
||
91 | "echo" => "stty_echo:1", |
||
92 | "-echo" => "stty_echo:0", |
||
93 | "echoe" => "stty_echoe:1", |
||
94 | "-echoe" => "stty_echoe:0", |
||
95 | "echok" => "stty_echok:1", |
||
96 | "-echok" => "stty_echok:0", |
||
97 | "echonl" => "stty_echonl:1", |
||
98 | "-echonl" => "stty_echonl:0", |
||
99 | "echoke" => "stty_echoke:1", |
||
100 | "-echoke" => "stty_echoke:0", |
||
101 | "echoctl" => "stty_echoctl:1", |
||
102 | "-echoctl" => "stty_echoctl:0", |
||
103 | "istrip" => "stty_istrip:1", |
||
104 | "-istrip" => "stty_istrip:0", |
||
105 | "icrnl" => "stty_icrnl:1", |
||
106 | "-icrnl" => "stty_icrnl:0", |
||
107 | "ocrnl" => "stty_ocrnl:1", |
||
108 | "-ocrnl" => "stty_ocrnl:0", |
||
109 | "igncr" => "stty_igncr:1", |
||
110 | "-igncr" => "stty_igncr:0", |
||
111 | "inlcr" => "stty_inlcr:1", |
||
112 | "-inlcr" => "stty_inlcr:0", |
||
113 | "onlcr" => "stty_onlcr:1", |
||
114 | "-onlcr" => "stty_onlcr:0", |
||
115 | "opost" => "stty_opost:1", |
||
116 | "-opost" => "stty_opost:0", |
||
117 | "isig" => "stty_isig:1", |
||
118 | "-isig" => "stty_isig:0", |
||
119 | "icanon" => "stty_icanon:1", |
||
120 | "-icanon" => "stty_icanon:0", |
||
121 | "parenb" => "parity_enable:1", |
||
122 | "-parenb" => "parity_enable:0", |
||
123 | "inpck" => "parity_enable:1", |
||
124 | "-inpck" => "parity:none", |
||
125 | "cs5" => "databits:5", |
||
126 | "cs6" => "databits:6", |
||
127 | "cs7" => "databits:7", |
||
128 | "cs8" => "databits:8", |
||
129 | "cstopb" => "stopbits:2", |
||
130 | "-cstopb" => "stopbits:1", |
||
131 | "parodd" => "parity:odd", |
||
132 | "-parodd" => "parity:even", |
||
133 | "clocal" => "handshake:none", |
||
134 | "-clocal" => "handshake:dtr", |
||
135 | "crtscts" => "handshake:rts", |
||
136 | "-crtscts" => "handshake:none", |
||
137 | "ixon" => "handshake:xoff", |
||
138 | "-ixon" => "handshake:none", |
||
139 | "ixoff" => "handshake:xoff", |
||
140 | "-ixoff" => "handshake:none", |
||
141 | "start" => "xon_char:argv_char", |
||
142 | "stop" => "xoff_char:argv_char", |
||
143 | ); |
||
144 | |||
145 | #### Package variable declarations #### |
||
146 | |||
147 | my @binary_opt = (0, 1); |
||
148 | my @byte_opt = (0, 255); |
||
149 | |||
150 | my $cfg_file_sig="Win32::SerialPort_Configuration_File -- DO NOT EDIT --\n"; |
||
151 | |||
152 | my $Verbose = 0; |
||
153 | |||
154 | # test*.t only - suppresses default messages |
||
155 | sub set_test_mode_active { |
||
156 | return unless (@_ == 2); |
||
157 | Win32API::CommPort->set_no_messages($_[1]); |
||
158 | # object not defined but :: upsets strict |
||
159 | return (keys %validate); |
||
160 | } |
||
161 | |||
162 | sub new { |
||
163 | my $proto = shift; |
||
164 | my $class = ref($proto) || $proto; |
||
165 | my $device = shift; |
||
166 | my @new_cmd = ($device); |
||
167 | my $quiet = shift; |
||
168 | if ($quiet) { |
||
169 | push @new_cmd, 1; |
||
170 | } |
||
171 | my $self = $class->SUPER::new(@new_cmd); |
||
172 | |||
173 | unless ($self) { |
||
174 | return 0 if ($quiet); |
||
175 | return; |
||
176 | } |
||
177 | |||
178 | # "private" data |
||
179 | $self->{"_DEBUG"} = 0; |
||
180 | $self->{U_MSG} = 0; |
||
181 | $self->{E_MSG} = 0; |
||
182 | $self->{OFS} = ""; |
||
183 | $self->{ORS} = ""; |
||
184 | $self->{"_T_INPUT"} = ""; |
||
185 | $self->{"_LOOK"} = ""; |
||
186 | $self->{"_LASTLOOK"} = ""; |
||
187 | $self->{"_LASTLINE"} = ""; |
||
188 | $self->{"_CLASTLINE"} = ""; |
||
189 | $self->{"_SIZE"} = 1; |
||
190 | $self->{"_LMATCH"} = ""; |
||
191 | $self->{"_LPATT"} = ""; |
||
192 | $self->{"_PROMPT"} = ""; |
||
193 | $self->{"_MATCH"} = []; |
||
194 | $self->{"_CMATCH"} = []; |
||
195 | @{ $self->{"_MATCH"} } = "\n"; |
||
196 | @{ $self->{"_CMATCH"} } = "\n"; |
||
197 | $self->{DVTYPE} = "none"; |
||
198 | $self->{HNAME} = "localhost"; |
||
199 | $self->{HADDR} = 0; |
||
200 | $self->{DATYPE} = "raw"; |
||
201 | $self->{CFG_1} = "none"; |
||
202 | $self->{CFG_2} = "none"; |
||
203 | $self->{CFG_3} = "none"; |
||
204 | |||
205 | # user settable options for lookfor (the "stty" collection) |
||
206 | # defaults like RedHat linux unless indicated |
||
207 | # char to abort nextline subroutine |
||
208 | $self->{intr} = "\cC"; # MUST be single char |
||
209 | |||
210 | # char to abort perl |
||
211 | $self->{quit} = "\cD"; # MUST be single char |
||
212 | |||
213 | # end_of_file char (linux typ: "\cD") |
||
214 | $self->{s_eof} = "\cZ"; # MUST be single char |
||
215 | |||
216 | # end_of_line char |
||
217 | $self->{eol} = "\cJ"; # MUST be single char |
||
218 | |||
219 | # delete one character from buffer (backspace) |
||
220 | $self->{erase} = "\cH"; # MUST be single char |
||
221 | |||
222 | # clear line buffer |
||
223 | $self->{s_kill} = "\cU"; # MUST be single char |
||
224 | |||
225 | # written after erase character |
||
226 | $self->{bsdel} = "\cH \cH"; |
||
227 | |||
228 | # written after kill character |
||
229 | my $space76 = " "x76; |
||
230 | $self->{clear} = "\r$space76\r"; # 76 spaces |
||
231 | |||
232 | # echo every character |
||
233 | $self->{echo} = 0; |
||
234 | |||
235 | # echo erase character with bsdel string |
||
236 | $self->{echoe} = 1; |
||
237 | |||
238 | # echo \n after kill character |
||
239 | $self->{echok} = 1; |
||
240 | |||
241 | # echo \n |
||
242 | $self->{echonl} = 0; |
||
243 | |||
244 | # echo clear string after kill character |
||
245 | $self->{echoke} = 1; # linux console yes, serial no |
||
246 | |||
247 | # echo "^Char" for control chars |
||
248 | $self->{echoctl} = 0; # linux console yes, serial no |
||
249 | |||
250 | # strip input to 7-bits |
||
251 | $self->{istrip} = 0; |
||
252 | |||
253 | # map \r to \n on input |
||
254 | $self->{icrnl} = 0; |
||
255 | |||
256 | # map \r to \n on output |
||
257 | $self->{ocrnl} = 0; |
||
258 | |||
259 | # ignore \r on input |
||
260 | $self->{igncr} = 0; |
||
261 | |||
262 | # map \n to \r on input |
||
263 | $self->{inlcr} = 0; |
||
264 | |||
265 | # map \n to \r\n on output |
||
266 | $self->{onlcr} = 1; |
||
267 | |||
268 | # enable output mapping |
||
269 | $self->{opost} = 0; |
||
270 | |||
271 | # enable quit and intr characters |
||
272 | $self->{isig} = 0; # linux actually SUPPORTS signals |
||
273 | |||
274 | # enable erase and kill characters |
||
275 | $self->{icanon} = 0; |
||
276 | |||
277 | my $token; |
||
278 | my @bauds = $self->are_baudrate; |
||
279 | foreach $token (@bauds) { $opts{$token} = "baudrate:$token"; } |
||
280 | |||
281 | # initialize (in CommPort) and write_settings need these defined |
||
282 | $self->{"_N_U_MSG"} = 0; |
||
283 | $self->{"_N_E_MSG"} = 0; |
||
284 | $self->{"_N_ALIAS"} = 0; |
||
285 | $self->{"_N_intr"} = 0; |
||
286 | $self->{"_N_quit"} = 0; |
||
287 | $self->{"_N_s_eof"} = 0; |
||
288 | $self->{"_N_eol"} = 0; |
||
289 | $self->{"_N_erase"} = 0; |
||
290 | $self->{"_N_s_kill"} = 0; |
||
291 | $self->{"_N_bsdel"} = 0; |
||
292 | $self->{"_N_clear"} = 0; |
||
293 | $self->{"_N_echo"} = 0; |
||
294 | $self->{"_N_echoe"} = 0; |
||
295 | $self->{"_N_echok"} = 0; |
||
296 | $self->{"_N_echonl"} = 0; |
||
297 | $self->{"_N_echoke"} = 0; |
||
298 | $self->{"_N_echoctl"} = 0; |
||
299 | $self->{"_N_istrip"} = 0; |
||
300 | $self->{"_N_icrnl"} = 0; |
||
301 | $self->{"_N_ocrnl"} = 0; |
||
302 | $self->{"_N_opost"} = 0; |
||
303 | $self->{"_N_igncr"} = 0; |
||
304 | $self->{"_N_inlcr"} = 0; |
||
305 | $self->{"_N_onlcr"} = 0; |
||
306 | $self->{"_N_isig"} = 0; |
||
307 | $self->{"_N_icanon"} = 0; |
||
308 | $self->{"_N_DVTYPE"} = 0; |
||
309 | $self->{"_N_HNAME"} = 0; |
||
310 | $self->{"_N_HADDR"} = 0; |
||
311 | $self->{"_N_DATYPE"} = 0; |
||
312 | $self->{"_N_CFG_1"} = 0; |
||
313 | $self->{"_N_CFG_2"} = 0; |
||
314 | $self->{"_N_CFG_3"} = 0; |
||
315 | |||
316 | $self->{ALIAS} = $device; # so "\\.\+++" can be changed |
||
317 | $self->{DEVICE} = $device; # clone so NAME stays in CommPort |
||
318 | |||
319 | ($self->{MAX_RXB}, $self->{MAX_TXB}) = $self->buffer_max; |
||
320 | |||
321 | bless ($self, $class); |
||
322 | return $self; |
||
323 | } |
||
324 | |||
325 | |||
326 | sub stty_intr { |
||
327 | my $self = shift; |
||
328 | if (@_ == 1) { $self->{intr} = shift; } |
||
329 | return if (@_); |
||
330 | return $self->{intr}; |
||
331 | } |
||
332 | |||
333 | sub stty_quit { |
||
334 | my $self = shift; |
||
335 | if (@_ == 1) { $self->{quit} = shift; } |
||
336 | return if (@_); |
||
337 | return $self->{quit}; |
||
338 | } |
||
339 | |||
340 | sub is_stty_eof { |
||
341 | my $self = shift; |
||
342 | if (@_ == 1) { $self->{s_eof} = chr(shift); } |
||
343 | return if (@_); |
||
344 | return ord($self->{s_eof}); |
||
345 | } |
||
346 | |||
347 | sub is_stty_eol { |
||
348 | my $self = shift; |
||
349 | if (@_ == 1) { $self->{eol} = chr(shift); } |
||
350 | return if (@_); |
||
351 | return ord($self->{eol}); |
||
352 | } |
||
353 | |||
354 | sub is_stty_quit { |
||
355 | my $self = shift; |
||
356 | if (@_ == 1) { $self->{quit} = chr(shift); } |
||
357 | return if (@_); |
||
358 | return ord($self->{quit}); |
||
359 | } |
||
360 | |||
361 | sub is_stty_intr { |
||
362 | my $self = shift; |
||
363 | if (@_ == 1) { $self->{intr} = chr(shift); } |
||
364 | return if (@_); |
||
365 | return ord($self->{intr}); |
||
366 | } |
||
367 | |||
368 | sub is_stty_erase { |
||
369 | my $self = shift; |
||
370 | if (@_ == 1) { $self->{erase} = chr(shift); } |
||
371 | return if (@_); |
||
372 | return ord($self->{erase}); |
||
373 | } |
||
374 | |||
375 | sub is_stty_kill { |
||
376 | my $self = shift; |
||
377 | if (@_ == 1) { $self->{s_kill} = chr(shift); } |
||
378 | return if (@_); |
||
379 | return ord($self->{s_kill}); |
||
380 | } |
||
381 | |||
382 | sub is_stty_clear { |
||
383 | my $self = shift; |
||
384 | my @chars; |
||
385 | if (@_ == 1) { |
||
386 | @chars = split (//, shift); |
||
387 | for (@chars) { |
||
388 | $_ = chr ( ord($_) - 32 ); |
||
389 | } |
||
390 | $self->{clear} = join("", @chars); |
||
391 | return $self->{clear}; |
||
392 | } |
||
393 | return if (@_); |
||
394 | @chars = split (//, $self->{clear}); |
||
395 | for (@chars) { |
||
396 | $_ = chr ( ord($_) + 32 ); |
||
397 | } |
||
398 | my $permute = join("", @chars); |
||
399 | return $permute; |
||
400 | } |
||
401 | |||
402 | sub stty_eof { |
||
403 | my $self = shift; |
||
404 | if (@_ == 1) { $self->{s_eof} = shift; } |
||
405 | return if (@_); |
||
406 | return $self->{s_eof}; |
||
407 | } |
||
408 | |||
409 | sub stty_eol { |
||
410 | my $self = shift; |
||
411 | if (@_ == 1) { $self->{eol} = shift; } |
||
412 | return if (@_); |
||
413 | return $self->{eol}; |
||
414 | } |
||
415 | |||
416 | sub stty_erase { |
||
417 | my $self = shift; |
||
418 | if (@_ == 1) { |
||
419 | my $tmp = shift; |
||
420 | return unless (length($tmp) == 1); |
||
421 | $self->{erase} = $tmp; |
||
422 | } |
||
423 | return if (@_); |
||
424 | return $self->{erase}; |
||
425 | } |
||
426 | |||
427 | sub stty_kill { |
||
428 | my $self = shift; |
||
429 | if (@_ == 1) { |
||
430 | my $tmp = shift; |
||
431 | return unless (length($tmp) == 1); |
||
432 | $self->{s_kill} = $tmp; |
||
433 | } |
||
434 | return if (@_); |
||
435 | return $self->{s_kill}; |
||
436 | } |
||
437 | |||
438 | sub stty_bsdel { |
||
439 | my $self = shift; |
||
440 | if (@_ == 1) { $self->{bsdel} = shift; } |
||
441 | return if (@_); |
||
442 | return $self->{bsdel}; |
||
443 | } |
||
444 | |||
445 | sub stty_clear { |
||
446 | my $self = shift; |
||
447 | if (@_ == 1) { $self->{clear} = shift; } |
||
448 | return if (@_); |
||
449 | return $self->{clear}; |
||
450 | } |
||
451 | |||
452 | sub stty_echo { |
||
453 | my $self = shift; |
||
454 | if (@_ == 1) { $self->{echo} = yes_true ( shift ) } |
||
455 | return if (@_); |
||
456 | return $self->{echo}; |
||
457 | } |
||
458 | |||
459 | sub stty_echoe { |
||
460 | my $self = shift; |
||
461 | if (@_ == 1) { $self->{echoe} = yes_true ( shift ) } |
||
462 | return if (@_); |
||
463 | return $self->{echoe}; |
||
464 | } |
||
465 | |||
466 | sub stty_echok { |
||
467 | my $self = shift; |
||
468 | if (@_ == 1) { $self->{echok} = yes_true ( shift ) } |
||
469 | return if (@_); |
||
470 | return $self->{echok}; |
||
471 | } |
||
472 | |||
473 | sub stty_echonl { |
||
474 | my $self = shift; |
||
475 | if (@_ == 1) { $self->{echonl} = yes_true ( shift ) } |
||
476 | return if (@_); |
||
477 | return $self->{echonl}; |
||
478 | } |
||
479 | |||
480 | sub stty_echoke { |
||
481 | my $self = shift; |
||
482 | if (@_ == 1) { $self->{echoke} = yes_true ( shift ) } |
||
483 | return if (@_); |
||
484 | return $self->{echoke}; |
||
485 | } |
||
486 | |||
487 | sub stty_echoctl { |
||
488 | my $self = shift; |
||
489 | if (@_ == 1) { $self->{echoctl} = yes_true ( shift ) } |
||
490 | return if (@_); |
||
491 | return $self->{echoctl}; |
||
492 | } |
||
493 | |||
494 | sub stty_istrip { |
||
495 | my $self = shift; |
||
496 | if (@_ == 1) { $self->{istrip} = yes_true ( shift ) } |
||
497 | return if (@_); |
||
498 | return $self->{istrip}; |
||
499 | } |
||
500 | |||
501 | sub stty_icrnl { |
||
502 | my $self = shift; |
||
503 | if (@_ == 1) { $self->{icrnl} = yes_true ( shift ) } |
||
504 | return if (@_); |
||
505 | return $self->{icrnl}; |
||
506 | } |
||
507 | |||
508 | sub stty_ocrnl { |
||
509 | my $self = shift; |
||
510 | if (@_ == 1) { $self->{ocrnl} = yes_true ( shift ) } |
||
511 | return if (@_); |
||
512 | return $self->{ocrnl}; |
||
513 | } |
||
514 | |||
515 | sub stty_opost { |
||
516 | my $self = shift; |
||
517 | if (@_ == 1) { $self->{opost} = yes_true ( shift ) } |
||
518 | return if (@_); |
||
519 | return $self->{opost}; |
||
520 | } |
||
521 | |||
522 | sub stty_igncr { |
||
523 | my $self = shift; |
||
524 | if (@_ == 1) { $self->{igncr} = yes_true ( shift ) } |
||
525 | return if (@_); |
||
526 | return $self->{igncr}; |
||
527 | } |
||
528 | |||
529 | sub stty_inlcr { |
||
530 | my $self = shift; |
||
531 | if (@_ == 1) { $self->{inlcr} = yes_true ( shift ) } |
||
532 | return if (@_); |
||
533 | return $self->{inlcr}; |
||
534 | } |
||
535 | |||
536 | sub stty_onlcr { |
||
537 | my $self = shift; |
||
538 | if (@_ == 1) { $self->{onlcr} = yes_true ( shift ) } |
||
539 | return if (@_); |
||
540 | return $self->{onlcr}; |
||
541 | } |
||
542 | |||
543 | sub stty_isig { |
||
544 | my $self = shift; |
||
545 | if (@_ == 1) { $self->{isig} = yes_true ( shift ) } |
||
546 | return if (@_); |
||
547 | return $self->{isig}; |
||
548 | } |
||
549 | |||
550 | sub stty_icanon { |
||
551 | my $self = shift; |
||
552 | if (@_ == 1) { $self->{icanon} = yes_true ( shift ) } |
||
553 | return if (@_); |
||
554 | return $self->{icanon}; |
||
555 | } |
||
556 | |||
557 | sub is_prompt { |
||
558 | my $self = shift; |
||
559 | if (@_ == 1) { $self->{"_PROMPT"} = shift; } |
||
560 | return if (@_); |
||
561 | return $self->{"_PROMPT"}; |
||
562 | } |
||
563 | |||
564 | sub are_match { |
||
565 | my $self = shift; |
||
566 | my $pat; |
||
567 | my $patno = 0; |
||
568 | my $reno = 0; |
||
569 | my $re_next = 0; |
||
570 | if (@_) { |
||
571 | @{ $self->{"_MATCH"} } = @_; |
||
572 | if ($] >= 5.005) { |
||
573 | @{ $self->{"_CMATCH"} } = (); |
||
574 | while ($pat = shift) { |
||
575 | if ($re_next) { |
||
576 | $re_next = 0; |
||
577 | eval 'push (@{ $self->{"_CMATCH"} }, qr/$pat/)'; |
||
578 | } else { |
||
579 | push (@{ $self->{"_CMATCH"} }, $pat); |
||
580 | } |
||
581 | if ($pat eq "-re") { |
||
582 | $re_next++; |
||
583 | } |
||
584 | } |
||
585 | } else { |
||
586 | @{ $self->{"_CMATCH"} } = @_; |
||
587 | } |
||
588 | } |
||
589 | return @{ $self->{"_MATCH"} }; |
||
590 | } |
||
591 | |||
592 | |||
593 | # parse values for start/restart |
||
594 | sub get_start_values { |
||
595 | return unless (@_ == 2); |
||
596 | my $self = shift; |
||
597 | my $filename = shift; |
||
598 | |||
599 | unless ( open CF, "<$filename" ) { |
||
600 | carp "can't open file: $filename"; |
||
601 | return; |
||
602 | } |
||
603 | my ($signature, $name, @values) = <CF>; |
||
604 | close CF; |
||
605 | |||
606 | unless ( $cfg_file_sig eq $signature ) { |
||
607 | carp "Invalid signature in $filename: $signature"; |
||
608 | return; |
||
609 | } |
||
610 | chomp $name; |
||
611 | unless ( $self->{DEVICE} eq $name ) { |
||
612 | carp "Invalid Port DEVICE=$self->{DEVICE} in $filename: $name"; |
||
613 | return; |
||
614 | } |
||
615 | if ($Verbose or not $self) { |
||
616 | print "signature = $signature"; |
||
617 | print "name = $name\n"; |
||
618 | if ($Verbose) { |
||
619 | print "values:\n"; |
||
620 | foreach (@values) { print " $_"; } |
||
621 | } |
||
622 | } |
||
623 | my $item; |
||
624 | my $key; |
||
625 | my $value; |
||
626 | my $gosub; |
||
627 | my $fault = 0; |
||
628 | no strict 'refs'; # for $gosub |
||
629 | foreach $item (@values) { |
||
630 | chomp $item; |
||
631 | ($key, $value) = split (/,/, $item); |
||
632 | if ($value eq "") { $fault++ } |
||
633 | else { |
||
634 | $gosub = $validate{$key}; |
||
635 | unless (defined &$gosub ($self, $value)) { |
||
636 | carp "Invalid parameter for $key=$value "; |
||
637 | return; |
||
638 | } |
||
639 | } |
||
640 | } |
||
641 | use strict 'refs'; |
||
642 | if ($fault) { |
||
643 | carp "Invalid value in $filename"; |
||
644 | undef $self; |
||
645 | return; |
||
646 | } |
||
647 | 1; |
||
648 | } |
||
649 | |||
650 | sub restart { |
||
651 | return unless (@_ == 2); |
||
652 | my $self = shift; |
||
653 | my $filename = shift; |
||
654 | |||
655 | unless ( $self->init_done ) { |
||
656 | carp "Can't restart before Port has been initialized"; |
||
657 | return; |
||
658 | } |
||
659 | get_start_values($self, $filename); |
||
660 | write_settings($self); |
||
661 | } |
||
662 | |||
663 | sub start { |
||
664 | my $proto = shift; |
||
665 | my $class = ref($proto) || $proto; |
||
666 | |||
667 | return unless (@_); |
||
668 | my $filename = shift; |
||
669 | |||
670 | unless ( open CF, "<$filename" ) { |
||
671 | carp "can't open file: $filename"; |
||
672 | return; |
||
673 | } |
||
674 | my ($signature, $name, @values) = <CF>; |
||
675 | close CF; |
||
676 | |||
677 | unless ( $cfg_file_sig eq $signature ) { |
||
678 | carp "Invalid signature in $filename: $signature"; |
||
679 | return; |
||
680 | } |
||
681 | chomp $name; |
||
682 | my $self = new ($class, $name); |
||
683 | if ($Verbose or not $self) { |
||
684 | print "signature = $signature"; |
||
685 | print "class = $class\n"; |
||
686 | print "name = $name\n"; |
||
687 | if ($Verbose) { |
||
688 | print "values:\n"; |
||
689 | foreach (@values) { print " $_"; } |
||
690 | } |
||
691 | } |
||
692 | if ($self) { |
||
693 | if ( get_start_values($self, $filename) ) { |
||
694 | write_settings ($self); |
||
695 | } |
||
696 | else { |
||
697 | carp "Invalid value in $filename"; |
||
698 | undef $self; |
||
699 | return; |
||
700 | } |
||
701 | } |
||
702 | return $self; |
||
703 | } |
||
704 | |||
705 | sub write_settings { |
||
706 | my $self = shift; |
||
707 | my @items = keys %validate; |
||
708 | |||
709 | # initialize returns number of faults |
||
710 | if ( $self->initialize(@items) ) { |
||
711 | unless (nocarp) { |
||
712 | carp "write_settings failed, closing port"; |
||
713 | $self->close; |
||
714 | } |
||
715 | return; |
||
716 | } |
||
717 | |||
718 | $self->update_DCB; |
||
719 | if ($Verbose) { |
||
720 | print "writing settings to $self->{ALIAS}\n"; |
||
721 | } |
||
722 | 1; |
||
723 | } |
||
724 | |||
725 | sub save { |
||
726 | my $self = shift; |
||
727 | my $item; |
||
728 | my $getsub; |
||
729 | my $value; |
||
730 | |||
731 | return unless (@_); |
||
732 | unless ($self->init_done) { |
||
733 | carp "can't save until init_done"; |
||
734 | return; |
||
735 | } |
||
736 | |||
737 | my $filename = shift; |
||
738 | unless ( open CF, ">$filename" ) { |
||
739 | carp "can't open file: $filename"; |
||
740 | return; |
||
741 | } |
||
742 | print CF "$cfg_file_sig"; |
||
743 | print CF "$self->{DEVICE}\n"; |
||
744 | # used to "reopen" so must be DEVICE=NAME |
||
745 | |||
746 | no strict 'refs'; # for $gosub |
||
747 | while (($item, $getsub) = each %validate) { |
||
748 | chomp $getsub; |
||
749 | $value = scalar &$getsub($self); |
||
750 | print CF "$item,$value\n"; |
||
751 | } |
||
752 | use strict 'refs'; |
||
753 | close CF; |
||
754 | if ($Verbose) { |
||
755 | print "wrote file $filename for $self->{ALIAS}\n"; |
||
756 | } |
||
757 | 1; |
||
758 | } |
||
759 | |||
760 | ##### tied FileHandle support |
||
761 | |||
762 | sub TIEHANDLE { |
||
763 | my $proto = shift; |
||
764 | my $class = ref($proto) || $proto; |
||
765 | |||
766 | return unless (@_); |
||
767 | |||
768 | my $self = start($class, shift); |
||
769 | return $self; |
||
770 | } |
||
771 | |||
772 | # WRITE this, LIST |
||
773 | # This method will be called when the handle is written to via the |
||
774 | # syswrite function. |
||
775 | |||
776 | sub WRITE { |
||
777 | return if (@_ < 3); |
||
778 | my $self = shift; |
||
779 | my $buf = shift; |
||
780 | my $len = shift; |
||
781 | my $offset = 0; |
||
782 | if (@_) { $offset = shift; } |
||
783 | my $out2 = substr($buf, $offset, $len); |
||
784 | return unless ($self->post_print($out2)); |
||
785 | return length($out2); |
||
786 | } |
||
787 | |||
788 | # PRINT this, LIST |
||
789 | # This method will be triggered every time the tied handle is printed to |
||
790 | # with the print() function. Beyond its self reference it also expects |
||
791 | # the list that was passed to the print function. |
||
792 | |||
793 | sub PRINT { |
||
794 | my $self = shift; |
||
795 | return unless (@_); |
||
796 | my $ofs = $, ? $, : ""; |
||
797 | if ($self->{OFS}) { $ofs = $self->{OFS}; } |
||
798 | my $ors = $\ ? $\ : ""; |
||
799 | if ($self->{ORS}) { $ors = $self->{ORS}; } |
||
800 | my $output = join($ofs,@_); |
||
801 | $output .= $ors; |
||
802 | return $self->post_print($output); |
||
803 | } |
||
804 | |||
805 | sub output_field_separator { |
||
806 | my $self = shift; |
||
807 | my $prev = $self->{OFS}; |
||
808 | if (@_) { $self->{OFS} = shift; } |
||
809 | return $prev; |
||
810 | } |
||
811 | |||
812 | sub output_record_separator { |
||
813 | my $self = shift; |
||
814 | my $prev = $self->{ORS}; |
||
815 | if (@_) { $self->{ORS} = shift; } |
||
816 | return $prev; |
||
817 | } |
||
818 | |||
819 | sub post_print { |
||
820 | my $self = shift; |
||
821 | return unless (@_); |
||
822 | my $output = shift; |
||
823 | if ($self->stty_opost) { |
||
824 | if ($self->stty_ocrnl) { $output =~ s/\r/\n/osg; } |
||
825 | if ($self->stty_onlcr) { $output =~ s/\n/\r\n/osg; } |
||
826 | } |
||
827 | my $to_do = length($output); |
||
828 | my $done = 0; |
||
829 | my $written = 0; |
||
830 | while ($done < $to_do) { |
||
831 | my $out2 = substr($output, $done); |
||
832 | $written = $self->write($out2); |
||
833 | if (! defined $written) { |
||
834 | $^E = 1121; # ERROR_COUNTER_TIMEOUT |
||
835 | return; |
||
836 | } |
||
837 | return 0 unless ($written); |
||
838 | $done += $written; |
||
839 | } |
||
840 | $^E = 0; |
||
841 | 1; |
||
842 | } |
||
843 | |||
844 | # PRINTF this, LIST |
||
845 | # This method will be triggered every time the tied handle is printed to |
||
846 | # with the printf() function. Beyond its self reference it also expects |
||
847 | # the format and list that was passed to the printf function. |
||
848 | |||
849 | sub PRINTF { |
||
850 | my $self = shift; |
||
851 | my $fmt = shift; |
||
852 | return unless ($fmt); |
||
853 | return unless (@_); |
||
854 | my $output = sprintf($fmt, @_); |
||
855 | $self->PRINT($output); |
||
856 | } |
||
857 | |||
858 | # READ this, LIST |
||
859 | # This method will be called when the handle is read from via the read |
||
860 | # or sysread functions. |
||
861 | |||
862 | sub READ { |
||
863 | return if (@_ < 3); |
||
864 | my $buf = \$_[1]; |
||
865 | my ($self, $junk, $len, $offset) = @_; |
||
866 | unless (defined $offset) { $offset = 0; } |
||
867 | my $done = 0; |
||
868 | my $count_in = 0; |
||
869 | my $string_in = ""; |
||
870 | my $in2 = ""; |
||
871 | my $bufsize = $self->internal_buffer; |
||
872 | |||
873 | while ($done < $len) { |
||
874 | my $size = $len - $done; |
||
875 | if ($size > $bufsize) { $size = $bufsize; } |
||
876 | ($count_in, $string_in) = $self->read($size); |
||
877 | if ($count_in) { |
||
878 | $in2 .= $string_in; |
||
879 | $done += $count_in; |
||
880 | $^E = 0; |
||
881 | } |
||
882 | elsif ($done) { |
||
883 | $^E = 0; |
||
884 | last; |
||
885 | } |
||
886 | else { |
||
887 | $^E = 1121; # ERROR_COUNTER_TIMEOUT |
||
888 | last; |
||
889 | } |
||
890 | } |
||
891 | my $tail = substr($$buf, $offset + $done); |
||
892 | my $head = substr($$buf, 0, $offset); |
||
893 | if ($self->{icrnl}) { $in2 =~ tr/\r/\n/; } |
||
894 | if ($self->{inlcr}) { $in2 =~ tr/\n/\r/; } |
||
895 | if ($self->{igncr}) { $in2 =~ s/\r//gos; } |
||
896 | $$buf = $head.$in2.$tail; |
||
897 | return $done if ($done); |
||
898 | return; |
||
899 | } |
||
900 | |||
901 | # READLINE this |
||
902 | # This method will be called when the handle is read from via <HANDLE>. |
||
903 | # The method should return undef when there is no more data. |
||
904 | |||
905 | sub READLINE { |
||
906 | my $self = shift; |
||
907 | return if (@_); |
||
908 | my $gotit = ""; |
||
909 | my $match = ""; |
||
910 | my $was; |
||
911 | |||
912 | if (wantarray) { |
||
913 | my @lines; |
||
914 | for (;;) { |
||
915 | $was = $self->reset_error; |
||
916 | if ($was) { |
||
917 | $^E = 1117; # ERROR_IO_DEVICE |
||
918 | return @lines if (@lines); |
||
919 | return; |
||
920 | } |
||
921 | if (! defined ($gotit = $self->streamline($self->{"_SIZE"}))) { |
||
922 | $^E = 1121; # ERROR_COUNTER_TIMEOUT |
||
923 | return @lines if (@lines); |
||
924 | return; |
||
925 | } |
||
926 | $match = $self->matchclear; |
||
927 | if ( ($gotit ne "") || ($match ne "") ) { |
||
928 | $^E = 0; |
||
929 | $gotit .= $match; |
||
930 | push (@lines, $gotit); |
||
931 | return @lines if ($gotit =~ /$self->{"_CLASTLINE"}/s); |
||
932 | } |
||
933 | } |
||
934 | } |
||
935 | else { |
||
936 | for (;;) { |
||
937 | $was = $self->reset_error; |
||
938 | if ($was) { |
||
939 | $^E = 1117; # ERROR_IO_DEVICE |
||
940 | return; |
||
941 | } |
||
942 | if (! defined ($gotit = $self->lookfor($self->{"_SIZE"}))) { |
||
943 | $^E = 1121; # ERROR_COUNTER_TIMEOUT |
||
944 | return; |
||
945 | } |
||
946 | $match = $self->matchclear; |
||
947 | if ( ($gotit ne "") || ($match ne "") ) { |
||
948 | $^E = 0; |
||
949 | return $gotit.$match; # traditional <HANDLE> behavior |
||
950 | } |
||
951 | } |
||
952 | } |
||
953 | } |
||
954 | |||
955 | # GETC this |
||
956 | # This method will be called when the getc function is called. |
||
957 | |||
958 | sub GETC { |
||
959 | my $self = shift; |
||
960 | my ($count, $in) = $self->read(1); |
||
961 | if ($count == 1) { |
||
962 | $^E = 0; |
||
963 | return $in; |
||
964 | } |
||
965 | else { |
||
966 | $^E = 1121; # ERROR_COUNTER_TIMEOUT |
||
967 | return; |
||
968 | } |
||
969 | } |
||
970 | |||
971 | # CLOSE this |
||
972 | # This method will be called when the handle is closed via the close |
||
973 | # function. |
||
974 | |||
975 | sub CLOSE { |
||
976 | my $self = shift; |
||
977 | my $success = $self->close; |
||
978 | if ($Verbose) { printf "CLOSE result:%d\n", $success; } |
||
979 | return $success; |
||
980 | } |
||
981 | |||
982 | # DESTROY this |
||
983 | # As with the other types of ties, this method will be called when the |
||
984 | # tied handle is about to be destroyed. This is useful for debugging and |
||
985 | # possibly cleaning up. |
||
986 | |||
987 | sub DESTROY { |
||
988 | my $self = shift; |
||
989 | if ($Verbose) { print "SerialPort::DESTROY called.\n"; } |
||
990 | $self->SUPER::DESTROY(); |
||
991 | } |
||
992 | |||
993 | ############### |
||
994 | |||
995 | sub alias { |
||
996 | my $self = shift; |
||
997 | if (@_) { $self->{ALIAS} = shift; } # should return true for legal names |
||
998 | return $self->{ALIAS}; |
||
999 | } |
||
1000 | |||
1001 | sub user_msg { |
||
1002 | my $self = shift; |
||
1003 | if (@_) { $self->{U_MSG} = yes_true ( shift ) } |
||
1004 | return wantarray ? @binary_opt : $self->{U_MSG}; |
||
1005 | } |
||
1006 | |||
1007 | sub error_msg { |
||
1008 | my $self = shift; |
||
1009 | if (@_) { $self->{E_MSG} = yes_true ( shift ) } |
||
1010 | return wantarray ? @binary_opt : $self->{E_MSG}; |
||
1011 | } |
||
1012 | |||
1013 | sub devicetype { |
||
1014 | my $self = shift; |
||
1015 | if (@_) { $self->{DVTYPE} = shift; } # return true for legal names |
||
1016 | return $self->{DVTYPE}; |
||
1017 | } |
||
1018 | |||
1019 | sub hostname { |
||
1020 | my $self = shift; |
||
1021 | if (@_) { $self->{HNAME} = shift; } # return true for legal names |
||
1022 | return $self->{HNAME}; |
||
1023 | } |
||
1024 | |||
1025 | sub hostaddr { |
||
1026 | my $self = shift; |
||
1027 | if (@_) { $self->{HADDR} = shift; } # return true for assigned port |
||
1028 | return $self->{HADDR}; |
||
1029 | } |
||
1030 | |||
1031 | sub datatype { |
||
1032 | my $self = shift; |
||
1033 | if (@_) { $self->{DATYPE} = shift; } # return true for legal types |
||
1034 | return $self->{DATYPE}; |
||
1035 | } |
||
1036 | |||
1037 | sub cfg_param_1 { |
||
1038 | my $self = shift; |
||
1039 | if (@_) { $self->{CFG_1} = shift; } # return true for legal param |
||
1040 | return $self->{CFG_1}; |
||
1041 | } |
||
1042 | |||
1043 | sub cfg_param_2 { |
||
1044 | my $self = shift; |
||
1045 | if (@_) { $self->{CFG_2} = shift; } # return true for legal param |
||
1046 | return $self->{CFG_2}; |
||
1047 | } |
||
1048 | |||
1049 | sub cfg_param_3 { |
||
1050 | my $self = shift; |
||
1051 | if (@_) { $self->{CFG_3} = shift; } # return true for legal param |
||
1052 | return $self->{CFG_3}; |
||
1053 | } |
||
1054 | |||
1055 | sub baudrate { |
||
1056 | my $self = shift; |
||
1057 | if (@_) { |
||
1058 | unless ( defined $self->is_baudrate( shift ) ) { |
||
1059 | if ($self->{U_MSG} or $Verbose) { |
||
1060 | carp "Could not set baudrate on $self->{ALIAS}"; |
||
1061 | } |
||
1062 | return; |
||
1063 | } |
||
1064 | } |
||
1065 | return wantarray ? $self->are_baudrate : $self->is_baudrate; |
||
1066 | } |
||
1067 | |||
1068 | sub status { |
||
1069 | my $self = shift; |
||
1070 | my $ok = 0; |
||
1071 | my $fmask = 0; |
||
1072 | my $v1 = $Verbose | $self->{"_DEBUG"}; |
||
1073 | my $v2 = $v1 | $self->{U_MSG}; |
||
1074 | my $v3 = $v1 | $self->{E_MSG}; |
||
1075 | |||
1076 | my @stat = $self->is_status; |
||
1077 | return unless (scalar @stat); |
||
1078 | $fmask=$stat[ST_BLOCK]; |
||
1079 | if ($v1) { printf "BlockingFlags= %lx\n", $fmask; } |
||
1080 | if ($v2 && $fmask) { |
||
1081 | printf "Waiting for CTS\n" if ($fmask & BM_fCtsHold); |
||
1082 | printf "Waiting for DSR\n" if ($fmask & BM_fDsrHold); |
||
1083 | printf "Waiting for RLSD\n" if ($fmask & BM_fRlsdHold); |
||
1084 | printf "Waiting for XON\n" if ($fmask & BM_fXoffHold); |
||
1085 | printf "Waiting, XOFF was sent\n" if ($fmask & BM_fXoffSent); |
||
1086 | printf "End_of_File received\n" if ($fmask & BM_fEof); |
||
1087 | printf "Character waiting to TX\n" if ($fmask & BM_fTxim); |
||
1088 | } |
||
1089 | $fmask=$stat[ST_ERROR]; |
||
1090 | if ($v1) { printf "Error_BitMask= %lx\n", $fmask; } |
||
1091 | if ($v3 && $fmask) { |
||
1092 | # only prints if error is new (API resets each call) |
||
1093 | printf "Invalid MODE or bad HANDLE\n" if ($fmask & CE_MODE); |
||
1094 | printf "Receive Overrun detected\n" if ($fmask & CE_RXOVER); |
||
1095 | printf "Buffer Overrun detected\n" if ($fmask & CE_OVERRUN); |
||
1096 | printf "Parity Error detected\n" if ($fmask & CE_RXPARITY); |
||
1097 | printf "Framing Error detected\n" if ($fmask & CE_FRAME); |
||
1098 | printf "Break Signal detected\n" if ($fmask & CE_BREAK); |
||
1099 | printf "Transmit Buffer is full\n" if ($fmask & CE_TXFULL); |
||
1100 | } |
||
1101 | return @stat; |
||
1102 | } |
||
1103 | |||
1104 | sub handshake { |
||
1105 | my $self = shift; |
||
1106 | if (@_) { |
||
1107 | unless ( $self->is_handshake(shift) ) { |
||
1108 | if ($self->{U_MSG} or $Verbose) { |
||
1109 | carp "Could not set handshake on $self->{ALIAS}"; |
||
1110 | } |
||
1111 | return; |
||
1112 | } |
||
1113 | } |
||
1114 | return wantarray ? $self->are_handshake : $self->is_handshake; |
||
1115 | } |
||
1116 | |||
1117 | sub parity { |
||
1118 | my $self = shift; |
||
1119 | if (@_) { |
||
1120 | unless ( $self->is_parity(shift) ) { |
||
1121 | if ($self->{U_MSG} or $Verbose) { |
||
1122 | carp "Could not set parity on $self->{ALIAS}"; |
||
1123 | } |
||
1124 | return; |
||
1125 | } |
||
1126 | } |
||
1127 | return wantarray ? $self->are_parity : $self->is_parity; |
||
1128 | } |
||
1129 | |||
1130 | sub databits { |
||
1131 | my $self = shift; |
||
1132 | if (@_) { |
||
1133 | unless ( $self->is_databits(shift) ) { |
||
1134 | if ($self->{U_MSG} or $Verbose) { |
||
1135 | carp "Could not set databits on $self->{ALIAS}"; |
||
1136 | } |
||
1137 | return; |
||
1138 | } |
||
1139 | } |
||
1140 | return wantarray ? $self->are_databits : $self->is_databits; |
||
1141 | } |
||
1142 | |||
1143 | sub stopbits { |
||
1144 | my $self = shift; |
||
1145 | if (@_) { |
||
1146 | unless ( $self->is_stopbits(shift) ) { |
||
1147 | if ($self->{U_MSG} or $Verbose) { |
||
1148 | carp "Could not set stopbits on $self->{ALIAS}"; |
||
1149 | } |
||
1150 | return; |
||
1151 | } |
||
1152 | } |
||
1153 | return wantarray ? $self->are_stopbits : $self->is_stopbits; |
||
1154 | } |
||
1155 | |||
1156 | # single value for save/start |
||
1157 | sub set_read_buf { |
||
1158 | my $self = shift; |
||
1159 | if (@_) { |
||
1160 | return unless (@_ == 1); |
||
1161 | my $rbuf = int shift; |
||
1162 | return unless (($rbuf > 0) and ($rbuf <= $self->{MAX_RXB})); |
||
1163 | $self->is_read_buf($rbuf); |
||
1164 | } |
||
1165 | return $self->is_read_buf; |
||
1166 | } |
||
1167 | |||
1168 | # single value for save/start |
||
1169 | sub set_write_buf { |
||
1170 | my $self = shift; |
||
1171 | if (@_) { |
||
1172 | return unless (@_ == 1); |
||
1173 | my $wbuf = int shift; |
||
1174 | return unless (($wbuf >= 0) and ($wbuf <= $self->{MAX_TXB})); |
||
1175 | $self->is_write_buf($wbuf); |
||
1176 | } |
||
1177 | return $self->is_write_buf; |
||
1178 | } |
||
1179 | |||
1180 | sub buffers { |
||
1181 | my $self = shift; |
||
1182 | |||
1183 | if (@_ == 2) { |
||
1184 | my $rbuf = shift; |
||
1185 | my $wbuf = shift; |
||
1186 | unless (defined set_read_buf ($self, $rbuf)) { |
||
1187 | if ($self->{U_MSG} or $Verbose) { |
||
1188 | carp "Can't set read buffer on $self->{ALIAS}"; |
||
1189 | } |
||
1190 | return; |
||
1191 | } |
||
1192 | unless (defined set_write_buf ($self, $wbuf)) { |
||
1193 | if ($self->{U_MSG} or $Verbose) { |
||
1194 | carp "Can't set write buffer on $self->{ALIAS}"; |
||
1195 | } |
||
1196 | return; |
||
1197 | } |
||
1198 | $self->is_buffers($rbuf, $wbuf) || return; |
||
1199 | } |
||
1200 | elsif (@_) { return; } |
||
1201 | return wantarray ? $self->are_buffers : 1; |
||
1202 | } |
||
1203 | |||
1204 | sub read { |
||
1205 | return unless (@_ == 2); |
||
1206 | my $self = shift; |
||
1207 | my $wanted = shift; |
||
1208 | my $ok = 0; |
||
1209 | my $result = ""; |
||
1210 | return unless ($wanted > 0); |
||
1211 | |||
1212 | my $got = $self->read_bg ($wanted); |
||
1213 | |||
1214 | if ($got != $wanted) { |
||
1215 | ($ok, $got, $result) = $self->read_done(1); # block until done |
||
1216 | } |
||
1217 | else { ($ok, $got, $result) = $self->read_done(0); } |
||
1218 | print "read=$got\n" if ($Verbose); |
||
1219 | return ($got, $result); |
||
1220 | } |
||
1221 | |||
1222 | sub lookclear { |
||
1223 | my $self = shift; |
||
1224 | if (nocarp && (@_ == 1)) { |
||
1225 | $self->{"_T_INPUT"} = shift; |
||
1226 | } |
||
1227 | $self->{"_LOOK"} = ""; |
||
1228 | $self->{"_LASTLOOK"} = ""; |
||
1229 | $self->{"_LMATCH"} = ""; |
||
1230 | $self->{"_LPATT"} = ""; |
||
1231 | return if (@_); |
||
1232 | 1; |
||
1233 | } |
||
1234 | |||
1235 | sub linesize { |
||
1236 | my $self = shift; |
||
1237 | if (@_) { |
||
1238 | my $val = int shift; |
||
1239 | return if ($val < 0); |
||
1240 | $self->{"_SIZE"} = $val; |
||
1241 | } |
||
1242 | return $self->{"_SIZE"}; |
||
1243 | } |
||
1244 | |||
1245 | sub lastline { |
||
1246 | my $self = shift; |
||
1247 | if (@_) { |
||
1248 | $self->{"_LASTLINE"} = shift; |
||
1249 | if ($] >= 5.005) { |
||
1250 | eval '$self->{"_CLASTLINE"} = qr/$self->{"_LASTLINE"}/'; |
||
1251 | } else { |
||
1252 | $self->{"_CLASTLINE"} = $self->{"_LASTLINE"}; |
||
1253 | } |
||
1254 | } |
||
1255 | return $self->{"_LASTLINE"}; |
||
1256 | } |
||
1257 | |||
1258 | sub matchclear { |
||
1259 | my $self = shift; |
||
1260 | my $found = $self->{"_LMATCH"}; |
||
1261 | $self->{"_LMATCH"} = ""; |
||
1262 | return if (@_); |
||
1263 | return $found; |
||
1264 | } |
||
1265 | |||
1266 | sub lastlook { |
||
1267 | my $self = shift; |
||
1268 | return if (@_); |
||
1269 | return ( $self->{"_LMATCH"}, $self->{"_LASTLOOK"}, |
||
1270 | $self->{"_LPATT"}, $self->{"_LOOK"} ); |
||
1271 | } |
||
1272 | |||
1273 | sub lookfor { |
||
1274 | my $self = shift; |
||
1275 | my $size = 0; |
||
1276 | if (@_) { $size = shift; } |
||
1277 | my $loc = ""; |
||
1278 | my $count_in = 0; |
||
1279 | my $string_in = ""; |
||
1280 | $self->{"_LMATCH"} = ""; |
||
1281 | $self->{"_LPATT"} = ""; |
||
1282 | |||
1283 | if ( ! $self->{"_LOOK"} ) { |
||
1284 | $loc = $self->{"_LASTLOOK"}; |
||
1285 | } |
||
1286 | |||
1287 | if ($size) { |
||
1288 | my ($bbb, $iii, $ooo, $eee) = status($self); |
||
1289 | if ($iii > $size) { $size = $iii; } |
||
1290 | ($count_in, $string_in) = $self->read($size); |
||
1291 | return unless ($count_in); |
||
1292 | $loc .= $string_in; |
||
1293 | } |
||
1294 | else { |
||
1295 | $loc .= $self->input; |
||
1296 | } |
||
1297 | |||
1298 | if ($loc ne "") { |
||
1299 | if ($self->{icrnl}) { $loc =~ tr/\r/\n/; } |
||
1300 | my $n_char; |
||
1301 | my $mpos; |
||
1302 | my $erase_is_bsdel = 0; |
||
1303 | my $nl_after_kill = ""; |
||
1304 | my $clear_after_kill = 0; |
||
1305 | my $echo_ctl = 0; |
||
1306 | my $lookbuf; |
||
1307 | my $re_next = 0; |
||
1308 | my $got_match = 0; |
||
1309 | my $pat; |
||
1310 | my $lf_erase = ""; |
||
1311 | my $lf_kill = ""; |
||
1312 | my $lf_eof = ""; |
||
1313 | my $lf_quit = ""; |
||
1314 | my $lf_intr = ""; |
||
1315 | my $nl_2_crnl = 0; |
||
1316 | my $cr_2_nl = 0; |
||
1317 | |||
1318 | if ($self->{opost}) { |
||
1319 | $nl_2_crnl = $self->{onlcr}; |
||
1320 | $cr_2_nl = $self->{ocrnl}; |
||
1321 | } |
||
1322 | |||
1323 | if ($self->{echo}) { |
||
1324 | $erase_is_bsdel = $self->{echoe}; |
||
1325 | if ($self->{echok}) { |
||
1326 | $nl_after_kill = $self->{onlcr} ? "\r\n" : "\n"; |
||
1327 | } |
||
1328 | $clear_after_kill = $self->{echoke}; |
||
1329 | $echo_ctl = $self->{echoctl}; |
||
1330 | } |
||
1331 | |||
1332 | if ($self->{icanon}) { |
||
1333 | $lf_erase = $self->{erase}; |
||
1334 | $lf_kill = $self->{s_kill}; |
||
1335 | $lf_eof = $self->{s_eof}; |
||
1336 | } |
||
1337 | |||
1338 | if ($self->{isig}) { |
||
1339 | $lf_quit = $self->{quit}; |
||
1340 | $lf_intr = $self->{intr}; |
||
1341 | } |
||
1342 | |||
1343 | my @loc_char = split (//, $loc); |
||
1344 | while (defined ($n_char = shift @loc_char)) { |
||
1345 | ## printf STDERR "0x%x ", ord($n_char); |
||
1346 | if ($n_char eq $lf_erase) { |
||
1347 | if ($erase_is_bsdel && (length $self->{"_LOOK"}) ) { |
||
1348 | $mpos = chop $self->{"_LOOK"}; |
||
1349 | $self->write($self->{bsdel}); |
||
1350 | if ($echo_ctl && (($mpos lt "@")|($mpos eq chr(127)))) { |
||
1351 | $self->write($self->{bsdel}); |
||
1352 | } |
||
1353 | } |
||
1354 | } |
||
1355 | elsif ($n_char eq $lf_kill) { |
||
1356 | $self->{"_LOOK"} = ""; |
||
1357 | $self->write($self->{clear}) if ($clear_after_kill); |
||
1358 | $self->write($nl_after_kill); |
||
1359 | $self->write($self->{"_PROMPT"}); |
||
1360 | } |
||
1361 | elsif ($n_char eq $lf_intr) { |
||
1362 | $self->{"_LOOK"} = ""; |
||
1363 | $self->{"_LASTLOOK"} = ""; |
||
1364 | return; |
||
1365 | } |
||
1366 | elsif ($n_char eq $lf_quit) { |
||
1367 | exit; |
||
1368 | } |
||
1369 | else { |
||
1370 | $mpos = ord $n_char; |
||
1371 | if ($self->{istrip}) { |
||
1372 | if ($mpos > 127) { $n_char = chr($mpos - 128); } |
||
1373 | } |
||
1374 | $self->{"_LOOK"} .= $n_char; |
||
1375 | ## print $n_char; |
||
1376 | if ($cr_2_nl) { $n_char =~ s/\r/\n/os; } |
||
1377 | if ($nl_2_crnl) { $n_char =~ s/\n/\r\n/os; } |
||
1378 | if (($mpos < 32) && $echo_ctl && |
||
1379 | ($mpos != is_stty_eol($self))) { |
||
1380 | $n_char = chr($mpos + 64); |
||
1381 | $self->write("^$n_char"); |
||
1382 | } |
||
1383 | elsif (($mpos == 127) && $echo_ctl) { |
||
1384 | $self->write("^."); |
||
1385 | } |
||
1386 | elsif ($self->{echonl} && ($n_char =~ "\n")) { |
||
1387 | # also writes "\r\n" for onlcr |
||
1388 | $self->write($n_char); |
||
1389 | } |
||
1390 | elsif ($self->{echo}) { |
||
1391 | # also writes "\r\n" for onlcr |
||
1392 | $self->write($n_char); |
||
1393 | } |
||
1394 | $lookbuf = $self->{"_LOOK"}; |
||
1395 | if (($lf_eof ne "") and ($lookbuf =~ /$lf_eof$/)) { |
||
1396 | $self->{"_LOOK"} = ""; |
||
1397 | $self->{"_LASTLOOK"} = ""; |
||
1398 | return $lookbuf; |
||
1399 | } |
||
1400 | $count_in = 0; |
||
1401 | foreach $pat ( @{ $self->{"_CMATCH"} } ) { |
||
1402 | if ($pat eq "-re") { |
||
1403 | $re_next++; |
||
1404 | $count_in++; |
||
1405 | next; |
||
1406 | } |
||
1407 | if ($re_next) { |
||
1408 | $re_next = 0; |
||
1409 | # always at $lookbuf end when processing single char |
||
1410 | if ( $lookbuf =~ s/$pat//s ) { |
||
1411 | $self->{"_LMATCH"} = $&; |
||
1412 | $got_match++; |
||
1413 | } |
||
1414 | } |
||
1415 | elsif (($mpos = index($lookbuf, $pat)) > -1) { |
||
1416 | $got_match++; |
||
1417 | $lookbuf = substr ($lookbuf, 0, $mpos); |
||
1418 | $self->{"_LMATCH"} = $pat; |
||
1419 | } |
||
1420 | if ($got_match) { |
||
1421 | $self->{"_LPATT"} = $self->{"_MATCH"}[$count_in]; |
||
1422 | if (scalar @loc_char) { |
||
1423 | $self->{"_LASTLOOK"} = join("", @loc_char); |
||
1424 | ## print ".$self->{\"_LASTLOOK\"}."; |
||
1425 | } |
||
1426 | else { |
||
1427 | $self->{"_LASTLOOK"} = ""; |
||
1428 | } |
||
1429 | $self->{"_LOOK"} = ""; |
||
1430 | return $lookbuf; |
||
1431 | } |
||
1432 | $count_in++; |
||
1433 | } |
||
1434 | } |
||
1435 | } |
||
1436 | } |
||
1437 | return ""; |
||
1438 | } |
||
1439 | |||
1440 | sub streamline { |
||
1441 | my $self = shift; |
||
1442 | my $size = 0; |
||
1443 | if (@_) { $size = shift; } |
||
1444 | my $loc = ""; |
||
1445 | my $mpos; |
||
1446 | my $count_in = 0; |
||
1447 | my $string_in = ""; |
||
1448 | my $re_next = 0; |
||
1449 | my $got_match = 0; |
||
1450 | my $best_pos = 0; |
||
1451 | my $pat; |
||
1452 | my $match = ""; |
||
1453 | my $before = ""; |
||
1454 | my $after = ""; |
||
1455 | my $best_match = ""; |
||
1456 | my $best_before = ""; |
||
1457 | my $best_after = ""; |
||
1458 | my $best_pat = ""; |
||
1459 | $self->{"_LMATCH"} = ""; |
||
1460 | $self->{"_LPATT"} = ""; |
||
1461 | |||
1462 | if ( ! $self->{"_LOOK"} ) { |
||
1463 | $loc = $self->{"_LASTLOOK"}; |
||
1464 | } |
||
1465 | |||
1466 | if ($size) { |
||
1467 | my ($bbb, $iii, $ooo, $eee) = status($self); |
||
1468 | if ($iii > $size) { $size = $iii; } |
||
1469 | ($count_in, $string_in) = $self->read($size); |
||
1470 | return unless ($count_in); |
||
1471 | $loc .= $string_in; |
||
1472 | } |
||
1473 | else { |
||
1474 | $loc .= $self->input; |
||
1475 | } |
||
1476 | |||
1477 | if ($loc ne "") { |
||
1478 | $self->{"_LOOK"} .= $loc; |
||
1479 | $count_in = 0; |
||
1480 | foreach $pat ( @{ $self->{"_CMATCH"} } ) { |
||
1481 | if ($pat eq "-re") { |
||
1482 | $re_next++; |
||
1483 | $count_in++; |
||
1484 | next; |
||
1485 | } |
||
1486 | if ($re_next) { |
||
1487 | $re_next = 0; |
||
1488 | if ( $self->{"_LOOK"} =~ /$pat/s ) { |
||
1489 | ( $match, $before, $after ) = ( $&, $`, $' ); |
||
1490 | $got_match++; |
||
1491 | $mpos = length($before); |
||
1492 | if ($mpos) { |
||
1493 | next if ($best_pos && ($mpos > $best_pos)); |
||
1494 | $best_pos = $mpos; |
||
1495 | $best_pat = $self->{"_MATCH"}[$count_in]; |
||
1496 | $best_match = $match; |
||
1497 | $best_before = $before; |
||
1498 | $best_after = $after; |
||
1499 | } else { |
||
1500 | $self->{"_LPATT"} = $self->{"_MATCH"}[$count_in]; |
||
1501 | $self->{"_LMATCH"} = $match; |
||
1502 | $self->{"_LASTLOOK"} = $after; |
||
1503 | $self->{"_LOOK"} = ""; |
||
1504 | return $before; |
||
1505 | # pattern at start will be best |
||
1506 | } |
||
1507 | } |
||
1508 | } |
||
1509 | elsif (($mpos = index($self->{"_LOOK"}, $pat)) > -1) { |
||
1510 | $got_match++; |
||
1511 | $before = substr ($self->{"_LOOK"}, 0, $mpos); |
||
1512 | if ($mpos) { |
||
1513 | next if ($best_pos && ($mpos > $best_pos)); |
||
1514 | $best_pos = $mpos; |
||
1515 | $best_pat = $pat; |
||
1516 | $best_match = $pat; |
||
1517 | $best_before = $before; |
||
1518 | $mpos += length($pat); |
||
1519 | $best_after = substr ($self->{"_LOOK"}, $mpos); |
||
1520 | } else { |
||
1521 | $self->{"_LPATT"} = $pat; |
||
1522 | $self->{"_LMATCH"} = $pat; |
||
1523 | $before = substr ($self->{"_LOOK"}, 0, $mpos); |
||
1524 | $mpos += length($pat); |
||
1525 | $self->{"_LASTLOOK"} = substr ($self->{"_LOOK"}, $mpos); |
||
1526 | $self->{"_LOOK"} = ""; |
||
1527 | return $before; |
||
1528 | # match at start will be best |
||
1529 | } |
||
1530 | } |
||
1531 | $count_in++; |
||
1532 | } |
||
1533 | if ($got_match) { |
||
1534 | $self->{"_LPATT"} = $best_pat; |
||
1535 | $self->{"_LMATCH"} = $best_match; |
||
1536 | $self->{"_LASTLOOK"} = $best_after; |
||
1537 | $self->{"_LOOK"} = ""; |
||
1538 | return $best_before; |
||
1539 | } |
||
1540 | } |
||
1541 | return ""; |
||
1542 | } |
||
1543 | |||
1544 | sub input { |
||
1545 | return unless (@_ == 1); |
||
1546 | my $self = shift; |
||
1547 | my $result = ""; |
||
1548 | if (nocarp && $self->{"_T_INPUT"}) { |
||
1549 | $result = $self->{"_T_INPUT"}; |
||
1550 | $self->{"_T_INPUT"} = ""; |
||
1551 | return $result; |
||
1552 | } |
||
1553 | my $ok = 0; |
||
1554 | my $got_p = " "x4; |
||
1555 | my ($bbb, $wanted, $ooo, $eee) = status($self); |
||
1556 | return "" if ($eee); |
||
1557 | return "" unless $wanted; |
||
1558 | |||
1559 | my $got = $self->read_bg ($wanted); |
||
1560 | |||
1561 | if ($got != $wanted) { |
||
1562 | # block if unexpected happens |
||
1563 | ($ok, $got, $result) = $self->read_done(1); # block until done |
||
1564 | } |
||
1565 | else { ($ok, $got, $result) = $self->read_done(0); } |
||
1566 | ### print "input: got= $got result=$result\n"; |
||
1567 | return $got ? $result : ""; |
||
1568 | } |
||
1569 | |||
1570 | sub write { |
||
1571 | return unless (@_ == 2); |
||
1572 | my $self = shift; |
||
1573 | my $wbuf = shift; |
||
1574 | my $ok = 1; |
||
1575 | |||
1576 | return 0 if ($wbuf eq ""); |
||
1577 | my $lbuf = length ($wbuf); |
||
1578 | |||
1579 | my $written = $self->write_bg ($wbuf); |
||
1580 | |||
1581 | if ($written != $lbuf) { |
||
1582 | ($ok, $written) = $self->write_done(1); # block until done |
||
1583 | } |
||
1584 | if ($Verbose) { |
||
1585 | print "wbuf=$wbuf\n"; |
||
1586 | print "lbuf=$lbuf\n"; |
||
1587 | print "written=$written\n"; |
||
1588 | } |
||
1589 | return unless ($ok); |
||
1590 | return $written; |
||
1591 | } |
||
1592 | |||
1593 | sub transmit_char { |
||
1594 | my $self = shift; |
||
1595 | return unless (@_ == 1); |
||
1596 | my $v = int shift; |
||
1597 | return if (($v < 0) or ($v > 255)); |
||
1598 | return unless $self->xmit_imm_char ($v); |
||
1599 | return wantarray ? @byte_opt : 1; |
||
1600 | } |
||
1601 | |||
1602 | sub xon_char { |
||
1603 | my $self = shift; |
||
1604 | if (@_ == 1) { |
||
1605 | my $v = int shift; |
||
1606 | return if (($v < 0) or ($v > 255)); |
||
1607 | $self->is_xon_char($v); |
||
1608 | } |
||
1609 | return wantarray ? @byte_opt : $self->is_xon_char; |
||
1610 | } |
||
1611 | |||
1612 | sub xoff_char { |
||
1613 | my $self = shift; |
||
1614 | if (@_ == 1) { |
||
1615 | my $v = int shift; |
||
1616 | return if (($v < 0) or ($v > 255)); |
||
1617 | $self->is_xoff_char($v); |
||
1618 | } |
||
1619 | return wantarray ? @byte_opt : $self->is_xoff_char; |
||
1620 | } |
||
1621 | |||
1622 | sub eof_char { |
||
1623 | my $self = shift; |
||
1624 | if (@_ == 1) { |
||
1625 | my $v = int shift; |
||
1626 | return if (($v < 0) or ($v > 255)); |
||
1627 | $self->is_eof_char($v); |
||
1628 | } |
||
1629 | return wantarray ? @byte_opt : $self->is_eof_char; |
||
1630 | } |
||
1631 | |||
1632 | sub event_char { |
||
1633 | my $self = shift; |
||
1634 | if (@_ == 1) { |
||
1635 | my $v = int shift; |
||
1636 | return if (($v < 0) or ($v > 255)); |
||
1637 | $self->is_event_char($v); |
||
1638 | } |
||
1639 | return wantarray ? @byte_opt : $self->is_event_char; |
||
1640 | } |
||
1641 | |||
1642 | sub error_char { |
||
1643 | my $self = shift; |
||
1644 | if (@_ == 1) { |
||
1645 | my $v = int shift; |
||
1646 | return if (($v < 0) or ($v > 255)); |
||
1647 | $self->is_error_char($v); |
||
1648 | } |
||
1649 | return wantarray ? @byte_opt : $self->is_error_char; |
||
1650 | } |
||
1651 | |||
1652 | sub xon_limit { |
||
1653 | my $self = shift; |
||
1654 | if (@_ == 1) { |
||
1655 | my $v = int shift; |
||
1656 | return if (($v < 0) or ($v > SHORTsize)); |
||
1657 | $self->is_xon_limit($v); |
||
1658 | } |
||
1659 | return wantarray ? (0, SHORTsize) : $self->is_xon_limit; |
||
1660 | } |
||
1661 | |||
1662 | sub xoff_limit { |
||
1663 | my $self = shift; |
||
1664 | if (@_ == 1) { |
||
1665 | my $v = int shift; |
||
1666 | return if (($v < 0) or ($v > SHORTsize)); |
||
1667 | $self->is_xoff_limit($v); |
||
1668 | } |
||
1669 | return wantarray ? (0, SHORTsize) : $self->is_xoff_limit; |
||
1670 | } |
||
1671 | |||
1672 | sub read_interval { |
||
1673 | my $self = shift; |
||
1674 | if (@_) { |
||
1675 | return unless defined $self->is_read_interval( shift ); |
||
1676 | } |
||
1677 | return wantarray ? (0, LONGsize) : $self->is_read_interval; |
||
1678 | } |
||
1679 | |||
1680 | sub read_char_time { |
||
1681 | my $self = shift; |
||
1682 | if (@_) { |
||
1683 | return unless defined $self->is_read_char_time( shift ); |
||
1684 | } |
||
1685 | return wantarray ? (0, LONGsize) : $self->is_read_char_time; |
||
1686 | } |
||
1687 | |||
1688 | sub read_const_time { |
||
1689 | my $self = shift; |
||
1690 | if (@_) { |
||
1691 | return unless defined $self->is_read_const_time( shift ); |
||
1692 | } |
||
1693 | return wantarray ? (0, LONGsize) : $self->is_read_const_time; |
||
1694 | } |
||
1695 | |||
1696 | sub write_const_time { |
||
1697 | my $self = shift; |
||
1698 | if (@_) { |
||
1699 | return unless defined $self->is_write_const_time( shift ); |
||
1700 | } |
||
1701 | return wantarray ? (0, LONGsize) : $self->is_write_const_time; |
||
1702 | } |
||
1703 | |||
1704 | sub write_char_time { |
||
1705 | my $self = shift; |
||
1706 | if (@_) { |
||
1707 | return unless defined $self->is_write_char_time( shift ); |
||
1708 | } |
||
1709 | return wantarray ? (0, LONGsize) : $self->is_write_char_time; |
||
1710 | } |
||
1711 | |||
1712 | |||
1713 | # true/false parameters |
||
1714 | |||
1715 | sub binary { |
||
1716 | my $self = shift; |
||
1717 | if (@_) { |
||
1718 | return unless defined $self->is_binary( shift ); |
||
1719 | } |
||
1720 | return $self->is_binary; |
||
1721 | } |
||
1722 | |||
1723 | sub parity_enable { |
||
1724 | my $self = shift; |
||
1725 | if (@_) { |
||
1726 | if ( $self->can_parity_enable ) { |
||
1727 | $self->is_parity_enable( shift ); |
||
1728 | } |
||
1729 | elsif ($self->{U_MSG}) { |
||
1730 | carp "Can't set parity enable on $self->{ALIAS}"; |
||
1731 | } |
||
1732 | } |
||
1733 | return $self->is_parity_enable; |
||
1734 | } |
||
1735 | |||
1736 | sub modemlines { |
||
1737 | return unless (@_ == 1); |
||
1738 | my $self = shift; |
||
1739 | my $result = $self->is_modemlines; |
||
1740 | if ($Verbose) { |
||
1741 | print "CTS is ON\n" if ($result & MS_CTS_ON); |
||
1742 | print "DSR is ON\n" if ($result & MS_DSR_ON); |
||
1743 | print "RING is ON\n" if ($result & MS_RING_ON); |
||
1744 | print "RLSD is ON\n" if ($result & MS_RLSD_ON); |
||
1745 | } |
||
1746 | return $result; |
||
1747 | } |
||
1748 | |||
1749 | sub stty { |
||
1750 | my $ob = shift; |
||
1751 | my $token; |
||
1752 | if (@_) { |
||
1753 | my $ok = 1; |
||
1754 | no strict 'refs'; # for $gosub |
||
1755 | while ($token = shift) { |
||
1756 | if (exists $opts{$token}) { |
||
1757 | ## print " $opts{$token}\n"; |
||
1758 | my ($gosub, $value) = split (':', $opts{$token}); |
||
1759 | if ($value eq "argv_char") { $value = &argv_char(shift); } |
||
1760 | if (defined $value) { |
||
1761 | &$gosub($ob, $value); |
||
1762 | } else { |
||
1763 | nocarp or carp "bad value for parameter $token\n"; |
||
1764 | $ok = 0; |
||
1765 | } |
||
1766 | } |
||
1767 | else { |
||
1768 | nocarp or carp "parameter $token not found\n"; |
||
1769 | $ok = 0; |
||
1770 | } |
||
1771 | } |
||
1772 | use strict 'refs'; |
||
1773 | return $ok; |
||
1774 | } |
||
1775 | else { |
||
1776 | my @settings; # array returned by () |
||
1777 | my $current = $ob->baudrate; |
||
1778 | push @settings, "$current"; |
||
1779 | |||
1780 | push @settings, "intr"; |
||
1781 | push @settings, cntl_char($ob->stty_intr); |
||
1782 | push @settings, "quit"; |
||
1783 | push @settings, cntl_char($ob->stty_quit); |
||
1784 | push @settings, "erase"; |
||
1785 | push @settings, cntl_char($ob->stty_erase); |
||
1786 | push @settings, "kill"; |
||
1787 | push @settings, cntl_char($ob->stty_kill); |
||
1788 | push @settings, "eof"; |
||
1789 | push @settings, cntl_char($ob->stty_eof); |
||
1790 | push @settings, "eol"; |
||
1791 | push @settings, cntl_char($ob->stty_eol); |
||
1792 | push @settings, "start"; |
||
1793 | push @settings, cntl_char(chr $ob->xon_char); |
||
1794 | push @settings, "stop"; |
||
1795 | push @settings, cntl_char(chr $ob->xoff_char); |
||
1796 | # "stop" is last CHAR type |
||
1797 | |||
1798 | push @settings, ($ob->stty_echo ? "" : "-")."echo"; |
||
1799 | push @settings, ($ob->stty_echoe ? "" : "-")."echoe"; |
||
1800 | push @settings, ($ob->stty_echok ? "" : "-")."echok"; |
||
1801 | push @settings, ($ob->stty_echonl ? "" : "-")."echonl"; |
||
1802 | push @settings, ($ob->stty_echoke ? "" : "-")."echoke"; |
||
1803 | push @settings, ($ob->stty_echoctl ? "" : "-")."echoctl"; |
||
1804 | push @settings, ($ob->stty_istrip ? "" : "-")."istrip"; |
||
1805 | push @settings, ($ob->stty_icrnl ? "" : "-")."icrnl"; |
||
1806 | push @settings, ($ob->stty_ocrnl ? "" : "-")."ocrnl"; |
||
1807 | push @settings, ($ob->stty_igncr ? "" : "-")."igncr"; |
||
1808 | push @settings, ($ob->stty_inlcr ? "" : "-")."inlcr"; |
||
1809 | push @settings, ($ob->stty_onlcr ? "" : "-")."onlcr"; |
||
1810 | push @settings, ($ob->stty_opost ? "" : "-")."opost"; |
||
1811 | push @settings, ($ob->stty_isig ? "" : "-")."isig"; |
||
1812 | push @settings, ($ob->stty_icanon ? "" : "-")."icanon"; |
||
1813 | |||
1814 | $current = $ob->databits; |
||
1815 | push @settings, "cs$current"; |
||
1816 | push @settings, (($ob->stopbits == 2) ? "" : "-")."cstopb"; |
||
1817 | |||
1818 | $current = $ob->handshake; |
||
1819 | push @settings, (($current eq "dtr") ? "" : "-")."clocal"; |
||
1820 | push @settings, (($current eq "rts") ? "" : "-")."crtscts"; |
||
1821 | push @settings, (($current eq "xoff") ? "" : "-")."ixoff"; |
||
1822 | push @settings, (($current eq "xoff") ? "" : "-")."ixon"; |
||
1823 | |||
1824 | my $parity = $ob->parity; |
||
1825 | if ($parity eq "none") { |
||
1826 | push @settings, "-parenb"; |
||
1827 | push @settings, "-parodd"; |
||
1828 | push @settings, "-inpck"; |
||
1829 | } |
||
1830 | else { |
||
1831 | $current = $ob->is_parity_enable; |
||
1832 | push @settings, ($current ? "" : "-")."parenb"; |
||
1833 | push @settings, (($parity eq "odd") ? "" : "-")."parodd"; |
||
1834 | push @settings, ($current ? "" : "-")."inpck"; |
||
1835 | # mark and space not supported |
||
1836 | } |
||
1837 | return @settings; |
||
1838 | } |
||
1839 | } |
||
1840 | |||
1841 | sub cntl_char { |
||
1842 | my $n_char = shift; |
||
1843 | return "<undef>" unless (defined $n_char); |
||
1844 | my $pos = ord $n_char; |
||
1845 | if ($pos < 32) { |
||
1846 | $n_char = "^".chr($pos + 64); |
||
1847 | } |
||
1848 | if ($pos > 126) { |
||
1849 | $n_char = sprintf "0x%x", $pos; |
||
1850 | } |
||
1851 | return $n_char; |
||
1852 | } |
||
1853 | |||
1854 | sub argv_char { |
||
1855 | my $n_char = shift; |
||
1856 | return unless (defined $n_char); |
||
1857 | my $pos = $n_char; |
||
1858 | if ($n_char =~ s/^\^//) { |
||
1859 | $pos = ord($n_char) - 64; |
||
1860 | } |
||
1861 | elsif ($n_char =~ s/^0x//) { |
||
1862 | $pos = hex($n_char); |
||
1863 | } |
||
1864 | elsif ($n_char =~ /^0/) { |
||
1865 | $pos = oct($n_char); |
||
1866 | } |
||
1867 | ## print "pos = $pos\n"; |
||
1868 | return $pos; |
||
1869 | } |
||
1870 | |||
1871 | sub debug { |
||
1872 | my $self = shift; |
||
1873 | if (ref($self)) { |
||
1874 | if (@_) { $self->{"_DEBUG"} = yes_true ( shift ); } |
||
1875 | else { |
||
1876 | my $tmp = $self->{"_DEBUG"}; |
||
1877 | nocarp || carp "Debug level: $self->{ALIAS} = $tmp"; |
||
1878 | $self->debug_comm($tmp); |
||
1879 | return $self->{"_DEBUG"}; |
||
1880 | } |
||
1881 | } else { |
||
1882 | $Verbose = yes_true ($self); |
||
1883 | nocarp || carp "SerialPort Debug Class = $Verbose"; |
||
1884 | Win32API::CommPort::debug_comm($Verbose); |
||
1885 | return $Verbose; |
||
1886 | } |
||
1887 | } |
||
1888 | |||
1889 | sub close { |
||
1890 | my $self = shift; |
||
1891 | |||
1892 | return unless (defined $self->{ALIAS}); |
||
1893 | |||
1894 | if ($Verbose or $self->{"_DEBUG"}) { |
||
1895 | carp "Closing $self " . $self->{ALIAS}; |
||
1896 | } |
||
1897 | my $success = $self->SUPER::close; |
||
1898 | $self->{DEVICE} = undef; |
||
1899 | $self->{ALIAS} = undef; |
||
1900 | if ($Verbose) { |
||
1901 | printf "SerialPort close result:%d\n", $success; |
||
1902 | } |
||
1903 | return $success; |
||
1904 | } |
||
1905 | |||
1906 | 1; # so the require or use succeeds |
||
1907 | |||
1908 | # Autoload methods go after =cut, and are processed by the autosplit program. |
||
1909 | |||
1910 | __END__ |
||
1911 | |||
1912 | =pod |
||
1913 | |||
1914 | =head1 NAME |
||
1915 | |||
1916 | Win32::SerialPort - User interface to Win32 Serial API calls |
||
1917 | |||
1918 | =head1 SYNOPSIS |
||
1919 | |||
1920 | require 5.003; |
||
1921 | use Win32::SerialPort qw( :STAT 0.19 ); |
||
1922 | |||
1923 | =head2 Constructors |
||
1924 | |||
1925 | $PortObj = new Win32::SerialPort ($PortName, $quiet) |
||
1926 | || die "Can't open $PortName: $^E\n"; # $quiet is optional |
||
1927 | |||
1928 | $PortObj = start Win32::SerialPort ($Configuration_File_Name) |
||
1929 | || die "Can't start $Configuration_File_Name: $^E\n"; |
||
1930 | |||
1931 | $PortObj = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name) |
||
1932 | || die "Can't tie using $Configuration_File_Name: $^E\n"; |
||
1933 | |||
1934 | |||
1935 | =head2 Configuration Utility Methods |
||
1936 | |||
1937 | $PortObj->alias("MODEM1"); |
||
1938 | |||
1939 | # before using start, restart, or tie |
||
1940 | $PortObj->save($Configuration_File_Name) |
||
1941 | || warn "Can't save $Configuration_File_Name: $^E\n"; |
||
1942 | |||
1943 | # after new, must check for failure |
||
1944 | $PortObj->write_settings || undef $PortObj; |
||
1945 | print "Can't change Device_Control_Block: $^E\n" unless ($PortObj); |
||
1946 | |||
1947 | # rereads file to either return open port to a known state |
||
1948 | # or switch to a different configuration on the same port |
||
1949 | $PortObj->restart($Configuration_File_Name) |
||
1950 | || warn "Can't reread $Configuration_File_Name: $^E\n"; |
||
1951 | |||
1952 | # "app. variables" saved in $Configuration_File, not used internally |
||
1953 | $PortObj->devicetype('none'); # CM11, CM17, 'weeder', 'modem' |
||
1954 | $PortObj->hostname('localhost'); # for socket-based implementations |
||
1955 | $PortObj->hostaddr(0); # false unless specified |
||
1956 | $PortObj->datatype('raw'); # in case an application needs_to_know |
||
1957 | $PortObj->cfg_param_1('none'); # null string '' hard to save/restore |
||
1958 | $PortObj->cfg_param_2('none'); # 3 spares should be enough for now |
||
1959 | $PortObj->cfg_param_3('none'); # one may end up as a log file path |
||
1960 | |||
1961 | # specials for test suite only |
||
1962 | @necessary_param = Win32::SerialPort->set_test_mode_active(1); |
||
1963 | $PortObj->lookclear("loopback to next 'input' method"); |
||
1964 | |||
1965 | =head2 Configuration Parameter Methods |
||
1966 | |||
1967 | # most methods can be called three ways: |
||
1968 | $PortObj->handshake("xoff"); # set parameter |
||
1969 | $flowcontrol = $PortObj->handshake; # current value (scalar) |
||
1970 | @handshake_opts = $PortObj->handshake; # permitted choices (list) |
||
1971 | |||
1972 | # similar |
||
1973 | $PortObj->baudrate(9600); |
||
1974 | $PortObj->parity("odd"); |
||
1975 | $PortObj->databits(8); |
||
1976 | $PortObj->stopbits(1); |
||
1977 | |||
1978 | # range parameters return (minimum, maximum) in list context |
||
1979 | $PortObj->xon_limit(100); # bytes left in buffer |
||
1980 | $PortObj->xoff_limit(100); # space left in buffer |
||
1981 | $PortObj->xon_char(0x11); |
||
1982 | $PortObj->xoff_char(0x13); |
||
1983 | $PortObj->eof_char(0x0); |
||
1984 | $PortObj->event_char(0x0); |
||
1985 | $PortObj->error_char(0); # for parity errors |
||
1986 | |||
1987 | $PortObj->buffers(4096, 4096); # read, write |
||
1988 | # returns current in list context |
||
1989 | |||
1990 | $PortObj->read_interval(100); # max time between read char (milliseconds) |
||
1991 | $PortObj->read_char_time(5); # avg time between read char |
||
1992 | $PortObj->read_const_time(100); # total = (avg * bytes) + const |
||
1993 | $PortObj->write_char_time(5); |
||
1994 | $PortObj->write_const_time(100); |
||
1995 | |||
1996 | # true/false parameters (return scalar context only) |
||
1997 | |||
1998 | $PortObj->binary(T); # just say Yes (Win 3.x option) |
||
1999 | $PortObj->parity_enable(F); # faults during input |
||
2000 | $PortObj->debug(0); |
||
2001 | |||
2002 | =head2 Operating Methods |
||
2003 | |||
2004 | ($BlockingFlags, $InBytes, $OutBytes, $LatchErrorFlags) = $PortObj->status |
||
2005 | || warn "could not get port status\n"; |
||
2006 | |||
2007 | if ($BlockingFlags) { warn "Port is blocked"; } |
||
2008 | if ($BlockingFlags & BM_fCtsHold) { warn "Waiting for CTS"; } |
||
2009 | if ($LatchErrorFlags & CE_FRAME) { warn "Framing Error"; } |
||
2010 | # The API resets errors when reading status, $LatchErrorFlags |
||
2011 | # is all $ErrorFlags seen since the last reset_error |
||
2012 | |||
2013 | Additional useful constants may be exported eventually. If the only fault |
||
2014 | action desired is a message, B<status> provides I<Built-In> BitMask processing: |
||
2015 | |||
2016 | $PortObj->error_msg(1); # prints hardware messages like "Framing Error" |
||
2017 | $PortObj->user_msg(1); # prints function messages like "Waiting for CTS" |
||
2018 | |||
2019 | ($count_in, $string_in) = $PortObj->read($InBytes); |
||
2020 | warn "read unsuccessful\n" unless ($count_in == $InBytes); |
||
2021 | |||
2022 | $count_out = $PortObj->write($output_string); |
||
2023 | warn "write failed\n" unless ($count_out); |
||
2024 | warn "write incomplete\n" if ( $count_out != length($output_string) ); |
||
2025 | |||
2026 | if ($string_in = $PortObj->input) { PortObj->write($string_in); } |
||
2027 | # simple echo with no control character processing |
||
2028 | |||
2029 | $PortObj->transmit_char(0x03); # bypass buffer (and suspend) |
||
2030 | |||
2031 | $ModemStatus = $PortObj->modemlines; |
||
2032 | if ($ModemStatus & $PortObj->MS_RLSD_ON) { print "carrier detected"; } |
||
2033 | |||
2034 | =head2 Methods used with Tied FileHandles |
||
2035 | |||
2036 | $PortObj = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name) |
||
2037 | || die "Can't tie: $^E\n"; ## TIEHANDLE ## |
||
2038 | |||
2039 | print FH "text"; ## PRINT ## |
||
2040 | $char = getc FH; ## GETC ## |
||
2041 | syswrite FH, $out, length($out), 0; ## WRITE ## |
||
2042 | $line = <FH>; ## READLINE ## |
||
2043 | @lines = <FH>; ## READLINE ## |
||
2044 | printf FH "received: %s", $line; ## PRINTF ## |
||
2045 | read (FH, $in, 5, 0) or die "$^E"; ## READ ## |
||
2046 | sysread (FH, $in, 5, 0) or die "$^E"; ## READ ## |
||
2047 | close FH || warn "close failed"; ## CLOSE ## |
||
2048 | undef $PortObj; |
||
2049 | untie *FH; ## DESTROY ## |
||
2050 | |||
2051 | $PortObj->linesize(10); # with READLINE |
||
2052 | $PortObj->lastline("_GOT_ME_"); # with READLINE, list only |
||
2053 | |||
2054 | $old_ors = $PortObj->output_record_separator("RECORD"); # with PRINT |
||
2055 | $old_ofs = $PortObj->output_field_separator("COMMA"); # with PRINT |
||
2056 | |||
2057 | =head2 Destructors |
||
2058 | |||
2059 | $PortObj->close || warn "close failed"; |
||
2060 | # passed to CommPort to release port to OS - needed to reopen |
||
2061 | # close will not usually DESTROY the object |
||
2062 | # also called as: close FH || warn "close failed"; |
||
2063 | |||
2064 | |||
2065 | undef $PortObj; |
||
2066 | # preferred unless reopen expected since it triggers DESTROY |
||
2067 | # calls $PortObj->close but does not confirm success |
||
2068 | # MUST precede untie - do all three IN THIS SEQUENCE before re-tie. |
||
2069 | |||
2070 | untie *FH; |
||
2071 | |||
2072 | =head2 Methods for I/O Processing |
||
2073 | |||
2074 | $PortObj->are_match("text", "\n"); # possible end strings |
||
2075 | $PortObj->lookclear; # empty buffers |
||
2076 | $PortObj->write("Feed Me:"); # initial prompt |
||
2077 | $PortObj->is_prompt("More Food:"); # new prompt after "kill" char |
||
2078 | |||
2079 | my $gotit = ""; |
||
2080 | my $match1 = ""; |
||
2081 | until ("" ne $gotit) { |
||
2082 | $gotit = $PortObj->lookfor; # poll until data ready |
||
2083 | die "Aborted without match\n" unless (defined $gotit); |
||
2084 | last if ($gotit); |
||
2085 | $match1 = $PortObj->matchclear; # match is first thing received |
||
2086 | last if ($match1); |
||
2087 | sleep 1; # polling sample time |
||
2088 | } |
||
2089 | |||
2090 | printf "gotit = %s\n", $gotit; # input BEFORE the match |
||
2091 | my ($match, $after, $pattern, $instead) = $PortObj->lastlook; |
||
2092 | # input that MATCHED, input AFTER the match, PATTERN that matched |
||
2093 | # input received INSTEAD when timeout without match |
||
2094 | |||
2095 | if ($match1) { |
||
2096 | $match = $match1; |
||
2097 | } |
||
2098 | printf "lastlook-match = %s -after = %s -pattern = %s\n", |
||
2099 | $match, $after, $pattern; |
||
2100 | |||
2101 | $gotit = $PortObj->lookfor($count); # block until $count chars received |
||
2102 | |||
2103 | $PortObj->are_match("-re", "pattern", "text"); |
||
2104 | # possible match strings: "pattern" is a regular expression, |
||
2105 | # "text" is a literal string |
||
2106 | |||
2107 | $gotit = $PortObj->streamline; # poll until data ready |
||
2108 | $gotit = $PortObj->streamline($count);# block until $count chars received |
||
2109 | # fast alternatives to lookfor with no character processing |
||
2110 | |||
2111 | $PortObj->stty_intr("\cC"); # char to abort lookfor method |
||
2112 | $PortObj->stty_quit("\cD"); # char to abort perl |
||
2113 | $PortObj->stty_eof("\cZ"); # end_of_file char |
||
2114 | $PortObj->stty_eol("\cJ"); # end_of_line char |
||
2115 | $PortObj->stty_erase("\cH"); # delete one character from buffer (backspace) |
||
2116 | $PortObj->stty_kill("\cU"); # clear line buffer |
||
2117 | |||
2118 | $PortObj->is_stty_intr(3); # ord(char) to abort lookfor method |
||
2119 | $qc = $PortObj->is_stty_quit; # ($qc == 4) for "\cD" |
||
2120 | $PortObj->is_stty_eof(26); |
||
2121 | $PortObj->is_stty_eol(10); |
||
2122 | $PortObj->is_stty_erase(8); |
||
2123 | $PortObj->is_stty_kill(21); |
||
2124 | |||
2125 | my $air = " "x76; |
||
2126 | $PortObj->stty_clear("\r$air\r"); # written after kill character |
||
2127 | $PortObj->is_stty_clear; # internal version for config file |
||
2128 | $PortObj->stty_bsdel("\cH \cH"); # written after erase character |
||
2129 | |||
2130 | $PortObj->stty_echo(0); # echo every character |
||
2131 | $PortObj->stty_echoe(1); # if echo erase character with bsdel string |
||
2132 | $PortObj->stty_echok(1); # if echo \n after kill character |
||
2133 | $PortObj->stty_echonl(0); # if echo \n |
||
2134 | $PortObj->stty_echoke(1); # if echo clear string after kill character |
||
2135 | $PortObj->stty_echoctl(0); # if echo "^Char" for control chars |
||
2136 | $PortObj->stty_istrip(0); # strip input to 7-bits |
||
2137 | $PortObj->stty_icrnl(0); # map \r to \n on input |
||
2138 | $PortObj->stty_ocrnl(0); # map \r to \n on output |
||
2139 | $PortObj->stty_igncr(0); # ignore \r on input |
||
2140 | $PortObj->stty_inlcr(0); # map \n to \r on input |
||
2141 | $PortObj->stty_onlcr(1); # map \n to \r\n on output |
||
2142 | $PortObj->stty_opost(0); # enable output mapping |
||
2143 | $PortObj->stty_isig(0); # enable quit and intr characters |
||
2144 | $PortObj->stty_icanon(0); # enable erase and kill characters |
||
2145 | |||
2146 | $PortObj->stty("-icanon"); # disable eof, erase and kill char, Unix-style |
||
2147 | @stty_all = $PortObj->stty(); # get all the parameters, Perl-style |
||
2148 | |||
2149 | =head2 Capability Methods inherited from Win32API::CommPort |
||
2150 | |||
2151 | These return scalar context only. |
||
2152 | |||
2153 | can_baud can_databits can_stopbits |
||
2154 | can_dtrdsr can_handshake can_parity_check |
||
2155 | can_parity_config can_parity_enable can_rlsd |
||
2156 | can_16bitmode is_rs232 is_modem |
||
2157 | can_rtscts can_xonxoff can_xon_char |
||
2158 | can_spec_char can_interval_timeout can_total_timeout |
||
2159 | buffer_max can_rlsd_config |
||
2160 | |||
2161 | =head2 Operating Methods inherited from Win32API::CommPort |
||
2162 | |||
2163 | write_bg write_done read_bg |
||
2164 | read_done reset_error suspend_tx |
||
2165 | resume_tx dtr_active rts_active |
||
2166 | break_active xoff_active xon_active |
||
2167 | purge_all purge_rx purge_tx |
||
2168 | pulse_rts_on pulse_rts_off pulse_dtr_on |
||
2169 | pulse_dtr_off ignore_null ignore_no_dsr |
||
2170 | subst_pe_char abort_on_error output_xoff |
||
2171 | output_dsr output_cts tx_on_xoff |
||
2172 | input_xoff get_tick_count |
||
2173 | |||
2174 | |||
2175 | =head1 DESCRIPTION |
||
2176 | |||
2177 | |||
2178 | This module uses Win32API::CommPort for raw access to the API calls and |
||
2179 | related constants. It provides an object-based user interface to allow |
||
2180 | higher-level use of common API call sequences for dealing with serial |
||
2181 | ports. |
||
2182 | |||
2183 | Uses features of the Win32 API to implement non-blocking I/O, serial |
||
2184 | parameter setting, event-loop operation, and enhanced error handling. |
||
2185 | |||
2186 | To pass in C<NULL> as the pointer to an optional buffer, pass in C<$null=0>. |
||
2187 | This is expected to change to an empty list reference, C<[]>, when Perl |
||
2188 | supports that form in this usage. |
||
2189 | |||
2190 | =head2 Initialization |
||
2191 | |||
2192 | The primary constructor is B<new> with a F<PortName> (as the Registry |
||
2193 | knows it) specified. This will create an object, and get the available |
||
2194 | options and capabilities via the Win32 API. The object is a superset |
||
2195 | of a B<Win32API::CommPort> object, and supports all of its methods. |
||
2196 | The port is not yet ready for read/write access. First, the desired |
||
2197 | I<parameter settings> must be established. Since these are tuning |
||
2198 | constants for an underlying hardware driver in the Operating System, |
||
2199 | they are all checked for validity by the methods that set them. The |
||
2200 | B<write_settings> method writes a new I<Device Control Block> to the |
||
2201 | driver. The B<write_settings> method will return true if the port is |
||
2202 | ready for access or C<undef> on failure. Ports are opened for binary |
||
2203 | transfers. A separate C<binmode> is not needed. The USER must release |
||
2204 | the object if B<write_settings> does not succeed. |
||
2205 | |||
2206 | Version 0.15 adds an optional C<$quiet> parameter to B<new>. Failure |
||
2207 | to open a port prints a error message to STDOUT by default. Since only |
||
2208 | one application at a time can "own" the port, one source of failure was |
||
2209 | "port in use". There was previously no way to check this without getting |
||
2210 | a "fail message". Setting C<$quiet> disables this built-in message. It |
||
2211 | also returns 0 instead of C<undef> if the port is unavailable (still FALSE, |
||
2212 | used for testing this condition - other faults may still return C<undef>). |
||
2213 | Use of C<$quiet> only applies to B<new>. |
||
2214 | |||
2215 | =over 8 |
||
2216 | |||
2217 | Certain parameters I<MUST> be set before executing B<write_settings>. |
||
2218 | Others will attempt to deduce defaults from the hardware or from other |
||
2219 | parameters. The I<Required> parameters are: |
||
2220 | |||
2221 | =item baudrate |
||
2222 | |||
2223 | Any legal value. |
||
2224 | |||
2225 | =item parity |
||
2226 | |||
2227 | One of the following: "none", "odd", "even", "mark", "space". |
||
2228 | If you select anything except "none", you will need to set B<parity_enable>. |
||
2229 | |||
2230 | =item databits |
||
2231 | |||
2232 | An integer from 5 to 8. |
||
2233 | |||
2234 | =item stopbits |
||
2235 | |||
2236 | Legal values are 1, 1.5, and 2. But 1.5 only works with 5 databits, 2 does |
||
2237 | not work with 5 databits, and other combinations may not work on all |
||
2238 | hardware if parity is also used. |
||
2239 | |||
2240 | =back |
||
2241 | |||
2242 | The B<handshake> setting is recommended but no longer required. Select one |
||
2243 | of the following: "none", "rts", "xoff", "dtr". |
||
2244 | |||
2245 | Some individual parameters (eg. baudrate) can be changed after the |
||
2246 | initialization is completed. These will be validated and will |
||
2247 | update the I<Device Control Block> as required. The B<save> |
||
2248 | method will write the current parameters to a file that B<start, tie,> and |
||
2249 | B<restart> can use to reestablish a functional setup. |
||
2250 | |||
2251 | $PortObj = new Win32::SerialPort ($PortName, $quiet) |
||
2252 | || die "Can't open $PortName: $^E\n"; # $quiet is optional |
||
2253 | |||
2254 | $PortObj->user_msg(ON); |
||
2255 | $PortObj->databits(8); |
||
2256 | $PortObj->baudrate(9600); |
||
2257 | $PortObj->parity("none"); |
||
2258 | $PortObj->stopbits(1); |
||
2259 | $PortObj->handshake("rts"); |
||
2260 | $PortObj->buffers(4096, 4096); |
||
2261 | |||
2262 | $PortObj->write_settings || undef $PortObj; |
||
2263 | |||
2264 | $PortObj->save($Configuration_File_Name); |
||
2265 | |||
2266 | $PortObj->baudrate(300); |
||
2267 | $PortObj->restart($Configuration_File_Name); # back to 9600 baud |
||
2268 | |||
2269 | $PortObj->close || die "failed to close"; |
||
2270 | undef $PortObj; # frees memory back to perl |
||
2271 | |||
2272 | The F<PortName> maps to both the Registry I<Device Name> and the |
||
2273 | I<Properties> associated with that device. A single I<Physical> port |
||
2274 | can be accessed using two or more I<Device Names>. But the options |
||
2275 | and setup data will differ significantly in the two cases. A typical |
||
2276 | example is a Modem on port "COM2". Both of these F<PortNames> open |
||
2277 | the same I<Physical> hardware: |
||
2278 | |||
2279 | $P1 = new Win32::SerialPort ("COM2"); |
||
2280 | |||
2281 | $P2 = new Win32::SerialPort ("\\\\.\\Nanohertz Modem model K-9"); |
||
2282 | |||
2283 | $P1 is a "generic" serial port. $P2 includes all of $P1 plus a variety |
||
2284 | of modem-specific added options and features. The "raw" API calls return |
||
2285 | different size configuration structures in the two cases. Win32 uses the |
||
2286 | "\\.\" prefix to identify "named" devices. Since both names use the same |
||
2287 | I<Physical> hardware, they can not both be used at the same time. The OS |
||
2288 | will complain. Consider this A Good Thing. Use B<alias> to convert the |
||
2289 | name used by "built-in" messages. |
||
2290 | |||
2291 | $P2->alias("FIDO"); |
||
2292 | |||
2293 | The second constructor, B<start> is intended to simplify scripts which |
||
2294 | need a constant setup. It executes all the steps from B<new> to |
||
2295 | B<write_settings> based on a previously saved configuration. This |
||
2296 | constructor will return C<undef> on a bad configuration file or failure |
||
2297 | of a validity check. The returned object is ready for access. |
||
2298 | |||
2299 | $PortObj2 = start Win32::SerialPort ($Configuration_File_Name) |
||
2300 | || die; |
||
2301 | |||
2302 | The third constructor, B<tie>, combines the B<start> with Perl's |
||
2303 | support for tied FileHandles (see I<perltie>). Win32::SerialPort |
||
2304 | implements the complete set of methods: TIEHANDLE, PRINT, PRINTF, |
||
2305 | WRITE, READ, GETC, READLINE, CLOSE, and DESTROY. Tied FileHandle |
||
2306 | support was new with Version 0.14. |
||
2307 | |||
2308 | $PortObj2 = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name) |
||
2309 | || die; |
||
2310 | |||
2311 | The implementation attempts to mimic STDIN/STDOUT behaviour as closely |
||
2312 | as possible: calls block until done, data strings that exceed internal |
||
2313 | buffers are divided transparently into multiple calls, and B<stty_onlcr> |
||
2314 | and B<stty_ocrnl> are applied to output data (WRITE, PRINT, PRINTF) when |
||
2315 | B<stty_opost> is true. In Version 0.17, the output separators C<$,> and |
||
2316 | C<$\> are also applied to PRINT if set. Since PRINTF is treated internally |
||
2317 | as a single record PRINT, C<$\> will be applied. Output separators are not |
||
2318 | applied to WRITE (called as C<syswrite FH, $scalar, $length, [$offset]>). |
||
2319 | |||
2320 | The B<output_record_separator> and B<output_field_separator> methods can set |
||
2321 | I<Port-FileHandle-Specific> versions of C<$,> and C<$\> if desired. |
||
2322 | The input_record_separator C<$/> is not explicitly supported - but an |
||
2323 | identical function can be obtained with a suitable B<are_match> setting. |
||
2324 | Record separators are experimental in Version 0.17. They are not saved |
||
2325 | in the configuration_file. |
||
2326 | |||
2327 | The tied FileHandle methods may be combined with the Win32::SerialPort |
||
2328 | methods for B<read, input>, and B<write> as well as other methods. The |
||
2329 | typical restrictions against mixing B<print> with B<syswrite> do not |
||
2330 | apply. Since both B<(tied) read> and B<sysread> call the same C<$ob-E<gt>READ> |
||
2331 | method, and since a separate C<$ob-E<gt>read> method has existed for some |
||
2332 | time in Win32::SerialPort, you should always use B<sysread> with the |
||
2333 | tied interface. Beginning in Version 0.17, B<sysread> checks the input |
||
2334 | against B<stty_icrnl>, B<stty_inlcr>, and B<stty_igncr>. With B<stty_igncr> |
||
2335 | active, the B<sysread> returns the count of all characters received including |
||
2336 | and C<\r> characters subsequently deleted. |
||
2337 | |||
2338 | Because all the tied methods block, they should ALWAYS be used with |
||
2339 | timeout settings and are not suitable for background operations and |
||
2340 | polled loops. The B<sysread> method may return fewer characters than |
||
2341 | requested when a timeout occurs. The method call is still considered |
||
2342 | successful. If a B<sysread> times out after receiving some characters, |
||
2343 | the actual elapsed time may be as much as twice the programmed limit. |
||
2344 | If no bytes are received, the normal timing applies. |
||
2345 | |||
2346 | =head2 Configuration and Capability Methods |
||
2347 | |||
2348 | Starting in Version 0.18, a number of I<Application Variables> are saved |
||
2349 | in B<$Configuration_File>. These parameters are not used internally. But |
||
2350 | methods allow setting and reading them. The intent is to facilitate the |
||
2351 | use of separate I<configuration scripts> to create the files. Then an |
||
2352 | application can use B<start> as the Constructor and not bother with |
||
2353 | command line processing or managing its own small configuration file. |
||
2354 | The default values and number of parameters is subject to change. |
||
2355 | |||
2356 | $PortObj->devicetype('none'); |
||
2357 | $PortObj->hostname('localhost'); # for socket-based implementations |
||
2358 | $PortObj->hostaddr(0); # a "false" value |
||
2359 | $PortObj->datatype('raw'); # 'record' is another possibility |
||
2360 | $PortObj->cfg_param_1('none'); |
||
2361 | $PortObj->cfg_param_2('none'); # 3 spares should be enough for now |
||
2362 | $PortObj->cfg_param_3('none'); |
||
2363 | |||
2364 | The Win32 Serial Comm API provides extensive information concerning |
||
2365 | the capabilities and options available for a specific port (and |
||
2366 | instance). "Modem" ports have different capabilties than "RS-232" |
||
2367 | ports - even if they share the same Hardware. Many traditional modem |
||
2368 | actions are handled via TAPI. "Fax" ports have another set of options - |
||
2369 | and are accessed via MAPI. Yet many of the same low-level API commands |
||
2370 | and data structures are "common" to each type ("Modem" is implemented |
||
2371 | as an "RS-232" superset). In addition, Win95 supports a variety of |
||
2372 | legacy hardware (e.g fixed 134.5 baud) while WinNT has hooks for ISDN, |
||
2373 | 16-data-bit paths, and 256Kbaud. |
||
2374 | |||
2375 | =over 8 |
||
2376 | |||
2377 | Binary selections will accept as I<true> any of the following: |
||
2378 | C<("YES", "Y", "ON", "TRUE", "T", "1", 1)> (upper/lower/mixed case) |
||
2379 | Anything else is I<false>. |
||
2380 | |||
2381 | There are a large number of possible configuration and option parameters. |
||
2382 | To facilitate checking option validity in scripts, most configuration |
||
2383 | methods can be used in three different ways: |
||
2384 | |||
2385 | =item method called with an argument |
||
2386 | |||
2387 | The parameter is set to the argument, if valid. An invalid argument |
||
2388 | returns I<false> (undef) and the parameter is unchanged. The function |
||
2389 | will also I<carp> if B<$user_msg> is I<true>. After B<write_settings>, |
||
2390 | the port will be updated immediately if allowed. Otherwise, the value |
||
2391 | will be applied when B<write_settings> is called. |
||
2392 | |||
2393 | =item method called with no argument in scalar context |
||
2394 | |||
2395 | The current value is returned. If the value is not initialized either |
||
2396 | directly or by default, return "undef" which will parse to I<false>. |
||
2397 | For binary selections (true/false), return the current value. All |
||
2398 | current values from "multivalue" selections will parse to I<true>. |
||
2399 | Current values may differ from requested values until B<write_settings>. |
||
2400 | There is no way to see requests which have not yet been applied. |
||
2401 | Setting the same parameter again overwrites the first request. Test |
||
2402 | the return value of the setting method to check "success". |
||
2403 | |||
2404 | =item method called with no argument in list context |
||
2405 | |||
2406 | Return a list consisting of all acceptable choices for parameters with |
||
2407 | discrete choices. Return a list C<(minimum, maximum)> for parameters |
||
2408 | which can be set to a range of values. Binary selections have no need |
||
2409 | to call this way - but will get C<(0,1)> if they do. Beginning in |
||
2410 | Version 0.16, Binary selections inherited from Win32API::CommPort may |
||
2411 | not return anything useful in list context. The null list C<(undef)> |
||
2412 | will be returned for failed calls in list context (e.g. for an invalid |
||
2413 | or unexpected argument). |
||
2414 | |||
2415 | =item Asynchronous (Background) I/O |
||
2416 | |||
2417 | The module handles Polling (do if Ready), Synchronous (block until |
||
2418 | Ready), and Asynchronous Modes (begin and test if Ready) with the timeout |
||
2419 | choices provided by the API. No effort has yet been made to interact with |
||
2420 | Windows events. But background I/O has been used successfully with the |
||
2421 | Perl Tk modules and callbacks from the event loop. |
||
2422 | |||
2423 | =item Timeouts |
||
2424 | |||
2425 | The API provides two timing models. The first applies only to reading and |
||
2426 | essentially determines I<Read Not Ready> by checking the time between |
||
2427 | consecutive characters. The B<ReadFile> operation returns if that time |
||
2428 | exceeds the value set by B<read_interval>. It does this by timestamping |
||
2429 | each character. It appears that at least one character must by received in |
||
2430 | I<every> B<read> I<call to the API> to initialize the mechanism. The timer |
||
2431 | is then reset by each succeeding character. If no characters are received, |
||
2432 | the read will block indefinitely. |
||
2433 | |||
2434 | Setting B<read_interval> to C<0xffffffff> will do a non-blocking read. |
||
2435 | The B<ReadFile> returns immediately whether or not any characters are |
||
2436 | actually read. This replicates the behavior of the API. |
||
2437 | |||
2438 | The other model defines the total time allowed to complete the operation. |
||
2439 | A fixed overhead time is added to the product of bytes and per_byte_time. |
||
2440 | A wide variety of timeout options can be defined by selecting the three |
||
2441 | parameters: fixed, each, and size. |
||
2442 | |||
2443 | Read_Total = B<read_const_time> + (B<read_char_time> * bytes_to_read) |
||
2444 | |||
2445 | Write_Total = B<write_const_time> + (B<write_char_time> * bytes_to_write) |
||
2446 | |||
2447 | When reading a known number of characters, the I<Read_Total> mechanism is |
||
2448 | recommended. This mechanism I<MUST> be used with I<tied FileHandles> because |
||
2449 | the tie methods can make multiple internal API calls in response to a single |
||
2450 | B<sysread> or B<READLINE>. The I<Read_Interval> mechanism is suitable for |
||
2451 | a B<read> method that expects a response of variable or unknown size. You |
||
2452 | should then also set a long I<Read_Total> timeout as a "backup" in case |
||
2453 | no bytes are received. |
||
2454 | |||
2455 | =back |
||
2456 | |||
2457 | =head2 Exports |
||
2458 | |||
2459 | Nothing is exported by default. Nothing is currently exported. Optional |
||
2460 | tags from Win32API::CommPort are passed through. |
||
2461 | |||
2462 | =over 4 |
||
2463 | |||
2464 | =item :PARAM |
||
2465 | |||
2466 | Utility subroutines and constants for parameter setting and test: |
||
2467 | |||
2468 | LONGsize SHORTsize nocarp yes_true |
||
2469 | OS_Error internal_buffer |
||
2470 | |||
2471 | =item :STAT |
||
2472 | |||
2473 | Serial communications constants from Win32API::CommPort. Included are the |
||
2474 | constants for ascertaining why a transmission is blocked: |
||
2475 | |||
2476 | BM_fCtsHold BM_fDsrHold BM_fRlsdHold BM_fXoffHold |
||
2477 | BM_fXoffSent BM_fEof BM_fTxim BM_AllBits |
||
2478 | |||
2479 | Which incoming bits are active: |
||
2480 | |||
2481 | MS_CTS_ON MS_DSR_ON MS_RING_ON MS_RLSD_ON |
||
2482 | |||
2483 | What hardware errors have been detected: |
||
2484 | |||
2485 | CE_RXOVER CE_OVERRUN CE_RXPARITY CE_FRAME |
||
2486 | CE_BREAK CE_TXFULL CE_MODE |
||
2487 | |||
2488 | Offsets into the array returned by B<status:> |
||
2489 | |||
2490 | ST_BLOCK ST_INPUT ST_OUTPUT ST_ERROR |
||
2491 | |||
2492 | =back |
||
2493 | |||
2494 | =head2 Stty Emulation |
||
2495 | |||
2496 | Nothing wrong with dreaming! A subset of stty options is available |
||
2497 | through a B<stty> method. The purpose is support of existing serial |
||
2498 | devices which have embedded knowledge of Unix communication line and |
||
2499 | login practices. It is also needed by Tom Christiansen's Perl Power Tools |
||
2500 | project. This is new and experimental in Version 0.15. The B<stty> method |
||
2501 | returns an array of "traditional stty values" when called with no |
||
2502 | arguments. With arguments, it sets the corresponding parameters. |
||
2503 | |||
2504 | $ok = $PortObj->stty("-icanon"); # equivalent to stty_icanon(0) |
||
2505 | @stty_all = $PortObj->stty(); # get all the parameters, Perl-style |
||
2506 | $ok = $PortObj->stty("cs7",19200); # multiple parameters |
||
2507 | $ok = $PortObj->stty(@stty_save); # many parameters |
||
2508 | |||
2509 | The distribution includes a demo script, stty.plx, which gives details |
||
2510 | of usage. Not all Unix parameters are currently supported. But the array |
||
2511 | will contain all those which can be set. The order in C<@stty_all> will |
||
2512 | match the following pattern: |
||
2513 | |||
2514 | baud, # numeric, always first |
||
2515 | "intr", character, # the parameters which set special characters |
||
2516 | "name", character, ... |
||
2517 | "stop", character, # "stop" will always be the last "pair" |
||
2518 | "parameter", # the on/off settings |
||
2519 | "-parameter", ... |
||
2520 | |||
2521 | Version 0.13 added the primitive functions required to implement this |
||
2522 | feature. A number of methods named B<stty_xxx> do what an |
||
2523 | I<experienced stty user> would expect. |
||
2524 | Unlike B<stty> on Unix, the B<stty_xxx> operations apply only to I/O |
||
2525 | processed via the B<lookfor> method or the I<tied FileHandle> methods. |
||
2526 | The B<read, input, read_done, write> methods all treat data as "raw". |
||
2527 | |||
2528 | |||
2529 | The following stty functions have related SerialPort functions: |
||
2530 | --------------------------------------------------------------- |
||
2531 | stty (control) SerialPort Default Value |
||
2532 | ---------------- ------------------ ------------- |
||
2533 | parenb inpck parity_enable from port |
||
2534 | |||
2535 | parodd parity from port |
||
2536 | |||
2537 | cs5 cs6 cs7 cs8 databits from port |
||
2538 | |||
2539 | cstopb stopbits from port |
||
2540 | |||
2541 | clocal crtscts handshake from port |
||
2542 | ixon ixoff handshake from port |
||
2543 | |||
2544 | time read_const_time from port |
||
2545 | |||
2546 | 110 300 600 1200 2400 baudrate from port |
||
2547 | 4800 9600 19200 38400 baudrate |
||
2548 | |||
2549 | 75 134.5 150 1800 fixed baud only - not selectable |
||
2550 | |||
2551 | g, "stty < /dev/x" start, save none |
||
2552 | |||
2553 | sane restart none |
||
2554 | |||
2555 | |||
2556 | |||
2557 | stty (input) SerialPort Default Value |
||
2558 | ---------------- ------------------ ------------- |
||
2559 | istrip stty_istrip off |
||
2560 | |||
2561 | igncr stty_igncr off |
||
2562 | |||
2563 | inlcr stty_inlcr off |
||
2564 | |||
2565 | icrnl stty_icrnl on |
||
2566 | |||
2567 | parmrk error_char from port (off typ) |
||
2568 | |||
2569 | |||
2570 | |||
2571 | stty (output) SerialPort Default Value |
||
2572 | ---------------- ------------------ ------------- |
||
2573 | ocrnl stty_ocrnl off if opost |
||
2574 | |||
2575 | onlcr stty_onlcr on if opost |
||
2576 | |||
2577 | opost stty_opost off |
||
2578 | |||
2579 | |||
2580 | |||
2581 | stty (local) SerialPort Default Value |
||
2582 | ---------------- ------------------ ------------- |
||
2583 | raw read, write, input none |
||
2584 | |||
2585 | cooked lookfor none |
||
2586 | |||
2587 | echo stty_echo off |
||
2588 | |||
2589 | echoe stty_echoe on if echo |
||
2590 | |||
2591 | echok stty_echok on if echo |
||
2592 | |||
2593 | echonl stty_echonl off |
||
2594 | |||
2595 | echoke stty_echoke on if echo |
||
2596 | |||
2597 | echoctl stty_echoctl off |
||
2598 | |||
2599 | isig stty_isig off |
||
2600 | |||
2601 | icanon stty_icanon off |
||
2602 | |||
2603 | |||
2604 | |||
2605 | stty (char) SerialPort Default Value |
||
2606 | ---------------- ------------------ ------------- |
||
2607 | intr stty_intr "\cC" |
||
2608 | is_stty_intr 3 |
||
2609 | |||
2610 | quit stty_quit "\cD" |
||
2611 | is_stty_quit 4 |
||
2612 | |||
2613 | erase stty_erase "\cH" |
||
2614 | is_stty_erase 8 |
||
2615 | |||
2616 | (erase echo) stty_bsdel "\cH \cH" |
||
2617 | |||
2618 | kill stty_kill "\cU" |
||
2619 | is_stty_kill 21 |
||
2620 | |||
2621 | (kill echo) stty_clear "\r {76}\r" |
||
2622 | is_stty_clear "-@{76}-" |
||
2623 | |||
2624 | eof stty_eof "\cZ" |
||
2625 | is_stty_eof 26 |
||
2626 | |||
2627 | eol stty_eol "\cJ" |
||
2628 | is_stty_eol 10 |
||
2629 | |||
2630 | start xon_char from port ("\cQ" typ) |
||
2631 | is_xon_char 17 |
||
2632 | |||
2633 | stop xoff_char from port ("\cS" typ) |
||
2634 | is_xoff_char 19 |
||
2635 | |||
2636 | |||
2637 | |||
2638 | The following stty functions have no equivalent in SerialPort: |
||
2639 | -------------------------------------------------------------- |
||
2640 | [-]hup [-]ignbrk [-]brkint [-]ignpar |
||
2641 | [-]tostop susp 0 50 |
||
2642 | 134 200 exta extb |
||
2643 | [-]cread [-]hupcl |
||
2644 | |||
2645 | The stty function list is taken from the documentation for IO::Stty by |
||
2646 | Austin Schutz. |
||
2647 | |||
2648 | =head2 Lookfor and I/O Processing |
||
2649 | |||
2650 | Many of the B<stty_xxx> methods support features which are necessary for |
||
2651 | line-oriented input (such as command-line handling). These include methods |
||
2652 | which select control-keys to delete characters (B<stty_erase>) and lines |
||
2653 | (B<stty_kill>), define input boundaries (B<stty_eol, stty_eof>), and abort |
||
2654 | processing (B<stty_intr, stty_quit>). These keys also have B<is_stty_xxx> |
||
2655 | methods which convert the key-codes to numeric equivalents which can be |
||
2656 | saved in the configuration file. |
||
2657 | |||
2658 | Some communications programs have a different but related need - to collect |
||
2659 | (or discard) input until a specific pattern is detected. For lines, the |
||
2660 | pattern is a line-termination. But there are also requirements to search |
||
2661 | for other strings in the input such as "username:" and "password:". The |
||
2662 | B<lookfor> method provides a consistant mechanism for solving this problem. |
||
2663 | It searches input character-by-character looking for a match to any of the |
||
2664 | elements of an array set using the B<are_match> method. It returns the |
||
2665 | entire input up to the match pattern if a match is found. If no match |
||
2666 | is found, it returns "" unless an input error or abort is detected (which |
||
2667 | returns undef). |
||
2668 | |||
2669 | The actual match and the characters after it (if any) may also be viewed |
||
2670 | using the B<lastlook> method. In Version 0.13, the match test included |
||
2671 | a C<s/$pattern//s> test which worked fine for literal text but returned |
||
2672 | the I<Regular Expression> that matched when C<$pattern> contained any Perl |
||
2673 | metacharacters. That was probably a bug - although no one reported it. |
||
2674 | |||
2675 | In Version 0.14, B<lastlook> returns both the input and the pattern from |
||
2676 | the match test. It also adopts the convention from Expect.pm that match |
||
2677 | strings are literal text (tested using B<index>) unless preceeded in the |
||
2678 | B<are_match> list by a B<"-re",> entry. The default B<are_match> list |
||
2679 | is C<("\n")>, which matches complete lines. |
||
2680 | |||
2681 | my ($match, $after, $pattern, $instead) = $PortObj->lastlook; |
||
2682 | # input that MATCHED, input AFTER the match, PATTERN that matched |
||
2683 | # input received INSTEAD when timeout without match ("" if match) |
||
2684 | |||
2685 | $PortObj->are_match("text1", "-re", "pattern", "text2"); |
||
2686 | # possible match strings: "pattern" is a regular expression, |
||
2687 | # "text1" and "text2" are literal strings |
||
2688 | |||
2689 | The I<Regular Expression> handling in B<lookfor> is still |
||
2690 | experimental. Please let me know if you use it (or can't use it), so |
||
2691 | I can confirm bug fixes don't break your code. For literal strings, |
||
2692 | C<$match> and C<$pattern> should be identical. The C<$instead> value |
||
2693 | returns the internal buffer tested by the match logic. A successful |
||
2694 | match or a B<lookclear> resets it to "" - so it is only useful for error |
||
2695 | handling such as timeout processing or reporting unexpected responses. |
||
2696 | |||
2697 | The B<lookfor> method is designed to be sampled periodically (polled). Any |
||
2698 | characters after the match pattern are saved for a subsequent B<lookfor>. |
||
2699 | Internally, B<lookfor> is implemented using the nonblocking B<input> method |
||
2700 | when called with no parameter. If called with a count, B<lookfor> calls |
||
2701 | C<$PortObj-E<gt>read(count)> which blocks until the B<read> is I<Complete> or |
||
2702 | a I<Timeout> occurs. The blocking alternative should not be used unless a |
||
2703 | fault time has been defined using B<read_interval, read_const_time, and |
||
2704 | read_char_time>. It exists mostly to support the I<tied FileHandle> |
||
2705 | functions B<sysread, getc,> and B<E<lt>FHE<gt>>. |
||
2706 | |||
2707 | The internal buffers used by B<lookfor> may be purged by the B<lookclear> |
||
2708 | method (which also clears the last match). For testing, B<lookclear> can |
||
2709 | accept a string which is "looped back" to the next B<input>. This feature |
||
2710 | is enabled only when C<set_test_mode_active(1)>. Normally, B<lookclear> |
||
2711 | will return C<undef> if given parameters. It still purges the buffers and |
||
2712 | last_match in that case (but nothing is "looped back"). You will want |
||
2713 | B<stty_echo(0)> when exercising loopback. |
||
2714 | |||
2715 | Version 0.15 adds a B<matchclear> method. It is designed to handle the |
||
2716 | "special case" where the match string is the first character(s) received |
||
2717 | by B<lookfor>. In this case, C<$lookfor_return == "">, B<lookfor> does |
||
2718 | not provide a clear indication that a match was found. The B<matchclear> |
||
2719 | returns the same C<$match> that would be returned by B<lastlook> and |
||
2720 | resets it to "" without resetting any of the other buffers. Since the |
||
2721 | B<lookfor> already searched I<through> the match, B<matchclear> is used |
||
2722 | to both detect and step-over "blank" lines. |
||
2723 | |||
2724 | The character-by-character processing used by B<lookfor> to support the |
||
2725 | I<stty emulation> is fine for interactive activities and tasks which |
||
2726 | expect short responses. But it has too much "overhead" to handle fast |
||
2727 | data streams. Version 0.15 adds a B<streamline> method which is a fast, |
||
2728 | line-oriented alternative with no echo support or input handling except |
||
2729 | for pattern searching. Exact benchmarks will vary with input data and |
||
2730 | patterns, but my tests indicate B<streamline> is 10-20 times faster then |
||
2731 | B<lookfor> when uploading files averaging 25-50 characters per line. |
||
2732 | Since B<streamline> uses the same internal buffers, the B<lookclear, |
||
2733 | lastlook, are_match, and matchclear> methods act the same in both cases. |
||
2734 | In fact, calls to B<streamline> and B<lookfor> can be interleaved if desired |
||
2735 | (e.g. an interactive task that starts an upload and returns to interactive |
||
2736 | activity when it is complete). |
||
2737 | |||
2738 | Beginning in Version 0.15, the B<READLINE> method supports "list context". |
||
2739 | A tied FileHandle can slurp in a whole file with an "@lines = E<lt>FHE<gt>" |
||
2740 | construct. In "scalar context", B<READLINE> calls B<lookfor>. But it calls |
||
2741 | B<streamline> in "list context". Both contexts also call B<matchclear> |
||
2742 | to detect "empty" lines and B<reset_error> to detect hardware problems. |
||
2743 | The existance of a hardware fault is reported with C<$^E>, although the |
||
2744 | specific fault is only reported when B<error_msg> is true. |
||
2745 | |||
2746 | There are two additional methods for supporting "list context" input: |
||
2747 | B<lastline> sets an "end_of_file" I<Regular Expression>, and B<linesize> |
||
2748 | permits changing the "packet size" in the blocking read operation to allow |
||
2749 | tuning performance to data characteristics. These two only apply during |
||
2750 | B<READLINE>. The default for B<linesize> is 1. There is no default for |
||
2751 | the B<lastline> method. |
||
2752 | |||
2753 | In Version 0.15, I<Regular Expressions> set by B<are_match> and B<lastline> |
||
2754 | will be pre-compiled using the I<qr//> construct on Perl 5.005 and higher. |
||
2755 | This doubled B<lookfor> and B<streamline> speed in my tests with |
||
2756 | I<Regular Expressions> - but actual improvements depend on both patterns |
||
2757 | and input data. |
||
2758 | |||
2759 | The functionality of B<lookfor> includes a limited subset of the capabilities |
||
2760 | found in Austin Schutz's I<Expect.pm> for Unix (and Tcl's expect which it |
||
2761 | resembles). The C<$before, $match, $pattern, and $after> return values are |
||
2762 | available if someone needs to create an "expect" subroutine for porting a |
||
2763 | script. When using multiple patterns, there is one important functional |
||
2764 | difference: I<Expect.pm> looks at each pattern in turn and returns the first |
||
2765 | match found; B<lookfor> and B<streamline> test all patterns and return the |
||
2766 | one found I<earliest> in the input if more than one matches. |
||
2767 | |||
2768 | Because B<lookfor> can be used to manage a command-line environment much |
||
2769 | like a Unix serial login, a number of "stty-like" methods are included to |
||
2770 | handle the issues raised by serial logins. One issue is dissimilar line |
||
2771 | terminations. This is addressed by the following methods: |
||
2772 | |||
2773 | $PortObj->stty_icrnl; # map \r to \n on input |
||
2774 | $PortObj->stty_igncr; # ignore \r on input |
||
2775 | $PortObj->stty_inlcr; # map \n to \r on input |
||
2776 | $PortObj->stty_ocrnl; # map \r to \n on output |
||
2777 | $PortObj->stty_onlcr; # map \n to \r\n on output |
||
2778 | $PortObj->stty_opost; # enable output mapping |
||
2779 | |||
2780 | The default specifies a raw device with no input or output processing. |
||
2781 | In Version 0.14, the default was a device which sends "\r" at the end |
||
2782 | of a line, requires "\r\n" to terminate incoming lines, and expects the |
||
2783 | "host" to echo every keystroke. Many "dumb terminals" act this way and |
||
2784 | the defaults were similar to Unix defaults. But some users found this |
||
2785 | ackward and confusing. |
||
2786 | |||
2787 | Sometimes, you want perl to echo input characters back to the serial |
||
2788 | device (and other times you don't want that). |
||
2789 | |||
2790 | $PortObj->stty_echo; # echo every character |
||
2791 | $PortObj->stty_echoe; # if echo erase with bsdel string (default) |
||
2792 | $PortObj->stty_echok; # if echo \n after kill character (default) |
||
2793 | $PortObj->stty_echonl; # echo \n even if stty_echo(0) |
||
2794 | $PortObj->stty_echoke; # if echo clear string after kill (default) |
||
2795 | $PortObj->stty_echoctl; # if echo "^Char" for control chars |
||
2796 | |||
2797 | $PortObj->stty_istrip; # strip input to 7-bits |
||
2798 | |||
2799 | my $air = " "x76; # overwrite entire line with spaces |
||
2800 | $PortObj->stty_clear("\r$air\r"); # written after kill character |
||
2801 | $PortObj->is_prompt("PROMPT:"); # need to write after kill |
||
2802 | $PortObj->stty_bsdel("\cH \cH"); # written after erase character |
||
2803 | |||
2804 | # internal method that permits clear string with \r in config file |
||
2805 | my $plus32 = "@"x76; # overwrite line with spaces (ord += 32) |
||
2806 | $PortObj->is_stty_clear("-$plus32-"); # equivalent to stty_clear |
||
2807 | |||
2808 | |||
2809 | =head1 NOTES |
||
2810 | |||
2811 | The object returned by B<new> or B<start> is NOT a I<FileHandle>. You |
||
2812 | will be disappointed if you try to use it as one. If you need a |
||
2813 | I<FileHandle>, you must use B<tie> as the constructor. |
||
2814 | |||
2815 | e.g. the following is WRONG!!____C<print $PortObj "some text";> |
||
2816 | |||
2817 | You need something like this (Perl 5.005): |
||
2818 | |||
2819 | # construct |
||
2820 | $tie_ob = tie(*FOO,'Win32::SerialPort', $cfgfile) |
||
2821 | or die "Can't start $cfgfile\n"; |
||
2822 | |||
2823 | print FOO "enter char: "; # destination is FileHandle, not Object |
||
2824 | my $in = getc FOO; |
||
2825 | syswrite FOO, "$in\n", 2, 0; |
||
2826 | print FOO "enter line: "; |
||
2827 | $in = <FOO>; |
||
2828 | printf FOO "received: %s\n", $in; |
||
2829 | print FOO "enter 5 char: "; |
||
2830 | sysread (FOO, $in, 5, 0) or die; |
||
2831 | printf FOO "received: %s\n", $in; |
||
2832 | |||
2833 | # destruct |
||
2834 | close FOO || print "close failed\n"; |
||
2835 | undef $tie_ob; # Don't forget this one!! |
||
2836 | untie *FOO; |
||
2837 | |||
2838 | Always include the C<undef $tie_ob> before the B<untie>. See the I<Gotcha> |
||
2839 | description in I<perltie>. |
||
2840 | |||
2841 | The Perl 5.004 implementation of I<tied FileHandles> is missing |
||
2842 | B<close> and B<syswrite>. The Perl 5.003 version is essentially unusable. |
||
2843 | If you need these functions, consider Perl 5.005 seriously. |
||
2844 | |||
2845 | An important note about Win32 filenames. The reserved device names such |
||
2846 | as C< COM1, AUX, LPT1, CON, PRN > can NOT be used as filenames. Hence |
||
2847 | I<"COM2.cfg"> would not be usable for B<$Configuration_File_Name>. |
||
2848 | |||
2849 | Thanks to Ken White for testing on NT. |
||
2850 | |||
2851 | There is a linux clone of this module implemented using I<POSIX.pm>. |
||
2852 | It also runs on AIX and Solaris, and will probably run on other POSIX |
||
2853 | systems as well. It does not currently support the complete set of methods - |
||
2854 | although portability of user programs is excellent for the calls it does |
||
2855 | support. It is available from CPAN as I<Device::SerialPort>. |
||
2856 | |||
2857 | =head1 KNOWN LIMITATIONS |
||
2858 | |||
2859 | Since everything is (sometimes convoluted but still pure) Perl, you can |
||
2860 | fix flaws and change limits if required. But please file a bug report if |
||
2861 | you do. This module has been tested with each of the binary perl versions |
||
2862 | for which Win32::API is supported: AS builds 315, 316, 500-509 and GS |
||
2863 | 5.004_02. It has only been tested on Intel hardware. |
||
2864 | |||
2865 | Although the B<lookfor, stty_xxx, and Tied FileHandle> mechanisms are |
||
2866 | considered stable, they have only been tested on a small subset of possible |
||
2867 | applications. While "\r" characters may be included in the clear string |
||
2868 | using B<is_stty_clear> internally, "\n" characters may NOT be included |
||
2869 | in multi-character strings if you plan to save the strings in a configuration |
||
2870 | file (which uses "\n" as an internal terminator). |
||
2871 | |||
2872 | =over 4 |
||
2873 | |||
2874 | =item Tutorial |
||
2875 | |||
2876 | With all the options, this module needs a good tutorial. It doesn't |
||
2877 | have a complete one yet. A I<"How to get started"> tutorial appeared |
||
2878 | B<The Perl Journal #13> (March 1999). Examples from the article are |
||
2879 | available from http://tpj.com and from http://members.aol.com/Bbirthisel. |
||
2880 | The demo programs in the distribution are a good starting point for |
||
2881 | additional examples. |
||
2882 | |||
2883 | =item Buffers |
||
2884 | |||
2885 | The size of the Win32 buffers are selectable with B<buffers>. But each read |
||
2886 | method currently uses a fixed internal buffer of 4096 bytes. This can be |
||
2887 | changed in the Win32API::CommPort source and read with B<internal_buffer>. |
||
2888 | The XS version will support dynamic buffer sizing. Large operations are |
||
2889 | automatically converted to multiple smaller ones by the B<tied FileHandle> |
||
2890 | methods. |
||
2891 | |||
2892 | =item Modems |
||
2893 | |||
2894 | Lots of modem-specific options are not supported. The same is true of |
||
2895 | TAPI, MAPI. I<API Wizards> are welcome to contribute. |
||
2896 | |||
2897 | =item API Options |
||
2898 | |||
2899 | Lots of options are just "passed through from the API". Some probably |
||
2900 | shouldn't be used together. The module validates the obvious choices when |
||
2901 | possible. For something really fancy, you may need additional API |
||
2902 | documentation. Available from I<Micro$oft Pre$$>. |
||
2903 | |||
2904 | =back |
||
2905 | |||
2906 | =head1 BUGS |
||
2907 | |||
2908 | On Win32, a port must B<close> before it can be reopened again by the same |
||
2909 | process. If a physical port can be accessed using more than one name (see |
||
2910 | above), all names are treated as one. The perl script can also be run |
||
2911 | multiple times within a single batch file or shell script. The I<Makefile.PL> |
||
2912 | spawns subshells with backticks to run the test suite on Perl 5.003 - ugly, |
||
2913 | but it works. |
||
2914 | |||
2915 | On NT, a B<read_done> or B<write_done> returns I<False> if a background |
||
2916 | operation is aborted by a purge. Win95 returns I<True>. |
||
2917 | |||
2918 | EXTENDED_OS_ERROR ($^E) is not supported by the binary ports before 5.005. |
||
2919 | It "sort-of-tracks" B<$!> in 5.003 and 5.004, but YMMV. |
||
2920 | |||
2921 | A few NT systems seem to set B<can_parity_enable> true, but do not actually |
||
2922 | support setting B<parity_enable>. This may be a characteristic of certain |
||
2923 | third-party serial drivers. |
||
2924 | |||
2925 | __Please send comments and bug reports to wcbirthisel@alum.mit.edu. |
||
2926 | |||
2927 | =head1 AUTHORS |
||
2928 | |||
2929 | Bill Birthisel, wcbirthisel@alum.mit.edu, http://members.aol.com/Bbirthisel/. |
||
2930 | |||
2931 | Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/. |
||
2932 | |||
2933 | =head1 SEE ALSO |
||
2934 | |||
2935 | Win32API::CommPort - the low-level API calls which support this module |
||
2936 | |||
2937 | Win32API::File I<when available> |
||
2938 | |||
2939 | Win32::API - Aldo Calpini's "Magic", http://www.divinf.it/dada/perl/ |
||
2940 | |||
2941 | Perltoot.xxx - Tom (Christiansen)'s Object-Oriented Tutorial |
||
2942 | |||
2943 | Expect.pm - Austin Schutz's adaptation of TCL's "expect" for Unix Perls |
||
2944 | |||
2945 | =head1 COPYRIGHT |
||
2946 | |||
2947 | Copyright (C) 1999, Bill Birthisel. All rights reserved. |
||
2948 | |||
2949 | This module is free software; you can redistribute it and/or modify it |
||
2950 | under the same terms as Perl itself. |
||
2951 | |||
2952 | =head2 COMPATIBILITY |
||
2953 | |||
2954 | Most of the code in this module has been stable since version 0.12. |
||
2955 | Except for items indicated as I<Experimental>, I do not expect functional |
||
2956 | changes which are not fully backwards compatible. However, Version 0.16 |
||
2957 | removes the "dummy (0, 1) list" which was returned by many binary methods |
||
2958 | in case they were called in list context. I do not know of any use outside |
||
2959 | the test suite for that feature. |
||
2960 | |||
2961 | Version 0.12 added an I<Install.PL> script to put modules into the documented |
||
2962 | Namespaces. The script uses I<MakeMaker> tools not available in |
||
2963 | ActiveState 3xx builds. Users of those builds will need to install |
||
2964 | differently (see README). Programs in the test suite are modified for |
||
2965 | the current version. Additions to the configurtion files generated by |
||
2966 | B<save> prevent those created by Version 0.18 from being used by earlier |
||
2967 | Versions. 4 November 1999. |
||
2968 | |||
2969 | =cut |