File Coverage

blib/lib/Device/SerialPort.pm
Criterion Covered Total %
statement 50 1333 3.7
branch 4 764 0.5
condition 1 158 0.6
subroutine 15 169 8.8
pod 5 147 3.4
total 75 2571 2.9


line stmt bran cond sub pod time code
1             # This is a POSIX version of the Win32::Serialport module
2             # ported by Joe Doss, Kees Cook
3             # Originally for use with the MisterHouse and Sendpage programs
4             #
5             # $Id: SerialPort.pm 313 2007-10-24 05:50:46Z keescook $
6             #
7             # Copyright (C) 1999, Bill Birthisel
8             # Copyright (C) 2000-2007 Kees Cook
9             # kees@outflux.net, http://outflux.net/
10             #
11             # This program is free software; you can redistribute it and/or
12             # modify it under the terms of the GNU General Public License
13             # as published by the Free Software Foundation; either version 2
14             # of the License, or (at your option) any later version.
15             #
16             # This program is distributed in the hope that it will be useful,
17             # but WITHOUT ANY WARRANTY; without even the implied warranty of
18             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19             # GNU General Public License for more details.
20             #
21             # You should have received a copy of the GNU General Public License
22             # along with this program; if not, write to the Free Software
23             # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24             # http://www.gnu.org/copyleft/gpl.html
25             #
26             package Device::SerialPort;
27              
28 5     5   173581 use 5.006;
  5         21  
  5         214  
29 5     5   29 use strict;
  5         9  
  5         194  
30 5     5   33 use warnings;
  5         9  
  5         195  
31 5     5   2900 use POSIX qw(:termios_h);
  5         35147  
  5         33  
32 5     5   11557 use IO::Handle;
  5         44227  
  5         415  
33 5     5   42 use Carp;
  5         12  
  5         307  
34              
35 5     5   29 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  5         13  
  5         1165  
36             $VERSION = 1.04;
37              
38             require Exporter;
39              
40             @ISA = qw(Exporter);
41             @EXPORT= qw();
42             @EXPORT_OK= qw();
43             %EXPORT_TAGS = (STAT => [qw( MS_CTS_ON MS_DSR_ON
44             MS_RING_ON MS_RLSD_ON
45             MS_DTR_ON MS_RTS_ON
46             ST_BLOCK ST_INPUT
47             ST_OUTPUT ST_ERROR
48             TIOCM_CD TIOCM_RI
49             TIOCM_DSR TIOCM_DTR
50             TIOCM_CTS TIOCM_RTS
51             TIOCM_LE
52             )],
53              
54             PARAM => [qw( LONGsize SHORTsize OS_Error
55             nocarp yes_true )]);
56              
57             Exporter::export_ok_tags('STAT', 'PARAM');
58              
59             $EXPORT_TAGS{ALL} = \@EXPORT_OK;
60              
61             require XSLoader;
62             XSLoader::load('Device::SerialPort', $VERSION);
63              
64             #### Package variable declarations ####
65              
66 5         23414 use vars qw($IOCTL_VALUE_RTS $IOCTL_VALUE_DTR $IOCTL_VALUE_TERMIOXFLOW
67 5     5   36 $ms_per_tick);
  5         8  
