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# 26package Device::SerialPort; 27 28use 5.006; 29use strict; 30use warnings; 31use POSIX qw(:termios_h); 32use IO::Handle; 33use Carp; 34 35use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); 36$VERSION = 1.04; 37 38require 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 57Exporter::export_ok_tags('STAT', 'PARAM'); 58 59$EXPORT_TAGS{ALL} = \@EXPORT_OK; 60 61require XSLoader; 62XSLoader::load('Device::SerialPort', $VERSION); 63 64#### Package variable declarations #### 65 66use vars qw($IOCTL_VALUE_RTS $IOCTL_VALUE_DTR $IOCTL_VALUE_TERMIOXFLOW 67 $ms_per_tick); 68 69# Load all the system bits we need 70my $bits=Device::SerialPort::Bits::get_hash(); 71my $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 79sub CRTSCTS { return $bits->{'CRTSCTS'} || 0; } 80 81sub OCRNL { return $bits->{'OCRNL'} || 0; } 82 83sub ONLCR { return $bits->{'ONLCR'} || 0; } 84 85sub ECHOKE { return $bits->{'ECHOKE'} || 0; } 86 87sub ECHOCTL { return $bits->{'ECHOCTL'} || 0; } 88 89sub 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 96sub MS_RLSD_ON { return TIOCM_CD(); } 97sub TIOCM_CD { return $bits->{'TIOCM_CAR'} || $bits->{'TIOCM_CD'} || 0; } 98 99sub MS_RING_ON { return TIOCM_RI(); } 100sub TIOCM_RI { return $bits->{'TIOCM_RNG'} || $bits->{'TIOCM_RI'} || 0; } 101 102sub MS_CTS_ON { return TIOCM_CTS(); } 103sub TIOCM_CTS { return $bits->{'TIOCM_CTS'} || 0; } 104 105sub MS_DSR_ON { return TIOCM_DSR(); } 106sub TIOCM_DSR { return $bits->{'TIOCM_DSR'} || 0; } 107 108# For POSIX completeness 109sub MS_RTS_ON { return TIOCM_RTS(); } 110sub TIOCM_RTS { return $bits->{'TIOCM_RTS'} || 0; } 111 112sub MS_DTR_ON { return TIOCM_DTR(); } 113sub TIOCM_DTR { return $bits->{'TIOCM_DTR'} || 0; } 114 115# "status" 116sub ST_BLOCK {0} # status offsets for caller 117sub ST_INPUT {1} 118sub ST_OUTPUT {2} 119sub ST_ERROR {3} # latched 120 121# parameters that must be included in a "save" and "checking subs" 122 123my %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 138my @termios_fields = ( 139 "C_CFLAG", 140 "C_IFLAG", 141 "C_ISPEED", 142 "C_LFLAG", 143 "C_OFLAG", 144 "C_OSPEED" 145 ); 146 147my %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 161my @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 169my %bauds; 170foreach my $baud (@baudrates) { 171 my $baudvar="B$baud"; 172 $bauds{$baud}=$bits->{$baudvar} if (defined($bits->{$baudvar})); 173} 174 175my $Babble = 0; 176my $testactive = 0; # test mode active 177 178my @Yes_resp = ( 179 "YES", "Y", 180 "ON", 181 "TRUE", "T", 182 "1" 183 ); 184 185my @binary_opt = ( 0, 1 ); 186my @byte_opt = (0, 255); 187 188my $cfg_file_sig="Device::SerialPort_Configuration_File -- DO NOT EDIT --\n"; 189 190## my $null=[]; 191my $null=0; 192my $zero=0; 193 194# Preloaded methods go here. 195 196sub init_ms_per_tick 197{ 198 my $from_posix=undef; 199 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 for (;;) { 210 eval { $from_posix = POSIX::sysconf(&POSIX::_SC_CLK_TCK); }; 211 last if (!$@); 212 $errors.="$@\n"; 213 214 if (defined($bits->{'_SC_CLK_TCK'})) { 215 $from_posix = POSIX::sysconf($bits->{'_SC_CLK_TCK'}); 216 last; 217 } 218 $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 eval { $from_posix = &POSIX::CLK_TCK; }; 223 last if (!$@); 224 $errors.="$@\n"; 225 226 last; 227 } 228 if (!defined($from_posix) || $from_posix == 0) { 229 die "Cannot find a useful value for _SC_CLK_TCK:\n$errors"; 230 } 231 $ms_per_tick = 1000.0 / $from_posix; 232} 233 234sub get_tick_count { 235 # clone of Win32::GetTickCount - perhaps same 49 day problem 236 237 if (!defined($ms_per_tick)) { 238 init_ms_per_tick(); 239 } 240 241 my ($real2, $user2, $system2, $cuser2, $csystem2) = POSIX::times(); 242 $real2 *= $ms_per_tick; 243 ## printf "real2 = %8.0f\n", $real2; 244 return int $real2; 245} 246 247sub SHORTsize { 0xffff; } # mostly for AltPort test 248sub LONGsize { 0xffffffff; } # mostly for AltPort test 249 250sub OS_Error { print "Device::SerialPort OS_Error\n"; } 251 252# test*.pl only - suppresses default messages 253sub set_test_mode_active { 254 return unless (@_ == 2); 255 $testactive = $_[1]; # allow "off" 256 my @fields = @termios_fields; 257 my $item; 258 foreach $item (keys %c_cc_fields) { 259 push @fields, "C_$item"; 260 } 261 foreach $item (keys %validate) { 262 push @fields, "$item"; 263 } 264 return @fields; 265} 266 267sub nocarp { return $testactive } 268 269sub yes_true { 270 my $choice = uc shift; 271 my $ans = 0; 272 foreach (@Yes_resp) { $ans = 1 if ( $choice eq $_ ) } 273 return $ans; 274} 275 276sub new { 277 my $proto = shift; 278 my $class = ref($proto) || $proto; 279 my $self = {}; 280 my $ok = 0; # API return value 281 282 my $item = 0; 283 284 my $nameOrConf = shift; 285 return start($class, $nameOrConf, @_) if (-f $nameOrConf && ! -c $nameOrConf ); 286 287 $self->{NAME} = $nameOrConf; 288 289 290 shift; # ignore "$quiet" parameter 291 my $lockfile = shift; 292 if ($lockfile) { 293 $self->{LOCK} = $lockfile; 294 my $lockf = POSIX::open($self->{LOCK}, 295 &POSIX::O_WRONLY | 296 &POSIX::O_CREAT | 297 &POSIX::O_NOCTTY | 298 &POSIX::O_EXCL); 299 return undef if (!defined($lockf)); 300 301 my $pid = "$$\n"; 302 $ok = POSIX::write($lockf, $pid, length $pid); 303 my $ok2 = POSIX::close($lockf); 304 return unless ($ok && (defined $ok2)); 305 sleep 2; # wild guess for Version 0.05 306 } 307 else { 308 $self->{LOCK} = ""; 309 } 310 311 $self->{FD}= POSIX::open($self->{NAME}, 312 &POSIX::O_RDWR | 313 &POSIX::O_NOCTTY | 314 &POSIX::O_NONBLOCK); 315 316 unless (defined $self->{FD}) { $self->{FD} = -1; } 317 unless ($self->{FD} >= 0) { 318 # the "unlink" will destroy the err code, so preserve it 319 my $save_err=$!+0; 320 321 if ($self->{LOCK}) { 322 unlink $self->{LOCK}; 323 $self->{LOCK} = ""; 324 } 325 326 $!=$save_err+0; 327 return undef; 328 } 329 330 $self->{TERMIOS} = POSIX::Termios->new(); 331 332 # a handle object for ioctls: read-only ok 333 $self->{HANDLE} = new_from_fd IO::Handle ($self->{FD}, "r"); 334 335 # get the current attributes 336 $ok = $self->{TERMIOS}->getattr($self->{FD}); 337 338 unless ( $ok ) { 339 carp "can't getattr: $!"; 340 undef $self; 341 return undef; 342 } 343 344 # save the original values 345 $self->{"_CFLAG"} = $self->{TERMIOS}->getcflag(); 346 $self->{"_IFLAG"} = $self->{TERMIOS}->getiflag(); 347 $self->{"_ISPEED"} = $self->{TERMIOS}->getispeed(); 348 $self->{"_LFLAG"} = $self->{TERMIOS}->getlflag(); 349 $self->{"_OFLAG"} = $self->{TERMIOS}->getoflag(); 350 $self->{"_OSPEED"} = $self->{TERMIOS}->getospeed(); 351 352 # build termiox flag anyway 353 $self->{'TERMIOX'} = 0; 354 355 # copy the original values into "current" values 356 foreach $item (keys %c_cc_fields) { 357 $self->{"_$item"} = $self->{TERMIOS}->getcc($c_cc_fields{$item}); 358 } 359 foreach $item (keys %c_cc_fields) { 360 $self->{"C_$item"} = $self->{"_$item"}; 361 } 362 $self->{"C_CFLAG"} = $self->{"_CFLAG"}; 363 $self->{"C_IFLAG"} = $self->{"_IFLAG"}; 364 $self->{"C_ISPEED"} = $self->{"_ISPEED"}; 365 $self->{"C_LFLAG"} = $self->{"_LFLAG"}; 366 $self->{"C_OFLAG"} = $self->{"_OFLAG"}; 367 $self->{"C_OSPEED"} = $self->{"_OSPEED"}; 368 369 # Finally, default to "raw" mode for this package 370 $self->{"C_IFLAG"} &= ~(IGNBRK|BRKINT|PARMRK|IGNPAR|INPCK|ISTRIP|INLCR|IGNCR|ICRNL|IXON); 371 $self->{"C_OFLAG"} &= ~OPOST; 372 $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 $self->{"C_IFLAG"} |= IGNBRK; 382 $self->{"C_CFLAG"} |= (CLOCAL|CREAD); 383 384 # 9600 baud 385 $self->{"C_OSPEED"} = $bauds{"9600"}; 386 $self->{"C_ISPEED"} = $bauds{"9600"}; 387 388 # 8data bits 389 $self->{"C_CFLAG"} &= ~CSIZE; 390 $self->{"C_CFLAG"} |= CS8; 391 392 # disable parity 393 $self->{"C_CFLAG"} &= ~(PARENB | PARODD); 394 395 # 1 stop bit 396 $self->{"C_CFLAG"} &= ~CSTOPB; 397 398 # by default, disable the OSX arbitrary baud settings 399 $self->{"IOSSIOSPEED_BAUD"} = -1; 400 401 &write_settings($self); 402 403 $self->{ALIAS} = $self->{NAME}; # so "\\.\+++" can be changed 404 405 # "private" data 406 $self->{"_DEBUG"} = 0; 407 $self->{U_MSG} = 0; 408 $self->{E_MSG} = 0; 409 $self->{RCONST} = 0; 410 $self->{RTOT} = 0; 411 $self->{"_T_INPUT"} = ""; 412 $self->{"_LOOK"} = ""; 413 $self->{"_LASTLOOK"} = ""; 414 $self->{"_LASTLINE"} = ""; 415 $self->{"_CLASTLINE"} = ""; 416 $self->{"_SIZE"} = 1; 417 $self->{OFS} = ""; 418 $self->{ORS} = ""; 419 $self->{"_LMATCH"} = ""; 420 $self->{"_LPATT"} = ""; 421 $self->{"_PROMPT"} = ""; 422 $self->{"_MATCH"} = []; 423 $self->{"_CMATCH"} = []; 424 @{ $self->{"_MATCH"} } = "\n"; 425 @{ $self->{"_CMATCH"} } = "\n"; 426 $self->{DVTYPE} = "none"; 427 $self->{HNAME} = "localhost"; 428 $self->{HADDR} = 0; 429 $self->{DATYPE} = "raw"; 430 $self->{CFG_1} = "none"; 431 $self->{CFG_2} = "none"; 432 $self->{CFG_3} = "none"; 433 434 bless ($self, $class); 435 436 unless ($self->can_ioctl()) { 437 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 return $self; 445} 446 447# Returns "1" on success 448sub write_settings { 449 my $self = shift; 450 my ($item, $result); 451 452 # put current values into Termios structure 453 $self->{TERMIOS}->setcflag($self->{"C_CFLAG"}); 454 $self->{TERMIOS}->setlflag($self->{"C_LFLAG"}); 455 $self->{TERMIOS}->setiflag($self->{"C_IFLAG"}); 456 $self->{TERMIOS}->setoflag($self->{"C_OFLAG"}); 457 $self->{TERMIOS}->setispeed($self->{"C_ISPEED"}); 458 $self->{TERMIOS}->setospeed($self->{"C_OSPEED"}); 459 460 foreach $item (keys %c_cc_fields) { 461 $self->{TERMIOS}->setcc($c_cc_fields{$item}, $self->{"C_$item"}); 462 } 463 464 # setattr returns undef on failure 465 $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 if ($self->{"IOSSIOSPEED_BAUD"} != -1 && $self->can_arbitrary_baud()) { 470 my $speed = pack( "L", $self->{"IOSSIOSPEED_BAUD"}); 471 $self->ioctl('IOSSIOSPEED', \$speed ); 472 } 473 474 if ($Babble) { 475 print "wrote settings to $self->{ALIAS}\n"; 476 } 477 478 return $result; 479} 480 481sub save { 482 my $self = shift; 483 my $item; 484 my $getsub; 485 my $value; 486 487 return unless (@_); 488 489 my $filename = shift; 490 unless ( open CF, ">$filename" ) { 491 #carp "can't open file: $filename"; 492 return undef; 493 } 494 print CF "$cfg_file_sig"; 495 print CF "$self->{NAME}\n"; 496 # used to "reopen" so must be DEVICE=NAME 497 print CF "$self->{LOCK}\n"; 498 # use lock to "open" if established 499 500 # put current values from Termios structure FIRST 501 foreach $item (@termios_fields) { 502 printf CF "$item,%d\n", $self->{"$item"}; 503 } 504 foreach $item (keys %c_cc_fields) { 505 printf CF "C_$item,%d\n", $self->{"C_$item"}; 506 } 507 508 no strict 'refs'; # for $gosub 509 while (($item, $getsub) = each %validate) { 510 chomp $getsub; 511 $value = scalar &$getsub($self); 512 print CF "$item,$value\n"; 513 } 514 use strict 'refs'; 515 close CF; 516 if ($Babble) { 517 print "wrote file $filename for $self->{ALIAS}\n"; 518 } 519 1; 520} 521 522# parse values for start/restart 523sub get_start_values { 524 return unless (@_ == 2); 525 my $self = shift; 526 my $filename = shift; 527 528 unless ( open CF, "<$filename" ) { 529 carp "can't open file: $filename: $!"; 530 return; 531 } 532 my ($signature, $name, $lockfile, @values) = <CF>; 533 close CF; 534 535 unless ( $cfg_file_sig eq $signature ) { 536 carp "Invalid signature in $filename: $signature"; 537 return; 538 } 539 chomp $name; 540 unless ( $self->{NAME} eq $name ) { 541 carp "Invalid Port DEVICE=$self->{NAME} in $filename: $name"; 542 return; 543 } 544 chomp $lockfile; 545 if ($Babble or not $self) { 546 print "signature = $signature"; 547 print "name = $name\n"; 548 if ($Babble) { 549 print "values:\n"; 550 foreach (@values) { print " $_"; } 551 } 552 } 553 my $item; 554 my @fields = @termios_fields; 555 foreach $item (keys %c_cc_fields) { 556 push @fields, "C_$item"; 557 } 558 my %termios; 559 foreach $item (@fields) { 560 $termios{$item} = 1; 561 } 562 my $key; 563 my $value; 564 my $gosub; 565 my $fault = 0; 566 no strict 'refs'; # for $gosub 567 foreach $item (@values) { 568 chomp $item; 569 ($key, $value) = split (/,/, $item); 570 if ($value eq "") { $fault++ } 571 elsif (defined $termios{$key}) { 572 $self->{"$key"} = $value; 573 } 574 else { 575 $gosub = $validate{$key}; 576 unless (defined &$gosub ($self, $value)) { 577 carp "Invalid parameter for $key=$value "; 578 return; 579 } 580 } 581 } 582 use strict 'refs'; 583 if ($fault) { 584 carp "Invalid value in $filename"; 585 undef $self; 586 return; 587 } 588 1; 589} 590 591sub restart { 592 return unless (@_ == 2); 593 my $self = shift; 594 my $filename = shift; 595 get_start_values($self, $filename); 596 write_settings($self); 597} 598 599sub start { 600 my $proto = shift; 601 my $class = ref($proto) || $proto; 602 603 return unless (@_); 604 my $filename = shift; 605 606 unless ( open CF, "<$filename" ) { 607 carp "can't open file: $filename: $!"; 608 return; 609 } 610 my ($signature, $name, $lockfile, @values) = <CF>; 611 close CF; 612 613 unless ( $cfg_file_sig eq $signature ) { 614 carp "Invalid signature in $filename: $signature"; 615 return; 616 } 617 chomp $name; 618 chomp $lockfile; 619 my $self = new ($class, $name, 1, $lockfile); # quiet for lock 620 return 0 if ($lockfile and not $self); 621 if ($Babble or not $self) { 622 print "signature = $signature"; 623 print "class = $class\n"; 624 print "name = $name\n"; 625 print "lockfile = $lockfile\n"; 626 if ($Babble) { 627 print "values:\n"; 628 foreach (@values) { print " $_"; } 629 } 630 } 631 if ($self) { 632 if ( get_start_values($self, $filename) ) { 633 write_settings ($self); 634 } 635 else { 636 carp "Invalid value in $filename"; 637 undef $self; 638 return; 639 } 640 } 641 return $self; 642} 643 644# true/false capabilities (read only) 645# currently just constants in the POSIX case 646 647sub can_baud { return 1; } 648sub can_databits { return 1; } 649sub can_stopbits { return 1; } 650sub can_dtrdsr { return 1; } 651sub can_handshake { return 1; } 652sub can_parity_check { return 1; } 653sub can_parity_config { return 1; } 654sub can_parity_enable { return 1; } 655sub can_rlsd { return 0; } # currently 656sub can_16bitmode { return 0; } # Win32-specific 657sub is_rs232 { return 1; } 658sub is_modem { return 0; } # Win32-specific 659sub can_rtscts { return 1; } # this is a flow option 660sub can_xonxoff { return 1; } # this is a flow option 661sub can_xon_char { return 1; } # use stty 662sub can_spec_char { return 0; } # use stty 663sub can_interval_timeout { return 0; } # currently 664sub can_total_timeout { return 1; } # currently 665sub binary { return 1; } 666 667sub reset_error { return 0; } # for compatibility 668 669sub can_ioctl { 670 if (defined($bits->{'TIOCMBIS'}) && # Turn on 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 return 1; 679 } 680 return 0; 681 682 #return 0 unless ($bitset && $bitclear && $rtsout && 683 # (($dtrset && $dtrclear) || $dtrout)); 684 #return 1; 685} 686 687sub can_modemlines { 688 return 1 if (defined($bits->{'TIOCMGET'})); 689 return 0; 690} 691 692sub can_wait_modemlines { 693 return 1 if (defined($bits->{'TIOCMIWAIT'})); 694 return 0; 695} 696 697sub can_intr_count { 698 return 1 if (defined($bits->{'TIOCGICOUNT'})); 699 return 0; 700} 701 702sub can_status { 703 return 1 if (defined($bits->{'portable_TIOCINQ'}) && 704 defined($bits->{'TIOCOUTQ'})); 705 return 0; 706 #return 0 unless ($incount && $outcount); 707 #return 1; 708} 709 710sub can_write_done { 711 my ($self)=@_; 712 return 1 if ($self->can_status && 713 defined($bits->{'TIOCSERGETLSR'}) && 714 TIOCM_LE); 715 return 0; 716} 717 718# can we control the rts line? 719sub can_rts { 720 if (defined($bits->{'TIOCMBIS'}) && 721 defined($bits->{'TIOCMBIC'}) && 722 defined($bits->{'TIOCM_RTS'})) { 723 return 1; 724 } 725 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) 733sub can_arbitrary_baud { 734 return 1 if (defined($bits->{'IOSSIOSPEED'})); 735 return 0; 736} 737 738sub termiox { 739 my $self = shift; 740 return unless ($IOCTL_VALUE_TERMIOXFLOW); 741 my $on = shift; 742 my $rc; 743 744 $self->{'TERMIOX'}=$on ? $IOCTL_VALUE_TERMIOXFLOW : 0; 745 746 my $flags=pack('SSSS',0,0,0,0); 747 return undef unless $self->ioctl('TCGETX', \$flags); 748 #if (!($rc=ioctl($self->{HANDLE}, $tcgetx, $flags))) { 749 #warn "TCGETX($tcgetx) ioctl: $!\n"; 750 #} 751 752 my @vals=unpack('SSSS',$flags); 753 $vals[0]= $on ? $IOCTL_VALUE_TERMIOXFLOW : 0; 754 $flags=pack('SSSS',@vals); 755 756 return undef unless $self->ioctl('TCSETX', \$flags); 757 #if (!($rc=ioctl($self->{HANDLE}, $tcsetx, $flags))) { 758 #warn "TCSETX($tcsetx) ioctl: $!\n"; 759 #} 760 return 1; 761} 762 763sub handshake { 764 my $self = shift; 765 766 if (@_) { 767 if ( $_[0] eq "none" ) { 768 $self->{"C_IFLAG"} &= ~(IXON | IXOFF); 769 $self->termiox(0) if ($IOCTL_VALUE_TERMIOXFLOW); 770 $self->{"C_CFLAG"} &= ~CRTSCTS; 771 } 772 elsif ( $_[0] eq "xoff" ) { 773 $self->{"C_IFLAG"} |= (IXON | IXOFF); 774 $self->termiox(0) if ($IOCTL_VALUE_TERMIOXFLOW); 775 $self->{"C_CFLAG"} &= ~CRTSCTS; 776 } 777 elsif ( $_[0] eq "rts" ) { 778 $self->{"C_IFLAG"} &= ~(IXON | IXOFF); 779 $self->termiox(1) if ($IOCTL_VALUE_TERMIOXFLOW); 780 $self->{"C_CFLAG"} |= CRTSCTS; 781 } 782 else { 783 if ($self->{U_MSG} or $Babble) { 784 carp "Can't set handshake on $self->{ALIAS}"; 785 } 786 return undef; 787 } 788 write_settings($self); 789 } 790 if (wantarray) { return ("none", "xoff", "rts"); } 791 my $mask = (IXON|IXOFF); 792 return "xoff" if ($mask == ($self->{"C_IFLAG"} & $mask)); 793 if ($IOCTL_VALUE_TERMIOXFLOW) { 794 return "rts" if ($self->{'TERMIOX'} & $IOCTL_VALUE_TERMIOXFLOW); 795 } else { 796 return "rts" if ($self->{"C_CFLAG"} & CRTSCTS); 797 } 798 return "none"; 799} 800 801sub baudrate { 802 my ($self,$rate) = @_; 803 my $item = 0; 804 805 if (defined($rate)) { 806 # specific baud rate 807 if (defined $bauds{$rate}) { 808 $self->{"C_OSPEED"} = $bauds{$rate}; 809 $self->{"C_ISPEED"} = $bauds{$rate}; 810 $self->{"IOSSIOSPEED_BAUD"} = -1; 811 write_settings($self); 812 } 813 # arbitrary baud rate 814 elsif ($self->can_arbitrary_baud()) { 815 $self->{"IOSSIOSPEED_BAUD"} = $rate; 816 write_settings($self); 817 return $rate; 818 } 819 # no such baud rate 820 else { 821 if ($self->{U_MSG} or $Babble) { 822 carp "Can't set baudrate ($rate) on $self->{ALIAS}"; 823 } 824 return 0; 825 } 826 } 827 if (wantarray) { return (keys %bauds); } 828 foreach $item (keys %bauds) { 829 return $item if ($bauds{$item} == $self->{"C_OSPEED"}); 830 } 831 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 839sub parity { 840 my $self = shift; 841 if (@_) { 842 if ( $_[0] eq "none" ) { 843 $self->{"C_CFLAG"} &= ~(PARENB|PARODD); 844 } 845 elsif ( $_[0] eq "odd" ) { 846 $self->{"C_CFLAG"} |= (PARENB|PARODD); 847 } 848 elsif ( $_[0] eq "even" ) { 849 $self->{"C_CFLAG"} |= PARENB; 850 $self->{"C_CFLAG"} &= ~PARODD; 851 } 852 else { 853 if ($self->{U_MSG} or $Babble) { 854 carp "Can't set parity on $self->{ALIAS}"; 855 } 856 return undef; 857 } 858 return undef if (!(write_settings($self))); 859 } 860 if (wantarray) { return ("none", "odd", "even"); } 861 return "none" unless ($self->{"C_CFLAG"} & PARENB); 862 my $mask = (PARENB|PARODD); 863 return "odd" if ($mask == ($self->{"C_CFLAG"} & $mask)); 864 $mask = (PARENB); 865 return "even" if ($mask == ($self->{"C_CFLAG"} & $mask)); 866 return "unknown"; 867} 868 869sub databits { 870 my $self = shift; 871 if (@_) { 872 if ( $_[0] == 8 ) { 873 $self->{"C_CFLAG"} &= ~CSIZE; 874 $self->{"C_CFLAG"} |= CS8; 875 } 876 elsif ( $_[0] == 7 ) { 877 $self->{"C_CFLAG"} &= ~CSIZE; 878 $self->{"C_CFLAG"} |= CS7; 879 } 880 elsif ( $_[0] == 6 ) { 881 $self->{"C_CFLAG"} &= ~CSIZE; 882 $self->{"C_CFLAG"} |= CS6; 883 } 884 elsif ( $_[0] == 5 ) { 885 $self->{"C_CFLAG"} &= ~CSIZE; 886 $self->{"C_CFLAG"} |= CS5; 887 } 888 else { 889 if ($self->{U_MSG} or $Babble) { 890 carp "Can't set databits on $self->{ALIAS}"; 891 } 892 return undef; 893 } 894 write_settings($self); 895 } 896 if (wantarray) { return (5, 6, 7, 8); } 897 my $mask = ($self->{"C_CFLAG"} & CSIZE); 898 return 8 if ($mask == CS8); 899 return 7 if ($mask == CS7); 900 return 6 if ($mask == CS6); 901 return 5; 902} 903 904sub stopbits { 905 my $self = shift; 906 if (@_) { 907 if ( $_[0] == 2 ) { 908 $self->{"C_CFLAG"} |= CSTOPB; 909 } 910 elsif ( $_[0] == 1 ) { 911 $self->{"C_CFLAG"} &= ~CSTOPB; 912 } 913 else { 914 if ($self->{U_MSG} or $Babble) { 915 carp "Can't set stopbits on $self->{ALIAS}"; 916 } 917 return undef; 918 } 919 write_settings($self); 920 } 921 if (wantarray) { return (1, 2); } 922 return 2 if ($self->{"C_CFLAG"} & CSTOPB); 923 return 1; 924} 925 926sub is_xon_char { 927 my $self = shift; 928 if (@_) { 929 my $v = int shift; 930 return if (($v < 0) or ($v > 255)); 931 $self->{"C_VSTART"} = $v; 932 write_settings($self); 933 } 934 return $self->{"C_VSTART"}; 935} 936 937sub is_xoff_char { 938 my $self = shift; 939 if (@_) { 940 my $v = int shift; 941 return if (($v < 0) or ($v > 255)); 942 $self->{"C_VSTOP"} = $v; 943 write_settings($self); 944 } 945 return $self->{"C_VSTOP"}; 946} 947 948sub is_stty_intr { 949 my $self = shift; 950 if (@_) { 951 my $v = int shift; 952 return if (($v < 0) or ($v > 255)); 953 $self->{"C_VINTR"} = $v; 954 write_settings($self); 955 } 956 return $self->{"C_VINTR"}; 957} 958 959sub is_stty_quit { 960 my $self = shift; 961 if (@_) { 962 my $v = int shift; 963 return if (($v < 0) or ($v > 255)); 964 $self->{"C_VQUIT"} = $v; 965 write_settings($self); 966 } 967 return $self->{"C_VQUIT"}; 968} 969 970sub is_stty_eof { 971 my $self = shift; 972 if (@_) { 973 my $v = int shift; 974 return if (($v < 0) or ($v > 255)); 975 $self->{"C_VEOF"} = $v; 976 write_settings($self); 977 } 978 return $self->{"C_VEOF"}; 979} 980 981sub is_stty_eol { 982 my $self = shift; 983 if (@_) { 984 my $v = int shift; 985 return if (($v < 0) or ($v > 255)); 986 $self->{"C_VEOL"} = $v; 987 write_settings($self); 988 } 989 return $self->{"C_VEOL"}; 990} 991 992sub is_stty_erase { 993 my $self = shift; 994 if (@_) { 995 my $v = int shift; 996 return if (($v < 0) or ($v > 255)); 997 $self->{"C_VERASE"} = $v; 998 write_settings($self); 999 } 1000 return $self->{"C_VERASE"}; 1001} 1002 1003sub is_stty_kill { 1004 my $self = shift; 1005 if (@_) { 1006 my $v = int shift; 1007 return if (($v < 0) or ($v > 255)); 1008 $self->{"C_VKILL"} = $v; 1009 write_settings($self); 1010 } 1011 return $self->{"C_VKILL"}; 1012} 1013 1014sub is_stty_susp { 1015 my $self = shift; 1016 if (@_) { 1017 my $v = int shift; 1018 return if (($v < 0) or ($v > 255)); 1019 $self->{"C_VSUSP"} = $v; 1020 write_settings($self); 1021 } 1022 return $self->{"C_VSUSP"}; 1023} 1024 1025sub stty_echo { 1026 my $self = shift; 1027 if (@_) { 1028 if ( yes_true( shift ) ) { 1029 $self->{"C_LFLAG"} |= ECHO; 1030 } else { 1031 $self->{"C_LFLAG"} &= ~ECHO; 1032 } 1033 write_settings($self); 1034 } 1035 return ($self->{"C_LFLAG"} & ECHO) ? 1 : 0; 1036} 1037 1038sub stty_echoe { 1039 my $self = shift; 1040 if (@_) { 1041 if ( yes_true( shift ) ) { 1042 $self->{"C_LFLAG"} |= ECHOE; 1043 } else { 1044 $self->{"C_LFLAG"} &= ~ECHOE; 1045 } 1046 write_settings($self); 1047 } 1048 return ($self->{"C_LFLAG"} & ECHOE) ? 1 : 0; 1049} 1050 1051sub stty_echok { 1052 my $self = shift; 1053 if (@_) { 1054 if ( yes_true( shift ) ) { 1055 $self->{"C_LFLAG"} |= ECHOK; 1056 } else { 1057 $self->{"C_LFLAG"} &= ~ECHOK; 1058 } 1059 write_settings($self); 1060 } 1061 return ($self->{"C_LFLAG"} & ECHOK) ? 1 : 0; 1062} 1063 1064sub stty_echonl { 1065 my $self = shift; 1066 if (@_) { 1067 if ( yes_true( shift ) ) { 1068 $self->{"C_LFLAG"} |= ECHONL; 1069 } else { 1070 $self->{"C_LFLAG"} &= ~ECHONL; 1071 } 1072 write_settings($self); 1073 } 1074 return ($self->{"C_LFLAG"} & ECHONL) ? 1 : 0; 1075} 1076 1077 # non-POSIX 1078sub stty_echoke { 1079 my $self = shift; 1080 return unless ECHOKE; 1081 if (@_) { 1082 if ( yes_true( shift ) ) { 1083 $self->{"C_LFLAG"} |= ECHOKE; 1084 } else { 1085 $self->{"C_LFLAG"} &= ~ECHOKE; 1086 } 1087 write_settings($self); 1088 } 1089 return ($self->{"C_LFLAG"} & ECHOKE) ? 1 : 0; 1090} 1091 1092 # non-POSIX 1093sub stty_echoctl { 1094 my $self = shift; 1095 return unless ECHOCTL; 1096 if (@_) { 1097 if ( yes_true( shift ) ) { 1098 $self->{"C_LFLAG"} |= ECHOCTL; 1099 } else { 1100 $self->{"C_LFLAG"} &= ~ECHOCTL; 1101 } 1102 write_settings($self); 1103 } 1104 return ($self->{"C_LFLAG"} & ECHOCTL) ? 1 : 0; 1105} 1106 1107# Mark parity errors with a leading "NULL" character 1108sub stty_parmrk { 1109 my $self = shift; 1110 if (@_) { 1111 if ( yes_true( shift ) ) { 1112 $self->{"C_IFLAG"} |= PARMRK; 1113 } else { 1114 $self->{"C_IFLAG"} &= ~PARMRK; 1115 } 1116 write_settings($self); 1117 } 1118 return wantarray ? @binary_opt : ($self->{"C_IFLAG"} & PARMRK); 1119} 1120 1121# Ignore parity errors (considered dangerous) 1122sub stty_ignpar { 1123 my $self = shift; 1124 if (@_) { 1125 if ( yes_true( shift ) ) { 1126 $self->{"C_IFLAG"} |= IGNPAR; 1127 } else { 1128 $self->{"C_IFLAG"} &= ~IGNPAR; 1129 } 1130 write_settings($self); 1131 } 1132 return wantarray ? @binary_opt : ($self->{"C_IFLAG"} & IGNPAR); 1133} 1134 1135# Ignore breaks 1136sub stty_ignbrk { 1137 my $self = shift; 1138 if (@_) { 1139 if ( yes_true( shift ) ) { 1140 $self->{"C_IFLAG"} |= IGNBRK; 1141 } else { 1142 $self->{"C_IFLAG"} &= ~IGNBRK; 1143 } 1144 write_settings($self); 1145 } 1146 return ($self->{"C_IFLAG"} & IGNBRK) ? 1 : 0; 1147} 1148 1149# Strip parity bit 1150sub stty_istrip { 1151 my $self = shift; 1152 if (@_) { 1153 if ( yes_true( shift ) ) { 1154 $self->{"C_IFLAG"} |= ISTRIP; 1155 } else { 1156 $self->{"C_IFLAG"} &= ~ISTRIP; 1157 } 1158 write_settings($self); 1159 } 1160 return ($self->{"C_IFLAG"} & ISTRIP) ? 1 : 0; 1161} 1162 1163# check incoming parity bit 1164sub stty_inpck { 1165 my $self = shift; 1166 if (@_) { 1167 if ( yes_true( shift ) ) { 1168 $self->{"C_IFLAG"} |= INPCK; 1169 } else { 1170 $self->{"C_IFLAG"} &= ~INPCK; 1171 } 1172 write_settings($self); 1173 } 1174 return ($self->{"C_IFLAG"} & INPCK) ? 1 : 0; 1175} 1176 1177sub stty_icrnl { 1178 my $self = shift; 1179 if (@_) { 1180 if ( yes_true( shift ) ) { 1181 $self->{"C_IFLAG"} |= ICRNL; 1182 } else { 1183 $self->{"C_IFLAG"} &= ~ICRNL; 1184 } 1185 write_settings($self); 1186 } 1187 return ($self->{"C_IFLAG"} & ICRNL) ? 1 : 0; 1188} 1189 1190sub stty_igncr { 1191 my $self = shift; 1192 if (@_) { 1193 if ( yes_true( shift ) ) { 1194 $self->{"C_IFLAG"} |= IGNCR; 1195 } else { 1196 $self->{"C_IFLAG"} &= ~IGNCR; 1197 } 1198 write_settings($self); 1199 } 1200 return ($self->{"C_IFLAG"} & IGNCR) ? 1 : 0; 1201} 1202 1203sub stty_inlcr { 1204 my $self = shift; 1205 if (@_) { 1206 if ( yes_true( shift ) ) { 1207 $self->{"C_IFLAG"} |= INLCR; 1208 } else { 1209 $self->{"C_IFLAG"} &= ~INLCR; 1210 } 1211 write_settings($self); 1212 } 1213 return ($self->{"C_IFLAG"} & INLCR) ? 1 : 0; 1214} 1215 1216 # non-POSIX 1217sub stty_ocrnl { 1218 my $self = shift; 1219 return unless OCRNL; 1220 if (@_) { 1221 if ( yes_true( shift ) ) { 1222 $self->{"C_OFLAG"} |= OCRNL; 1223 } else { 1224 $self->{"C_OFLAG"} &= ~OCRNL; 1225 } 1226 write_settings($self); 1227 } 1228 return ($self->{"C_OFLAG"} & OCRNL) ? 1 : 0; 1229} 1230 1231 # non-POSIX 1232sub stty_onlcr { 1233 my $self = shift; 1234 return unless ONLCR; 1235 if (@_) { 1236 if ( yes_true( shift ) ) { 1237 $self->{"C_OFLAG"} |= ONLCR; 1238 } else { 1239 $self->{"C_OFLAG"} &= ~ONLCR; 1240 } 1241 write_settings($self); 1242 } 1243 return ($self->{"C_OFLAG"} & ONLCR) ? 1 : 0; 1244} 1245 1246sub stty_opost { 1247 my $self = shift; 1248 if (@_) { 1249 if ( yes_true( shift ) ) { 1250 $self->{"C_OFLAG"} |= OPOST; 1251 } else { 1252 $self->{"C_OFLAG"} &= ~OPOST; 1253 } 1254 write_settings($self); 1255 } 1256 return ($self->{"C_OFLAG"} & OPOST) ? 1 : 0; 1257} 1258 1259sub stty_isig { 1260 my $self = shift; 1261 if (@_) { 1262 if ( yes_true( shift ) ) { 1263 $self->{"C_LFLAG"} |= ISIG; 1264 } else { 1265 $self->{"C_LFLAG"} &= ~ISIG; 1266 } 1267 write_settings($self); 1268 } 1269 return ($self->{"C_LFLAG"} & ISIG) ? 1 : 0; 1270} 1271 1272sub stty_icanon { 1273 my $self = shift; 1274 if (@_) { 1275 if ( yes_true( shift ) ) { 1276 $self->{"C_LFLAG"} |= ICANON; 1277 } else { 1278 $self->{"C_LFLAG"} &= ~ICANON; 1279 } 1280 write_settings($self); 1281 } 1282 return ($self->{"C_LFLAG"} & ICANON) ? 1 : 0; 1283} 1284 1285sub alias { 1286 my $self = shift; 1287 if (@_) { $self->{ALIAS} = shift; } # should return true for legal names 1288 return $self->{ALIAS}; 1289} 1290 1291sub devicetype { 1292 my $self = shift; 1293 if (@_) { $self->{DVTYPE} = shift; } # return true for legal names 1294 return $self->{DVTYPE}; 1295} 1296 1297sub hostname { 1298 my $self = shift; 1299 if (@_) { $self->{HNAME} = shift; } # return true for legal names 1300 return $self->{HNAME}; 1301} 1302 1303sub hostaddr { 1304 my $self = shift; 1305 if (@_) { $self->{HADDR} = shift; } # return true for assigned port 1306 return $self->{HADDR}; 1307} 1308 1309sub datatype { 1310 my $self = shift; 1311 if (@_) { $self->{DATYPE} = shift; } # return true for legal types 1312 return $self->{DATYPE}; 1313} 1314 1315sub cfg_param_1 { 1316 my $self = shift; 1317 if (@_) { $self->{CFG_1} = shift; } # return true for legal param 1318 return $self->{CFG_1}; 1319} 1320 1321sub cfg_param_2 { 1322 my $self = shift; 1323 if (@_) { $self->{CFG_2} = shift; } # return true for legal param 1324 return $self->{CFG_2}; 1325} 1326 1327sub cfg_param_3 { 1328 my $self = shift; 1329 if (@_) { $self->{CFG_3} = shift; } # return true for legal param 1330 return $self->{CFG_3}; 1331} 1332 1333sub buffers { 1334 my $self = shift; 1335 if (@_) { return unless (@_ == 2); } 1336 return wantarray ? (4096, 4096) : 1; 1337} 1338 1339sub read_const_time { 1340 my $self = shift; 1341 if (@_) { 1342 $self->{RCONST} = (shift)/1000; # milliseconds -> select_time 1343 $self->{"C_VTIME"} = $self->{RCONST} * 10000; # wants tenths of sec 1344 $self->{"C_VMIN"} = 0; 1345 write_settings($self); 1346 } 1347 return $self->{RCONST}*1000; 1348} 1349 1350sub read_char_time { 1351 my $self = shift; 1352 if (@_) { 1353 $self->{RTOT} = (shift)/1000; # milliseconds -> select_time 1354 } 1355 return $self->{RTOT}*1000; 1356} 1357 1358sub read { 1359 return undef unless (@_ == 2); 1360 my $self = shift; 1361 my $wanted = shift; 1362 my $result = ""; 1363 my $ok = 0; 1364 return (0, "") unless ($wanted > 0); 1365 1366 my $done = 0; 1367 my $count_in = 0; 1368 my $string_in = ""; 1369 my $in2 = ""; 1370 my $bufsize = 255; # VMIN max (declared as char) 1371 1372 while ($done < $wanted) { 1373 my $size = $wanted - $done; 1374 if ($size > $bufsize) { $size = $bufsize; } 1375 ($count_in, $string_in) = $self->read_vmin($size); 1376 if ($count_in) { 1377 $in2 .= $string_in; 1378 $done += $count_in; 1379 } 1380 elsif ($done) { 1381 last; 1382 } 1383 else { 1384 return if (!defined $count_in); 1385 last; 1386 } 1387 } 1388 return ($done, $in2); 1389} 1390 1391sub read_vmin { 1392 return undef unless (@_ == 2); 1393 my $self = shift; 1394 my $wanted = shift; 1395 my $result = ""; 1396 my $ok = 0; 1397 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 my $rin = ""; 1405 vec($rin, $self->{FD}, 1) = 1; 1406 my $ein = $rin; 1407 my $tin = $self->{RCONST} + ($wanted * $self->{RTOT}); 1408 my $rout; 1409 my $wout; 1410 my $eout; 1411 my $tout; 1412 my $ready = select($rout=$rin, $wout=undef, $eout=$ein, $tout=$tin); 1413 1414 my $got=0; 1415 1416 if ($ready>0) { 1417 $got = POSIX::read ($self->{FD}, $result, $wanted); 1418 1419 if (! defined $got) { 1420 return (0,"") if (&POSIX::EAGAIN == ($ok = POSIX::errno())); 1421 return (0,"") if (!$ready and (0 == $ok)); 1422 # at least Solaris acts like eof() in this case 1423 carp "Error #$ok in Device::SerialPort::read"; 1424 return; 1425 } 1426 elsif ($got == 0 && $wanted!=0) { 1427 # if read returns "0" on a non-zero request, it's EOF 1428 return; 1429 } 1430 } 1431 1432 print "read_vmin=$got, ready=$ready, result=..$result..\n" if ($Babble); 1433 return ($got, $result); 1434} 1435 1436sub are_match { 1437 my $self = shift; 1438 my $pat; 1439 my $patno = 0; 1440 my $reno = 0; 1441 my $re_next = 0; 1442 if (@_) { 1443 @{ $self->{"_MATCH"} } = @_; 1444 if ($] >= 5.005) { 1445 @{ $self->{"_CMATCH"} } = (); 1446 while ($pat = shift) { 1447 if ($re_next) { 1448 $re_next = 0; 1449 eval 'push (@{ $self->{"_CMATCH"} }, qr/$pat/)'; 1450 } else { 1451 push (@{ $self->{"_CMATCH"} }, $pat); 1452 } 1453 if ($pat eq "-re") { 1454 $re_next++; 1455 } 1456 } 1457 } else { 1458 @{ $self->{"_CMATCH"} } = @_; 1459 } 1460 } 1461 return @{ $self->{"_MATCH"} }; 1462} 1463 1464sub lookclear { 1465 my $self = shift; 1466 if (nocarp && (@_ == 1)) { 1467 $self->{"_T_INPUT"} = shift; 1468 } 1469 $self->{"_LOOK"} = ""; 1470 $self->{"_LASTLOOK"} = ""; 1471 $self->{"_LMATCH"} = ""; 1472 $self->{"_LPATT"} = ""; 1473 return if (@_); 1474 1; 1475} 1476 1477sub linesize { 1478 my $self = shift; 1479 if (@_) { 1480 my $val = int shift; 1481 return if ($val < 0); 1482 $self->{"_SIZE"} = $val; 1483 } 1484 return $self->{"_SIZE"}; 1485} 1486 1487sub lastline { 1488 my $self = shift; 1489 if (@_) { 1490 $self->{"_LASTLINE"} = shift; 1491 if ($] >= 5.005) { 1492 eval '$self->{"_CLASTLINE"} = qr/$self->{"_LASTLINE"}/'; 1493 } else { 1494 $self->{"_CLASTLINE"} = $self->{"_LASTLINE"}; 1495 } 1496 } 1497 return $self->{"_LASTLINE"}; 1498} 1499 1500sub matchclear { 1501 my $self = shift; 1502 my $found = $self->{"_LMATCH"}; 1503 $self->{"_LMATCH"} = ""; 1504 return if (@_); 1505 return $found; 1506} 1507 1508sub lastlook { 1509 my $self = shift; 1510 return if (@_); 1511 return ( $self->{"_LMATCH"}, $self->{"_LASTLOOK"}, 1512 $self->{"_LPATT"}, $self->{"_LOOK"} ); 1513} 1514 1515sub lookfor { 1516 my $self = shift; 1517 my $size = 0; 1518 if (@_) { $size = shift; } 1519 my $loc = ""; 1520 my $count_in = 0; 1521 my $string_in = ""; 1522 $self->{"_LMATCH"} = ""; 1523 $self->{"_LPATT"} = ""; 1524 1525 if ( ! $self->{"_LOOK"} ) { 1526 $loc = $self->{"_LASTLOOK"}; 1527 } 1528 1529 if ($size) { 1530 ($count_in, $string_in) = $self->read($size); 1531 return unless ($count_in); 1532 $loc .= $string_in; 1533 } 1534 else { 1535 $loc .= $self->input; 1536 } 1537 1538 if ($loc ne "") { 1539 my $n_char; 1540 my $mpos; 1541 my $lookbuf; 1542 my $re_next = 0; 1543 my $got_match = 0; 1544 my $pat; 1545 1546 my @loc_char = split (//, $loc); 1547 while (defined ($n_char = shift @loc_char)) { 1548 $mpos = ord $n_char; 1549 $self->{"_LOOK"} .= $n_char; 1550 $lookbuf = $self->{"_LOOK"}; 1551 $count_in = 0; 1552 foreach $pat ( @{ $self->{"_CMATCH"} } ) { 1553 if ($pat eq "-re") { 1554 $re_next++; 1555 $count_in++; 1556 next; 1557 } 1558 if ($re_next) { 1559 $re_next = 0; 1560 # always at $lookbuf end when processing single char 1561 if ( $lookbuf =~ s/$pat//s ) { 1562 $self->{"_LMATCH"} = $&; 1563 $got_match++; 1564 } 1565 } 1566 elsif (($mpos = index($lookbuf, $pat)) > -1) { 1567 $got_match++; 1568 $lookbuf = substr ($lookbuf, 0, $mpos); 1569 $self->{"_LMATCH"} = $pat; 1570 } 1571 if ($got_match) { 1572 $self->{"_LPATT"} = $self->{"_MATCH"}[$count_in]; 1573 if (scalar @loc_char) { 1574 $self->{"_LASTLOOK"} = join("", @loc_char); 1575 } 1576 else { 1577 $self->{"_LASTLOOK"} = ""; 1578 } 1579 $self->{"_LOOK"} = ""; 1580 return $lookbuf; 1581 } 1582 $count_in++; 1583 } 1584#### } 1585 } 1586 } 1587 return ""; 1588} 1589 1590sub streamline { 1591 my $self = shift; 1592 my $size = 0; 1593 if (@_) { $size = shift; } 1594 my $loc = ""; 1595 my $mpos; 1596 my $count_in = 0; 1597 my $string_in = ""; 1598 my $re_next = 0; 1599 my $got_match = 0; 1600 my $best_pos = 0; 1601 my $pat; 1602 my $match = ""; 1603 my $before = ""; 1604 my $after = ""; 1605 my $best_match = ""; 1606 my $best_before = ""; 1607 my $best_after = ""; 1608 my $best_pat = ""; 1609 $self->{"_LMATCH"} = ""; 1610 $self->{"_LPATT"} = ""; 1611 1612 if ( ! $self->{"_LOOK"} ) { 1613 $loc = $self->{"_LASTLOOK"}; 1614 } 1615 1616 if ($size) { 1617 ($count_in, $string_in) = $self->read($size); 1618 return unless ($count_in); 1619 $loc .= $string_in; 1620 } 1621 else { 1622 $loc .= $self->input; 1623 } 1624 1625 if ($loc ne "") { 1626 $self->{"_LOOK"} .= $loc; 1627 $count_in = 0; 1628 foreach $pat ( @{ $self->{"_CMATCH"} } ) { 1629 if ($pat eq "-re") { 1630 $re_next++; 1631 $count_in++; 1632 next; 1633 } 1634 if ($re_next) { 1635 $re_next = 0; 1636 if ( $self->{"_LOOK"} =~ /$pat/s ) { 1637 ( $match, $before, $after ) = ( $&, $`, $' ); 1638 $got_match++; 1639 $mpos = length($before); 1640 if ($mpos) { 1641 next if ($best_pos && ($mpos > $best_pos)); 1642 $best_pos = $mpos; 1643 $best_pat = $self->{"_MATCH"}[$count_in]; 1644 $best_match = $match; 1645 $best_before = $before; 1646 $best_after = $after; 1647 } 1648 else { 1649 $self->{"_LPATT"} = $self->{"_MATCH"}[$count_in]; 1650 $self->{"_LMATCH"} = $match; 1651 $self->{"_LASTLOOK"} = $after; 1652 $self->{"_LOOK"} = ""; 1653 return $before; 1654 # pattern at start will be best 1655 } 1656 } 1657 } 1658 elsif (($mpos = index($self->{"_LOOK"}, $pat)) > -1) { 1659 $got_match++; 1660 $before = substr ($self->{"_LOOK"}, 0, $mpos); 1661 if ($mpos) { 1662 next if ($best_pos && ($mpos > $best_pos)); 1663 $best_pos = $mpos; 1664 $best_pat = $pat; 1665 $best_match = $pat; 1666 $best_before = $before; 1667 $mpos += length($pat); 1668 $best_after = substr ($self->{"_LOOK"}, $mpos); 1669 } 1670 else { 1671 $self->{"_LPATT"} = $pat; 1672 $self->{"_LMATCH"} = $pat; 1673 $before = substr ($self->{"_LOOK"}, 0, $mpos); 1674 $mpos += length($pat); 1675 $self->{"_LASTLOOK"} = substr ($self->{"_LOOK"}, $mpos); 1676 $self->{"_LOOK"} = ""; 1677 return $before; 1678 # match at start will be best 1679 } 1680 } 1681 $count_in++; 1682 } 1683 if ($got_match) { 1684 $self->{"_LPATT"} = $best_pat; 1685 $self->{"_LMATCH"} = $best_match; 1686 $self->{"_LASTLOOK"} = $best_after; 1687 $self->{"_LOOK"} = ""; 1688 return $best_before; 1689 } 1690 } 1691 return ""; 1692} 1693 1694sub input { 1695 return undef unless (@_ == 1); 1696 my $self = shift; 1697 my $ok = 0; 1698 my $result = ""; 1699 my $wanted = 255; 1700 1701 if (nocarp && $self->{"_T_INPUT"}) { 1702 $result = $self->{"_T_INPUT"}; 1703 $self->{"_T_INPUT"} = ""; 1704 return $result; 1705 } 1706 1707 if ( $self->{"C_VMIN"} ) { 1708 $self->{"C_VMIN"} = 0; 1709 write_settings($self); 1710 } 1711 1712 my $got = POSIX::read ($self->{FD}, $result, $wanted); 1713 1714 unless (defined $got) { $got = -1; } 1715 if ($got == -1) { 1716 return "" if (&POSIX::EAGAIN == ($ok = POSIX::errno())); 1717 return "" if (0 == $ok); # at least Solaris acts like eof() 1718 carp "Error #$ok in Device::SerialPort::input" 1719 } 1720 return $result; 1721} 1722 1723sub write { 1724 return undef unless (@_ == 2); 1725 my $self = shift; 1726 my $wbuf = shift; 1727 my $ok; 1728 1729 return 0 if ($wbuf eq ""); 1730 my $lbuf = length ($wbuf); 1731 1732 my $written = POSIX::write ($self->{FD}, $wbuf, $lbuf); 1733 1734 return $written; 1735} 1736 1737sub write_drain { 1738 my $self = shift; 1739 return if (@_); 1740 return 1 if (defined POSIX::tcdrain($self->{FD})); 1741 return; 1742} 1743 1744sub purge_all { 1745 my $self = shift; 1746 return if (@_); 1747 return 1 if (defined POSIX::tcflush($self->{FD}, TCIOFLUSH)); 1748 return; 1749} 1750 1751sub purge_rx { 1752 my $self = shift; 1753 return if (@_); 1754 return 1 if (defined POSIX::tcflush($self->{FD}, TCIFLUSH)); 1755 return; 1756} 1757 1758sub purge_tx { 1759 my $self = shift; 1760 return if (@_); 1761 return 1 if (defined POSIX::tcflush($self->{FD}, TCOFLUSH)); 1762 return; 1763} 1764 1765sub buffer_max { 1766 my $self = shift; 1767 if (@_) {return undef; } 1768 return (4096, 4096); 1769} 1770 1771 # true/false parameters 1772 1773sub user_msg { 1774 my $self = shift; 1775 if (@_) { $self->{U_MSG} = yes_true ( shift ) } 1776 return wantarray ? @binary_opt : $self->{U_MSG}; 1777} 1778 1779sub error_msg { 1780 my $self = shift; 1781 if (@_) { $self->{E_MSG} = yes_true ( shift ) } 1782 return wantarray ? @binary_opt : $self->{E_MSG}; 1783} 1784 1785sub parity_enable { 1786 my $self = shift; 1787 if (@_) { 1788 if ( yes_true( shift ) ) { 1789 $self->{"C_CFLAG"} |= PARENB; 1790 } else { 1791 $self->{"C_CFLAG"} &= ~PARENB; 1792 } 1793 write_settings($self); 1794 } 1795 return wantarray ? @binary_opt : ($self->{"C_CFLAG"} & PARENB); 1796} 1797 1798sub write_done { 1799 return unless (@_ == 2); 1800 my $self = shift; 1801 return unless ($self->can_write_done); 1802 my $rc; 1803 my $wait = yes_true ( shift ); 1804 $self->write_drain if ($wait); 1805 1806 my $mstat = " "; 1807 my $result; 1808 for (;;) { 1809 return unless $self->ioctl('TIOCOUTQ',\$mstat); 1810 $result = unpack('L', $mstat); 1811 return (0, 0) if ($result); # characters pending 1812 1813 return unless $self->ioctl('TIOCSERGETLSR',\$mstat); 1814 $result = (unpack('L', $mstat) & TIOCM_LE); 1815 last unless ($wait); 1816 last if ($result); # shift register empty 1817 select (undef, undef, undef, 0.02); 1818 } 1819 return $result ? (1, 0) : (0, 0); 1820} 1821 1822sub modemlines { 1823 return undef unless (@_ == 1); 1824 my $self = shift; 1825 return undef unless ($self->can_modemlines); 1826 1827 my $mstat = pack('L',0); 1828 return undef unless $self->ioctl('TIOCMGET',\$mstat); 1829 my $result = unpack('L', $mstat); 1830 if ($Babble) { 1831 printf "result = %x\n", $result; 1832 print "CTS is ON\n" if ($result & MS_CTS_ON); 1833 print "DSR is ON\n" if ($result & MS_DSR_ON); 1834 print "RING is ON\n" if ($result & MS_RING_ON); 1835 print "RLSD is ON\n" if ($result & MS_RLSD_ON); 1836 } 1837 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? 1843sub wait_modemlines { 1844 return undef unless (@_ == 2); 1845 my $self = shift; 1846 my $flags = shift || 0; 1847 return undef unless ($self->can_wait_modemlines); 1848 1849 if ($Babble) { 1850 printf "wait_modemlines flag = %u\n", $flags; 1851 } 1852 my $mstat = pack('L',$flags); 1853 return $self->ioctl('TIOCMIWAIT',\$mstat); 1854} 1855 1856sub intr_count { 1857 return undef unless (@_ == 1); 1858 my $self = shift; 1859 return undef unless ($self->can_intr_count); 1860 1861 my $mstat = pack('L',0); 1862 return $self->ioctl('TIOCGICOUNT',\$mstat); 1863 my $result = unpack('L', $mstat); 1864 if ($Babble) { 1865 printf "result = %x\n", $result; 1866 } 1867 return $result; 1868} 1869 1870sub status { 1871 my $self = shift; 1872 return if (@_); 1873 return unless ($self->can_status); 1874 my @stat = (0, 0, 0, 0); 1875 my $mstat = " "; 1876 1877 return unless $self->ioctl('portable_TIOCINQ', \$mstat); 1878 1879 $stat[ST_INPUT] = unpack('L', $mstat); 1880 return unless $self->ioctl('TIOCOUTQ', \$mstat); 1881 1882 $stat[ST_OUTPUT] = unpack('L', $mstat); 1883 1884 if ( $Babble or $self->{"_DEBUG"} ) { 1885 printf "Blocking Bits= %d\n", $stat[ST_BLOCK]; 1886 printf "Input Queue= %d\n", $stat[ST_INPUT]; 1887 printf "Output Queue= %d\n", $stat[ST_OUTPUT]; 1888 printf "Latched Errors= %d\n", $stat[ST_ERROR]; 1889 } 1890 return @stat; 1891} 1892 1893sub dtr_active { 1894 return unless (@_ == 2); 1895 my $self = shift; 1896 return unless $self->can_dtrdsr(); 1897 my $on = yes_true( shift ); 1898 my $rc; 1899 1900 # if we have set DTR and clear DTR, we should use it (OpenBSD) 1901 my $value=0; 1902 if (defined($bits->{'TIOCSDTR'}) && 1903 defined($bits->{'TIOCCDTR'})) { 1904 $value=0; 1905 $rc=$self->ioctl($on ? 'TIOCSDTR' : 'TIOCCDTR', \$value); 1906 } 1907 else { 1908 $value=$IOCTL_VALUE_DTR; 1909 $rc=$self->ioctl($on ? 'TIOCMBIS' : 'TIOCMBIC', \$value); 1910 } 1911 warn "dtr_active($on) ioctl: $!\n" if (!$rc); 1912 1913 # ARG! Solaris destroys termios settings after a DTR toggle!! 1914 write_settings($self); 1915 1916 return $rc; 1917} 1918 1919sub rts_active { 1920 return unless (@_ == 2); 1921 my $self = shift; 1922 return unless ($self->can_rts()); 1923 my $on = yes_true( shift ); 1924 # returns ioctl result 1925 my $value=$IOCTL_VALUE_RTS; 1926 my $rc=$self->ioctl($on ? 'TIOCMBIS' : 'TIOCMBIC', \$value); 1927 #my $rc=ioctl($self->{HANDLE}, $on ? $bitset : $bitclear, $rtsout); 1928 warn "rts_active($on) ioctl: $!\n" if (!$rc); 1929 return $rc; 1930} 1931 1932sub pulse_break_on { 1933 return unless (@_ == 2); 1934 my $self = shift; 1935 my $delay = (shift)/1000; 1936 my $length = 0; 1937 my $ok = POSIX::tcsendbreak($self->{FD}, $length); 1938 warn "could not pulse break on: $!\n" unless ($ok); 1939 select (undef, undef, undef, $delay); 1940 return $ok; 1941} 1942 1943sub pulse_rts_on { 1944 return unless (@_ == 2); 1945 my $self = shift; 1946 return unless ($self->can_rts()); 1947 my $delay = (shift)/1000; 1948 $self->rts_active(1) or warn "could not pulse rts on\n"; 1949 select (undef, undef, undef, $delay); 1950 $self->rts_active(0) or warn "could not restore from rts on\n"; 1951 select (undef, undef, undef, $delay); 1952 1; 1953} 1954 1955sub pulse_dtr_on { 1956 return unless (@_ == 2); 1957 my $self = shift; 1958 return unless $self->can_ioctl(); 1959 my $delay = (shift)/1000; 1960 $self->dtr_active(1) or warn "could not pulse dtr on\n"; 1961 select (undef, undef, undef, $delay); 1962 $self->dtr_active(0) or warn "could not restore from dtr on\n"; 1963 select (undef, undef, undef, $delay); 1964 1; 1965} 1966 1967sub pulse_rts_off { 1968 return unless (@_ == 2); 1969 my $self = shift; 1970 return unless ($self->can_rts()); 1971 my $delay = (shift)/1000; 1972 $self->rts_active(0) or warn "could not pulse rts off\n"; 1973 select (undef, undef, undef, $delay); 1974 $self->rts_active(1) or warn "could not restore from rts off\n"; 1975 select (undef, undef, undef, $delay); 1976 1; 1977} 1978 1979sub pulse_dtr_off { 1980 return unless (@_ == 2); 1981 my $self = shift; 1982 return unless $self->can_ioctl(); 1983 my $delay = (shift)/1000; 1984 $self->dtr_active(0) or warn "could not pulse dtr off\n"; 1985 select (undef, undef, undef, $delay); 1986 $self->dtr_active(1) or warn "could not restore from dtr off\n"; 1987 select (undef, undef, undef, $delay); 1988 1; 1989} 1990 1991sub debug { 1992 my $self = shift; 1993 if (ref($self)) { 1994 if (@_) { $self->{"_DEBUG"} = yes_true ( shift ); } 1995 if (wantarray) { return @binary_opt; } 1996 else { 1997 my $tmp = $self->{"_DEBUG"}; 1998 nocarp || carp "Debug level: $self->{ALIAS} = $tmp"; 1999 return $self->{"_DEBUG"}; 2000 } 2001 } else { 2002 if (@_) { $Babble = yes_true ( shift ); } 2003 if (wantarray) { return @binary_opt; } 2004 else { 2005 nocarp || carp "Debug Class = $Babble"; 2006 return $Babble; 2007 } 2008 } 2009} 2010 2011sub close { 2012 my $self = shift; 2013 my $ok = undef; 2014 my $item; 2015 2016 return unless (defined $self->{NAME}); 2017 2018 if ($Babble) { 2019 carp "Closing $self " . $self->{ALIAS}; 2020 } 2021 if ($self->{FD}) { 2022 purge_all ($self); 2023 2024 # Gracefully handle shutdown without termios 2025 if (defined($self->{TERMIOS})) { 2026 # copy the original values into "current" values 2027 foreach $item (keys %c_cc_fields) { 2028 $self->{"C_$item"} = $self->{"_$item"}; 2029 } 2030 2031 $self->{"C_CFLAG"} = $self->{"_CFLAG"}; 2032 $self->{"C_IFLAG"} = $self->{"_IFLAG"}; 2033 $self->{"C_ISPEED"} = $self->{"_ISPEED"}; 2034 $self->{"C_LFLAG"} = $self->{"_LFLAG"}; 2035 $self->{"C_OFLAG"} = $self->{"_OFLAG"}; 2036 $self->{"C_OSPEED"} = $self->{"_OSPEED"}; 2037 2038 write_settings($self); 2039 } 2040 2041 $ok = POSIX::close($self->{FD}); 2042 2043 # we need to explicitly close this handle 2044 $self->{HANDLE}->close if (defined($self->{HANDLE}) && 2045 $self->{HANDLE}->opened); 2046 2047 $self->{FD} = undef; 2048 $self->{HANDLE} = undef; 2049 } 2050 if ($self->{LOCK}) { 2051 unless ( unlink $self->{LOCK} ) { 2052 nocarp or carp "can't remove lockfile: $self->{LOCK}\n"; 2053 } 2054 $self->{LOCK} = ""; 2055 } 2056 $self->{NAME} = undef; 2057 $self->{ALIAS} = undef; 2058 return unless ($ok); 2059 1; 2060} 2061 2062sub ioctl 2063{ 2064 my ($self,$code,$ref) = @_; 2065 return undef unless (defined $self->{NAME}); 2066 2067 2068 if ($Babble) { 2069 my $num = $$ref; 2070 $num = unpack('L', $num); 2071 carp "ioctl $code($bits->{$code}) $ref: $num"; 2072 } 2073 2074 my $magic; 2075 if (!defined($magic = $bits->{$code})) { 2076 carp "cannot ioctl '$code': no system value found\n"; 2077 return undef; 2078 } 2079 2080 if (!ioctl($self->{HANDLE},$magic,$$ref)) { 2081 carp "$code($magic) ioctl failed: $!"; 2082 return undef; 2083 } 2084 2085 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 2095sub DESTROY { 2096 my $self = shift; 2097 return unless (defined $self->{NAME}); 2098 if ($self->{"_DEBUG"}) { 2099 carp "Destroying $self->{NAME}"; 2100 } 2101 $self->close; 2102} 2103 2104sub TIEHANDLE { 2105 my $proto = shift; 2106 my $class = ref($proto) || $proto; 2107 2108 return unless (@_); 2109 2110# my $self = start($class, shift); 2111 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 2118sub WRITE { 2119 return if (@_ < 3); 2120 my $self = shift; 2121 my $buf = shift; 2122 my $len = shift; 2123 my $offset = 0; 2124 if (@_) { $offset = shift; } 2125 my $out2 = substr($buf, $offset, $len); 2126 return unless ($self->post_print($out2)); 2127 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 2135sub PRINT { 2136 my $self = shift; 2137 return unless (@_); 2138 my $ofs = $, ? $, : ""; 2139 if ($self->{OFS}) { $ofs = $self->{OFS}; } 2140 my $ors = $\ ? $\ : ""; 2141 if ($self->{ORS}) { $ors = $self->{ORS}; } 2142 my $output = join($ofs,@_); 2143 $output .= $ors; 2144 return $self->post_print($output); 2145} 2146 2147sub output_field_separator { 2148 my $self = shift; 2149 my $prev = $self->{OFS}; 2150 if (@_) { $self->{OFS} = shift; } 2151 return $prev; 2152} 2153 2154sub output_record_separator { 2155 my $self = shift; 2156 my $prev = $self->{ORS}; 2157 if (@_) { $self->{ORS} = shift; } 2158 return $prev; 2159} 2160 2161sub post_print { 2162 my $self = shift; 2163 return unless (@_); 2164 my $output = shift; 2165 my $to_do = length($output); 2166 my $done = 0; 2167 my $written = 0; 2168 while ($done < $to_do) { 2169 my $out2 = substr($output, $done); 2170 $written = $self->write($out2); 2171 if (! defined $written) { 2172 return; 2173 } 2174 return 0 unless ($written); 2175 $done += $written; 2176 } 2177 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 2185sub PRINTF { 2186 my $self = shift; 2187 my $fmt = shift; 2188 return unless ($fmt); 2189 return unless (@_); 2190 my $output = sprintf($fmt, @_); 2191 $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 2198sub READ { 2199 return if (@_ < 3); 2200 my $buf = \$_[1]; 2201 my ($self, $junk, $size, $offset) = @_; 2202 unless (defined $offset) { $offset = 0; } 2203 my $count_in = 0; 2204 my $string_in = ""; 2205 2206 ($count_in, $string_in) = $self->read($size); 2207 2208 $$buf = '' unless defined $$buf; 2209 my $buflen = length $$buf; 2210 2211 my ($tail, $head) = ('',''); 2212 2213 if($offset >= 0){ # positive offset 2214 if($buflen > $offset + $count_in){ 2215 $tail = substr($$buf, $offset + $count_in); 2216 } 2217 2218 if($buflen < $offset){ 2219 $head = $$buf . ("\0" x ($offset - $buflen)); 2220 } else { 2221 $head = substr($$buf, 0, $offset); 2222 } 2223 } else { # negative offset 2224 $head = substr($$buf, 0, ($buflen + $offset)); 2225 2226 if(-$offset > $count_in){ 2227 $tail = substr($$buf, $offset + $count_in); 2228 } 2229 } 2230 2231 # remaining unhandled case: $offset < 0 && -$offset > $buflen 2232 $$buf = $head.$string_in.$tail; 2233 return $count_in; 2234} 2235 2236# READLINE this 2237# This method will be called when the handle is read from via <HANDLE>. 2238# The method should return undef when there is no more data. 2239 2240sub READLINE { 2241 my $self = shift; 2242 return if (@_); 2243 my $count_in = 0; 2244 my $string_in = ""; 2245 my $match = ""; 2246 my $was; 2247 2248 if (wantarray) { 2249 my @lines; 2250 for (;;) { 2251 last if ($was = $self->reset_error); # dummy, currently 2252 if ($self->stty_icanon) { 2253 ($count_in, $string_in) = $self->read_vmin(255); 2254 last if (! defined $count_in); 2255 } 2256 else { 2257 $string_in = $self->streamline($self->{"_SIZE"}); 2258 last if (! defined $string_in); 2259 $match = $self->matchclear; 2260 if ( ($string_in ne "") || ($match ne "") ) { 2261 $string_in .= $match; 2262 } 2263 } 2264 push (@lines, $string_in); 2265 last if ($string_in =~ /$self->{"_CLASTLINE"}/s); 2266 } 2267 return @lines if (@lines); 2268 return; 2269 } 2270 else { 2271 my $last_icanon = $self->stty_icanon; 2272 $self->stty_icanon(1); 2273 for (;;) { 2274 last if ($was = $self->reset_error); # dummy, currently 2275 $string_in = $self->lookfor($self->{"_SIZE"}); 2276 last if (! defined $string_in); 2277 $match = $self->matchclear; 2278 if ( ($string_in ne "") || ($match ne "") ) { 2279 $string_in .= $match; # traditional <HANDLE> behavior 2280 $self->stty_icanon(0); 2281 return $string_in; 2282 } 2283 } 2284 $self->stty_icanon($last_icanon); 2285 return; 2286 } 2287} 2288 2289# GETC this 2290# This method will be called when the getc function is called. 2291 2292sub GETC { 2293 my $self = shift; 2294 my ($count, $in) = $self->read(1); 2295 if ($count == 1) { 2296 return $in; 2297 } 2298 return; 2299} 2300 2301# CLOSE this 2302# This method will be called when the handle is closed via the close 2303# function. 2304 2305sub CLOSE { 2306 my $self = shift; 2307 $self->write_drain; 2308 my $success = $self->close; 2309 if ($Babble) { printf "CLOSE result:%d\n", $success; } 2310 return $success; 2311} 2312 2313# FILENO this 2314# This method will be called if we ever need the FD from the handle 2315 2316sub FILENO { 2317 my $self = shift; 2318 return $self->{FD}; 2319} 2320 23211; # so the require or use succeeds 2322 2323__END__ 2324 2325=pod 2326 2327=head1 NAME 2328 2329Device::SerialPort - Linux/POSIX emulation of Win32::SerialPort functions. 2330 2331=head1 SYNOPSIS 2332 2333 use Device::SerialPort qw( :PARAM :STAT 0.07 ); 2334 2335=head2 Constructors 2336 2337 # $lockfile is optional 2338 $PortObj = new Device::SerialPort ($PortName, $quiet, $lockfile) 2339 || die "Can't open $PortName: $!\n"; 2340 2341 $PortObj = start Device::SerialPort ($Configuration_File_Name) 2342 || die "Can't start $Configuration_File_Name: $!\n"; 2343 2344 $PortObj = tie (*FH, 'Device::SerialPort', $Configuration_File_Name) 2345 || die "Can't tie using $Configuration_File_Name: $!\n"; 2346 2347=head2 Configuration Utility Methods 2348 2349 $PortObj->alias("MODEM1"); 2350 2351 $PortObj->save($Configuration_File_Name) 2352 || warn "Can't save $Configuration_File_Name: $!\n"; 2353 2354 # currently optional after new, POSIX version expected to succeed 2355 $PortObj->write_settings; 2356 2357 # rereads file to either return open port to a known state 2358 # or switch to a different configuration on the same port 2359 $PortObj->restart($Configuration_File_Name) 2360 || warn "Can't reread $Configuration_File_Name: $!\n"; 2361 2362 # "app. variables" saved in $Configuration_File, not used internally 2363 $PortObj->devicetype('none'); # CM11, CM17, 'weeder', 'modem' 2364 $PortObj->hostname('localhost'); # for socket-based implementations 2365 $PortObj->hostaddr(0); # false unless specified 2366 $PortObj->datatype('raw'); # in case an application needs_to_know 2367 $PortObj->cfg_param_1('none'); # null string '' hard to save/restore 2368 $PortObj->cfg_param_2('none'); # 3 spares should be enough for now 2369 $PortObj->cfg_param_3('none'); # one may end up as a log file path 2370 2371 # test suite use only 2372 @necessary_param = Device::SerialPort->set_test_mode_active(1); 2373 2374 # exported by :PARAM 2375 nocarp || carp "Something fishy"; 2376 $a = SHORTsize; # 0xffff 2377 $a = LONGsize; # 0xffffffff 2378 $answer = yes_true("choice"); # 1 or 0 2379 OS_Error unless ($API_Call_OK); # prints error 2380 2381=head2 Configuration Parameter Methods 2382 2383 # most methods can be called two ways: 2384 $PortObj->handshake("xoff"); # set parameter 2385 $flowcontrol = $PortObj->handshake; # current value (scalar) 2386 2387 # The only "list context" method calls from Win32::SerialPort 2388 # currently supported are those for baudrate, parity, databits, 2389 # stopbits, and handshake (which only accept specific input values). 2390 @handshake_opts = $PortObj->handshake; # permitted choices (list) 2391 2392 # similar 2393 $PortObj->baudrate(9600); 2394 $PortObj->parity("odd"); 2395 $PortObj->databits(8); 2396 $PortObj->stopbits(1); # POSIX does not support 1.5 stopbits 2397 2398 # these are essentially dummies in POSIX implementation 2399 # the calls exist to support compatibility 2400 $PortObj->buffers(4096, 4096); # returns (4096, 4096) 2401 @max_values = $PortObj->buffer_max; # returns (4096, 4096) 2402 $PortObj->reset_error; # returns 0 2403 2404 # true/false parameters (return scalar context only) 2405 # parameters exist, but message processing not yet fully implemented 2406 $PortObj->user_msg(ON); # built-in instead of warn/die above 2407 $PortObj->error_msg(ON); # translate error bitmasks and carp 2408 2409 $PortObj->parity_enable(F); # faults during input 2410 $PortObj->debug(0); 2411 2412 # true/false capabilities (read only) 2413 # most are just constants in the POSIX case 2414 $PortObj->can_baud; # 1 2415 $PortObj->can_databits; # 1 2416 $PortObj->can_stopbits; # 1 2417 $PortObj->can_dtrdsr; # 1 2418 $PortObj->can_handshake; # 1 2419 $PortObj->can_parity_check; # 1 2420 $PortObj->can_parity_config; # 1 2421 $PortObj->can_parity_enable; # 1 2422 $PortObj->can_rlsd; # 0 currently 2423 $PortObj->can_16bitmode; # 0 Win32-specific 2424 $PortObj->is_rs232; # 1 2425 $PortObj->is_modem; # 0 Win32-specific 2426 $PortObj->can_rtscts; # 1 2427 $PortObj->can_xonxoff; # 1 2428 $PortObj->can_xon_char; # 1 use stty 2429 $PortObj->can_spec_char; # 0 use stty 2430 $PortObj->can_interval_timeout; # 0 currently 2431 $PortObj->can_total_timeout; # 1 currently 2432 $PortObj->can_ioctl; # automatically detected 2433 $PortObj->can_status; # automatically detected 2434 $PortObj->can_write_done; # automatically detected 2435 $PortObj->can_modemlines; # automatically detected 2436 $PortObj->can_wait_modemlines;# automatically detected 2437 $PortObj->can_intr_count; # automatically detected 2438 $PortObj->can_arbitrary_baud; # automatically detected 2439 2440=head2 Operating Methods 2441 2442 ($count_in, $string_in) = $PortObj->read($InBytes); 2443 warn "read unsuccessful\n" unless ($count_in == $InBytes); 2444 2445 $count_out = $PortObj->write($output_string); 2446 warn "write failed\n" unless ($count_out); 2447 warn "write incomplete\n" if ( $count_out != length($output_string) ); 2448 2449 if ($string_in = $PortObj->input) { PortObj->write($string_in); } 2450 # simple echo with no control character processing 2451 2452 if ($PortObj->can_wait_modemlines) { 2453 $rc = $PortObj->wait_modemlines( MS_RLSD_ON ); 2454 if (!$rc) { print "carrier detect changed\n"; } 2455 } 2456 2457 if ($PortObj->can_modemlines) { 2458 $ModemStatus = $PortObj->modemlines; 2459 if ($ModemStatus & $PortObj->MS_RLSD_ON) { print "carrier detected\n"; } 2460 } 2461 2462 if ($PortObj->can_intr_count) { 2463 $count = $PortObj->intr_count(); 2464 print "got $count interrupts\n"; 2465 } 2466 2467 if ($PortObj->can_arbitrary_baud) { 2468 print "this port can set arbitrary baud rates\n"; 2469 } 2470 2471 ($BlockingFlags, $InBytes, $OutBytes, $ErrorFlags) = $PortObj->status; 2472 # same format for compatibility. Only $InBytes and $OutBytes are 2473 # currently returned (on linux). Others are 0. 2474 # Check return value of "can_status" to see if this call is valid. 2475 2476 ($done, $count_out) = $PortObj->write_done(0); 2477 # POSIX defaults to background write. Currently $count_out always 0. 2478 # $done set when hardware finished transmitting and shared line can 2479 # be released for other use. Ioctl may not work on all OSs. 2480 # Check return value of "can_write_done" to see if this call is valid. 2481 2482 $PortObj->write_drain; # POSIX alternative to Win32 write_done(1) 2483 # set when software is finished transmitting 2484 $PortObj->purge_all; 2485 $PortObj->purge_rx; 2486 $PortObj->purge_tx; 2487 2488 # controlling outputs from the port 2489 $PortObj->dtr_active(T); # sends outputs direct to hardware 2490 $PortObj->rts_active(Yes); # return status of ioctl call 2491 # return undef on failure 2492 2493 $PortObj->pulse_break_on($milliseconds); # off version is implausible 2494 $PortObj->pulse_rts_on($milliseconds); 2495 $PortObj->pulse_rts_off($milliseconds); 2496 $PortObj->pulse_dtr_on($milliseconds); 2497 $PortObj->pulse_dtr_off($milliseconds); 2498 # sets_bit, delays, resets_bit, delays 2499 # returns undef if unsuccessful or ioctls not implemented 2500 2501 $PortObj->read_const_time(100); # const time for read (milliseconds) 2502 $PortObj->read_char_time(5); # avg time between read char 2503 2504 $milliseconds = $PortObj->get_tick_count; 2505 2506=head2 Methods used with Tied FileHandles 2507 2508 $PortObj = tie (*FH, 'Device::SerialPort', $Configuration_File_Name) 2509 || die "Can't tie: $!\n"; ## TIEHANDLE ## 2510 2511 print FH "text"; ## PRINT ## 2512 $char = getc FH; ## GETC ## 2513 syswrite FH, $out, length($out), 0; ## WRITE ## 2514 $line = <FH>; ## READLINE ## 2515 @lines = <FH>; ## READLINE ## 2516 printf FH "received: %s", $line; ## PRINTF ## 2517 read (FH, $in, 5, 0) or die "$!"; ## READ ## 2518 sysread (FH, $in, 5, 0) or die "$!"; ## READ ## 2519 close FH || warn "close failed"; ## CLOSE ## 2520 undef $PortObj; 2521 untie *FH; ## DESTROY ## 2522 2523 $PortObj->linesize(10); # with READLINE 2524 $PortObj->lastline("_GOT_ME_"); # with READLINE, list only 2525 2526 ## with PRINT and PRINTF, return previous value of separator 2527 $old_ors = $PortObj->output_record_separator("RECORD"); 2528 $old_ofs = $PortObj->output_field_separator("COMMA"); 2529 2530=head2 Destructors 2531 2532 $PortObj->close || warn "close failed"; 2533 # release port to OS - needed to reopen 2534 # close will not usually DESTROY the object 2535 # also called as: close FH || warn "close failed"; 2536 2537 undef $PortObj; 2538 # preferred unless reopen expected since it triggers DESTROY 2539 # calls $PortObj->close but does not confirm success 2540 # MUST precede untie - do all three IN THIS SEQUENCE before re-tie. 2541 2542 untie *FH; 2543 2544=head2 Methods for I/O Processing 2545 2546 $PortObj->are_match("text", "\n"); # possible end strings 2547 $PortObj->lookclear; # empty buffers 2548 $PortObj->write("Feed Me:"); # initial prompt 2549 $PortObj->is_prompt("More Food:"); # not implemented 2550 2551 my $gotit = ""; 2552 until ("" ne $gotit) { 2553 $gotit = $PortObj->lookfor; # poll until data ready 2554 die "Aborted without match\n" unless (defined $gotit); 2555 sleep 1; # polling sample time 2556 } 2557 2558 printf "gotit = %s\n", $gotit; # input BEFORE the match 2559 my ($match, $after, $pattern, $instead) = $PortObj->lastlook; 2560 # input that MATCHED, input AFTER the match, PATTERN that matched 2561 # input received INSTEAD when timeout without match 2562 printf "lastlook-match = %s -after = %s -pattern = %s\n", 2563 $match, $after, $pattern; 2564 2565 $gotit = $PortObj->lookfor($count); # block until $count chars received 2566 2567 $PortObj->are_match("-re", "pattern", "text"); 2568 # possible match strings: "pattern" is a regular expression, 2569 # "text" is a literal string 2570 2571=head1 DESCRIPTION 2572 2573This module provides an object-based user interface essentially 2574identical to the one provided by the Win32::SerialPort module. 2575 2576=head2 Initialization 2577 2578The primary constructor is B<new> with either a F<PortName>, or a 2579F<Configuretion File> specified. With a F<PortName>, this 2580will open the port and create the object. The port is not yet ready 2581for read/write access. First, the desired I<parameter settings> must 2582be established. Since these are tuning constants for an underlying 2583hardware driver in the Operating System, they are all checked for 2584validity by the methods that set them. The B<write_settings> method 2585updates the port (and will return True under POSIX). Ports are opened 2586for binary transfers. A separate C<binmode> is not needed. 2587 2588 $PortObj = new Device::SerialPort ($PortName, $quiet, $lockfile) 2589 || die "Can't open $PortName: $!\n"; 2590 2591The C<$quiet> parameter is ignored and is only there for compatibility 2592with Win32::SerialPort. The C<$lockfile> parameter is optional. It will 2593attempt to create a file (containing just the current process id) at the 2594location specified. This file will be automatically deleted when the 2595C<$PortObj> is no longer used (by DESTROY). You would usually request 2596C<$lockfile> with C<$quiet> true to disable messages while attempting 2597to obtain exclusive ownership of the port via the lock. Lockfiles are 2598experimental in Version 0.07. They are intended for use with other 2599applications. No attempt is made to resolve port aliases (/dev/modem == 2600/dev/ttySx) or to deal with login processes such as getty and uugetty. 2601 2602Using a F<Configuration File> with B<new> or by using second constructor, 2603B<start>, scripts can be simplified if they need a constant setup. It 2604executes all the steps from B<new> to B<write_settings> based on a previously 2605saved configuration. This constructor will return C<undef> on a bad 2606configuration file or failure of a validity check. The returned object is 2607ready for access. This is new and experimental for Version 0.055. 2608 2609 $PortObj2 = start Device::SerialPort ($Configuration_File_Name) 2610 || die; 2611 2612The third constructor, B<tie>, will combine the B<start> with Perl's 2613support for tied FileHandles (see I<perltie>). Device::SerialPort will 2614implement the complete set of methods: TIEHANDLE, PRINT, PRINTF, 2615WRITE, READ, GETC, READLINE, CLOSE, and DESTROY. Tied FileHandle 2616support is new with Version 0.04 and the READ and READLINE methods 2617were added in Version 0.06. In "scalar context", READLINE sets B<stty_icanon> 2618to do character processing and calls B<lookfor>. It restores B<stty_icanon> 2619after the read. In "list context", READLINE does Canonical (line) reads if 2620B<stty_icanon> is set or calls B<streamline> if it is not. (B<stty_icanon> 2621is not altered). The B<streamline> choice allows duplicating the operation 2622of Win32::SerialPort for cross-platform scripts. 2623 2624The implementation attempts to mimic STDIN/STDOUT behaviour as closely 2625as possible: calls block until done and data strings that exceed internal 2626buffers are divided transparently into multiple calls. In Version 0.06, 2627the output separators C<$,> and C<$\> are also applied to PRINT if set. 2628The B<output_record_separator> and B<output_field_separator> methods can set 2629I<Port-FileHandle-Specific> versions of C<$,> and C<$\> if desired. Since 2630PRINTF is treated internally as a single record PRINT, C<$\> will be applied. 2631Output separators are not applied to WRITE (called as 2632C<syswrite FH, $scalar, $length, [$offset]>). 2633The input_record_separator C<$/> is not explicitly supported - but an 2634identical function can be obtained with a suitable B<are_match> setting. 2635 2636 $PortObj2 = tie (*FH, 'Device::SerialPort', $Configuration_File_Name) 2637 || die; 2638 2639The tied FileHandle methods may be combined with the Device::SerialPort 2640methods for B<read, input>, and B<write> as well as other methods. The 2641typical restrictions against mixing B<print> with B<syswrite> do not 2642apply. Since both B<(tied) read> and B<sysread> call the same C<$ob-E<gt>READ> 2643method, and since a separate C<$ob-E<gt>read> method has existed for some 2644time in Device::SerialPort, you should always use B<sysread> with the 2645tied interface (when it is implemented). 2646 2647=over 8 2648 2649Certain parameters I<SHOULD> be set before executing B<write_settings>. 2650Others will attempt to deduce defaults from the hardware or from other 2651parameters. The I<Required> parameters are: 2652 2653=item baudrate 2654 2655Any legal value. 2656 2657=item parity 2658 2659One of the following: "none", "odd", "even". 2660 2661By default, incoming parity is not checked. This mimics the behavior 2662of most terminal programs (like "minicom"). If you need parity checking 2663enabled, please use the "stty_inpck" and "stty_istrip" functions. 2664 2665=item databits 2666 2667An integer from 5 to 8. 2668 2669=item stopbits 2670 2671Legal values are 1 and 2. 2672 2673=item handshake 2674 2675One of the following: "none", "rts", "xoff". 2676 2677=back 2678 2679Some individual parameters (eg. baudrate) can be changed after the 2680initialization is completed. These will be validated and will 2681update the I<serial driver> as required. The B<save> method will 2682write the current parameters to a file that B<start, tie,> and 2683B<restart> can use to reestablish a functional setup. 2684 2685 $PortObj = new Win32::SerialPort ($PortName, $quiet) 2686 || die "Can't open $PortName: $^E\n"; # $quiet is optional 2687 2688 $PortObj->user_msg(ON); 2689 $PortObj->databits(8); 2690 $PortObj->baudrate(9600); 2691 $PortObj->parity("none"); 2692 $PortObj->stopbits(1); 2693 $PortObj->handshake("rts"); 2694 2695 $PortObj->write_settings || undef $PortObj; 2696 2697 $PortObj->save($Configuration_File_Name); 2698 $PortObj->baudrate(300); 2699 $PortObj->restart($Configuration_File_Name); # back to 9600 baud 2700 2701 $PortObj->close || die "failed to close"; 2702 undef $PortObj; # frees memory back to perl 2703 2704=head2 Configuration Utility Methods 2705 2706Use B<alias> to convert the name used by "built-in" messages. 2707 2708 $PortObj->alias("MODEM1"); 2709 2710Starting in Version 0.07, a number of I<Application Variables> are saved 2711in B<$Configuration_File>. These parameters are not used internally. But 2712methods allow setting and reading them. The intent is to facilitate the 2713use of separate I<configuration scripts> to create the files. Then an 2714application can use B<start> as the Constructor and not bother with 2715command line processing or managing its own small configuration file. 2716The default values and number of parameters is subject to change. 2717 2718 $PortObj->devicetype('none'); 2719 $PortObj->hostname('localhost'); # for socket-based implementations 2720 $PortObj->hostaddr(0); # a "false" value 2721 $PortObj->datatype('raw'); # 'record' is another possibility 2722 $PortObj->cfg_param_1('none'); 2723 $PortObj->cfg_param_2('none'); # 3 spares should be enough for now 2724 $PortObj->cfg_param_3('none'); 2725 2726=head2 Configuration and Capability Methods 2727 2728The Win32 Serial Comm API provides extensive information concerning 2729the capabilities and options available for a specific port (and 2730instance). This module will return suitable responses to facilitate 2731porting code from that environment. 2732 2733The B<get_tick_count> method is a clone of the I<Win32::GetTickCount()> 2734function. It matches a corresponding method in I<Win32::CommPort>. 2735It returns time in milliseconds - but can be used in cross-platform scripts. 2736 2737=over 8 2738 2739Binary selections will accept as I<true> any of the following: 2740C<("YES", "Y", "ON", "TRUE", "T", "1", 1)> (upper/lower/mixed case) 2741Anything else is I<false>. 2742 2743There are a large number of possible configuration and option parameters. 2744To facilitate checking option validity in scripts, most configuration 2745methods can be used in two different ways: 2746 2747=item method called with an argument 2748 2749The parameter is set to the argument, if valid. An invalid argument 2750returns I<false> (undef) and the parameter is unchanged. The function 2751will also I<carp> if B<$user_msg> is I<true>. The port will be updated 2752immediately if allowed (an automatic B<write_settings> is called). 2753 2754=item method called with no argument in scalar context 2755 2756The current value is returned. If the value is not initialized either 2757directly or by default, return "undef" which will parse to I<false>. 2758For binary selections (true/false), return the current value. All 2759current values from "multivalue" selections will parse to I<true>. 2760 2761=item method called with no argument in list context 2762 2763Methods which only accept a limited number of specific input values 2764return a list consisting of all acceptable choices. The null list 2765C<(undef)> will be returned for failed calls in list context (e.g. for 2766an invalid or unexpected argument). Only the baudrate, parity, databits, 2767stopbits, and handshake methods currently support this feature. 2768 2769=back 2770 2771=head2 Operating Methods 2772 2773Version 0.04 adds B<pulse> methods for the I<RTS, BREAK, and DTR> bits. The 2774B<pulse> methods assume the bit is in the opposite state when the method 2775is called. They set the requested state, delay the specified number of 2776milliseconds, set the opposite state, and again delay the specified time. 2777These methods are designed to support devices, such as the X10 "FireCracker" 2778control and some modems, which require pulses on these lines to signal 2779specific events or data. Timing for the I<active> part of B<pulse_break_on> 2780is handled by I<POSIX::tcsendbreak(0)>, which sends a 250-500 millisecond 2781BREAK pulse. It is I<NOT> guaranteed to block until done. 2782 2783 $PortObj->pulse_break_on($milliseconds); 2784 $PortObj->pulse_rts_on($milliseconds); 2785 $PortObj->pulse_rts_off($milliseconds); 2786 $PortObj->pulse_dtr_on($milliseconds); 2787 $PortObj->pulse_dtr_off($milliseconds); 2788 2789In Version 0.05, these calls and the B<rts_active> and B<dtr_active> calls 2790verify the parameters and any required I<ioctl constants>, and return C<undef> 2791unless the call succeeds. You can use the B<can_ioctl> method to see if 2792the required constants are available. On Version 0.04, the module would 2793not load unless I<asm/termios.ph> was found at startup. 2794 2795=head2 Stty Shortcuts 2796 2797Version 0.06 adds primitive methods to modify port parameters that would 2798otherwise require a C<system("stty...");> command. These act much like 2799the identically-named methods in Win32::SerialPort. However, they are 2800initialized from "current stty settings" when the port is opened rather 2801than from defaults. And like I<stty settings>, they are passed to the 2802serial driver and apply to all operations rather than only to I/O 2803processed via the B<lookfor> method or the I<tied FileHandle> methods. 2804Each returns the current setting for the parameter. There are no "global" 2805or "combination" parameters - you still need C<system("stty...")> for that. 2806 2807The methods which handle CHAR parameters set and return values as C<ord(CHAR)>. 2808This corresponds to the settings in the I<POSIX termios cc_field array>. You 2809are unlikely to actually want to modify most of these. They reflect the 2810special characters which can be set by I<stty>. 2811 2812 $PortObj->is_xon_char($num_char); # VSTART (stty start=.) 2813 $PortObj->is_xoff_char($num_char); # VSTOP 2814 $PortObj->is_stty_intr($num_char); # VINTR 2815 $PortObj->is_stty_quit($num_char); # VQUIT 2816 $PortObj->is_stty_eof($num_char); # VEOF 2817 $PortObj->is_stty_eol($num_char); # VEOL 2818 $PortObj->is_stty_erase($num_char); # VERASE 2819 $PortObj->is_stty_kill($num_char); # VKILL 2820 $PortObj->is_stty_susp($num_char); # VSUSP 2821 2822Binary settings supported by POSIX will return 0 or 1. Several parameters 2823settable by I<stty> do not yet have shortcut methods. Contact me if you 2824need one that is not supported. These are the common choices. Try C<man stty> 2825if you are not sure what they do. 2826 2827 $PortObj->stty_echo; 2828 $PortObj->stty_echoe; 2829 $PortObj->stty_echok; 2830 $PortObj->stty_echonl; 2831 $PortObj->stty_ignbrk; 2832 $PortObj->stty_istrip; 2833 $PortObj->stty_inpck; 2834 $PortObj->stty_parmrk; 2835 $PortObj->stty_ignpar; 2836 $PortObj->stty_icrnl; 2837 $PortObj->stty_igncr; 2838 $PortObj->stty_inlcr; 2839 $PortObj->stty_opost; 2840 $PortObj->stty_isig; 2841 $PortObj->stty_icanon; 2842 2843The following methods require successfully loading I<ioctl constants>. 2844They will return C<undef> if the needed constants are not found. But 2845the method calls may still be used without syntax errors or warnings 2846even in that case. 2847 2848 $PortObj->stty_ocrlf; 2849 $PortObj->stty_onlcr; 2850 $PortObj->stty_echoke; 2851 $PortObj->stty_echoctl; 2852 2853=head2 Lookfor and I/O Processing 2854 2855Some communications programs have a different need - to collect 2856(or discard) input until a specific pattern is detected. For lines, the 2857pattern is a line-termination. But there are also requirements to search 2858for other strings in the input such as "username:" and "password:". The 2859B<lookfor> method provides a consistant mechanism for solving this problem. 2860It searches input character-by-character looking for a match to any of the 2861elements of an array set using the B<are_match> method. It returns the 2862entire input up to the match pattern if a match is found. If no match 2863is found, it returns "" unless an input error or abort is detected (which 2864returns undef). 2865 2866Unlike Win32::SerialPort, B<lookfor> does not handle backspace, echo, and 2867other character processing. It expects the serial driver to handle those 2868and to be controlled via I<stty>. For interacting with humans, you will 2869probably want C<stty_icanon(1)> during B<lookfor> to obtain familiar 2870command-line response. The actual match and the characters after it (if 2871any) may also be viewed using the B<lastlook> method. It also adopts the 2872convention from Expect.pm that match strings are literal text (tested using 2873B<index>) unless preceeded in the B<are_match> list by a B<"-re",> entry. 2874The default B<are_match> list is C<("\n")>, which matches complete lines. 2875 2876 my ($match, $after, $pattern, $instead) = $PortObj->lastlook; 2877 # input that MATCHED, input AFTER the match, PATTERN that matched 2878 # input received INSTEAD when timeout without match ("" if match) 2879 2880 $PortObj->are_match("text1", "-re", "pattern", "text2"); 2881 # possible match strings: "pattern" is a regular expression, 2882 # "text1" and "text2" are literal strings 2883 2884Everything in B<lookfor> is still experimental. Please let me know if you 2885use it (or can't use it), so I can confirm bug fixes don't break your code. 2886For literal strings, C<$match> and C<$pattern> should be identical. The 2887C<$instead> value returns the internal buffer tested by the match logic. 2888A successful match or a B<lookclear> resets it to "" - so it is only useful 2889for error handling such as timeout processing or reporting unexpected 2890responses. 2891 2892The B<lookfor> method is designed to be sampled periodically (polled). Any 2893characters after the match pattern are saved for a subsequent B<lookfor>. 2894Internally, B<lookfor> is implemented using the nonblocking B<input> method 2895when called with no parameter. If called with a count, B<lookfor> calls 2896C<$PortObj-E<gt>read(count)> which blocks until the B<read> is I<Complete> or 2897a I<Timeout> occurs. The blocking alternative should not be used unless a 2898fault time has been defined using B<read_interval, read_const_time, and 2899read_char_time>. It exists mostly to support the I<tied FileHandle> 2900functions B<sysread, getc,> and B<E<lt>FHE<gt>>. When B<stty_icanon> is 2901active, even the non-blocking calls will not return data until the line 2902is complete. 2903 2904The internal buffers used by B<lookfor> may be purged by the B<lookclear> 2905method (which also clears the last match). For testing, B<lookclear> can 2906accept a string which is "looped back" to the next B<input>. This feature 2907is enabled only when C<set_test_mode_active(1)>. Normally, B<lookclear> 2908will return C<undef> if given parameters. It still purges the buffers and 2909last_match in that case (but nothing is "looped back"). You will want 2910B<stty_echo(0)> when exercising loopback. 2911 2912The B<matchclear> method is designed to handle the 2913"special case" where the match string is the first character(s) received 2914by B<lookfor>. In this case, C<$lookfor_return == "">, B<lookfor> does 2915not provide a clear indication that a match was found. The B<matchclear> 2916returns the same C<$match> that would be returned by B<lastlook> and 2917resets it to "" without resetting any of the other buffers. Since the 2918B<lookfor> already searched I<through> the match, B<matchclear> is used 2919to both detect and step-over "blank" lines. 2920 2921The character-by-character processing used by B<lookfor> is fine for 2922interactive activities and tasks which expect short responses. But it 2923has too much "overhead" to handle fast data streams.There is also a 2924B<streamline> method which is a fast, line-oriented alternative with 2925just pattern searching. Since B<streamline> uses the same internal buffers, 2926the B<lookclear, lastlook, are_match, and matchclear> methods act the same 2927in both cases. In fact, calls to B<streamline> and B<lookfor> can be 2928interleaved if desired (e.g. an interactive task that starts an upload and 2929returns to interactive activity when it is complete). 2930 2931There are two additional methods for supporting "list context" input: 2932B<lastline> sets an "end_of_file" I<Regular Expression>, and B<linesize> 2933permits changing the "packet size" in the blocking read operation to allow 2934tuning performance to data characteristics. These two only apply during 2935B<READLINE>. The default for B<linesize> is 1. There is no default for 2936the B<lastline> method. 2937 2938The I<Regular Expressions> set by B<are_match> and B<lastline> 2939will be pre-compiled using the I<qr//> construct on Perl 5.005 and higher. 2940This doubled B<lookfor> and B<streamline> speed in my tests with 2941I<Regular Expressions> - but actual improvements depend on both patterns 2942and input data. 2943 2944The functionality of B<lookfor> includes a limited subset of the capabilities 2945found in Austin Schutz's I<Expect.pm> for Unix (and Tcl's expect which it 2946resembles). The C<$before, $match, $pattern, and $after> return values are 2947available if someone needs to create an "expect" subroutine for porting a 2948script. When using multiple patterns, there is one important functional 2949difference: I<Expect.pm> looks at each pattern in turn and returns the first 2950match found; B<lookfor> and B<streamline> test all patterns and return the 2951one found I<earliest> in the input if more than one matches. 2952 2953=head2 Exports 2954 2955Nothing is exported by default. The following tags can be used to have 2956large sets of symbols exported: 2957 2958=over 4 2959 2960=item :PARAM 2961 2962Utility subroutines and constants for parameter setting and test: 2963 2964 LONGsize SHORTsize nocarp yes_true 2965 OS_Error 2966 2967=item :STAT 2968 2969The Constants named BM_* and CE_* are omitted. But the modem status (MS_*) 2970Constants are defined for possible use with B<modemlines> and 2971B<wait_modemlines>. They are 2972assigned to corresponding functions, but the bit position will be 2973different from that on Win32. 2974 2975Which incoming bits are active: 2976 2977 MS_CTS_ON - Clear to send 2978 MS_DSR_ON - Data set ready 2979 MS_RING_ON - Ring indicator 2980 MS_RLSD_ON - Carrier detected 2981 MS_RTS_ON - Request to send (might not exist on Win32) 2982 MS_DTR_ON - Data terminal ready (might not exist on Win32) 2983 2984If you want to write more POSIX-looking code, you can use the constants 2985seen there, instead of the Win32 versions: 2986 2987 TIOCM_CTS, TIOCM_DSR, TIOCM_RI, TIOCM_CD, TIOCM_RTS, and TIOCM_DTR 2988 2989Offsets into the array returned by B<status:> 2990 2991 ST_BLOCK ST_INPUT ST_OUTPUT ST_ERROR 2992 2993=item :ALL 2994 2995All of the above. Except for the I<test suite>, there is not really a good 2996reason to do this. 2997 2998=back 2999 3000=head1 PINOUT 3001 3002Here is a handy pinout map, showing each line and signal on a standard DB9 3003connector: 3004 3005=over 8 3006 3007=item 1 DCD 3008 3009Data Carrier Detect 3010 3011=item 2 RD 3012 3013Receive Data 3014 3015=item 3 TD 3016 3017Transmit Data 3018 3019=item 4 DTR 3020 3021Data Terminal Ready 3022 3023=item 5 SG 3024 3025Signal Ground 3026 3027=item 6 DSR 3028 3029Data Set Ready 3030 3031=item 7 RTS 3032 3033Request to Send 3034 3035=item 8 CTS 3036 3037Clear to Send 3038 3039=item 9 RI 3040 3041Ring Indicator 3042 3043=back 3044 3045=head1 NOTES 3046 3047The object returned by B<new> is NOT a I<Filehandle>. You will be 3048disappointed if you try to use it as one. 3049 3050e.g. the following is WRONG!! 3051 3052 print $PortObj "some text"; 3053 3054This module uses I<POSIX termios> extensively. Raw API calls are B<very> 3055unforgiving. You will certainly want to start perl with the B<-w> switch. 3056If you can, B<use strict> as well. Try to ferret out all the syntax and 3057usage problems BEFORE issuing the API calls (many of which modify tuning 3058constants in hardware device drivers....not where you want to look for bugs). 3059 3060With all the options, this module needs a good tutorial. It doesn't 3061have one yet. 3062 3063=head1 EXAMPLE 3064 3065It is recommended to always use "read(255)" due to some unexpected 3066behavior with the termios under some operating systems (Linux and Solaris 3067at least). To deal with this, a routine is usually needed to read from 3068the serial port until you have what you want. This is a quick example 3069of how to do that: 3070 3071 my $port=Device::SerialPort->new("/dev/ttyS0"); 3072 3073 my $STALL_DEFAULT=10; # how many seconds to wait for new input 3074 3075 my $timeout=$STALL_DEFAULT; 3076 3077 $port->read_char_time(0); # don't wait for each character 3078 $port->read_const_time(1000); # 1 second per unfulfilled "read" call 3079 3080 my $chars=0; 3081 my $buffer=""; 3082 while ($timeout>0) { 3083 my ($count,$saw)=$port->read(255); # will read _up to_ 255 chars 3084 if ($count > 0) { 3085 $chars+=$count; 3086 $buffer.=$saw; 3087 3088 # Check here to see if what we want is in the $buffer 3089 # say "last" if we find it 3090 } 3091 else { 3092 $timeout--; 3093 } 3094 } 3095 3096 if ($timeout==0) { 3097 die "Waited $STALL_DEFAULT seconds and never saw what I wanted\n"; 3098 } 3099 3100 3101=head1 PORTING 3102 3103For a serial port to work under Unix, you need the ability to do several 3104types of operations. With POSIX, these operations are implemented with 3105a set of "tc*" functions. However, not all Unix systems follow this 3106correctly. In those cases, the functions change, but the variables used 3107as parameters generally turn out to be the same. 3108 3109=over 4 3110 3111=item Get/Set RTS 3112 3113This is only available through the bit-set(TIOCMBIS)/bit-clear(TIOCMBIC) 3114ioctl function using the RTS value(TIOCM_RTS). 3115 3116 ioctl($handle,$on ? $TIOCMBIS : $TIOCMBIC, $TIOCM_RTS); 3117 3118=item Get/Set DTR 3119 3120This is available through the bit-set(TIOCMBIS)/bit-clear(TIOCMBIC) 3121ioctl function using the DTR value(TIOCM_DTR) 3122 3123 ioctl($handle,$on ? $TIOCMBIS : $TIOCMBIC, $TIOCM_DTR); 3124 3125or available through the DTRSET/DTRCLEAR ioctl functions, if they exist. 3126 3127 ioctl($handle,$on ? $TIOCSDTR : $TIOCCDTR, 0); 3128 3129=item Get modem lines 3130 3131To read Clear To Send (CTS), Data Set Ready (DSR), Ring Indicator (RING), and 3132Carrier Detect (CD/RLSD), the TIOCMGET ioctl function must be used. 3133 3134 ioctl($handle, $TIOCMGET, $status); 3135 3136To decode the individual modem lines, some bits have multiple possible 3137constants: 3138 3139=over 4 3140 3141=item Clear To Send (CTS) 3142 3143TIOCM_CTS 3144 3145=item Data Set Ready (DSR) 3146 3147TIOCM_DSR 3148 3149=item Ring Indicator (RING) 3150 3151TIOCM_RNG 3152TIOCM_RI 3153 3154=item Carrier Detect (CD/RLSD) 3155 3156TIOCM_CAR 3157TIOCM_CD 3158 3159=back 3160 3161=item Get Buffer Status 3162 3163To get information about the state of the serial port input and output 3164buffers, the TIOCINQ and TIOCOUTQ ioctl functions must be used. I'm not 3165totally sure what is returned by these functions across all Unix systems. 3166Under Linux, it is the integer number of characters in the buffer. 3167 3168 ioctl($handle,$in ? $TIOCINQ : $TIOCOUTQ, $count); 3169 $count = unpack('i',$count); 3170 3171=item Get Line Status 3172 3173To get information about the state of the serial transmission line 3174(to see if a write has made its way totally out of the serial port 3175buffer), the TIOCSERGETLSR ioctl function must be used. Additionally, 3176the "Get Buffer Status" methods must be functioning, as well as having 3177the first bit of the result set (Linux is TIOCSER_TEMT, others unknown, 3178but we've been using TIOCM_LE even though that should be returned from 3179the TIOCMGET ioctl). 3180 3181 ioctl($handle,$TIOCSERGETLSR, $status); 3182 $done = (unpack('i', $status) & $TIOCSER_TEMT); 3183 3184=item Set Flow Control 3185 3186Some Unix systems require special TCGETX/TCSETX ioctls functions and the 3187CTSXON/RTSXOFF constants to turn on and off CTS/RTS "hard" flow control 3188instead of just using the normal POSIX tcsetattr calls. 3189 3190 ioctl($handle, $TCGETX, $flags); 3191 @bytes = unpack('SSSS',$flags); 3192 $bytes[0] = $on ? ($CTSXON | $RTSXOFF) : 0; 3193 $flags = pack('SSSS',@bytes); 3194 ioctl($handle, $TCSETX, $flags); 3195 3196=back 3197 3198=head1 KNOWN LIMITATIONS 3199 3200The current version of the module has been tested with Perl 5.003 and 3201above. It was initially ported from Win32 and was designed to be used 3202without requiring a compiler or using XS. Since everything is (sometimes 3203convoluted but still pure) Perl, you can fix flaws and change limits if 3204required. But please file a bug report if you do. 3205 3206The B<read> method, and tied methods which call it, currently can use a 3207fixed timeout which approximates behavior of the I<Win32::SerialPort> 3208B<read_const_time> and B<read_char_time> methods. It is used internally 3209by I<select>. If the timeout is set to zero, the B<read> call will return 3210immediately. A B<read> larger than 255 bytes will be split internally 3211into 255-byte POSIX calls due to limitations of I<select> and I<VMIN>. 3212The timeout is reset for each 255-byte segment. Hence, for large B<reads>, 3213use a B<read_const_time> suitable for a 255-byte read. All of this is 3214expeimental in Version 0.055. 3215 3216 $PortObj->read_const_time(500); # 500 milliseconds = 0.5 seconds 3217 $PortObj->read_char_time(5); # avg time between read char 3218 3219The timing model defines the total time allowed to complete the operation. 3220A fixed overhead time is added to the product of bytes and per_byte_time. 3221 3222Read_Total = B<read_const_time> + (B<read_char_time> * bytes_to_read) 3223 3224Write timeouts and B<read_interval> timeouts are not currently supported. 3225 3226On some machines, reads larger than 4,096 bytes may be truncated at 4,096, 3227regardless of the read size or read timing settings used. In this case, 3228try turning on or increasing the inter-character delay on your serial 3229device. Also try setting the read size to 3230 3231 $PortObj->read(1) or $PortObj->read(255) 3232 3233and performing multiple reads until the transfer is completed. 3234 3235 3236=head1 BUGS 3237 3238See the limitations about lockfiles. Experiment if you like. 3239 3240With all the I<currently unimplemented features>, we don't need any more. 3241But there probably are some. 3242 3243Please send comments and bug reports to kees@outflux.net. 3244 3245=head1 Win32::SerialPort & Win32API::CommPort 3246 3247=head2 Win32::SerialPort Functions Not Currently Supported 3248 3249 $LatchErrorFlags = $PortObj->reset_error; 3250 3251 $PortObj->read_interval(100); # max time between read char 3252 $PortObj->write_char_time(5); 3253 $PortObj->write_const_time(100); 3254 3255=head2 Functions Handled in a POSIX system by "stty" 3256 3257 xon_limit xoff_limit xon_char xoff_char 3258 eof_char event_char error_char stty_intr 3259 stty_quit stty_eof stty_eol stty_erase 3260 stty_kill stty_clear is_stty_clear stty_bsdel 3261 stty_echoke stty_echoctl stty_ocrnl stty_onlcr 3262 3263=head2 Win32::SerialPort Functions Not Ported to POSIX 3264 3265 transmit_char 3266 3267=head2 Win32API::CommPort Functions Not Ported to POSIX 3268 3269 init_done fetch_DCB update_DCB initialize 3270 are_buffers are_baudrate are_handshake are_parity 3271 are_databits are_stopbits is_handshake xmit_imm_char 3272 is_baudrate is_parity is_databits is_write_char_time 3273 debug_comm is_xon_limit is_xoff_limit is_read_const_time 3274 suspend_tx is_eof_char is_event_char is_read_char_time 3275 is_read_buf is_write_buf is_buffers is_read_interval 3276 is_error_char resume_tx is_stopbits is_write_const_time 3277 is_binary is_status write_bg is_parity_enable 3278 is_modemlines read_bg read_done break_active 3279 xoff_active is_read_buf is_write_buf xon_active 3280 3281=head2 "raw" Win32 API Calls and Constants 3282 3283A large number of Win32-specific elements have been omitted. Most of 3284these are only available in Win32::SerialPort and Win32API::CommPort 3285as optional Exports. The list includes the following: 3286 3287=over 4 3288 3289=item :RAW 3290 3291The API Wrapper Methods and Constants used only to support them 3292including PURGE_*, SET*, CLR*, EV_*, and ERROR_IO* 3293 3294=item :COMMPROP 3295 3296The Constants used for Feature and Properties Detection including 3297BAUD_*, PST_*, PCF_*, SP_*, DATABITS_*, STOPBITS_*, PARITY_*, and 3298COMMPROP_INITIALIZED 3299 3300=item :DCB 3301 3302The constants for the I<Win32 Device Control Block> including 3303CBR_*, DTR_*, RTS_*, *PARITY, *STOPBIT*, and FM_* 3304 3305=back 3306 3307=head2 Compatibility 3308 3309This code implements the functions required to support the MisterHouse 3310Home Automation software by Bruce Winter. It does not attempt to support 3311functions from Win32::SerialPort such as B<stty_emulation> that already 3312have POSIX implementations or to replicate I<Win32 idosyncracies>. However, 3313the supported functions are intended to clone the equivalent functions 3314in Win32::SerialPort and Win32API::CommPort. Any discrepancies or 3315omissions should be considered bugs and reported to the maintainer. 3316 3317=head1 AUTHORS 3318 3319 Based on Win32::SerialPort.pm, Version 0.8, by Bill Birthisel 3320 Ported to linux/POSIX by Joe Doss for MisterHouse 3321 Ported to Solaris/POSIX by Kees Cook for Sendpage 3322 Ported to BSD/POSIX by Kees Cook 3323 Ported to Perl XS by Kees Cook 3324 3325 Currently maintained by: 3326 Kees Cook, kees@outflux.net, http://outflux.net/ 3327 3328=head1 SEE ALSO 3329 3330Win32API::CommPort 3331 3332Win32::SerialPort 3333 3334perltoot - Tom Christiansen's Object-Oriented Tutorial 3335 3336=head1 COPYRIGHT 3337 3338 Copyright (C) 1999, Bill Birthisel. All rights reserved. 3339 Copyright (C) 2000-2007, Kees Cook. All rights reserved. 3340 3341This module is free software; you can redistribute it and/or modify it 3342under the same terms as Perl itself. 3343 3344=cut 3345 3346# /* vi:set ai ts=4 sw=4 expandtab: */ 3347