68              
69             # Load all the system bits we need
70             my $bits=Device::SerialPort::Bits::get_hash();
71             my $ms_per_tick=undef;
72              
73             # ioctl values
74             $IOCTL_VALUE_RTS = pack('L', $bits->{'TIOCM_RTS'} || 0);
75             $IOCTL_VALUE_DTR = pack('L', $bits->{'TIOCM_DTR'} || 0);
76             $IOCTL_VALUE_TERMIOXFLOW = (($bits->{'CTSXON'}||0) | ($bits->{'RTSXOFF'}||0));
77              
78             # non-POSIX constants commonly defined in termios.ph
79 0   0 0 0 0 sub CRTSCTS { return $bits->{'CRTSCTS'} || 0; }
80              
81 0   0 0 0 0 sub OCRNL { return $bits->{'OCRNL'} || 0; }
82              
83 0   0 0 0 0 sub ONLCR { return $bits->{'ONLCR'} || 0; }
84              
85 0   0 0 0 0 sub ECHOKE { return $bits->{'ECHOKE'} || 0; }
86              
87 0   0 0 0 0 sub ECHOCTL { return $bits->{'ECHOCTL'} || 0; }
88              
89 0   0 0 0 0 sub TIOCM_LE { return $bits->{'TIOCSER_TEMT'} || $bits->{'TIOCM_LE'} || 0; }
90              
91             # Set alternate bit names
92             $bits->{'portable_TIOCINQ'} = $bits->{'TIOCINQ'} || $bits->{'FIONREAD'};
93              
94             ## Next 4 use Win32 names for compatibility
95              
96 0     0 0 0 sub MS_RLSD_ON { return TIOCM_CD(); }
97 0   0 0 0 0 sub TIOCM_CD { return $bits->{'TIOCM_CAR'} || $bits->{'TIOCM_CD'} || 0; }
98              
99 0     0 0 0 sub MS_RING_ON { return TIOCM_RI(); }
100 0   0 0 0 0 sub TIOCM_RI { return $bits->{'TIOCM_RNG'} || $bits->{'TIOCM_RI'} || 0; }
101              
102 0     0 0 0 sub MS_CTS_ON { return TIOCM_CTS(); }
103 0   0 0 0 0 sub TIOCM_CTS { return $bits->{'TIOCM_CTS'} || 0; }
104              
105 0     0 0 0 sub MS_DSR_ON { return TIOCM_DSR(); }
106 0   0 0 0 0 sub TIOCM_DSR { return $bits->{'TIOCM_DSR'} || 0; }
107              
108             # For POSIX completeness
109 0     0 0 0 sub MS_RTS_ON { return TIOCM_RTS(); }
110 0   0 0 0 0 sub TIOCM_RTS { return $bits->{'TIOCM_RTS'} || 0; }
111              
112 0     0 0 0 sub MS_DTR_ON { return TIOCM_DTR(); }
113 0   0 0 0 0 sub TIOCM_DTR { return $bits->{'TIOCM_DTR'} || 0; }
114              
115             # "status"
116 0     0 0 0 sub ST_BLOCK {0} # status offsets for caller
117 0     0 0 0 sub ST_INPUT {1}
118 0     0 0 0 sub ST_OUTPUT {2}
119 0     0 0 0 sub ST_ERROR {3} # latched
120              
121             # parameters that must be included in a "save" and "checking subs"
122              
123             my %validate = (
124             ALIAS => "alias",
125             E_MSG => "error_msg",
126             RCONST => "read_const_time",
127             RTOT => "read_char_time",
128             U_MSG => "user_msg",
129             DVTYPE => "devicetype",
130             HNAME => "hostname",
131             HADDR => "hostaddr",
132             DATYPE => "datatype",
133             CFG_1 => "cfg_param_1",
134             CFG_2 => "cfg_param_2",
135             CFG_3 => "cfg_param_3",
136             );
137              
138             my @termios_fields = (
139             "C_CFLAG",
140             "C_IFLAG",
141             "C_ISPEED",
142             "C_LFLAG",
143             "C_OFLAG",
144             "C_OSPEED"
145             );
146              
147             my %c_cc_fields = (
148             VEOF => &POSIX::VEOF,
149             VEOL => &POSIX::VEOL,
150             VERASE => &POSIX::VERASE,
151             VINTR => &POSIX::VINTR,
152             VKILL => &POSIX::VKILL,
153             VQUIT => &POSIX::VQUIT,
154             VSUSP => &POSIX::VSUSP,
155             VSTART => &POSIX::VSTART,
156             VSTOP => &POSIX::VSTOP,
157             VMIN => &POSIX::VMIN,
158             VTIME => &POSIX::VTIME,
159             );
160              
161             my @baudrates = qw(
162             0 50 75 110 134 150 200 300 600
163             1200 1800 2400 4800 9600 19200 38400 57600
164             115200 230400 460800 500000 576000 921600 1000000
165             1152000 2000000 2500000 3000000 3500000 4000000
166             );
167              
168             # Build list of "valid" system baudrates
169             my %bauds;
170             foreach my $baud (@baudrates) {
171             my $baudvar="B$baud";
172             $bauds{$baud}=$bits->{$baudvar} if (defined($bits->{$baudvar}));
173             }
174              
175             my $Babble = 0;
176             my $testactive = 0; # test mode active
177              
178             my @Yes_resp = (
179             "YES", "Y",
180             "ON",
181             "TRUE", "T",
182             "1"
183             );
184              
185             my @binary_opt = ( 0, 1 );
186             my @byte_opt = (0, 255);
187              
188             my $cfg_file_sig="Device::SerialPort_Configuration_File -- DO NOT EDIT --\n";
189              
190             ## my $null=[];
191             my $null=0;
192             my $zero=0;
193              
194             # Preloaded methods go here.
195              
196             sub init_ms_per_tick
197             {
198 1     1 0 2 my $from_posix=undef;
199 1         1 my $errors="";
200              
201             # To find the real "CLK_TCK" value, it is *best* to query sysconf
202             # for it. However, this requires access to _SC_CLK_TCK. In
203             # modern versions of Perl (and libc) these this is correctly found
204             # in the POSIX module. On really old versions, the hard-coded
205             # "CLK_TCK" can be found. So, first attempt to use the POSIX
206             # module to get what we need, and then try our internal bit
207             # detection code, and finally fall back to the hard-coded value
208             # before totally giving up.
209 1         2 for (;;) {
210 1         2 eval { $from_posix = POSIX::sysconf(&POSIX::_SC_CLK_TCK); };
  1         6  
211 1 50       5 last if (!$@);
212 0         0 $errors.="$@\n";
213              
214 0 0       0 if (defined($bits->{'_SC_CLK_TCK'})) {
215 0         0 $from_posix = POSIX::sysconf($bits->{'_SC_CLK_TCK'});
216 0         0 last;
217             }
218 0         0 $errors.="_SC_CLK_TCK not found during compilation\n";
219              
220             # According to POSIX, "CLK_TCK" is obsolete now. See
221             # "man 2 times" and the POSIX-1996 standard
222 0         0 eval { $from_posix = &POSIX::CLK_TCK; };
  0         0  
223 0 0       0 last if (!$@);
224 0         0 $errors.="$@\n";
225              
226 0         0 last;
227             }
228 1 50 33     7 if (!defined($from_posix) || $from_posix == 0) {
229 0         0 die "Cannot find a useful value for _SC_CLK_TCK:\n$errors";
230             }
231 1         4 $ms_per_tick = 1000.0 / $from_posix;
232             }
233              
234             sub get_tick_count {
235             # clone of Win32::GetTickCount - perhaps same 49 day problem
236              
237 2 100   2 0 1275 if (!defined($ms_per_tick)) {
238 1         92 init_ms_per_tick();
239             }
240              
241 2         24 my ($real2, $user2, $system2, $cuser2, $csystem2) = POSIX::times();
242 2         7 $real2 *= $ms_per_tick;
243             ## printf "real2 = %8.0f\n", $real2;
244 2         12 return int $real2;
245             }
246              
247 2     2 0 1066 sub SHORTsize { 0xffff; } # mostly for AltPort test
248 0     0 0   sub LONGsize { 0xffffffff; } # mostly for AltPort test
249              
250 0     0 0   sub OS_Error { print "Device::SerialPort OS_Error\n"; }
251              
252             # test*.pl only - suppresses default messages
253             sub set_test_mode_active {
254 0 0   0 0   return unless (@_ == 2);
255 0           $testactive = $_[1]; # allow "off"
256 0           my @fields = @termios_fields;
257 0           my $item;
258 0           foreach $item (keys %c_cc_fields) {
259 0           push @fields, "C_$item";
260             }
261 0           foreach $item (keys %validate) {
262 0           push @fields, "$item";
263             }
264 0           return @fields;
265             }
266              
267 0     0 0   sub nocarp { return $testactive }
268              
269             sub yes_true {
270 0     0 0   my $choice = uc shift;
271 0           my $ans = 0;
272 0 0         foreach (@Yes_resp) { $ans = 1 if ( $choice eq $_ ) }
  0            
273 0           return $ans;
274             }
275              
276             sub new {
277 0     0 0   my $proto = shift;
278 0   0       my $class = ref($proto) || $proto;
279 0           my $self = {};
280 0           my $ok = 0; # API return value
281              
282 0           my $item = 0;
283              
284 0           my $nameOrConf = shift;
285 0 0 0       return start($class, $nameOrConf, @_) if (-f $nameOrConf && ! -c $nameOrConf );
286              
287 0           $self->{NAME} = $nameOrConf;
288              
289              
290 0           shift; # ignore "$quiet" parameter
291 0           my $lockfile = shift;
292 0 0         if ($lockfile) {
293 0           $self->{LOCK} = $lockfile;
294 0           my $lockf = POSIX::open($self->{LOCK},
295             &POSIX::O_WRONLY |
296             &POSIX::O_CREAT |
297             &POSIX::O_NOCTTY |
298             &POSIX::O_EXCL);
299 0 0         return undef if (!defined($lockf));
300              
301 0           my $pid = "$$\n";
302 0           $ok = POSIX::write($lockf, $pid, length $pid);
303 0           my $ok2 = POSIX::close($lockf);
304 0 0 0       return unless ($ok && (defined $ok2));
305 0           sleep 2; # wild guess for Version 0.05
306             }
307             else {
308 0           $self->{LOCK} = "";
309             }
310              
311 0           $self->{FD}= POSIX::open($self->{NAME},
312             &POSIX::O_RDWR |
313             &POSIX::O_NOCTTY |
314             &POSIX::O_NONBLOCK);
315              
316 0 0         unless (defined $self->{FD}) { $self->{FD} = -1; }
  0            
317 0 0         unless ($self->{FD} >= 0) {
318             # the "unlink" will destroy the err code, so preserve it
319 0           my $save_err=$!+0;
320              
321 0 0         if ($self->{LOCK}) {
322 0           unlink $self->{LOCK};
323 0           $self->{LOCK} = "";
324             }
325              
326 0           $!=$save_err+0;
327 0           return undef;
328             }
329              
330 0           $self->{TERMIOS} = POSIX::Termios->new();
331              
332             # a handle object for ioctls: read-only ok
333 0           $self->{HANDLE} = new_from_fd IO::Handle ($self->{FD}, "r");
334            
335             # get the current attributes
336 0           $ok = $self->{TERMIOS}->getattr($self->{FD});
337              
338 0 0         unless ( $ok ) {
339 0           carp "can't getattr: $!";
340 0           undef $self;
341 0           return undef;
342             }
343              
344             # save the original values
345 0           $self->{"_CFLAG"} = $self->{TERMIOS}->getcflag();
346 0           $self->{"_IFLAG"} = $self->{TERMIOS}->getiflag();
347 0           $self->{"_ISPEED"} = $self->{TERMIOS}->getispeed();
348 0           $self->{"_LFLAG"} = $self->{TERMIOS}->getlflag();
349 0           $self->{"_OFLAG"} = $self->{TERMIOS}->getoflag();
350 0           $self->{"_OSPEED"} = $self->{TERMIOS}->getospeed();
351              
352             # build termiox flag anyway
353 0           $self->{'TERMIOX'} = 0;
354              
355             # copy the original values into "current" values
356 0           foreach $item (keys %c_cc_fields) {
357 0           $self->{"_$item"} = $self->{TERMIOS}->getcc($c_cc_fields{$item});
358             }
359 0           foreach $item (keys %c_cc_fields) {
360 0           $self->{"C_$item"} = $self->{"_$item"};
361             }
362 0           $self->{"C_CFLAG"} = $self->{"_CFLAG"};
363 0           $self->{"C_IFLAG"} = $self->{"_IFLAG"};
364 0           $self->{"C_ISPEED"} = $self->{"_ISPEED"};
365 0           $self->{"C_LFLAG"} = $self->{"_LFLAG"};
366 0           $self->{"C_OFLAG"} = $self->{"_OFLAG"};
367 0           $self->{"C_OSPEED"} = $self->{"_OSPEED"};
368              
369             # Finally, default to "raw" mode for this package
370 0           $self->{"C_IFLAG"} &= ~(IGNBRK|BRKINT|PARMRK|IGNPAR|INPCK|ISTRIP|INLCR|IGNCR|ICRNL|IXON);
371 0           $self->{"C_OFLAG"} &= ~OPOST;
372 0           $self->{"C_LFLAG"} &= ~(ECHO|ECHONL|ICANON|ISIG|IEXTEN);
373              
374             # "minicom" does some alarming things for setting up "raw", which is mostly
375             # just the direct manipulation of the i, o, and l termios flags
376             #$self->{"C_IFLAG"} = 0;
377             #$self->{"C_OFLAG"} = 0;
378             #$self->{"C_LFLAG"} = 0;
379              
380             # Sane port
381 0           $self->{"C_IFLAG"} |= IGNBRK;
382 0           $self->{"C_CFLAG"} |= (CLOCAL|CREAD);
383              
384             # 9600 baud
385 0           $self->{"C_OSPEED"} = $bauds{"9600"};
386 0           $self->{"C_ISPEED"} = $bauds{"9600"};
387              
388             # 8data bits
389 0           $self->{"C_CFLAG"} &= ~CSIZE;
390 0           $self->{"C_CFLAG"} |= CS8;
391              
392             # disable parity
393 0           $self->{"C_CFLAG"} &= ~(PARENB | PARODD);
394              
395             # 1 stop bit
396 0           $self->{"C_CFLAG"} &= ~CSTOPB;
397              
398             # by default, disable the OSX arbitrary baud settings
399 0           $self->{"IOSSIOSPEED_BAUD"} = -1;
400              
401 0           &write_settings($self);
402              
403 0           $self->{ALIAS} = $self->{NAME}; # so "\\.\+++" can be changed
404              
405             # "private" data
406 0           $self->{"_DEBUG"} = 0;
407 0           $self->{U_MSG} = 0;
408 0           $self->{E_MSG} = 0;
409 0           $self->{RCONST} = 0;
410 0           $self->{RTOT} = 0;
411 0           $self->{"_T_INPUT"} = "";
412 0           $self->{"_LOOK"} = "";
413 0           $self->{"_LASTLOOK"} = "";
414 0           $self->{"_LASTLINE"} = "";
415 0           $self->{"_CLASTLINE"} = "";
416 0           $self->{"_SIZE"} = 1;
417 0           $self->{OFS} = "";
418 0           $self->{ORS} = "";
419 0           $self->{"_LMATCH"} = "";
420 0           $self->{"_LPATT"} = "";
421 0           $self->{"_PROMPT"} = "";
422 0           $self->{"_MATCH"} = [];
423 0           $self->{"_CMATCH"} = [];
424 0           @{ $self->{"_MATCH"} } = "\n";
  0            
425 0           @{ $self->{"_CMATCH"} } = "\n";
  0            
426 0           $self->{DVTYPE} = "none";
427 0           $self->{HNAME} = "localhost";
428 0           $self->{HADDR} = 0;
429 0           $self->{DATYPE} = "raw";
430 0           $self->{CFG_1} = "none";
431 0           $self->{CFG_2} = "none";
432 0           $self->{CFG_3} = "none";
433              
434 0           bless ($self, $class);
435              
436 0 0         unless ($self->can_ioctl()) {
437 0 0         nocarp or carp "disabling ioctl methods - system constants not found\n";
438             }
439              
440             # These might be a good idea (but we'll need to change the tests)
441             # $self->read_char_time(0); # no time
442             # $self->read_const_time(100); # 10th of a second
443              
444 0           return $self;
445             }
446              
447             # Returns "1" on success
448             sub write_settings {
449 0     0 0   my $self = shift;
450 0           my ($item, $result);
451              
452             # put current values into Termios structure
453 0           $self->{TERMIOS}->setcflag($self->{"C_CFLAG"});
454 0           $self->{TERMIOS}->setlflag($self->{"C_LFLAG"});
455 0           $self->{TERMIOS}->setiflag($self->{"C_IFLAG"});
456 0           $self->{TERMIOS}->setoflag($self->{"C_OFLAG"});
457 0           $self->{TERMIOS}->setispeed($self->{"C_ISPEED"});
458 0           $self->{TERMIOS}->setospeed($self->{"C_OSPEED"});
459              
460 0           foreach $item (keys %c_cc_fields) {
461 0           $self->{TERMIOS}->setcc($c_cc_fields{$item}, $self->{"C_$item"});
462             }
463              
464             # setattr returns undef on failure
465 0           $result = defined($self->{TERMIOS}->setattr($self->{FD}, &POSIX::TCSANOW));
466              
467             # IOSSIOSPEED settings are overwritten by setattr, so this needs to be
468             # called last.
469 0 0 0       if ($self->{"IOSSIOSPEED_BAUD"} != -1 && $self->can_arbitrary_baud()) {
470 0           my $speed = pack( "L", $self->{"IOSSIOSPEED_BAUD"});
471 0           $self->ioctl('IOSSIOSPEED', \$speed );
472             }
473              
474 0 0         if ($Babble) {
475 0           print "wrote settings to $self->{ALIAS}\n";
476             }
477              
478 0           return $result;
479             }
480              
481             sub save {
482 0     0 0   my $self = shift;
483 0           my $item;
484             my $getsub;
485 0           my $value;
486              
487 0 0         return unless (@_);
488              
489 0           my $filename = shift;
490 0 0         unless ( open CF, ">$filename" ) {
491             #carp "can't open file: $filename";
492 0           return undef;
493             }
494 0           print CF "$cfg_file_sig";
495 0           print CF "$self->{NAME}\n";
496             # used to "reopen" so must be DEVICE=NAME
497 0           print CF "$self->{LOCK}\n";
498             # use lock to "open" if established
499              
500             # put current values from Termios structure FIRST
501 0           foreach $item (@termios_fields) {
502 0           printf CF "$item,%d\n", $self->{"$item"};
503             }
504 0           foreach $item (keys %c_cc_fields) {
505 0           printf CF "C_$item,%d\n", $self->{"C_$item"};
506             }
507            
508 5     5   43 no strict 'refs'; # for $gosub
  5         10  
  5         450  
509 0           while (($item, $getsub) = each %validate) {
510 0           chomp $getsub;
511 0           $value = scalar &$getsub($self);
512 0           print CF "$item,$value\n";
513             }
514 5     5   75 use strict 'refs';
  5         15  
  5         2315  
515 0           close CF;
516 0 0         if ($Babble) {
517 0           print "wrote file $filename for $self->{ALIAS}\n";
518             }
519 0           1;
520             }
521              
522             # parse values for start/restart
523             sub get_start_values {
524 0 0   0 0   return unless (@_ == 2);
525 0           my $self = shift;
526 0           my $filename = shift;
527              
528 0 0         unless ( open CF, "<$filename" ) {
529 0           carp "can't open file: $filename: $!";
530 0           return;
531             }
532 0           my ($signature, $name, $lockfile, @values) = ;
533 0           close CF;
534            
535 0 0         unless ( $cfg_file_sig eq $signature ) {
536 0           carp "Invalid signature in $filename: $signature";
537 0           return;
538             }
539 0           chomp $name;
540 0 0         unless ( $self->{NAME} eq $name ) {
541 0           carp "Invalid Port DEVICE=$self->{NAME} in $filename: $name";
542 0           return;
543             }
544 0           chomp $lockfile;
545 0 0 0       if ($Babble or not $self) {
546 0           print "signature = $signature";
547 0           print "name = $name\n";
548 0 0         if ($Babble) {
549 0           print "values:\n";
550 0           foreach (@values) { print " $_"; }
  0            
551             }
552             }
553 0           my $item;
554 0           my @fields = @termios_fields;
555 0           foreach $item (keys %c_cc_fields) {
556 0           push @fields, "C_$item";
557             }
558 0           my %termios;
559 0           foreach $item (@fields) {
560 0           $termios{$item} = 1;
561             }
562 0           my $key;
563             my $value;
564 0           my $gosub;
565 0           my $fault = 0;
566 5     5   25 no strict 'refs'; # for $gosub
  5         10  
  5         899  
567 0           foreach $item (@values) {
568 0           chomp $item;
569 0           ($key, $value) = split (/,/, $item);
570 0 0         if ($value eq "") { $fault++ }
  0 0          
571             elsif (defined $termios{$key}) {
572 0           $self->{"$key"} = $value;
573             }
574             else {
575 0           $gosub = $validate{$key};
576 0 0         unless (defined &$gosub ($self, $value)) {
577 0           carp "Invalid parameter for $key=$value ";
578 0           return;
579             }
580             }
581             }
582 5     5   25 use strict 'refs';
  5         8  
  5         71462  
583 0 0         if ($fault) {
584 0           carp "Invalid value in $filename";
585 0           undef $self;
586 0           return;
587             }
588 0           1;
589             }
590              
591             sub restart {
592 0 0   0 0   return unless (@_ == 2);
593 0           my $self = shift;
594 0           my $filename = shift;
595 0           get_start_values($self, $filename);
596 0           write_settings($self);
597             }
598              
599             sub start {
600 0     0 0   my $proto = shift;
601 0   0       my $class = ref($proto) || $proto;
602              
603 0 0         return unless (@_);
604 0           my $filename = shift;
605              
606 0 0         unless ( open CF, "<$filename" ) {
607 0           carp "can't open file: $filename: $!";
608 0           return;
609             }
610 0           my ($signature, $name, $lockfile, @values) = ;
611 0           close CF;
612            
613 0 0         unless ( $cfg_file_sig eq $signature ) {
614 0           carp "Invalid signature in $filename: $signature";
615 0           return;
616             }
617 0           chomp $name;
618 0           chomp $lockfile;
619 0           my $self = new ($class, $name, 1, $lockfile); # quiet for lock
620 0 0 0       return 0 if ($lockfile and not $self);
621 0 0 0       if ($Babble or not $self) {
622 0           print "signature = $signature";
623 0           print "class = $class\n";
624 0           print "name = $name\n";
625 0           print "lockfile = $lockfile\n";
626 0 0         if ($Babble) {
627 0           print "values:\n";
628 0           foreach (@values) { print " $_"; }
  0            
629             }
630             }
631 0 0         if ($self) {
632 0 0         if ( get_start_values($self, $filename) ) {
633 0           write_settings ($self);
634             }
635             else {
636 0           carp "Invalid value in $filename";
637 0           undef $self;
638 0           return;
639             }
640             }
641 0           return $self;
642             }
643              
644             # true/false capabilities (read only)
645             # currently just constants in the POSIX case
646              
647 0     0 0   sub can_baud { return 1; }
648 0     0 0   sub can_databits { return 1; }
649 0     0 0   sub can_stopbits { return 1; }
650 0     0 0   sub can_dtrdsr { return 1; }
651 0     0 0   sub can_handshake { return 1; }
652 0     0 0   sub can_parity_check { return 1; }
653 0     0 0   sub can_parity_config { return 1; }
654 0     0 0   sub can_parity_enable { return 1; }
655 0     0 0   sub can_rlsd { return 0; } # currently
656 0     0 0   sub can_16bitmode { return 0; } # Win32-specific
657 0     0 0   sub is_rs232 { return 1; }
658 0     0 0   sub is_modem { return 0; } # Win32-specific
659 0     0 0   sub can_rtscts { return 1; } # this is a flow option
660 0     0 0   sub can_xonxoff { return 1; } # this is a flow option
661 0     0 0   sub can_xon_char { return 1; } # use stty
662 0     0 0   sub can_spec_char { return 0; } # use stty
663 0     0 0   sub can_interval_timeout { return 0; } # currently
664 0     0 0   sub can_total_timeout { return 1; } # currently
665 0     0 0   sub binary { return 1; }
666            
667 0     0 0   sub reset_error { return 0; } # for compatibility
668              
669             sub can_ioctl {
670 0 0 0 0 0   if (defined($bits->{'TIOCMBIS'}) && # Turn on
      0        
      0        
      0        
671             defined($bits->{'TIOCMBIC'}) && # Turn off
672             defined($bits->{'TIOCM_RTS'}) && # RTS value
673             ( ( defined($bits->{'TIOCSDTR'}) && # DTR ability/value
674             defined($bits->{'TIOCCDTR'}) ) ||
675             defined($bits->{'TIOCM_DTR'})
676             )
677             ) {
678 0           return 1;
679             }
680 0           return 0;
681              
682             #return 0 unless ($bitset && $bitclear && $rtsout &&
683             # (($dtrset && $dtrclear) || $dtrout));
684             #return 1;
685             }
686              
687             sub can_modemlines {
688 0 0   0 0   return 1 if (defined($bits->{'TIOCMGET'}));
689 0           return 0;
690             }
691              
692             sub can_wait_modemlines {
693 0 0   0 0   return 1 if (defined($bits->{'TIOCMIWAIT'}));
694 0           return 0;
695             }
696              
697             sub can_intr_count {
698 0 0   0 0   return 1 if (defined($bits->{'TIOCGICOUNT'}));
699 0           return 0;
700             }
701              
702             sub can_status {
703 0 0 0 0 0   return 1 if (defined($bits->{'portable_TIOCINQ'}) &&
704             defined($bits->{'TIOCOUTQ'}));
705 0           return 0;
706             #return 0 unless ($incount && $outcount);
707             #return 1;
708             }
709              
710             sub can_write_done {
711 0     0 0   my ($self)=@_;
712 0 0 0       return 1 if ($self->can_status &&
      0        
713             defined($bits->{'TIOCSERGETLSR'}) &&
714             TIOCM_LE);
715 0           return 0;
716             }
717              
718             # can we control the rts line?
719             sub can_rts {
720 0 0 0 0 0   if (defined($bits->{'TIOCMBIS'}) &&
      0        
721             defined($bits->{'TIOCMBIC'}) &&
722             defined($bits->{'TIOCM_RTS'})) {
723 0           return 1;
724             }
725 0           return 0;
726              
727             # why are we testing for _lack_ of dtrset/clear? can BSD NOT control RTS?
728             #return 0 unless($bitset && $bitclear && $rtsout && !($dtrset && $dtrclear));
729             #return 1;
730             }
731              
732             # can we set arbitrary baud rates? (OSX)
733             sub can_arbitrary_baud {
734 0 0   0 0   return 1 if (defined($bits->{'IOSSIOSPEED'}));
735 0           return 0;
736             }
737              
738             sub termiox {
739 0     0 0   my $self = shift;
740 0 0         return unless ($IOCTL_VALUE_TERMIOXFLOW);
741 0           my $on = shift;
742 0           my $rc;
743              
744 0 0         $self->{'TERMIOX'}=$on ? $IOCTL_VALUE_TERMIOXFLOW : 0;
745              
746 0           my $flags=pack('SSSS',0,0,0,0);
747 0 0         return undef unless $self->ioctl('TCGETX', \$flags);
748             #if (!($rc=ioctl($self->{HANDLE}, $tcgetx, $flags))) {
749             #warn "TCGETX($tcgetx) ioctl: $!\n";
750             #}
751              
752 0           my @vals=unpack('SSSS',$flags);
753 0 0         $vals[0]= $on ? $IOCTL_VALUE_TERMIOXFLOW : 0;
754 0           $flags=pack('SSSS',@vals);
755              
756 0 0         return undef unless $self->ioctl('TCSETX', \$flags);
757             #if (!($rc=ioctl($self->{HANDLE}, $tcsetx, $flags))) {
758             #warn "TCSETX($tcsetx) ioctl: $!\n";
759             #}
760 0           return 1;
761             }
762            
763             sub handshake {
764 0     0 1   my $self = shift;
765            
766 0 0         if (@_) {
767 0 0         if ( $_[0] eq "none" ) {
    0          
    0          
768 0           $self->{"C_IFLAG"} &= ~(IXON | IXOFF);
769 0 0         $self->termiox(0) if ($IOCTL_VALUE_TERMIOXFLOW);
770 0           $self->{"C_CFLAG"} &= ~CRTSCTS;
771             }
772             elsif ( $_[0] eq "xoff" ) {
773 0           $self->{"C_IFLAG"} |= (IXON | IXOFF);
774 0 0         $self->termiox(0) if ($IOCTL_VALUE_TERMIOXFLOW);
775 0           $self->{"C_CFLAG"} &= ~CRTSCTS;
776             }
777             elsif ( $_[0] eq "rts" ) {
778 0           $self->{"C_IFLAG"} &= ~(IXON | IXOFF);
779 0 0         $self->termiox(1) if ($IOCTL_VALUE_TERMIOXFLOW);
780 0           $self->{"C_CFLAG"} |= CRTSCTS;
781             }
782             else {
783 0 0 0       if ($self->{U_MSG} or $Babble) {
784 0           carp "Can't set handshake on $self->{ALIAS}";
785             }
786 0           return undef;
787             }
788 0           write_settings($self);
789             }
790 0 0         if (wantarray) { return ("none", "xoff", "rts"); }
  0            
791 0           my $mask = (IXON|IXOFF);
792 0 0         return "xoff" if ($mask == ($self->{"C_IFLAG"} & $mask));
793 0 0         if ($IOCTL_VALUE_TERMIOXFLOW) {
794 0 0         return "rts" if ($self->{'TERMIOX'} & $IOCTL_VALUE_TERMIOXFLOW);
795             } else {
796 0 0         return "rts" if ($self->{"C_CFLAG"} & CRTSCTS);
797             }
798 0           return "none";
799             }
800              
801             sub baudrate {
802 0     0 1   my ($self,$rate) = @_;
803 0           my $item = 0;
804              
805 0 0         if (defined($rate)) {
806             # specific baud rate
807 0 0         if (defined $bauds{$rate}) {
    0          
808 0           $self->{"C_OSPEED"} = $bauds{$rate};
809 0           $self->{"C_ISPEED"} = $bauds{$rate};
810 0           $self->{"IOSSIOSPEED_BAUD"} = -1;
811 0           write_settings($self);
812             }
813             # arbitrary baud rate
814             elsif ($self->can_arbitrary_baud()) {
815 0           $self->{"IOSSIOSPEED_BAUD"} = $rate;
816 0           write_settings($self);
817 0           return $rate;
818             }
819             # no such baud rate
820             else {
821 0 0 0       if ($self->{U_MSG} or $Babble) {
822 0           carp "Can't set baudrate ($rate) on $self->{ALIAS}";
823             }
824 0           return 0;
825             }
826             }
827 0 0         if (wantarray) { return (keys %bauds); }
  0            
828 0           foreach $item (keys %bauds) {
829 0 0         return $item if ($bauds{$item} == $self->{"C_OSPEED"});
830             }
831 0           return 0;
832             }
833              
834             # Interesting note about parity. It seems that while the "correct" thing
835             # to do is to enable inbound parity checking (INPCK) and to strip the bits,
836             # this doesn't seem to be sane for a large number of systems, modems,
837             # whatever. If "INPCK" or "ISTRIP" is needed, please use the stty_inpck
838             # and stty_istrip functions
839             sub parity {
840 0     0 1   my $self = shift;
841 0 0         if (@_) {
842 0 0         if ( $_[0] eq "none" ) {
    0          
    0          
843 0           $self->{"C_CFLAG"} &= ~(PARENB|PARODD);
844             }
845             elsif ( $_[0] eq "odd" ) {
846 0           $self->{"C_CFLAG"} |= (PARENB|PARODD);
847             }
848             elsif ( $_[0] eq "even" ) {
849 0           $self->{"C_CFLAG"} |= PARENB;
850 0           $self->{"C_CFLAG"} &= ~PARODD;
851             }
852             else {
853 0 0 0       if ($self->{U_MSG} or $Babble) {
854 0           carp "Can't set parity on $self->{ALIAS}";
855             }
856 0           return undef;
857             }
858 0 0         return undef if (!(write_settings($self)));
859             }
860 0 0         if (wantarray) { return ("none", "odd", "even"); }
  0            
861 0 0         return "none" unless ($self->{"C_CFLAG"} & PARENB);
862 0           my $mask = (PARENB|PARODD);
863 0 0         return "odd" if ($mask == ($self->{"C_CFLAG"} & $mask));
864 0           $mask = (PARENB);
865 0 0         return "even" if ($mask == ($self->{"C_CFLAG"} & $mask));
866 0           return "unknown";
867             }
868              
869             sub databits {
870 0     0 1   my $self = shift;
871 0 0         if (@_) {
872 0 0         if ( $_[0] == 8 ) {
    0          
    0          
    0          
873 0           $self->{"C_CFLAG"} &= ~CSIZE;
874 0           $self->{"C_CFLAG"} |= CS8;
875             }
876             elsif ( $_[0] == 7 ) {
877 0           $self->{"C_CFLAG"} &= ~CSIZE;
878 0           $self->{"C_CFLAG"} |= CS7;
879             }
880             elsif ( $_[0] == 6 ) {
881 0           $self->{"C_CFLAG"} &= ~CSIZE;
882 0           $self->{"C_CFLAG"} |= CS6;
883             }
884             elsif ( $_[0] == 5 ) {
885 0           $self->{"C_CFLAG"} &= ~CSIZE;
886 0           $self->{"C_CFLAG"} |= CS5;
887             }
888             else {
889 0 0 0       if ($self->{U_MSG} or $Babble) {
890 0           carp "Can't set databits on $self->{ALIAS}";
891             }
892 0           return undef;
893             }
894 0           write_settings($self);
895             }
896 0 0         if (wantarray) { return (5, 6, 7, 8); }
  0            
897 0           my $mask = ($self->{"C_CFLAG"} & CSIZE);
898 0 0         return 8 if ($mask == CS8);
899 0 0         return 7 if ($mask == CS7);
900 0 0         return 6 if ($mask == CS6);
901 0           return 5;
902             }
903              
904             sub stopbits {
905 0     0 1   my $self = shift;
906 0 0         if (@_) {
907 0 0         if ( $_[0] == 2 ) {
    0          
908 0           $self->{"C_CFLAG"} |= CSTOPB;
909             }
910             elsif ( $_[0] == 1 ) {
911 0           $self->{"C_CFLAG"} &= ~CSTOPB;
912             }
913             else {
914 0 0 0       if ($self->{U_MSG} or $Babble) {
915 0           carp "Can't set stopbits on $self->{ALIAS}";
916             }
917 0           return undef;
918             }
919 0           write_settings($self);
920             }
921 0 0         if (wantarray) { return (1, 2); }
  0            
922 0 0         return 2 if ($self->{"C_CFLAG"} & CSTOPB);
923 0           return 1;
924             }
925              
926             sub is_xon_char {
927 0     0 0   my $self = shift;
928 0 0         if (@_) {
929 0           my $v = int shift;
930 0 0 0       return if (($v < 0) or ($v > 255));
931 0           $self->{"C_VSTART"} = $v;
932 0           write_settings($self);
933             }
934 0           return $self->{"C_VSTART"};
935             }
936              
937             sub is_xoff_char {
938 0     0 0   my $self = shift;
939 0 0         if (@_) {
940 0           my $v = int shift;
941 0 0 0       return if (($v < 0) or ($v > 255));
942 0           $self->{"C_VSTOP"} = $v;
943 0           write_settings($self);
944             }
945 0           return $self->{"C_VSTOP"};
946             }
947              
948             sub is_stty_intr {
949 0     0 0   my $self = shift;
950 0 0         if (@_) {
951 0           my $v = int shift;
952 0 0 0       return if (($v < 0) or ($v > 255));
953 0           $self->{"C_VINTR"} = $v;
954 0           write_settings($self);
955             }
956 0           return $self->{"C_VINTR"};
957             }
958              
959             sub is_stty_quit {
960 0     0 0   my $self = shift;
961 0 0         if (@_) {
962 0           my $v = int shift;
963 0 0 0       return if (($v < 0) or ($v > 255));
964 0           $self->{"C_VQUIT"} = $v;
965 0           write_settings($self);
966             }
967 0           return $self->{"C_VQUIT"};
968             }
969              
970             sub is_stty_eof {
971 0     0 0   my $self = shift;
972 0 0         if (@_) {
973 0           my $v = int shift;
974 0 0 0       return if (($v < 0) or ($v > 255));
975 0           $self->{"C_VEOF"} = $v;
976 0           write_settings($self);
977             }
978 0           return $self->{"C_VEOF"};
979             }
980              
981             sub is_stty_eol {
982 0     0 0   my $self = shift;
983 0 0         if (@_) {
984 0           my $v = int shift;
985 0 0 0       return if (($v < 0) or ($v > 255));
986 0           $self->{"C_VEOL"} = $v;
987 0           write_settings($self);
988             }
989 0           return $self->{"C_VEOL"};
990             }
991              
992             sub is_stty_erase {
993 0     0 0   my $self = shift;
994 0 0         if (@_) {
995 0           my $v = int shift;
996 0 0 0       return if (($v < 0) or ($v > 255));
997 0           $self->{"C_VERASE"} = $v;
998 0           write_settings($self);
999             }
1000 0           return $self->{"C_VERASE"};
1001             }
1002              
1003             sub is_stty_kill {
1004 0     0 0   my $self = shift;
1005 0 0         if (@_) {
1006 0           my $v = int shift;
1007 0 0 0       return if (($v < 0) or ($v > 255));
1008 0           $self->{"C_VKILL"} = $v;
1009 0           write_settings($self);
1010             }
1011 0           return $self->{"C_VKILL"};
1012             }
1013              
1014             sub is_stty_susp {
1015 0     0 0   my $self = shift;
1016 0 0         if (@_) {
1017 0           my $v = int shift;
1018 0 0 0       return if (($v < 0) or ($v > 255));
1019 0           $self->{"C_VSUSP"} = $v;
1020 0           write_settings($self);
1021             }
1022 0           return $self->{"C_VSUSP"};
1023             }
1024              
1025             sub stty_echo {
1026 0     0 0   my $self = shift;
1027 0 0         if (@_) {
1028 0 0         if ( yes_true( shift ) ) {
1029 0           $self->{"C_LFLAG"} |= ECHO;
1030             } else {
1031 0           $self->{"C_LFLAG"} &= ~ECHO;
1032             }
1033 0           write_settings($self);
1034             }
1035 0 0         return ($self->{"C_LFLAG"} & ECHO) ? 1 : 0;
1036             }
1037              
1038             sub stty_echoe {
1039 0     0 0   my $self = shift;
1040 0 0         if (@_) {
1041 0 0         if ( yes_true( shift ) ) {
1042 0           $self->{"C_LFLAG"} |= ECHOE;
1043             } else {
1044 0           $self->{"C_LFLAG"} &= ~ECHOE;
1045             }
1046 0           write_settings($self);
1047             }
1048 0 0         return ($self->{"C_LFLAG"} & ECHOE) ? 1 : 0;
1049             }
1050              
1051             sub stty_echok {
1052 0     0 0   my $self = shift;
1053 0 0         if (@_) {
1054 0 0         if ( yes_true( shift ) ) {
1055 0           $self->{"C_LFLAG"} |= ECHOK;
1056             } else {
1057 0           $self->{"C_LFLAG"} &= ~ECHOK;
1058             }
1059 0           write_settings($self);
1060             }
1061 0 0         return ($self->{"C_LFLAG"} & ECHOK) ? 1 : 0;
1062             }
1063              
1064             sub stty_echonl {
1065 0     0 0   my $self = shift;
1066 0 0         if (@_) {
1067 0 0         if ( yes_true( shift ) ) {
1068 0           $self->{"C_LFLAG"} |= ECHONL;
1069             } else {
1070 0           $self->{"C_LFLAG"} &= ~ECHONL;
1071             }
1072 0           write_settings($self);
1073             }
1074 0 0         return ($self->{"C_LFLAG"} & ECHONL) ? 1 : 0;
1075             }
1076              
1077             # non-POSIX
1078             sub stty_echoke {
1079 0     0 0   my $self = shift;
1080 0 0         return unless ECHOKE;
1081 0 0         if (@_) {
1082 0 0         if ( yes_true( shift ) ) {
1083 0           $self->{"C_LFLAG"} |= ECHOKE;
1084             } else {
1085 0           $self->{"C_LFLAG"} &= ~ECHOKE;
1086             }
1087 0           write_settings($self);
1088             }
1089 0 0         return ($self->{"C_LFLAG"} & ECHOKE) ? 1 : 0;
1090             }
1091              
1092             # non-POSIX
1093             sub stty_echoctl {
1094 0     0 0   my $self = shift;
1095 0 0         return unless ECHOCTL;
1096 0 0         if (@_) {
1097 0 0         if ( yes_true( shift ) ) {
1098 0           $self->{"C_LFLAG"} |= ECHOCTL;
1099             } else {
1100 0           $self->{"C_LFLAG"} &= ~ECHOCTL;
1101             }
1102 0           write_settings($self);
1103             }
1104 0 0         return ($self->{"C_LFLAG"} & ECHOCTL) ? 1 : 0;
1105             }
1106              
1107             # Mark parity errors with a leading "NULL" character
1108             sub stty_parmrk {
1109 0     0 0   my $self = shift;
1110 0 0         if (@_) {
1111 0 0         if ( yes_true( shift ) ) {
1112 0           $self->{"C_IFLAG"} |= PARMRK;
1113             } else {
1114 0           $self->{"C_IFLAG"} &= ~PARMRK;
1115             }
1116 0           write_settings($self);
1117             }
1118 0 0         return wantarray ? @binary_opt : ($self->{"C_IFLAG"} & PARMRK);
1119             }
1120              
1121             # Ignore parity errors (considered dangerous)
1122             sub stty_ignpar {
1123 0     0 0   my $self = shift;
1124 0 0         if (@_) {
1125 0 0         if ( yes_true( shift ) ) {
1126 0           $self->{"C_IFLAG"} |= IGNPAR;
1127             } else {
1128 0           $self->{"C_IFLAG"} &= ~IGNPAR;
1129             }
1130 0           write_settings($self);
1131             }
1132 0 0         return wantarray ? @binary_opt : ($self->{"C_IFLAG"} & IGNPAR);
1133             }
1134              
1135             # Ignore breaks
1136             sub stty_ignbrk {
1137 0     0 0   my $self = shift;
1138 0 0         if (@_) {
1139 0 0         if ( yes_true( shift ) ) {
1140 0           $self->{"C_IFLAG"} |= IGNBRK;
1141             } else {
1142 0           $self->{"C_IFLAG"} &= ~IGNBRK;
1143             }
1144 0           write_settings($self);
1145             }
1146 0 0         return ($self->{"C_IFLAG"} & IGNBRK) ? 1 : 0;
1147             }
1148              
1149             # Strip parity bit
1150             sub stty_istrip {
1151 0     0 0   my $self = shift;
1152 0 0         if (@_) {
1153 0 0         if ( yes_true( shift ) ) {
1154 0           $self->{"C_IFLAG"} |= ISTRIP;
1155             } else {
1156 0           $self->{"C_IFLAG"} &= ~ISTRIP;
1157             }
1158 0           write_settings($self);
1159             }
1160 0 0         return ($self->{"C_IFLAG"} & ISTRIP) ? 1 : 0;
1161             }
1162              
1163             # check incoming parity bit
1164             sub stty_inpck {
1165 0     0 0   my $self = shift;
1166 0 0         if (@_) {
1167 0 0         if ( yes_true( shift ) ) {
1168 0           $self->{"C_IFLAG"} |= INPCK;
1169             } else {
1170 0           $self->{"C_IFLAG"} &= ~INPCK;
1171             }
1172 0           write_settings($self);
1173             }
1174 0 0         return ($self->{"C_IFLAG"} & INPCK) ? 1 : 0;
1175             }
1176              
1177             sub stty_icrnl {
1178 0     0 0   my $self = shift;
1179 0 0         if (@_) {
1180 0 0         if ( yes_true( shift ) ) {
1181 0           $self->{"C_IFLAG"} |= ICRNL;
1182             } else {
1183 0           $self->{"C_IFLAG"} &= ~ICRNL;
1184             }
1185 0           write_settings($self);
1186             }
1187 0 0         return ($self->{"C_IFLAG"} & ICRNL) ? 1 : 0;
1188             }
1189              
1190             sub stty_igncr {
1191 0     0 0   my $self = shift;
1192 0 0         if (@_) {
1193 0 0         if ( yes_true( shift ) ) {
1194 0           $self->{"C_IFLAG"} |= IGNCR;
1195             } else {
1196 0           $self->{"C_IFLAG"} &= ~IGNCR;
1197             }
1198 0           write_settings($self);
1199             }
1200 0 0         return ($self->{"C_IFLAG"} & IGNCR) ? 1 : 0;
1201             }
1202              
1203             sub stty_inlcr {
1204 0     0 0   my $self = shift;
1205 0 0         if (@_) {
1206 0 0         if ( yes_true( shift ) ) {
1207 0           $self->{"C_IFLAG"} |= INLCR;
1208             } else {
1209 0           $self->{"C_IFLAG"} &= ~INLCR;
1210             }
1211 0           write_settings($self);
1212             }
1213 0 0         return ($self->{"C_IFLAG"} & INLCR) ? 1 : 0;
1214             }
1215              
1216             # non-POSIX
1217             sub stty_ocrnl {
1218 0     0 0   my $self = shift;
1219 0 0         return unless OCRNL;
1220 0 0         if (@_) {
1221 0 0         if ( yes_true( shift ) ) {
1222 0           $self->{"C_OFLAG"} |= OCRNL;
1223             } else {
1224 0           $self->{"C_OFLAG"} &= ~OCRNL;
1225             }
1226 0           write_settings($self);
1227             }
1228 0 0         return ($self->{"C_OFLAG"} & OCRNL) ? 1 : 0;
1229             }
1230              
1231             # non-POSIX
1232             sub stty_onlcr {
1233 0     0 0   my $self = shift;
1234 0 0         return unless ONLCR;
1235 0 0         if (@_) {
1236 0 0         if ( yes_true( shift ) ) {
1237 0           $self->{"C_OFLAG"} |= ONLCR;
1238             } else {
1239 0           $self->{"C_OFLAG"} &= ~ONLCR;
1240             }
1241 0           write_settings($self);
1242             }
1243 0 0         return ($self->{"C_OFLAG"} & ONLCR) ? 1 : 0;
1244             }
1245              
1246             sub stty_opost {
1247 0     0 0   my $self = shift;
1248 0 0         if (@_) {
1249 0 0         if ( yes_true( shift ) ) {
1250 0           $self->{"C_OFLAG"} |= OPOST;
1251             } else {
1252 0           $self->{"C_OFLAG"} &= ~OPOST;
1253             }
1254 0           write_settings($self);
1255             }
1256 0 0         return ($self->{"C_OFLAG"} & OPOST) ? 1 : 0;
1257             }
1258              
1259             sub stty_isig {
1260 0     0 0   my $self = shift;
1261 0 0         if (@_) {
1262 0 0         if ( yes_true( shift ) ) {
1263 0           $self->{"C_LFLAG"} |= ISIG;
1264             } else {
1265 0           $self->{"C_LFLAG"} &= ~ISIG;
1266             }
1267 0           write_settings($self);
1268             }
1269 0 0         return ($self->{"C_LFLAG"} & ISIG) ? 1 : 0;
1270             }
1271              
1272             sub stty_icanon {
1273 0     0 0   my $self = shift;
1274 0 0         if (@_) {
1275 0 0         if ( yes_true( shift ) ) {
1276 0           $self->{"C_LFLAG"} |= ICANON;
1277             } else {
1278 0           $self->{"C_LFLAG"} &= ~ICANON;
1279             }
1280 0           write_settings($self);
1281             }
1282 0 0         return ($self->{"C_LFLAG"} & ICANON) ? 1 : 0;
1283             }
1284              
1285             sub alias {
1286 0     0 0   my $self = shift;
1287 0 0         if (@_) { $self->{ALIAS} = shift; } # should return true for legal names
  0            
1288 0           return $self->{ALIAS};
1289             }
1290              
1291             sub devicetype {
1292 0     0 0   my $self = shift;
1293 0 0         if (@_) { $self->{DVTYPE} = shift; } # return true for legal names
  0            
1294 0           return $self->{DVTYPE};
1295             }
1296              
1297             sub hostname {
1298 0     0 0   my $self = shift;
1299 0 0         if (@_) { $self->{HNAME} = shift; } # return true for legal names
  0            
1300 0           return $self->{HNAME};
1301             }
1302              
1303             sub hostaddr {
1304 0     0 0   my $self = shift;
1305 0 0         if (@_) { $self->{HADDR} = shift; } # return true for assigned port
  0            
1306 0           return $self->{HADDR};
1307             }
1308              
1309             sub datatype {
1310 0     0 0   my $self = shift;
1311 0 0         if (@_) { $self->{DATYPE} = shift; } # return true for legal types
  0            
1312 0           return $self->{DATYPE};
1313             }
1314              
1315             sub cfg_param_1 {
1316 0     0 0   my $self = shift;
1317 0 0         if (@_) { $self->{CFG_1} = shift; } # return true for legal param
  0            
1318 0           return $self->{CFG_1};
1319             }
1320              
1321             sub cfg_param_2 {
1322 0     0 0   my $self = shift;
1323 0 0         if (@_) { $self->{CFG_2} = shift; } # return true for legal param
  0            
1324 0           return $self->{CFG_2};
1325             }
1326              
1327             sub cfg_param_3 {
1328 0     0 0   my $self = shift;
1329 0 0         if (@_) { $self->{CFG_3} = shift; } # return true for legal param
  0            
1330 0           return $self->{CFG_3};
1331             }
1332              
1333             sub buffers {
1334 0     0 0   my $self = shift;
1335 0 0         if (@_) { return unless (@_ == 2); }
  0 0          
1336 0 0         return wantarray ? (4096, 4096) : 1;
1337             }
1338              
1339             sub read_const_time {
1340 0     0 0   my $self = shift;
1341 0 0         if (@_) {
1342 0           $self->{RCONST} = (shift)/1000; # milliseconds -> select_time
1343 0           $self->{"C_VTIME"} = $self->{RCONST} * 10000; # wants tenths of sec
1344 0           $self->{"C_VMIN"} = 0;
1345 0           write_settings($self);
1346             }
1347 0           return $self->{RCONST}*1000;
1348             }
1349              
1350             sub read_char_time {
1351 0     0 0   my $self = shift;
1352 0 0         if (@_) {
1353 0           $self->{RTOT} = (shift)/1000; # milliseconds -> select_time
1354             }
1355 0           return $self->{RTOT}*1000;
1356             }
1357              
1358             sub read {
1359 0 0   0 0   return undef unless (@_ == 2);
1360 0           my $self = shift;
1361 0           my $wanted = shift;
1362 0           my $result = "";
1363 0           my $ok = 0;
1364 0 0         return (0, "") unless ($wanted > 0);
1365              
1366 0           my $done = 0;
1367 0           my $count_in = 0;
1368 0           my $string_in = "";
1369 0           my $in2 = "";
1370 0           my $bufsize = 255; # VMIN max (declared as char)
1371              
1372 0           while ($done < $wanted) {
1373 0           my $size = $wanted - $done;
1374 0 0         if ($size > $bufsize) { $size = $bufsize; }
  0            
1375 0           ($count_in, $string_in) = $self->read_vmin($size);
1376 0 0         if ($count_in) {
    0          
1377 0           $in2 .= $string_in;
1378 0           $done += $count_in;
1379             }
1380             elsif ($done) {
1381 0           last;
1382             }
1383             else {
1384 0 0         return if (!defined $count_in);
1385 0           last;
1386             }
1387             }
1388 0           return ($done, $in2);
1389             }
1390              
1391             sub read_vmin {
1392 0 0   0 0   return undef unless (@_ == 2);
1393 0           my $self = shift;
1394 0           my $wanted = shift;
1395 0           my $result = "";
1396 0           my $ok = 0;
1397 0 0         return (0, "") unless ($wanted > 0);
1398              
1399             # This appears dangerous under Solaris
1400             # if ($self->{"C_VMIN"} != $wanted) {
1401             # $self->{"C_VMIN"} = $wanted;
1402             # write_settings($self);
1403             # }
1404 0           my $rin = "";
1405 0           vec($rin, $self->{FD}, 1) = 1;
1406 0           my $ein = $rin;
1407 0           my $tin = $self->{RCONST} + ($wanted * $self->{RTOT});
1408 0           my $rout;
1409             my $wout;
1410 0           my $eout;
1411 0           my $tout;
1412 0           my $ready = select($rout=$rin, $wout=undef, $eout=$ein, $tout=$tin);
1413              
1414 0           my $got=0;
1415              
1416 0 0         if ($ready>0) {
1417 0           $got = POSIX::read ($self->{FD}, $result, $wanted);
1418              
1419 0 0 0       if (! defined $got) {
    0          
1420 0 0         return (0,"") if (&POSIX::EAGAIN == ($ok = POSIX::errno()));
1421 0 0 0       return (0,"") if (!$ready and (0 == $ok));
1422             # at least Solaris acts like eof() in this case
1423 0           carp "Error #$ok in Device::SerialPort::read";
1424 0           return;
1425             }
1426             elsif ($got == 0 && $wanted!=0) {
1427             # if read returns "0" on a non-zero request, it's EOF
1428 0           return;
1429             }
1430             }
1431              
1432 0 0         print "read_vmin=$got, ready=$ready, result=..$result..\n" if ($Babble);
1433 0           return ($got, $result);
1434             }
1435              
1436             sub are_match {
1437 0     0 0   my $self = shift;
1438 0           my $pat;
1439 0           my $patno = 0;
1440 0           my $reno = 0;
1441 0           my $re_next = 0;
1442 0 0         if (@_) {
1443 0           @{ $self->{"_MATCH"} } = @_;
  0            
1444 0 0         if ($] >= 5.005) {
1445 0           @{ $self->{"_CMATCH"} } = ();
  0            
1446 0           while ($pat = shift) {
1447 0 0         if ($re_next) {
1448 0           $re_next = 0;
1449 0           eval 'push (@{ $self->{"_CMATCH"} }, qr/$pat/)';
1450             } else {
1451 0           push (@{ $self->{"_CMATCH"} }, $pat);
  0            
1452             }
1453 0 0         if ($pat eq "-re") {
1454 0           $re_next++;
1455             }
1456             }
1457             } else {
1458 0           @{ $self->{"_CMATCH"} } = @_;
  0            
1459             }
1460             }
1461 0           return @{ $self->{"_MATCH"} };
  0            
1462             }
1463              
1464             sub lookclear {
1465 0     0 0   my $self = shift;
1466 0 0 0       if (nocarp && (@_ == 1)) {
1467 0           $self->{"_T_INPUT"} = shift;
1468             }
1469 0           $self->{"_LOOK"} = "";
1470 0           $self->{"_LASTLOOK"} = "";
1471 0           $self->{"_LMATCH"} = "";
1472 0           $self->{"_LPATT"} = "";
1473 0 0         return if (@_);
1474 0           1;
1475             }
1476              
1477             sub linesize {
1478 0     0 0   my $self = shift;
1479 0 0         if (@_) {
1480 0           my $val = int shift;
1481 0 0         return if ($val < 0);
1482 0           $self->{"_SIZE"} = $val;
1483             }
1484 0           return $self->{"_SIZE"};
1485             }
1486              
1487             sub lastline {
1488 0     0 0   my $self = shift;
1489 0 0         if (@_) {
1490 0           $self->{"_LASTLINE"} = shift;
1491 0 0         if ($] >= 5.005) {
1492 0           eval '$self->{"_CLASTLINE"} = qr/$self->{"_LASTLINE"}/';
1493             } else {
1494 0           $self->{"_CLASTLINE"} = $self->{"_LASTLINE"};
1495             }
1496             }
1497 0           return $self->{"_LASTLINE"};
1498             }
1499              
1500             sub matchclear {
1501 0     0 0   my $self = shift;
1502 0           my $found = $self->{"_LMATCH"};
1503 0           $self->{"_LMATCH"} = "";
1504 0 0         return if (@_);
1505 0           return $found;
1506             }
1507              
1508             sub lastlook {
1509 0     0 0   my $self = shift;
1510 0 0         return if (@_);
1511 0           return ( $self->{"_LMATCH"}, $self->{"_LASTLOOK"},
1512             $self->{"_LPATT"}, $self->{"_LOOK"} );
1513             }
1514              
1515             sub lookfor {
1516 0     0 0   my $self = shift;
1517 0           my $size = 0;
1518 0 0         if (@_) { $size = shift; }
  0            
1519 0           my $loc = "";
1520 0           my $count_in = 0;
1521 0           my $string_in = "";
1522 0           $self->{"_LMATCH"} = "";
1523 0           $self->{"_LPATT"} = "";
1524              
1525 0 0         if ( ! $self->{"_LOOK"} ) {
1526 0           $loc = $self->{"_LASTLOOK"};
1527             }
1528              
1529 0 0         if ($size) {
1530 0           ($count_in, $string_in) = $self->read($size);
1531 0 0         return unless ($count_in);
1532 0           $loc .= $string_in;
1533             }
1534             else {
1535 0           $loc .= $self->input;
1536             }
1537              
1538 0 0         if ($loc ne "") {
1539 0           my $n_char;
1540             my $mpos;
1541 0           my $lookbuf;
1542 0           my $re_next = 0;
1543 0           my $got_match = 0;
1544 0           my $pat;
1545            
1546 0           my @loc_char = split (//, $loc);
1547 0           while (defined ($n_char = shift @loc_char)) {
1548 0           $mpos = ord $n_char;
1549 0           $self->{"_LOOK"} .= $n_char;
1550 0           $lookbuf = $self->{"_LOOK"};
1551 0           $count_in = 0;
1552 0           foreach $pat ( @{ $self->{"_CMATCH"} } ) {
  0            
1553 0 0         if ($pat eq "-re") {
1554 0           $re_next++;
1555 0           $count_in++;
1556 0           next;
1557             }
1558 0 0         if ($re_next) {
    0          
1559 0           $re_next = 0;
1560             # always at $lookbuf end when processing single char
1561 0 0         if ( $lookbuf =~ s/$pat//s ) {
1562 0           $self->{"_LMATCH"} = $&;
1563 0           $got_match++;
1564             }
1565             }
1566             elsif (($mpos = index($lookbuf, $pat)) > -1) {
1567 0           $got_match++;
1568 0           $lookbuf = substr ($lookbuf, 0, $mpos);
1569 0           $self->{"_LMATCH"} = $pat;
1570             }
1571 0 0         if ($got_match) {
1572 0           $self->{"_LPATT"} = $self->{"_MATCH"}[$count_in];
1573 0 0         if (scalar @loc_char) {
1574 0           $self->{"_LASTLOOK"} = join("", @loc_char);
1575             }
1576             else {
1577 0           $self->{"_LASTLOOK"} = "";
1578             }
1579 0           $self->{"_LOOK"} = "";
1580 0           return $lookbuf;
1581             }
1582 0           $count_in++;
1583             }
1584             #### }
1585             }
1586             }
1587 0           return "";
1588             }
1589              
1590             sub streamline {
1591 0     0 0   my $self = shift;
1592 0           my $size = 0;
1593 0 0         if (@_) { $size = shift; }
  0            
1594 0           my $loc = "";
1595 0           my $mpos;
1596 0           my $count_in = 0;
1597 0           my $string_in = "";
1598 0           my $re_next = 0;
1599 0           my $got_match = 0;
1600 0           my $best_pos = 0;
1601 0           my $pat;
1602 0           my $match = "";
1603 0           my $before = "";
1604 0           my $after = "";
1605 0           my $best_match = "";
1606 0           my $best_before = "";
1607 0           my $best_after = "";
1608 0           my $best_pat = "";
1609 0           $self->{"_LMATCH"} = "";
1610 0           $self->{"_LPATT"} = "";
1611              
1612 0 0         if ( ! $self->{"_LOOK"} ) {
1613 0           $loc = $self->{"_LASTLOOK"};
1614             }
1615              
1616 0 0         if ($size) {
1617 0           ($count_in, $string_in) = $self->read($size);
1618 0 0         return unless ($count_in);
1619 0           $loc .= $string_in;
1620             }
1621             else {
1622 0           $loc .= $self->input;
1623             }
1624              
1625 0 0         if ($loc ne "") {
1626 0           $self->{"_LOOK"} .= $loc;
1627 0           $count_in = 0;
1628 0           foreach $pat ( @{ $self->{"_CMATCH"} } ) {
  0            
1629 0 0         if ($pat eq "-re") {
1630 0           $re_next++;
1631 0           $count_in++;
1632 0           next;
1633             }
1634 0 0         if ($re_next) {
    0          
1635 0           $re_next = 0;
1636 0 0         if ( $self->{"_LOOK"} =~ /$pat/s ) {
1637 0           ( $match, $before, $after ) = ( $&, $`, $' );
1638 0           $got_match++;
1639 0           $mpos = length($before);
1640 0 0         if ($mpos) {
1641 0 0 0       next if ($best_pos && ($mpos > $best_pos));
1642 0           $best_pos = $mpos;
1643 0           $best_pat = $self->{"_MATCH"}[$count_in];
1644 0           $best_match = $match;
1645 0           $best_before = $before;
1646 0           $best_after = $after;
1647             }
1648             else {
1649 0           $self->{"_LPATT"} = $self->{"_MATCH"}[$count_in];
1650 0           $self->{"_LMATCH"} = $match;
1651 0           $self->{"_LASTLOOK"} = $after;
1652 0           $self->{"_LOOK"} = "";
1653 0           return $before;
1654             # pattern at start will be best
1655             }
1656             }
1657             }
1658             elsif (($mpos = index($self->{"_LOOK"}, $pat)) > -1) {
1659 0           $got_match++;
1660 0           $before = substr ($self->{"_LOOK"}, 0, $mpos);
1661 0 0         if ($mpos) {
1662 0 0 0       next if ($best_pos && ($mpos > $best_pos));
1663 0           $best_pos = $mpos;
1664 0           $best_pat = $pat;
1665 0           $best_match = $pat;
1666 0           $best_before = $before;
1667 0           $mpos += length($pat);
1668 0           $best_after = substr ($self->{"_LOOK"}, $mpos);
1669             }
1670             else {
1671 0           $self->{"_LPATT"} = $pat;
1672 0           $self->{"_LMATCH"} = $pat;
1673 0           $before = substr ($self->{"_LOOK"}, 0, $mpos);
1674 0           $mpos += length($pat);
1675 0           $self->{"_LASTLOOK"} = substr ($self->{"_LOOK"}, $mpos);
1676 0           $self->{"_LOOK"} = "";
1677 0           return $before;
1678             # match at start will be best
1679             }
1680             }
1681 0           $count_in++;
1682             }
1683 0 0         if ($got_match) {
1684 0           $self->{"_LPATT"} = $best_pat;
1685 0           $self->{"_LMATCH"} = $best_match;
1686 0           $self->{"_LASTLOOK"} = $best_after;
1687 0           $self->{"_LOOK"} = "";
1688 0           return $best_before;
1689             }
1690             }
1691 0           return "";
1692             }
1693              
1694             sub input {
1695 0 0   0 0   return undef unless (@_ == 1);
1696 0           my $self = shift;
1697 0           my $ok = 0;
1698 0           my $result = "";
1699 0           my $wanted = 255;
1700              
1701 0 0 0       if (nocarp && $self->{"_T_INPUT"}) {
1702 0           $result = $self->{"_T_INPUT"};
1703 0           $self->{"_T_INPUT"} = "";
1704 0           return $result;
1705             }
1706              
1707 0 0         if ( $self->{"C_VMIN"} ) {
1708 0           $self->{"C_VMIN"} = 0;
1709 0           write_settings($self);
1710             }
1711              
1712 0           my $got = POSIX::read ($self->{FD}, $result, $wanted);
1713              
1714 0 0         unless (defined $got) { $got = -1; }
  0            
1715 0 0         if ($got == -1) {
1716 0 0         return "" if (&POSIX::EAGAIN == ($ok = POSIX::errno()));
1717 0 0         return "" if (0 == $ok); # at least Solaris acts like eof()
1718 0           carp "Error #$ok in Device::SerialPort::input"
1719             }
1720 0           return $result;
1721             }
1722              
1723             sub write {
1724 0 0   0 0   return undef unless (@_ == 2);
1725 0           my $self = shift;
1726 0           my $wbuf = shift;
1727 0           my $ok;
1728              
1729 0 0         return 0 if ($wbuf eq "");
1730 0           my $lbuf = length ($wbuf);
1731              
1732 0           my $written = POSIX::write ($self->{FD}, $wbuf, $lbuf);
1733              
1734 0           return $written;
1735             }
1736              
1737             sub write_drain {
1738 0     0 0   my $self = shift;
1739 0 0         return if (@_);
1740 0 0         return 1 if (defined POSIX::tcdrain($self->{FD}));
1741 0           return;
1742             }
1743              
1744             sub purge_all {
1745 0     0 0   my $self = shift;
1746 0 0         return if (@_);
1747 0 0         return 1 if (defined POSIX::tcflush($self->{FD}, TCIOFLUSH));
1748 0           return;
1749             }
1750              
1751             sub purge_rx {
1752 0     0 0   my $self = shift;
1753 0 0         return if (@_);
1754 0 0         return 1 if (defined POSIX::tcflush($self->{FD}, TCIFLUSH));
1755 0           return;
1756             }
1757              
1758             sub purge_tx {
1759 0     0 0   my $self = shift;
1760 0 0         return if (@_);
1761 0 0         return 1 if (defined POSIX::tcflush($self->{FD}, TCOFLUSH));
1762 0           return;
1763             }
1764              
1765             sub buffer_max {
1766 0     0 0   my $self = shift;
1767 0 0         if (@_) {return undef; }
  0            
1768 0           return (4096, 4096);
1769             }
1770              
1771             # true/false parameters
1772              
1773             sub user_msg {
1774 0     0 0   my $self = shift;
1775 0 0         if (@_) { $self->{U_MSG} = yes_true ( shift ) }
  0            
1776 0 0         return wantarray ? @binary_opt : $self->{U_MSG};
1777             }
1778              
1779             sub error_msg {
1780 0     0 0   my $self = shift;
1781 0 0         if (@_) { $self->{E_MSG} = yes_true ( shift ) }
  0            
1782 0 0         return wantarray ? @binary_opt : $self->{E_MSG};
1783             }
1784              
1785             sub parity_enable {
1786 0     0 0   my $self = shift;
1787 0 0         if (@_) {
1788 0 0         if ( yes_true( shift ) ) {
1789 0           $self->{"C_CFLAG"} |= PARENB;
1790             } else {
1791 0           $self->{"C_CFLAG"} &= ~PARENB;
1792             }
1793 0           write_settings($self);
1794             }
1795 0 0         return wantarray ? @binary_opt : ($self->{"C_CFLAG"} & PARENB);
1796             }
1797              
1798             sub write_done {
1799 0 0   0 0   return unless (@_ == 2);
1800 0           my $self = shift;
1801 0 0         return unless ($self->can_write_done);
1802 0           my $rc;
1803 0           my $wait = yes_true ( shift );
1804 0 0         $self->write_drain if ($wait);
1805              
1806 0           my $mstat = " ";
1807 0           my $result;
1808 0           for (;;) {
1809 0 0         return unless $self->ioctl('TIOCOUTQ',\$mstat);
1810 0           $result = unpack('L', $mstat);
1811 0 0         return (0, 0) if ($result); # characters pending
1812              
1813 0 0         return unless $self->ioctl('TIOCSERGETLSR',\$mstat);
1814 0           $result = (unpack('L', $mstat) & TIOCM_LE);
1815 0 0         last unless ($wait);
1816 0 0         last if ($result); # shift register empty
1817 0           select (undef, undef, undef, 0.02);
1818             }
1819 0 0         return $result ? (1, 0) : (0, 0);
1820             }
1821              
1822             sub modemlines {
1823 0 0   0 0   return undef unless (@_ == 1);
1824 0           my $self = shift;
1825 0 0         return undef unless ($self->can_modemlines);
1826              
1827 0           my $mstat = pack('L',0);
1828 0 0         return undef unless $self->ioctl('TIOCMGET',\$mstat);
1829 0           my $result = unpack('L', $mstat);
1830 0 0         if ($Babble) {
1831 0           printf "result = %x\n", $result;
1832 0 0         print "CTS is ON\n" if ($result & MS_CTS_ON);
1833 0 0         print "DSR is ON\n" if ($result & MS_DSR_ON);
1834 0 0         print "RING is ON\n" if ($result & MS_RING_ON);
1835 0 0         print "RLSD is ON\n" if ($result & MS_RLSD_ON);
1836             }
1837 0           return $result;
1838             }
1839              
1840             # Strange thing is, this function doesn't always work for me. I suspect
1841             # I have a broken serial card. Everything else in my test system doesn't
1842             # work (USB, floppy) so why not serial too?
1843             sub wait_modemlines {
1844 0 0   0 0   return undef unless (@_ == 2);
1845 0           my $self = shift;
1846 0   0       my $flags = shift || 0;
1847 0 0         return undef unless ($self->can_wait_modemlines);
1848              
1849 0 0         if ($Babble) {
1850 0           printf "wait_modemlines flag = %u\n", $flags;
1851             }
1852 0           my $mstat = pack('L',$flags);
1853 0           return $self->ioctl('TIOCMIWAIT',\$mstat);
1854             }
1855              
1856             sub intr_count {
1857 0 0   0 0   return undef unless (@_ == 1);
1858 0           my $self = shift;
1859 0 0         return undef unless ($self->can_intr_count);
1860              
1861 0           my $mstat = pack('L',0);
1862 0           return $self->ioctl('TIOCGICOUNT',\$mstat);
1863 0           my $result = unpack('L', $mstat);
1864 0 0         if ($Babble) {
1865 0           printf "result = %x\n", $result;
1866             }
1867 0           return $result;
1868             }
1869              
1870             sub status {
1871 0     0 0   my $self = shift;
1872 0 0         return if (@_);
1873 0 0         return unless ($self->can_status);
1874 0           my @stat = (0, 0, 0, 0);
1875 0           my $mstat = " ";
1876              
1877 0 0         return unless $self->ioctl('portable_TIOCINQ', \$mstat);
1878              
1879 0           $stat[ST_INPUT] = unpack('L', $mstat);
1880 0 0         return unless $self->ioctl('TIOCOUTQ', \$mstat);
1881              
1882 0           $stat[ST_OUTPUT] = unpack('L', $mstat);
1883              
1884 0 0 0       if ( $Babble or $self->{"_DEBUG"} ) {
1885 0           printf "Blocking Bits= %d\n", $stat[ST_BLOCK];
1886 0           printf "Input Queue= %d\n", $stat[ST_INPUT];
1887 0           printf "Output Queue= %d\n", $stat[ST_OUTPUT];
1888 0           printf "Latched Errors= %d\n", $stat[ST_ERROR];
1889             }
1890 0           return @stat;
1891             }
1892              
1893             sub dtr_active {
1894 0 0   0 0   return unless (@_ == 2);
1895 0           my $self = shift;
1896 0 0         return unless $self->can_dtrdsr();
1897 0           my $on = yes_true( shift );
1898 0           my $rc;
1899              
1900             # if we have set DTR and clear DTR, we should use it (OpenBSD)
1901 0           my $value=0;
1902 0 0 0       if (defined($bits->{'TIOCSDTR'}) &&
1903             defined($bits->{'TIOCCDTR'})) {
1904 0           $value=0;
1905 0 0         $rc=$self->ioctl($on ? 'TIOCSDTR' : 'TIOCCDTR', \$value);
1906             }
1907             else {
1908 0           $value=$IOCTL_VALUE_DTR;
1909 0 0         $rc=$self->ioctl($on ? 'TIOCMBIS' : 'TIOCMBIC', \$value);
1910             }
1911 0 0         warn "dtr_active($on) ioctl: $!\n" if (!$rc);
1912              
1913             # ARG! Solaris destroys termios settings after a DTR toggle!!
1914 0           write_settings($self);
1915              
1916 0           return $rc;
1917             }
1918              
1919             sub rts_active {
1920 0 0   0 0   return unless (@_ == 2);
1921 0           my $self = shift;
1922 0 0         return unless ($self->can_rts());
1923 0           my $on = yes_true( shift );
1924             # returns ioctl result
1925 0           my $value=$IOCTL_VALUE_RTS;
1926 0 0         my $rc=$self->ioctl($on ? 'TIOCMBIS' : 'TIOCMBIC', \$value);
1927             #my $rc=ioctl($self->{HANDLE}, $on ? $bitset : $bitclear, $rtsout);
1928 0 0         warn "rts_active($on) ioctl: $!\n" if (!$rc);
1929 0           return $rc;
1930             }
1931              
1932             sub pulse_break_on {
1933 0 0   0 0   return unless (@_ == 2);
1934 0           my $self = shift;
1935 0           my $delay = (shift)/1000;
1936 0           my $length = 0;
1937 0           my $ok = POSIX::tcsendbreak($self->{FD}, $length);
1938 0 0         warn "could not pulse break on: $!\n" unless ($ok);
1939 0           select (undef, undef, undef, $delay);
1940 0           return $ok;
1941             }
1942              
1943             sub pulse_rts_on {
1944 0 0   0 0   return unless (@_ == 2);
1945 0           my $self = shift;
1946 0 0         return unless ($self->can_rts());
1947 0           my $delay = (shift)/1000;
1948 0 0         $self->rts_active(1) or warn "could not pulse rts on\n";
1949 0           select (undef, undef, undef, $delay);
1950 0 0         $self->rts_active(0) or warn "could not restore from rts on\n";
1951 0           select (undef, undef, undef, $delay);
1952 0           1;
1953             }
1954              
1955             sub pulse_dtr_on {
1956 0 0   0 0   return unless (@_ == 2);
1957 0           my $self = shift;
1958 0 0         return unless $self->can_ioctl();
1959 0           my $delay = (shift)/1000;
1960 0 0         $self->dtr_active(1) or warn "could not pulse dtr on\n";
1961 0           select (undef, undef, undef, $delay);
1962 0 0         $self->dtr_active(0) or warn "could not restore from dtr on\n";
1963 0           select (undef, undef, undef, $delay);
1964 0           1;
1965             }
1966              
1967             sub pulse_rts_off {
1968 0 0   0 0   return unless (@_ == 2);
1969 0           my $self = shift;
1970 0 0         return unless ($self->can_rts());
1971 0           my $delay = (shift)/1000;
1972 0 0         $self->rts_active(0) or warn "could not pulse rts off\n";
1973 0           select (undef, undef, undef, $delay);
1974 0 0         $self->rts_active(1) or warn "could not restore from rts off\n";
1975 0           select (undef, undef, undef, $delay);
1976 0           1;
1977             }
1978              
1979             sub pulse_dtr_off {
1980 0 0   0 0   return unless (@_ == 2);
1981 0           my $self = shift;
1982 0 0         return unless $self->can_ioctl();
1983 0           my $delay = (shift)/1000;
1984 0 0         $self->dtr_active(0) or warn "could not pulse dtr off\n";
1985 0           select (undef, undef, undef, $delay);
1986 0 0         $self->dtr_active(1) or warn "could not restore from dtr off\n";
1987 0           select (undef, undef, undef, $delay);
1988 0           1;
1989             }
1990              
1991             sub debug {
1992 0     0 0   my $self = shift;
1993 0 0         if (ref($self)) {
1994 0 0         if (@_) { $self->{"_DEBUG"} = yes_true ( shift ); }
  0            
1995 0 0         if (wantarray) { return @binary_opt; }
  0            
1996             else {
1997 0           my $tmp = $self->{"_DEBUG"};
1998 0 0         nocarp || carp "Debug level: $self->{ALIAS} = $tmp";
1999 0           return $self->{"_DEBUG"};
2000             }
2001             } else {
2002 0 0         if (@_) { $Babble = yes_true ( shift ); }
  0            
2003 0 0         if (wantarray) { return @binary_opt; }
  0            
2004             else {
2005 0 0         nocarp || carp "Debug Class = $Babble";
2006 0           return $Babble;
2007             }
2008             }
2009             }
2010              
2011             sub close {
2012 0     0 0   my $self = shift;
2013 0           my $ok = undef;
2014 0           my $item;
2015              
2016 0 0         return unless (defined $self->{NAME});
2017              
2018 0 0         if ($Babble) {
2019 0           carp "Closing $self " . $self->{ALIAS};
2020             }
2021 0 0         if ($self->{FD}) {
2022 0           purge_all ($self);
2023              
2024             # Gracefully handle shutdown without termios
2025 0 0         if (defined($self->{TERMIOS})) {
2026             # copy the original values into "current" values
2027 0           foreach $item (keys %c_cc_fields) {
2028 0           $self->{"C_$item"} = $self->{"_$item"};
2029             }
2030              
2031 0           $self->{"C_CFLAG"} = $self->{"_CFLAG"};
2032 0           $self->{"C_IFLAG"} = $self->{"_IFLAG"};
2033 0           $self->{"C_ISPEED"} = $self->{"_ISPEED"};
2034 0           $self->{"C_LFLAG"} = $self->{"_LFLAG"};
2035 0           $self->{"C_OFLAG"} = $self->{"_OFLAG"};
2036 0           $self->{"C_OSPEED"} = $self->{"_OSPEED"};
2037            
2038 0           write_settings($self);
2039             }
2040              
2041 0           $ok = POSIX::close($self->{FD});
2042              
2043             # we need to explicitly close this handle
2044 0 0 0       $self->{HANDLE}->close if (defined($self->{HANDLE}) &&
2045             $self->{HANDLE}->opened);
2046              
2047 0           $self->{FD} = undef;
2048 0           $self->{HANDLE} = undef;
2049             }
2050 0 0         if ($self->{LOCK}) {
2051 0 0         unless ( unlink $self->{LOCK} ) {
2052 0 0         nocarp or carp "can't remove lockfile: $self->{LOCK}\n";
2053             }
2054 0           $self->{LOCK} = "";
2055             }
2056 0           $self->{NAME} = undef;
2057 0           $self->{ALIAS} = undef;
2058 0 0         return unless ($ok);
2059 0           1;
2060             }
2061              
2062             sub ioctl
2063             {
2064 0     0 0   my ($self,$code,$ref) = @_;
2065 0 0         return undef unless (defined $self->{NAME});
2066              
2067              
2068 0 0         if ($Babble) {
2069 0           my $num = $$ref;
2070 0           $num = unpack('L', $num);
2071 0           carp "ioctl $code($bits->{$code}) $ref: $num";
2072             }
2073              
2074 0           my $magic;
2075 0 0         if (!defined($magic = $bits->{$code})) {
2076 0           carp "cannot ioctl '$code': no system value found\n";
2077 0           return undef;
2078             }
2079              
2080 0 0         if (!ioctl($self->{HANDLE},$magic,$$ref)) {
2081 0           carp "$code($magic) ioctl failed: $!";
2082 0           return undef;
2083             }
2084              
2085 0           return 1;
2086             }
2087              
2088             ##### tied FileHandle support
2089            
2090             # DESTROY this
2091             # As with the other types of ties, this method will be called when the
2092             # tied handle is about to be destroyed. This is useful for debugging and
2093             # possibly cleaning up.
2094              
2095             sub DESTROY {
2096 0     0     my $self = shift;
2097 0 0         return unless (defined $self->{NAME});
2098 0 0         if ($self->{"_DEBUG"}) {
2099 0           carp "Destroying $self->{NAME}";
2100             }
2101 0           $self->close;
2102             }
2103            
2104             sub TIEHANDLE {
2105 0     0     my $proto = shift;
2106 0   0       my $class = ref($proto) || $proto;
2107              
2108 0 0         return unless (@_);
2109              
2110             # my $self = start($class, shift);
2111 0           return new($class, @_);
2112             }
2113            
2114             # WRITE this, LIST
2115             # This method will be called when the handle is written to via the
2116             # syswrite function.
2117              
2118             sub WRITE {
2119 0 0   0     return if (@_ < 3);
2120 0           my $self = shift;
2121 0           my $buf = shift;
2122 0           my $len = shift;
2123 0           my $offset = 0;
2124 0 0         if (@_) { $offset = shift; }
  0            
2125 0           my $out2 = substr($buf, $offset, $len);
2126 0 0         return unless ($self->post_print($out2));
2127 0           return length($out2);
2128             }
2129              
2130             # PRINT this, LIST
2131             # This method will be triggered every time the tied handle is printed to
2132             # with the print() function. Beyond its self reference it also expects
2133             # the list that was passed to the print function.
2134            
2135             sub PRINT {
2136 0     0     my $self = shift;
2137 0 0         return unless (@_);
2138 0 0         my $ofs = $, ? $, : "";
2139 0 0         if ($self->{OFS}) { $ofs = $self->{OFS}; }
  0            
2140 0 0         my $ors = $\ ? $\ : "";
2141 0 0         if ($self->{ORS}) { $ors = $self->{ORS}; }
  0            
2142 0           my $output = join($ofs,@_);
2143 0           $output .= $ors;
2144 0           return $self->post_print($output);
2145             }
2146              
2147             sub output_field_separator {
2148 0     0 0   my $self = shift;
2149 0           my $prev = $self->{OFS};
2150 0 0         if (@_) { $self->{OFS} = shift; }
  0            
2151 0           return $prev;
2152             }
2153              
2154             sub output_record_separator {
2155 0     0 0   my $self = shift;
2156 0           my $prev = $self->{ORS};
2157 0 0         if (@_) { $self->{ORS} = shift; }
  0            
2158 0           return $prev;
2159             }
2160              
2161             sub post_print {
2162 0     0 0   my $self = shift;
2163 0 0         return unless (@_);
2164 0           my $output = shift;
2165 0           my $to_do = length($output);
2166 0           my $done = 0;
2167 0           my $written = 0;
2168 0           while ($done < $to_do) {
2169 0           my $out2 = substr($output, $done);
2170 0           $written = $self->write($out2);
2171 0 0         if (! defined $written) {
2172 0           return;
2173             }
2174 0 0         return 0 unless ($written);
2175 0           $done += $written;
2176             }
2177 0           1;
2178             }
2179            
2180             # PRINTF this, LIST
2181             # This method will be triggered every time the tied handle is printed to
2182             # with the printf() function. Beyond its self reference it also expects
2183             # the format and list that was passed to the printf function.
2184            
2185             sub PRINTF {
2186 0     0     my $self = shift;
2187 0           my $fmt = shift;
2188 0 0         return unless ($fmt);
2189 0 0         return unless (@_);
2190 0           my $output = sprintf($fmt, @_);
2191 0           $self->PRINT($output);
2192             }
2193            
2194             # READ this, LIST
2195             # This method will be called when the handle is read from via the read
2196             # or sysread functions.
2197              
2198             sub READ {
2199 0 0   0     return if (@_ < 3);
2200 0           my $buf = \$_[1];
2201 0           my ($self, $junk, $size, $offset) = @_;
2202 0 0         unless (defined $offset) { $offset = 0; }
  0            
2203 0           my $count_in = 0;
2204 0           my $string_in = "";
2205              
2206 0           ($count_in, $string_in) = $self->read($size);
2207              
2208 0 0         $$buf = '' unless defined $$buf;
2209 0           my $buflen = length $$buf;
2210              
2211 0           my ($tail, $head) = ('','');
2212              
2213 0 0         if($offset >= 0){ # positive offset
2214 0 0         if($buflen > $offset + $count_in){
2215 0           $tail = substr($$buf, $offset + $count_in);
2216             }
2217              
2218 0 0         if($buflen < $offset){
2219 0           $head = $$buf . ("\0" x ($offset - $buflen));
2220             } else {
2221 0           $head = substr($$buf, 0, $offset);
2222             }
2223             } else { # negative offset
2224 0           $head = substr($$buf, 0, ($buflen + $offset));
2225              
2226 0 0         if(-$offset > $count_in){
2227 0           $tail = substr($$buf, $offset + $count_in);
2228             }
2229             }
2230              
2231             # remaining unhandled case: $offset < 0 && -$offset > $buflen
2232 0           $$buf = $head.$string_in.$tail;
2233 0           return $count_in;
2234             }
2235              
2236             # READLINE this
2237             # This method will be called when the handle is read from via .
2238             # The method should return undef when there is no more data.
2239            
2240             sub READLINE {
2241 0     0     my $self = shift;
2242 0 0         return if (@_);
2243 0           my $count_in = 0;
2244 0           my $string_in = "";
2245 0           my $match = "";
2246 0           my $was;
2247              
2248 0 0         if (wantarray) {
2249 0           my @lines;
2250 0           for (;;) {
2251 0 0         last if ($was = $self->reset_error); # dummy, currently
2252 0 0         if ($self->stty_icanon) {
2253 0           ($count_in, $string_in) = $self->read_vmin(255);
2254 0 0         last if (! defined $count_in);
2255             }
2256             else {
2257 0           $string_in = $self->streamline($self->{"_SIZE"});
2258 0 0         last if (! defined $string_in);
2259 0           $match = $self->matchclear;
2260 0 0 0       if ( ($string_in ne "") || ($match ne "") ) {
2261 0           $string_in .= $match;
2262             }
2263             }
2264 0           push (@lines, $string_in);
2265 0 0         last if ($string_in =~ /$self->{"_CLASTLINE"}/s);
2266             }
2267 0 0         return @lines if (@lines);
2268 0           return;
2269             }
2270             else {
2271 0           my $last_icanon = $self->stty_icanon;
2272 0           $self->stty_icanon(1);
2273 0           for (;;) {
2274 0 0         last if ($was = $self->reset_error); # dummy, currently
2275 0           $string_in = $self->lookfor($self->{"_SIZE"});
2276 0 0         last if (! defined $string_in);
2277 0           $match = $self->matchclear;
2278 0 0 0       if ( ($string_in ne "") || ($match ne "") ) {
2279 0           $string_in .= $match; # traditional behavior
2280 0           $self->stty_icanon(0);
2281 0           return $string_in;
2282             }
2283             }
2284 0           $self->stty_icanon($last_icanon);
2285 0           return;
2286             }
2287             }
2288            
2289             # GETC this
2290             # This method will be called when the getc function is called.
2291            
2292             sub GETC {
2293 0     0     my $self = shift;
2294 0           my ($count, $in) = $self->read(1);
2295 0 0         if ($count == 1) {
2296 0           return $in;
2297             }
2298 0           return;
2299             }
2300            
2301             # CLOSE this
2302             # This method will be called when the handle is closed via the close
2303             # function.
2304            
2305             sub CLOSE {
2306 0     0     my $self = shift;
2307 0           $self->write_drain;
2308 0           my $success = $self->close;
2309 0 0         if ($Babble) { printf "CLOSE result:%d\n", $success; }
  0            
2310 0           return $success;
2311             }
2312              
2313             # FILENO this
2314             # This method will be called if we ever need the FD from the handle
2315              
2316             sub FILENO {
2317 0     0     my $self = shift;
2318 0           return $self->{FD};
2319             }
2320            
2321             1; # so the require or use succeeds
2322              
2323             __END__