File Coverage

blib/lib/Device/SerialPort.pm

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

# This is a POSIX version of the Win32::Serialport module
# ported by Joe Doss, Kees Cook
# Originally for use with the MisterHouse and Sendpage programs
#
# $Id: SerialPort.pm 313 2007-10-24 05:50:46Z keescook $
#
# Copyright (C) 1999, Bill Birthisel
# Copyright (C) 2000-2007 Kees Cook
# [e-mail], http://outflux.net/
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
# http://www.gnu.org/copyleft/gpl.html
#
package Device::SerialPort;

use 5.006;
use strict;
use warnings;
use POSIX qw(:termios_h);
use IO::Handle;
use Carp;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION = 1.04;

require Exporter;

@ISA = qw(Exporter);
@EXPORT= qw();
@EXPORT_OK= qw();
%EXPORT_TAGS = (STAT	=> [qw( MS_CTS_ON	MS_DSR_ON
                                MS_RING_ON	MS_RLSD_ON
                                MS_DTR_ON   MS_RTS_ON
                                ST_BLOCK	ST_INPUT
                                ST_OUTPUT	ST_ERROR
                                TIOCM_CD TIOCM_RI
                                TIOCM_DSR TIOCM_DTR
                                TIOCM_CTS TIOCM_RTS
                                TIOCM_LE
                               )],

                PARAM	=> [qw( LONGsize	SHORTsize	OS_Error
                                nocarp		yes_true )]);

Exporter::export_ok_tags('STAT', 'PARAM');

$EXPORT_TAGS{ALL} = \@EXPORT_OK;

require XSLoader;
XSLoader::load('Device::SerialPort', $VERSION);

#### Package variable declarations ####

use vars qw($IOCTL_VALUE_RTS $IOCTL_VALUE_DTR $IOCTL_VALUE_TERMIOXFLOW
            $ms_per_tick);

# Load all the system bits we need
my $bits=Device::SerialPort::Bits::get_hash();
my $ms_per_tick=undef;

# ioctl values
$IOCTL_VALUE_RTS = pack('L', $bits->{'TIOCM_RTS'} || 0);
$IOCTL_VALUE_DTR = pack('L', $bits->{'TIOCM_DTR'} || 0);
$IOCTL_VALUE_TERMIOXFLOW = (($bits->{'CTSXON'}||0) | ($bits->{'RTSXOFF'}||0));

# non-POSIX constants commonly defined in termios.ph
sub CRTSCTS { return $bits->{'CRTSCTS'} || 0; }

sub OCRNL { return $bits->{'OCRNL'} || 0; }

sub ONLCR { return $bits->{'ONLCR'} || 0; }

sub ECHOKE { return $bits->{'ECHOKE'} || 0; }

sub ECHOCTL { return $bits->{'ECHOCTL'} || 0; }

sub TIOCM_LE { return $bits->{'TIOCSER_TEMT'} || $bits->{'TIOCM_LE'} || 0; }

# Set alternate bit names
$bits->{'portable_TIOCINQ'} = $bits->{'TIOCINQ'} || $bits->{'FIONREAD'};

## Next 4 use Win32 names for compatibility

sub MS_RLSD_ON { return TIOCM_CD(); }
sub TIOCM_CD { return $bits->{'TIOCM_CAR'} || $bits->{'TIOCM_CD'} || 0; }

sub MS_RING_ON { return TIOCM_RI(); }
sub TIOCM_RI { return $bits->{'TIOCM_RNG'} || $bits->{'TIOCM_RI'} || 0; }

sub MS_CTS_ON { return TIOCM_CTS(); }
sub TIOCM_CTS { return $bits->{'TIOCM_CTS'} || 0; }

sub MS_DSR_ON { return TIOCM_DSR(); }
sub TIOCM_DSR { return $bits->{'TIOCM_DSR'} || 0; }

# For POSIX completeness
sub MS_RTS_ON { return TIOCM_RTS(); }
sub TIOCM_RTS { return $bits->{'TIOCM_RTS'} || 0; }

sub MS_DTR_ON { return TIOCM_DTR(); }
sub TIOCM_DTR { return $bits->{'TIOCM_DTR'} || 0; }

# "status"
sub ST_BLOCK	{0}	# status offsets for caller
sub ST_INPUT	{1}
sub ST_OUTPUT	{2}
sub ST_ERROR	{3}	# latched

# parameters that must be included in a "save" and "checking subs"

my %validate =	(
		ALIAS		=> "alias",
		E_MSG		=> "error_msg",
		RCONST		=> "read_const_time",
		RTOT		=> "read_char_time",
		U_MSG		=> "user_msg",
		DVTYPE		=> "devicetype",
		HNAME		=> "hostname",
		HADDR		=> "hostaddr",
		DATYPE		=> "datatype",
		CFG_1		=> "cfg_param_1",
		CFG_2		=> "cfg_param_2",
		CFG_3		=> "cfg_param_3",
		);

my @termios_fields = (
		     "C_CFLAG",
		     "C_IFLAG",
		     "C_ISPEED",
		     "C_LFLAG",
		     "C_OFLAG",
		     "C_OSPEED"
		     );

my %c_cc_fields = (
		   VEOF     => &POSIX::VEOF,
		   VEOL     => &POSIX::VEOL,
		   VERASE   => &POSIX::VERASE,
		   VINTR    => &POSIX::VINTR,
		   VKILL    => &POSIX::VKILL,
		   VQUIT    => &POSIX::VQUIT,
		   VSUSP    => &POSIX::VSUSP,
		   VSTART   => &POSIX::VSTART,
		   VSTOP    => &POSIX::VSTOP,
		   VMIN     => &POSIX::VMIN,
		   VTIME    => &POSIX::VTIME,
		   );

my @baudrates = qw(
    0 50 75 110 134 150 200 300 600
    1200 1800 2400 4800 9600 19200 38400 57600
    115200 230400 460800 500000 576000 921600 1000000
    1152000 2000000 2500000 3000000 3500000 4000000
);

# Build list of "valid" system baudrates
my %bauds;
foreach my $baud (@baudrates) {
    my $baudvar="B$baud";
    $bauds{$baud}=$bits->{$baudvar} if (defined($bits->{$baudvar}));
}

my $Babble = 0;
my $testactive = 0;	# test mode active

my @Yes_resp = (
		"YES", "Y",
		"ON",
		"TRUE", "T",
		"1"
		);

my @binary_opt = ( 0, 1 );
my @byte_opt = (0, 255);

my $cfg_file_sig="Device::SerialPort_Configuration_File -- DO NOT EDIT --\n";

## my $null=[];
my $null=0;
my $zero=0;

# Preloaded methods go here.

sub init_ms_per_tick
{
	my $from_posix=undef;
	my $errors="";

	# To find the real "CLK_TCK" value, it is *best* to query sysconf
	# for it.  However, this requires access to _SC_CLK_TCK.  In
	# modern versions of Perl (and libc) these this is correctly found
	# in the POSIX module.  On really old versions, the hard-coded
	# "CLK_TCK" can be found.  So, first attempt to use the POSIX
	# module to get what we need, and then try our internal bit
	# detection code, and finally fall back to the hard-coded value
	# before totally giving up.
	for (;;) {
		eval { $from_posix = POSIX::sysconf(&POSIX::_SC_CLK_TCK); };
		last if (!$@);
		$errors.="$@\n";

		if (defined($bits->{'_SC_CLK_TCK'})) {
			$from_posix = POSIX::sysconf($bits->{'_SC_CLK_TCK'});
			last;
		}
		$errors.="_SC_CLK_TCK not found during compilation\n";

		# According to POSIX, "CLK_TCK" is obsolete now.  See
		# "man 2 times" and the POSIX-1996 standard
		eval { $from_posix = &POSIX::CLK_TCK; };
		last if (!$@);
		$errors.="$@\n";

		last;
	}
	if (!defined($from_posix) || $from_posix == 0) {
		die "Cannot find a useful value for _SC_CLK_TCK:\n$errors";
	}
	$ms_per_tick = 1000.0 / $from_posix;
}

sub get_tick_count {
	# clone of Win32::GetTickCount - perhaps same 49 day problem

    if (!defined($ms_per_tick)) {
	init_ms_per_tick();
    }

    my ($real2, $user2, $system2, $cuser2, $csystem2) = POSIX::times();
    $real2 *= $ms_per_tick;
    ## printf "real2 = %8.0f\n", $real2;
    return int $real2;
}

sub SHORTsize { 0xffff; }	# mostly for AltPort test
sub LONGsize { 0xffffffff; }	# mostly for AltPort test

sub OS_Error { print "Device::SerialPort OS_Error\n"; }

# test*.pl only - suppresses default messages
sub set_test_mode_active {
    return unless (@_ == 2);
    $testactive = $_[1];     # allow "off"
    my @fields = @termios_fields;
    my $item;
    foreach $item (keys %c_cc_fields) {
        push @fields, "C_$item";
    }
    foreach $item (keys %validate) {
        push @fields, "$item";
    }
    return @fields;
}

sub nocarp { return $testactive }

sub yes_true {
    my $choice = uc shift;
    my $ans = 0;
    foreach (@Yes_resp) { $ans = 1 if ( $choice eq $_ ) }
    return $ans;
}

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {};
    my $ok    = 0;		# API return value

    my $item = 0;

    my $nameOrConf = shift;
    return start($class, $nameOrConf, @_) if (-f $nameOrConf && ! -c $nameOrConf );

    $self->{NAME}     = $nameOrConf;


    shift; # ignore "$quiet" parameter
    my $lockfile = shift;
    if ($lockfile) {
        $self->{LOCK} = $lockfile;
        my $lockf = POSIX::open($self->{LOCK},
				    &POSIX::O_WRONLY |
				    &POSIX::O_CREAT |
				    &POSIX::O_NOCTTY |
				    &POSIX::O_EXCL);
        return undef if (!defined($lockf));

        my $pid = "$$\n";
        $ok = POSIX::write($lockf, $pid, length $pid);
        my $ok2 = POSIX::close($lockf);
        return unless ($ok && (defined $ok2));
        sleep 2;	# wild guess for Version 0.05
    }
    else {
        $self->{LOCK} = "";
    }

    $self->{FD}= POSIX::open($self->{NAME},
				    &POSIX::O_RDWR |
				    &POSIX::O_NOCTTY |
				    &POSIX::O_NONBLOCK);

    unless (defined $self->{FD}) { $self->{FD} = -1; }
    unless ($self->{FD} >= 0) {
        # the "unlink" will destroy the err code, so preserve it
        my $save_err=$!+0;

        if ($self->{LOCK}) {
            unlink $self->{LOCK};
            $self->{LOCK} = "";
        }

        $!=$save_err+0;
        return undef;
    }

    $self->{TERMIOS} = POSIX::Termios->new();

    # a handle object for ioctls: read-only ok
    $self->{HANDLE} = new_from_fd IO::Handle ($self->{FD}, "r");

    # get the current attributes
    $ok = $self->{TERMIOS}->getattr($self->{FD});

    unless ( $ok ) {
        carp "can't getattr: $!";
        undef $self;
        return undef;
    }

    # save the original values
    $self->{"_CFLAG"} = $self->{TERMIOS}->getcflag();
    $self->{"_IFLAG"} = $self->{TERMIOS}->getiflag();
    $self->{"_ISPEED"} = $self->{TERMIOS}->getispeed();
    $self->{"_LFLAG"} = $self->{TERMIOS}->getlflag();
    $self->{"_OFLAG"} = $self->{TERMIOS}->getoflag();
    $self->{"_OSPEED"} = $self->{TERMIOS}->getospeed();

    # build termiox flag anyway
    $self->{'TERMIOX'} = 0;

    # copy the original values into "current" values
    foreach $item (keys %c_cc_fields) {
        $self->{"_$item"} = $self->{TERMIOS}->getcc($c_cc_fields{$item});
    }
    foreach $item (keys %c_cc_fields) {
        $self->{"C_$item"} = $self->{"_$item"};
    }
    $self->{"C_CFLAG"} = $self->{"_CFLAG"};
    $self->{"C_IFLAG"} = $self->{"_IFLAG"};
    $self->{"C_ISPEED"} = $self->{"_ISPEED"};
    $self->{"C_LFLAG"} = $self->{"_LFLAG"};
    $self->{"C_OFLAG"} = $self->{"_OFLAG"};
    $self->{"C_OSPEED"} = $self->{"_OSPEED"};

    # Finally, default to "raw" mode for this package
    $self->{"C_IFLAG"} &= ~(IGNBRK|BRKINT|PARMRK|IGNPAR|INPCK|ISTRIP|INLCR|IGNCR|ICRNL|IXON);
    $self->{"C_OFLAG"} &= ~OPOST;
    $self->{"C_LFLAG"} &= ~(ECHO|ECHONL|ICANON|ISIG|IEXTEN);

    # "minicom" does some alarming things for setting up "raw", which is mostly
    # just the direct manipulation of the i, o, and l termios flags
    #$self->{"C_IFLAG"} = 0;
    #$self->{"C_OFLAG"} = 0;
    #$self->{"C_LFLAG"} = 0;

    # Sane port
    $self->{"C_IFLAG"} |= IGNBRK;
    $self->{"C_CFLAG"} |= (CLOCAL|CREAD);

    # 9600 baud
    $self->{"C_OSPEED"} = $bauds{"9600"};
    $self->{"C_ISPEED"} = $bauds{"9600"};

    # 8data bits
    $self->{"C_CFLAG"} &= ~CSIZE;
    $self->{"C_CFLAG"} |= CS8;

    # disable parity
    $self->{"C_CFLAG"} &= ~(PARENB | PARODD);

    # 1 stop bit
    $self->{"C_CFLAG"} &= ~CSTOPB;

    # by default, disable the OSX arbitrary baud settings
    $self->{"IOSSIOSPEED_BAUD"} = -1;

    &write_settings($self);

    $self->{ALIAS} = $self->{NAME};	# so "\\.\+++" can be changed

    # "private" data
    $self->{"_DEBUG"}    	= 0;
    $self->{U_MSG}     		= 0;
    $self->{E_MSG}     		= 0;
    $self->{RCONST}   		= 0;
    $self->{RTOT}   		= 0;
    $self->{"_T_INPUT"}		= "";
    $self->{"_LOOK"}		= "";
    $self->{"_LASTLOOK"}	= "";
    $self->{"_LASTLINE"}	= "";
    $self->{"_CLASTLINE"}	= "";
    $self->{"_SIZE"}		= 1;
    $self->{OFS}		= "";
    $self->{ORS}		= "";
    $self->{"_LMATCH"}		= "";
    $self->{"_LPATT"}		= "";
    $self->{"_PROMPT"}		= "";
    $self->{"_MATCH"}		= [];
    $self->{"_CMATCH"}		= [];
    @{ $self->{"_MATCH"} }	= "\n";
    @{ $self->{"_CMATCH"} }	= "\n";
    $self->{DVTYPE}		= "none";
    $self->{HNAME}		= "localhost";
    $self->{HADDR}		= 0;
    $self->{DATYPE}		= "raw";
    $self->{CFG_1}		= "none";
    $self->{CFG_2}		= "none";
    $self->{CFG_3}		= "none";

    bless ($self, $class);

    unless ($self->can_ioctl()) {
       nocarp or carp "disabling ioctl methods - system constants not found\n";
    }

#	These might be a good idea (but we'll need to change the tests)
#    $self->read_char_time(0); 	  # no time
#    $self->read_const_time(100); # 10th of a second

    return $self;
}

# Returns "1" on success
sub write_settings {
    my $self = shift;
    my ($item, $result);

    # put current values into Termios structure
    $self->{TERMIOS}->setcflag($self->{"C_CFLAG"});
    $self->{TERMIOS}->setlflag($self->{"C_LFLAG"});
    $self->{TERMIOS}->setiflag($self->{"C_IFLAG"});
    $self->{TERMIOS}->setoflag($self->{"C_OFLAG"});
    $self->{TERMIOS}->setispeed($self->{"C_ISPEED"});
    $self->{TERMIOS}->setospeed($self->{"C_OSPEED"});

    foreach $item (keys %c_cc_fields) {
        $self->{TERMIOS}->setcc($c_cc_fields{$item}, $self->{"C_$item"});
    }

    # setattr returns undef on failure
    $result = defined($self->{TERMIOS}->setattr($self->{FD}, &POSIX::TCSANOW));

    # IOSSIOSPEED settings are overwritten by setattr, so this needs to be
    # called last.
    if ($self->{"IOSSIOSPEED_BAUD"} != -1 && $self->can_arbitrary_baud()) {
        my $speed = pack( "L", $self->{"IOSSIOSPEED_BAUD"});
        $self->ioctl('IOSSIOSPEED', \$speed );
    }

    if ($Babble) {
        print "wrote settings to $self->{ALIAS}\n";
    }

    return $result;
}

sub save {
    my $self = shift;
    my $item;
    my $getsub;
    my $value;

    return unless (@_);

    my $filename = shift;
    unless ( open CF, ">$filename" ) {
        #carp "can't open file: $filename";
        return undef;
    }
    print CF "$cfg_file_sig";
    print CF "$self->{NAME}\n";
	# used to "reopen" so must be DEVICE=NAME
    print CF "$self->{LOCK}\n";
	# use lock to "open" if established

    # put current values from Termios structure FIRST
    foreach $item (@termios_fields) {
        printf CF "$item,%d\n", $self->{"$item"};
    }
    foreach $item (keys %c_cc_fields) {
        printf CF "C_$item,%d\n", $self->{"C_$item"};
    }

    no strict 'refs';		# for $gosub
    while (($item, $getsub) = each %validate) {
        chomp $getsub;
        $value = scalar &$getsub($self);
        print CF "$item,$value\n";
    }
    use strict 'refs';
    close CF;
    if ($Babble) {
        print "wrote file $filename for $self->{ALIAS}\n";
    }
    1;
}

# parse values for start/restart
sub get_start_values {
    return unless (@_ == 2);
    my $self = shift;
    my $filename = shift;

    unless ( open CF, "<$filename" ) {
        carp "can't open file: $filename: $!";
        return;
    }
    my ($signature, $name, $lockfile, @values) = ;
    close CF;

    unless ( $cfg_file_sig eq $signature ) {
        carp "Invalid signature in $filename: $signature";
        return;
    }
    chomp $name;
    unless ( $self->{NAME} eq $name ) {
        carp "Invalid Port DEVICE=$self->{NAME} in $filename: $name";
        return;
    }
    chomp $lockfile;
    if ($Babble or not $self) {
        print "signature = $signature";
        print "name = $name\n";
        if ($Babble) {
            print "values:\n";
            foreach (@values) { print "    $_"; }
        }
    }
    my $item;
    my @fields = @termios_fields;
    foreach $item (keys %c_cc_fields) {
        push @fields, "C_$item";
    }
    my %termios;
    foreach $item (@fields) {
        $termios{$item} = 1;
    }
    my $key;
    my $value;
    my $gosub;
    my $fault = 0;
    no strict 'refs';		# for $gosub
    foreach $item (@values) {
        chomp $item;
        ($key, $value) = split (/,/, $item);
        if ($value eq "") { $fault++ }
	elsif (defined $termios{$key}) {
	    $self->{"$key"} = $value;
	}
    else {
            $gosub = $validate{$key};
            unless (defined &$gosub ($self, $value)) {
    	        carp "Invalid parameter for $key=$value   ";
    	        return;
            }
        }
    }
    use strict 'refs';
    if ($fault) {
        carp "Invalid value in $filename";
        undef $self;
        return;
    }
    1;
}

sub restart {
    return unless (@_ == 2);
    my $self = shift;
    my $filename = shift;
    get_start_values($self, $filename);
    write_settings($self);
}

sub start {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    return unless (@_);
    my $filename = shift;

    unless ( open CF, "<$filename" ) {
        carp "can't open file: $filename: $!";
        return;
    }
    my ($signature, $name, $lockfile, @values) = ;
    close CF;

    unless ( $cfg_file_sig eq $signature ) {
        carp "Invalid signature in $filename: $signature";
        return;
    }
    chomp $name;
    chomp $lockfile;
    my $self  = new ($class, $name, 1, $lockfile); # quiet for lock
    return 0 if ($lockfile and not $self);
    if ($Babble or not $self) {
        print "signature = $signature";
        print "class = $class\n";
        print "name = $name\n";
        print "lockfile = $lockfile\n";
        if ($Babble) {
            print "values:\n";
            foreach (@values) { print "    $_"; }
        }
    }
    if ($self) {
        if ( get_start_values($self, $filename) ) {
            write_settings ($self);
	}
        else {
            carp "Invalid value in $filename";
            undef $self;
            return;
        }
    }
    return $self;
}

# true/false capabilities (read only)
# currently just constants in the POSIX case

sub can_baud			{ return 1; }
sub can_databits		{ return 1; }
sub can_stopbits		{ return 1; }
sub can_dtrdsr			{ return 1; }
sub can_handshake		{ return 1; }
sub can_parity_check		{ return 1; }
sub can_parity_config		{ return 1; }
sub can_parity_enable		{ return 1; }
sub can_rlsd			{ return 0; } # currently
sub can_16bitmode		{ return 0; } # Win32-specific
sub is_rs232			{ return 1; }
sub is_modem			{ return 0; } # Win32-specific
sub can_rtscts			{ return 1; } # this is a flow option
sub can_xonxoff			{ return 1; } # this is a flow option
sub can_xon_char		{ return 1; } # use stty
sub can_spec_char		{ return 0; } # use stty
sub can_interval_timeout	{ return 0; } # currently
sub can_total_timeout		{ return 1; } # currently
sub binary			{ return 1; }

sub reset_error			{ return 0; } # for compatibility

sub can_ioctl {
    if (defined($bits->{'TIOCMBIS'}) &&         # Turn on
        defined($bits->{'TIOCMBIC'}) &&         # Turn off
        defined($bits->{'TIOCM_RTS'}) &&        # RTS value
        ( ( defined($bits->{'TIOCSDTR'}) &&     # DTR ability/value
            defined($bits->{'TIOCCDTR'}) ) ||
          defined($bits->{'TIOCM_DTR'})
        )
       ) {
        return 1;
    }
    return 0;

    #return 0 unless ($bitset && $bitclear && $rtsout &&
	#    (($dtrset && $dtrclear) || $dtrout));
    #return 1;
}

sub can_modemlines {
    return 1 if (defined($bits->{'TIOCMGET'}));
    return 0;
}

sub can_wait_modemlines {
    return 1 if (defined($bits->{'TIOCMIWAIT'}));
    return 0;
}

sub can_intr_count {
    return 1 if (defined($bits->{'TIOCGICOUNT'}));
    return 0;
}

sub can_status {
    return 1 if (defined($bits->{'portable_TIOCINQ'}) &&
                 defined($bits->{'TIOCOUTQ'}));
    return 0;
    #return 0 unless ($incount && $outcount);
    #return 1;
}

sub can_write_done {
    my ($self)=@_;
    return 1 if ($self->can_status &&
                 defined($bits->{'TIOCSERGETLSR'}) &&
                 TIOCM_LE);
    return 0;
}

# can we control the rts line?
sub can_rts {
    if (defined($bits->{'TIOCMBIS'}) &&
        defined($bits->{'TIOCMBIC'}) &&
        defined($bits->{'TIOCM_RTS'})) {
            return 1;
    }
    return 0;

    # why are we testing for _lack_ of dtrset/clear?  can BSD NOT control RTS?
    #return 0 unless($bitset && $bitclear && $rtsout && !($dtrset && $dtrclear));
    #return 1;
}

# can we set arbitrary baud rates? (OSX)
sub can_arbitrary_baud {
    return 1 if (defined($bits->{'IOSSIOSPEED'}));
    return 0;
}

sub termiox {
    my $self = shift;
    return unless ($IOCTL_VALUE_TERMIOXFLOW);
    my $on = shift;
    my $rc;

    $self->{'TERMIOX'}=$on ? $IOCTL_VALUE_TERMIOXFLOW : 0;

    my $flags=pack('SSSS',0,0,0,0);
    return undef unless $self->ioctl('TCGETX', \$flags);
    #if (!($rc=ioctl($self->{HANDLE}, $tcgetx, $flags))) {
	#warn "TCGETX($tcgetx) ioctl: $!\n";
    #}

    my @vals=unpack('SSSS',$flags);
    $vals[0]= $on ? $IOCTL_VALUE_TERMIOXFLOW : 0;
    $flags=pack('SSSS',@vals);

    return undef unless $self->ioctl('TCSETX', \$flags);
    #if (!($rc=ioctl($self->{HANDLE}, $tcsetx, $flags))) {
	#warn "TCSETX($tcsetx) ioctl: $!\n";
    #}
    return 1;
}

sub handshake {
    my $self = shift;

    if (@_) {
	if ( $_[0] eq "none" ) {
	    $self->{"C_IFLAG"} &= ~(IXON | IXOFF);
	    $self->termiox(0) if ($IOCTL_VALUE_TERMIOXFLOW);
	    $self->{"C_CFLAG"} &= ~CRTSCTS;
	}
	elsif ( $_[0] eq "xoff" ) {
	    $self->{"C_IFLAG"} |= (IXON | IXOFF);
	    $self->termiox(0) if ($IOCTL_VALUE_TERMIOXFLOW);
	    $self->{"C_CFLAG"} &= ~CRTSCTS;
	}
	elsif ( $_[0] eq "rts" ) {
	    $self->{"C_IFLAG"} &= ~(IXON | IXOFF);
	    $self->termiox(1) if ($IOCTL_VALUE_TERMIOXFLOW);
	    $self->{"C_CFLAG"} |= CRTSCTS;
	}
        else {
            if ($self->{U_MSG} or $Babble) {
                carp "Can't set handshake on $self->{ALIAS}";
            }
	    return undef;
        }
	write_settings($self);
    }
    if (wantarray) { return ("none", "xoff", "rts"); }
    my $mask = (IXON|IXOFF);
    return "xoff" if ($mask == ($self->{"C_IFLAG"} & $mask));
    if ($IOCTL_VALUE_TERMIOXFLOW) {
	return "rts" if ($self->{'TERMIOX'} & $IOCTL_VALUE_TERMIOXFLOW);
    } else {
    	return "rts" if ($self->{"C_CFLAG"} & CRTSCTS);
    }
    return "none";
}

sub baudrate {
    my ($self,$rate) = @_;
    my $item = 0;

    if (defined($rate)) {
        # specific baud rate
        if (defined $bauds{$rate}) {
            $self->{"C_OSPEED"} = $bauds{$rate};
            $self->{"C_ISPEED"} = $bauds{$rate};
            $self->{"IOSSIOSPEED_BAUD"} = -1;
            write_settings($self);
        }
        # arbitrary baud rate
        elsif ($self->can_arbitrary_baud()) {
            $self->{"IOSSIOSPEED_BAUD"} = $rate;
            write_settings($self);
            return $rate;
        }
        # no such baud rate
        else {
            if ($self->{U_MSG} or $Babble) {
                carp "Can't set baudrate ($rate) on $self->{ALIAS}";
            }
            return 0;
        }
    }
    if (wantarray) { return (keys %bauds); }
    foreach $item (keys %bauds) {
        return $item if ($bauds{$item} == $self->{"C_OSPEED"});
    }
    return 0;
}

# Interesting note about parity.  It seems that while the "correct" thing
# to do is to enable inbound parity checking (INPCK) and to strip the bits,
# this doesn't seem to be sane for a large number of systems, modems,
# whatever.  If "INPCK" or "ISTRIP" is needed, please use the stty_inpck
# and stty_istrip functions
sub parity {
    my $self = shift;
    if (@_) {
        if ( $_[0] eq "none" ) {
            $self->{"C_CFLAG"} &= ~(PARENB|PARODD);
        }
        elsif ( $_[0] eq "odd" ) {
            $self->{"C_CFLAG"} |= (PARENB|PARODD);
        }
        elsif ( $_[0] eq "even" ) {
	        $self->{"C_CFLAG"} |= PARENB;
            $self->{"C_CFLAG"} &= ~PARODD;
        }
        else {
            if ($self->{U_MSG} or $Babble) {
                carp "Can't set parity on $self->{ALIAS}";
            }
            return undef;
        }
        return undef if (!(write_settings($self)));
    }
    if (wantarray) { return ("none", "odd", "even"); }
    return "none" unless ($self->{"C_CFLAG"} & PARENB);
    my $mask = (PARENB|PARODD);
    return "odd"  if ($mask == ($self->{"C_CFLAG"} & $mask));
    $mask = (PARENB);
    return "even" if ($mask == ($self->{"C_CFLAG"} & $mask));
    return "unknown";
}

sub databits {
    my $self = shift;
    if (@_) {
	if ( $_[0] == 8 ) {
	    $self->{"C_CFLAG"} &= ~CSIZE;
	    $self->{"C_CFLAG"} |= CS8;
	}
	elsif ( $_[0] == 7 ) {
	    $self->{"C_CFLAG"} &= ~CSIZE;
	    $self->{"C_CFLAG"} |= CS7;
	}
	elsif ( $_[0] == 6 ) {
	    $self->{"C_CFLAG"} &= ~CSIZE;
	    $self->{"C_CFLAG"} |= CS6;
	}
	elsif ( $_[0] == 5 ) {
	    $self->{"C_CFLAG"} &= ~CSIZE;
	    $self->{"C_CFLAG"} |= CS5;
	}
        else {
            if ($self->{U_MSG} or $Babble) {
                carp "Can't set databits on $self->{ALIAS}";
            }
	    return undef;
        }
	write_settings($self);
    }
    if (wantarray) { return (5, 6, 7, 8); }
    my $mask = ($self->{"C_CFLAG"} & CSIZE);
    return 8 if ($mask == CS8);
    return 7 if ($mask == CS7);
    return 6 if ($mask == CS6);
    return 5;
}

sub stopbits {
    my $self = shift;
    if (@_) {
	if ( $_[0] == 2 ) {
	    $self->{"C_CFLAG"} |= CSTOPB;
	}
	elsif ( $_[0] == 1 ) {
	    $self->{"C_CFLAG"} &= ~CSTOPB;
	}
        else {
            if ($self->{U_MSG} or $Babble) {
                carp "Can't set stopbits on $self->{ALIAS}";
            }
	    return undef;
        }
	write_settings($self);
    }
    if (wantarray) { return (1, 2); }
    return 2 if ($self->{"C_CFLAG"} & CSTOPB);
    return 1;
}

sub is_xon_char {
    my $self = shift;
    if (@_) {
	my $v = int shift;
	return if (($v < 0) or ($v > 255));
	$self->{"C_VSTART"} = $v;
	write_settings($self);
    }
    return $self->{"C_VSTART"};
}

sub is_xoff_char {
    my $self = shift;
    if (@_) {
	my $v = int shift;
	return if (($v < 0) or ($v > 255));
	$self->{"C_VSTOP"} = $v;
	write_settings($self);
    }
    return $self->{"C_VSTOP"};
}

sub is_stty_intr {
    my $self = shift;
    if (@_) {
	my $v = int shift;
	return if (($v < 0) or ($v > 255));
	$self->{"C_VINTR"} = $v;
	write_settings($self);
    }
    return $self->{"C_VINTR"};
}

sub is_stty_quit {
    my $self = shift;
    if (@_) {
	my $v = int shift;
	return if (($v < 0) or ($v > 255));
	$self->{"C_VQUIT"} = $v;
	write_settings($self);
    }
    return $self->{"C_VQUIT"};
}

sub is_stty_eof {
    my $self = shift;
    if (@_) {
	my $v = int shift;
	return if (($v < 0) or ($v > 255));
	$self->{"C_VEOF"} = $v;
	write_settings($self);
    }
    return $self->{"C_VEOF"};
}

sub is_stty_eol {
    my $self = shift;
    if (@_) {
	my $v = int shift;
	return if (($v < 0) or ($v > 255));
	$self->{"C_VEOL"} = $v;
	write_settings($self);
    }
    return $self->{"C_VEOL"};
}

sub is_stty_erase {
    my $self = shift;
    if (@_) {
	my $v = int shift;
	return if (($v < 0) or ($v > 255));
	$self->{"C_VERASE"} = $v;
	write_settings($self);
    }
    return $self->{"C_VERASE"};
}

sub is_stty_kill {
    my $self = shift;
    if (@_) {
	my $v = int shift;
	return if (($v < 0) or ($v > 255));
	$self->{"C_VKILL"} = $v;
	write_settings($self);
    }
    return $self->{"C_VKILL"};
}

sub is_stty_susp {
    my $self = shift;
    if (@_) {
	my $v = int shift;
	return if (($v < 0) or ($v > 255));
	$self->{"C_VSUSP"} = $v;
	write_settings($self);
    }
    return $self->{"C_VSUSP"};
}

sub stty_echo {
    my $self = shift;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_LFLAG"} |= ECHO;
        } else {
	    $self->{"C_LFLAG"} &= ~ECHO;
	}
	write_settings($self);
    }
    return ($self->{"C_LFLAG"} & ECHO) ? 1 : 0;
}

sub stty_echoe {
    my $self = shift;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_LFLAG"} |= ECHOE;
        } else {
	    $self->{"C_LFLAG"} &= ~ECHOE;
	}
	write_settings($self);
    }
    return ($self->{"C_LFLAG"} & ECHOE) ? 1 : 0;
}

sub stty_echok {
    my $self = shift;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_LFLAG"} |= ECHOK;
        } else {
	    $self->{"C_LFLAG"} &= ~ECHOK;
	}
	write_settings($self);
    }
    return ($self->{"C_LFLAG"} & ECHOK) ? 1 : 0;
}

sub stty_echonl {
    my $self = shift;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_LFLAG"} |= ECHONL;
        } else {
	    $self->{"C_LFLAG"} &= ~ECHONL;
	}
	write_settings($self);
    }
    return ($self->{"C_LFLAG"} & ECHONL) ? 1 : 0;
}

	# non-POSIX
sub stty_echoke {
    my $self = shift;
    return unless ECHOKE;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_LFLAG"} |= ECHOKE;
        } else {
	    $self->{"C_LFLAG"} &= ~ECHOKE;
	}
	write_settings($self);
    }
    return ($self->{"C_LFLAG"} & ECHOKE) ? 1 : 0;
}

	# non-POSIX
sub stty_echoctl {
    my $self = shift;
    return unless ECHOCTL;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_LFLAG"} |= ECHOCTL;
        } else {
	    $self->{"C_LFLAG"} &= ~ECHOCTL;
	}
	write_settings($self);
    }
    return ($self->{"C_LFLAG"} & ECHOCTL) ? 1 : 0;
}

# Mark parity errors with a leading "NULL" character
sub stty_parmrk {
    my $self = shift;
    if (@_) {
        if ( yes_true( shift ) ) {
            $self->{"C_IFLAG"} |= PARMRK;
        } else {
            $self->{"C_IFLAG"} &= ~PARMRK;
        }
        write_settings($self);
    }
    return wantarray ? @binary_opt : ($self->{"C_IFLAG"} & PARMRK);
}

# Ignore parity errors (considered dangerous)
sub stty_ignpar {
    my $self = shift;
    if (@_) {
        if ( yes_true( shift ) ) {
            $self->{"C_IFLAG"} |= IGNPAR;
        } else {
            $self->{"C_IFLAG"} &= ~IGNPAR;
	    }
        write_settings($self);
    }
    return wantarray ? @binary_opt : ($self->{"C_IFLAG"} & IGNPAR);
}

# Ignore breaks
sub stty_ignbrk {
    my $self = shift;
    if (@_) {
        if ( yes_true( shift ) ) {
            $self->{"C_IFLAG"} |= IGNBRK;
        } else {
            $self->{"C_IFLAG"} &= ~IGNBRK;
        }
        write_settings($self);
    }
    return ($self->{"C_IFLAG"} & IGNBRK) ? 1 : 0;
}

# Strip parity bit
sub stty_istrip {
    my $self = shift;
    if (@_) {
        if ( yes_true( shift ) ) {
            $self->{"C_IFLAG"} |= ISTRIP;
        } else {
            $self->{"C_IFLAG"} &= ~ISTRIP;
        }
        write_settings($self);
    }
    return ($self->{"C_IFLAG"} & ISTRIP) ? 1 : 0;
}

# check incoming parity bit
sub stty_inpck {
    my $self = shift;
    if (@_) {
        if ( yes_true( shift ) ) {
            $self->{"C_IFLAG"} |= INPCK;
        } else {
            $self->{"C_IFLAG"} &= ~INPCK;
        }
        write_settings($self);
    }
    return ($self->{"C_IFLAG"} & INPCK) ? 1 : 0;
}

sub stty_icrnl {
    my $self = shift;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_IFLAG"} |= ICRNL;
        } else {
	    $self->{"C_IFLAG"} &= ~ICRNL;
	}
	write_settings($self);
    }
    return ($self->{"C_IFLAG"} & ICRNL) ? 1 : 0;
}

sub stty_igncr {
    my $self = shift;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_IFLAG"} |= IGNCR;
        } else {
	    $self->{"C_IFLAG"} &= ~IGNCR;
	}
	write_settings($self);
    }
    return ($self->{"C_IFLAG"} & IGNCR) ? 1 : 0;
}

sub stty_inlcr {
    my $self = shift;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_IFLAG"} |= INLCR;
        } else {
	    $self->{"C_IFLAG"} &= ~INLCR;
	}
	write_settings($self);
    }
    return ($self->{"C_IFLAG"} & INLCR) ? 1 : 0;
}

	# non-POSIX
sub stty_ocrnl {
    my $self = shift;
    return unless OCRNL;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_OFLAG"} |= OCRNL;
        } else {
	    $self->{"C_OFLAG"} &= ~OCRNL;
	}
	write_settings($self);
    }
    return ($self->{"C_OFLAG"} & OCRNL) ? 1 : 0;
}

	# non-POSIX
sub stty_onlcr {
    my $self = shift;
    return unless ONLCR;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_OFLAG"} |= ONLCR;
        } else {
	    $self->{"C_OFLAG"} &= ~ONLCR;
	}
	write_settings($self);
    }
    return ($self->{"C_OFLAG"} & ONLCR) ? 1 : 0;
}

sub stty_opost {
    my $self = shift;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_OFLAG"} |= OPOST;
        } else {
	    $self->{"C_OFLAG"} &= ~OPOST;
	}
	write_settings($self);
    }
    return ($self->{"C_OFLAG"} & OPOST) ? 1 : 0;
}

sub stty_isig {
    my $self = shift;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_LFLAG"} |= ISIG;
        } else {
	    $self->{"C_LFLAG"} &= ~ISIG;
	}
	write_settings($self);
    }
    return ($self->{"C_LFLAG"} & ISIG) ? 1 : 0;
}

sub stty_icanon {
    my $self = shift;
    if (@_) {
	if ( yes_true( shift ) ) {
	    $self->{"C_LFLAG"} |= ICANON;
        } else {
	    $self->{"C_LFLAG"} &= ~ICANON;
	}
	write_settings($self);
    }
    return ($self->{"C_LFLAG"} & ICANON) ? 1 : 0;
}

sub alias {
    my $self = shift;
    if (@_) { $self->{ALIAS} = shift; }	# should return true for legal names
    return $self->{ALIAS};
}

sub devicetype {
    my $self = shift;
    if (@_) { $self->{DVTYPE} = shift; } # return true for legal names
    return $self->{DVTYPE};
}

sub hostname {
    my $self = shift;
    if (@_) { $self->{HNAME} = shift; }	# return true for legal names
    return $self->{HNAME};
}

sub hostaddr {
    my $self = shift;
    if (@_) { $self->{HADDR} = shift; }	# return true for assigned port
    return $self->{HADDR};
}

sub datatype {
    my $self = shift;
    if (@_) { $self->{DATYPE} = shift; } # return true for legal types
    return $self->{DATYPE};
}

sub cfg_param_1 {
    my $self = shift;
    if (@_) { $self->{CFG_1} = shift; }	# return true for legal param
    return $self->{CFG_1};
}

sub cfg_param_2 {
    my $self = shift;
    if (@_) { $self->{CFG_2} = shift; }	# return true for legal param
    return $self->{CFG_2};
}

sub cfg_param_3 {
    my $self = shift;
    if (@_) { $self->{CFG_3} = shift; }	# return true for legal param
    return $self->{CFG_3};
}

sub buffers {
    my $self = shift;
    if (@_) { return unless (@_ == 2); }
    return wantarray ?  (4096, 4096) : 1;
}

sub read_const_time {
    my $self = shift;
    if (@_) {
	$self->{RCONST} = (shift)/1000; # milliseconds -> select_time
	$self->{"C_VTIME"} = $self->{RCONST} * 10000; # wants tenths of sec
	$self->{"C_VMIN"} = 0;
	write_settings($self);
    }
    return $self->{RCONST}*1000;
}

sub read_char_time {
    my $self = shift;
    if (@_) {
	$self->{RTOT} = (shift)/1000; # milliseconds -> select_time
    }
    return $self->{RTOT}*1000;
}

sub read {
    return undef unless (@_ == 2);
    my $self = shift;
    my $wanted = shift;
    my $result = "";
    my $ok     = 0;
    return (0, "") unless ($wanted > 0);

    my $done = 0;
    my $count_in = 0;
    my $string_in = "";
    my $in2 = "";
    my $bufsize = 255;	# VMIN max (declared as char)

    while ($done < $wanted) {
	my $size = $wanted - $done;
        if ($size > $bufsize) { $size = $bufsize; }
	($count_in, $string_in) = $self->read_vmin($size);
	if ($count_in) {
            $in2 .= $string_in;
	    $done += $count_in;
	}
	elsif ($done) {
	    last;
	}
        else {
            return if (!defined $count_in);
	    last;
        }
    }
    return ($done, $in2);
}

sub read_vmin {
    return undef unless (@_ == 2);
    my $self = shift;
    my $wanted = shift;
    my $result = "";
    my $ok     = 0;
    return (0, "") unless ($wanted > 0);

#	This appears dangerous under Solaris
#    if ($self->{"C_VMIN"} != $wanted) {
#	$self->{"C_VMIN"} = $wanted;
#        write_settings($self);
#    }
    my $rin = "";
    vec($rin, $self->{FD}, 1) = 1;
    my $ein = $rin;
    my $tin = $self->{RCONST} + ($wanted * $self->{RTOT});
    my $rout;
    my $wout;
    my $eout;
    my $tout;
    my $ready = select($rout=$rin, $wout=undef, $eout=$ein, $tout=$tin);

    my $got=0;

    if ($ready>0) {
        $got = POSIX::read ($self->{FD}, $result, $wanted);

        if (! defined $got) {
            return (0,"") if (&POSIX::EAGAIN == ($ok = POSIX::errno()));
            return (0,"") if (!$ready and (0 == $ok));
		    # at least Solaris acts like eof() in this case
            carp "Error #$ok in Device::SerialPort::read";
            return;
        }
        elsif ($got == 0 && $wanted!=0) {
            # if read returns "0" on a non-zero request, it's EOF
            return;
        }
    }

    print "read_vmin=$got, ready=$ready, result=..$result..\n" if ($Babble);
    return ($got, $result);
}

sub are_match {
    my $self = shift;
    my $pat;
    my $patno = 0;
    my $reno = 0;
    my $re_next = 0;
    if (@_) {
	@{ $self->{"_MATCH"} } = @_;
	if ($] >= 5.005) {
	    @{ $self->{"_CMATCH"} } = ();
	    while ($pat = shift) {
	        if ($re_next) {
		    $re_next = 0;
	            eval 'push (@{ $self->{"_CMATCH"} }, qr/$pat/)';
		} else {
	            push (@{ $self->{"_CMATCH"} }, $pat);
		}
	        if ($pat eq "-re") {
		    $re_next++;
	        }
	    }
	} else {
	    @{ $self->{"_CMATCH"} } = @_;
	}
    }
    return @{ $self->{"_MATCH"} };
}

sub lookclear {
    my $self = shift;
    if (nocarp && (@_ == 1)) {
        $self->{"_T_INPUT"} = shift;
    }
    $self->{"_LOOK"}	 = "";
    $self->{"_LASTLOOK"} = "";
    $self->{"_LMATCH"}	 = "";
    $self->{"_LPATT"}	 = "";
    return if (@_);
    1;
}

sub linesize {
    my $self = shift;
    if (@_) {
	my $val = int shift;
	return if ($val < 0);
        $self->{"_SIZE"} = $val;
    }
    return $self->{"_SIZE"};
}

sub lastline {
    my $self = shift;
    if (@_) {
        $self->{"_LASTLINE"} = shift;
	if ($] >= 5.005) {
	    eval '$self->{"_CLASTLINE"} = qr/$self->{"_LASTLINE"}/';
	} else {
            $self->{"_CLASTLINE"} = $self->{"_LASTLINE"};
	}
    }
    return $self->{"_LASTLINE"};
}

sub matchclear {
    my $self = shift;
    my $found = $self->{"_LMATCH"};
    $self->{"_LMATCH"}	 = "";
    return if (@_);
    return $found;
}

sub lastlook {
    my $self = shift;
    return if (@_);
    return ( $self->{"_LMATCH"}, $self->{"_LASTLOOK"},
	     $self->{"_LPATT"}, $self->{"_LOOK"} );
}

sub lookfor {
    my $self = shift;
    my $size = 0;
    if (@_) { $size = shift; }
    my $loc = "";
    my $count_in = 0;
    my $string_in = "";
    $self->{"_LMATCH"}	 = "";
    $self->{"_LPATT"}	 = "";

    if ( ! $self->{"_LOOK"} ) {
        $loc = $self->{"_LASTLOOK"};
    }

    if ($size) {
	($count_in, $string_in) = $self->read($size);
	return unless ($count_in);
        $loc .= $string_in;
    }
    else {
	$loc .= $self->input;
    }

    if ($loc ne "") {
	my $n_char;
	my $mpos;
	my $lookbuf;
	my $re_next = 0;
	my $got_match = 0;
	my $pat;

	my @loc_char = split (//, $loc);
	while (defined ($n_char = shift @loc_char)) {
		$mpos = ord $n_char;
        $self->{"_LOOK"} .= $n_char;
		$lookbuf = $self->{"_LOOK"};
		$count_in = 0;
		foreach $pat ( @{ $self->{"_CMATCH"} } ) {
		    if ($pat eq "-re") {
			$re_next++;
		        $count_in++;
			next;
		    }
		    if ($re_next) {
			$re_next = 0;
			# always at $lookbuf end when processing single char
		        if ( $lookbuf =~ s/$pat//s ) {
		            $self->{"_LMATCH"} = $&;
                    $got_match++;
                }
		    }
		    elsif (($mpos = index($lookbuf, $pat)) > -1) {
			$got_match++;
			$lookbuf = substr ($lookbuf, 0, $mpos);
		        $self->{"_LMATCH"} = $pat;
		    }
		    if ($got_match) {
		        $self->{"_LPATT"} = $self->{"_MATCH"}[$count_in];
		        if (scalar @loc_char) {
		            $self->{"_LASTLOOK"} = join("", @loc_char);
                }
		        else {
		            $self->{"_LASTLOOK"} = "";
		        }
		        $self->{"_LOOK"}     = "";
		        return $lookbuf;
                    }
		    $count_in++;
		}
####	    }
	}
    }
    return "";
}

sub streamline {
    my $self = shift;
    my $size = 0;
    if (@_) { $size = shift; }
    my $loc = "";
    my $mpos;
    my $count_in = 0;
    my $string_in = "";
    my $re_next = 0;
    my $got_match = 0;
    my $best_pos = 0;
    my $pat;
    my $match = "";
    my $before = "";
    my $after = "";
    my $best_match = "";
    my $best_before = "";
    my $best_after = "";
    my $best_pat = "";
    $self->{"_LMATCH"}	 = "";
    $self->{"_LPATT"}	 = "";

    if ( ! $self->{"_LOOK"} ) {
        $loc = $self->{"_LASTLOOK"};
    }

    if ($size) {
        ($count_in, $string_in) = $self->read($size);
        return unless ($count_in);
        $loc .= $string_in;
    }
    else {
        $loc .= $self->input;
    }

    if ($loc ne "") {
        $self->{"_LOOK"} .= $loc;
        $count_in = 0;
        foreach $pat ( @{ $self->{"_CMATCH"} } ) {
            if ($pat eq "-re") {
                $re_next++;
                $count_in++;
                next;
            }
            if ($re_next) {
                $re_next = 0;
                if ( $self->{"_LOOK"} =~ /$pat/s ) {
                    ( $match, $before, $after ) = ( $&, $`, $' );
                    $got_match++;
                    $mpos = length($before);
                    if ($mpos) {
                        next if ($best_pos && ($mpos > $best_pos));
                        $best_pos = $mpos;
                        $best_pat = $self->{"_MATCH"}[$count_in];
                        $best_match = $match;
                        $best_before = $before;
                        $best_after = $after;
                    }
                    else {
                        $self->{"_LPATT"} = $self->{"_MATCH"}[$count_in];
                        $self->{"_LMATCH"} = $match;
                        $self->{"_LASTLOOK"} = $after;
                        $self->{"_LOOK"}     = "";
                        return $before;
                        # pattern at start will be best
                    }
                }
            }
            elsif (($mpos = index($self->{"_LOOK"}, $pat)) > -1) {
                $got_match++;
                $before = substr ($self->{"_LOOK"}, 0, $mpos);
                if ($mpos) {
                    next if ($best_pos && ($mpos > $best_pos));
                    $best_pos = $mpos;
                    $best_pat = $pat;
                    $best_match = $pat;
                    $best_before = $before;
                    $mpos += length($pat);
                    $best_after = substr ($self->{"_LOOK"}, $mpos);
                }
                else {
                    $self->{"_LPATT"} = $pat;
                    $self->{"_LMATCH"} = $pat;
                    $before = substr ($self->{"_LOOK"}, 0, $mpos);
                    $mpos += length($pat);
                    $self->{"_LASTLOOK"} = substr ($self->{"_LOOK"}, $mpos);
                    $self->{"_LOOK"}     = "";
                    return $before;
                    # match at start will be best
                }
            }
            $count_in++;
        }
        if ($got_match) {
            $self->{"_LPATT"} = $best_pat;
            $self->{"_LMATCH"} = $best_match;
            $self->{"_LASTLOOK"} = $best_after;
            $self->{"_LOOK"}     = "";
            return $best_before;
        }
    }
    return "";
}

sub input {
    return undef unless (@_ == 1);
    my $self = shift;
    my $ok     = 0;
    my $result = "";
    my $wanted = 255;

    if (nocarp && $self->{"_T_INPUT"}) {
        $result = $self->{"_T_INPUT"};
        $self->{"_T_INPUT"} = "";
        return $result;
    }

    if ( $self->{"C_VMIN"} ) {
        $self->{"C_VMIN"} = 0;
        write_settings($self);
    }

    my $got = POSIX::read ($self->{FD}, $result, $wanted);

    unless (defined $got) { $got = -1; }
    if ($got == -1) {
        return "" if (&POSIX::EAGAIN == ($ok = POSIX::errno()));
        return "" if (0 == $ok);	# at least Solaris acts like eof()
        carp "Error #$ok in Device::SerialPort::input"
    }
    return $result;
}

sub write {
    return undef unless (@_ == 2);
    my $self = shift;
    my $wbuf = shift;
    my $ok;

    return 0 if ($wbuf eq "");
    my $lbuf = length ($wbuf);

    my $written = POSIX::write ($self->{FD}, $wbuf, $lbuf);

    return $written;
}

sub write_drain {
    my $self = shift;
    return if (@_);
    return 1 if (defined POSIX::tcdrain($self->{FD}));
    return;
}

sub purge_all {
    my $self = shift;
    return if (@_);
    return 1 if (defined POSIX::tcflush($self->{FD}, TCIOFLUSH));
    return;
}

sub purge_rx {
    my $self = shift;
    return if (@_);
    return 1 if (defined POSIX::tcflush($self->{FD}, TCIFLUSH));
    return;
}

sub purge_tx {
    my $self = shift;
    return if (@_);
    return 1 if (defined POSIX::tcflush($self->{FD}, TCOFLUSH));
    return;
}

sub buffer_max {
    my $self = shift;
    if (@_) {return undef; }
    return (4096, 4096);
}

  # true/false parameters

sub user_msg {
    my $self = shift;
    if (@_) { $self->{U_MSG} = yes_true ( shift ) }
    return wantarray ? @binary_opt : $self->{U_MSG};
}

sub error_msg {
    my $self = shift;
    if (@_) { $self->{E_MSG} = yes_true ( shift ) }
    return wantarray ? @binary_opt : $self->{E_MSG};
}

sub parity_enable {
    my $self = shift;
    if (@_) {
        if ( yes_true( shift ) ) {
            $self->{"C_CFLAG"} |= PARENB;
        } else {
            $self->{"C_CFLAG"} &= ~PARENB;
        }
        write_settings($self);
    }
    return wantarray ? @binary_opt : ($self->{"C_CFLAG"} & PARENB);
}

sub write_done {
    return unless (@_ == 2);
    my $self = shift;
    return unless ($self->can_write_done);
    my $rc;
    my $wait = yes_true ( shift );
    $self->write_drain if ($wait);

    my $mstat = " ";
    my $result;
    for (;;) {
        return unless $self->ioctl('TIOCOUTQ',\$mstat);
        $result = unpack('L', $mstat);
        return (0, 0) if ($result);	# characters pending

        return unless $self->ioctl('TIOCSERGETLSR',\$mstat);
        $result = (unpack('L', $mstat) & TIOCM_LE);
        last unless ($wait);
        last if ($result);		# shift register empty
        select (undef, undef, undef, 0.02);
    }
    return $result ? (1, 0) : (0, 0);
}

sub modemlines {
    return undef unless (@_ == 1);
    my $self = shift;
    return undef unless ($self->can_modemlines);

    my $mstat = pack('L',0);
    return undef unless $self->ioctl('TIOCMGET',\$mstat);
    my $result = unpack('L', $mstat);
    if ($Babble) {
        printf "result = %x\n", $result;
        print "CTS is ON\n"		if ($result & MS_CTS_ON);
        print "DSR is ON\n"		if ($result & MS_DSR_ON);
        print "RING is ON\n"		if ($result & MS_RING_ON);
        print "RLSD is ON\n"		if ($result & MS_RLSD_ON);
    }
    return $result;
}

# Strange thing is, this function doesn't always work for me.  I suspect
# I have a broken serial card.  Everything else in my test system doesn't
# work (USB, floppy) so why not serial too?
sub wait_modemlines {
    return undef unless (@_ == 2);
    my $self = shift;
    my $flags = shift || 0;
    return undef unless ($self->can_wait_modemlines);

    if ($Babble) {
        printf "wait_modemlines flag = %u\n", $flags;
    }
    my $mstat = pack('L',$flags);
    return $self->ioctl('TIOCMIWAIT',\$mstat);
}

sub intr_count {
    return undef unless (@_ == 1);
    my $self = shift;
    return undef unless ($self->can_intr_count);

    my $mstat = pack('L',0);
    return $self->ioctl('TIOCGICOUNT',\$mstat);
    my $result = unpack('L', $mstat);
    if ($Babble) {
        printf "result = %x\n", $result;
    }
    return $result;
}

sub status {
    my $self = shift;
    return if (@_);
    return unless ($self->can_status);
    my @stat = (0, 0, 0, 0);
    my $mstat = " ";

    return unless $self->ioctl('portable_TIOCINQ', \$mstat);

    $stat[ST_INPUT] = unpack('L', $mstat);
    return unless $self->ioctl('TIOCOUTQ', \$mstat);

    $stat[ST_OUTPUT] = unpack('L', $mstat);

    if ( $Babble or $self->{"_DEBUG"} ) {
        printf "Blocking Bits= %d\n", $stat[ST_BLOCK];
        printf "Input Queue= %d\n", $stat[ST_INPUT];
        printf "Output Queue= %d\n", $stat[ST_OUTPUT];
        printf "Latched Errors= %d\n", $stat[ST_ERROR];
    }
    return @stat;
}

sub dtr_active {
    return unless (@_ == 2);
    my $self = shift;
    return unless $self->can_dtrdsr();
    my $on = yes_true( shift );
    my $rc;

    # if we have set DTR and clear DTR, we should use it (OpenBSD)
    my $value=0;
    if (defined($bits->{'TIOCSDTR'}) &&
        defined($bits->{'TIOCCDTR'})) {
        $value=0;
        $rc=$self->ioctl($on ? 'TIOCSDTR' : 'TIOCCDTR', \$value);
    }
    else {
        $value=$IOCTL_VALUE_DTR;
        $rc=$self->ioctl($on ? 'TIOCMBIS' : 'TIOCMBIC', \$value);
    }
    warn "dtr_active($on) ioctl: $!\n"    if (!$rc);

    # ARG!  Solaris destroys termios settings after a DTR toggle!!
    write_settings($self);

    return $rc;
}

sub rts_active {
    return unless (@_ == 2);
    my $self = shift;
    return unless ($self->can_rts());
    my $on = yes_true( shift );
    # returns ioctl result
    my $value=$IOCTL_VALUE_RTS;
    my $rc=$self->ioctl($on ? 'TIOCMBIS' : 'TIOCMBIC', \$value);
    #my $rc=ioctl($self->{HANDLE}, $on ? $bitset : $bitclear, $rtsout);
    warn "rts_active($on) ioctl: $!\n" if (!$rc);
    return $rc;
}

sub pulse_break_on {
    return unless (@_ == 2);
    my $self = shift;
    my $delay = (shift)/1000;
    my $length = 0;
    my $ok = POSIX::tcsendbreak($self->{FD}, $length);
    warn "could not pulse break on: $!\n" unless ($ok);
    select (undef, undef, undef, $delay);
    return $ok;
}

sub pulse_rts_on {
    return unless (@_ == 2);
    my $self = shift;
    return unless ($self->can_rts());
    my $delay = (shift)/1000;
    $self->rts_active(1) or warn "could not pulse rts on\n";
    select (undef, undef, undef, $delay);
    $self->rts_active(0) or warn "could not restore from rts on\n";
    select (undef, undef, undef, $delay);
    1;
}

sub pulse_dtr_on {
    return unless (@_ == 2);
    my $self = shift;
    return unless $self->can_ioctl();
    my $delay = (shift)/1000;
    $self->dtr_active(1) or warn "could not pulse dtr on\n";
    select (undef, undef, undef, $delay);
    $self->dtr_active(0) or warn "could not restore from dtr on\n";
    select (undef, undef, undef, $delay);
    1;
}

sub pulse_rts_off {
    return unless (@_ == 2);
    my $self = shift;
    return unless ($self->can_rts());
    my $delay = (shift)/1000;
    $self->rts_active(0) or warn "could not pulse rts off\n";
    select (undef, undef, undef, $delay);
    $self->rts_active(1) or warn "could not restore from rts off\n";
    select (undef, undef, undef, $delay);
    1;
}

sub pulse_dtr_off {
    return unless (@_ == 2);
    my $self = shift;
    return unless $self->can_ioctl();
    my $delay = (shift)/1000;
    $self->dtr_active(0) or warn "could not pulse dtr off\n";
    select (undef, undef, undef, $delay);
    $self->dtr_active(1) or warn "could not restore from dtr off\n";
    select (undef, undef, undef, $delay);
    1;
}

sub debug {
    my $self = shift;
    if (ref($self))  {
        if (@_) { $self->{"_DEBUG"} = yes_true ( shift ); }
        if (wantarray) { return @binary_opt; }
        else {
	    my $tmp = $self->{"_DEBUG"};
            nocarp || carp "Debug level: $self->{ALIAS} = $tmp";
            return $self->{"_DEBUG"};
        }
    } else {
        if (@_) { $Babble = yes_true ( shift ); }
        if (wantarray) { return @binary_opt; }
        else {
            nocarp || carp "Debug Class = $Babble";
            return $Babble;
        }
    }
}

sub close {
    my $self = shift;
    my $ok = undef;
    my $item;

    return unless (defined $self->{NAME});

    if ($Babble) {
        carp "Closing $self " . $self->{ALIAS};
    }
    if ($self->{FD}) {
        purge_all ($self);

        # Gracefully handle shutdown without termios
        if (defined($self->{TERMIOS})) {
            # copy the original values into "current" values
            foreach $item (keys %c_cc_fields) {
        	    $self->{"C_$item"} = $self->{"_$item"};
    	    }

        	$self->{"C_CFLAG"} = $self->{"_CFLAG"};
        	$self->{"C_IFLAG"} = $self->{"_IFLAG"};
        	$self->{"C_ISPEED"} = $self->{"_ISPEED"};
        	$self->{"C_LFLAG"} = $self->{"_LFLAG"};
        	$self->{"C_OFLAG"} = $self->{"_OFLAG"};
        	$self->{"C_OSPEED"} = $self->{"_OSPEED"};

        	write_settings($self);
        }

        $ok = POSIX::close($self->{FD});

    	# we need to explicitly close this handle
    	$self->{HANDLE}->close if (defined($self->{HANDLE}) &&
                                   $self->{HANDLE}->opened);

    	$self->{FD} = undef;
    	$self->{HANDLE} = undef;
    }
    if ($self->{LOCK}) {
    	unless ( unlink $self->{LOCK} ) {
            nocarp or carp "can't remove lockfile: $self->{LOCK}\n";
    	}
        $self->{LOCK} = "";
    }
    $self->{NAME} = undef;
    $self->{ALIAS} = undef;
    return unless ($ok);
    1;
}

sub ioctl
{
    my ($self,$code,$ref) = @_;
    return undef unless (defined $self->{NAME});


    if ($Babble) {
        my $num = $$ref;
        $num = unpack('L', $num);
        carp "ioctl $code($bits->{$code}) $ref: $num";
    }

    my $magic;
    if (!defined($magic = $bits->{$code})) {
        carp "cannot ioctl '$code': no system value found\n";
        return undef;
    }

    if (!ioctl($self->{HANDLE},$magic,$$ref)) {
        carp "$code($magic) ioctl failed: $!";
        return undef;
    }

    return 1;
}

##### tied FileHandle support

# DESTROY this
#      As with the other types of ties, this method will be called when the
#      tied handle is about to be destroyed. This is useful for debugging and
#      possibly cleaning up.

sub DESTROY {
    my $self = shift;
    return unless (defined $self->{NAME});
    if ($self->{"_DEBUG"}) {
        carp "Destroying $self->{NAME}";
    }
    $self->close;
}

sub TIEHANDLE {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    return unless (@_);

#    my $self = start($class, shift);
    return new($class, @_);
}

# WRITE this, LIST
#      This method will be called when the handle is written to via the
#      syswrite function.

sub WRITE {
    return if (@_ < 3);
    my $self = shift;
    my $buf = shift;
    my $len = shift;
    my $offset = 0;
    if (@_) { $offset = shift; }
    my $out2 = substr($buf, $offset, $len);
    return unless ($self->post_print($out2));
    return length($out2);
}

# PRINT this, LIST
#      This method will be triggered every time the tied handle is printed to
#      with the print() function. Beyond its self reference it also expects
#      the list that was passed to the print function.

sub PRINT {
    my $self = shift;
    return unless (@_);
    my $ofs = $, ? $, : "";
    if ($self->{OFS}) { $ofs = $self->{OFS}; }
    my $ors = $\ ? $\ : "";
    if ($self->{ORS}) { $ors = $self->{ORS}; }
    my $output = join($ofs,@_);
    $output .= $ors;
    return $self->post_print($output);
}

sub output_field_separator {
    my $self = shift;
    my $prev = $self->{OFS};
    if (@_) { $self->{OFS} = shift; }
    return $prev;
}

sub output_record_separator {
    my $self = shift;
    my $prev = $self->{ORS};
    if (@_) { $self->{ORS} = shift; }
    return $prev;
}

sub post_print {
    my $self = shift;
    return unless (@_);
    my $output = shift;
    my $to_do = length($output);
    my $done = 0;
    my $written = 0;
    while ($done < $to_do) {
        my $out2 = substr($output, $done);
        $written = $self->write($out2);
	if (! defined $written) {
            return;
        }
	return 0 unless ($written);
	$done += $written;
    }
    1;
}

# PRINTF this, LIST
#      This method will be triggered every time the tied handle is printed to
#      with the printf() function. Beyond its self reference it also expects
#      the format and list that was passed to the printf function.

sub PRINTF {
    my $self = shift;
    my $fmt = shift;
    return unless ($fmt);
    return unless (@_);
    my $output = sprintf($fmt, @_);
    $self->PRINT($output);
}

# READ this, LIST
#      This method will be called when the handle is read from via the read
#      or sysread functions.

sub READ {
    return if (@_ < 3);
    my $buf = \$_[1];
    my ($self, $junk, $size, $offset) = @_;
    unless (defined $offset) { $offset = 0; }
    my $count_in = 0;
    my $string_in = "";

    ($count_in, $string_in) = $self->read($size);

    $$buf = '' unless defined $$buf;
    my $buflen = length $$buf;

    my ($tail, $head) = ('','');

    if($offset >= 0){ # positive offset
       if($buflen > $offset + $count_in){
           $tail = substr($$buf, $offset + $count_in);
       }

       if($buflen < $offset){
           $head = $$buf . ("\0" x ($offset - $buflen));
       } else {
           $head = substr($$buf, 0, $offset);
       }
    } else { # negative offset
       $head = substr($$buf, 0, ($buflen + $offset));

       if(-$offset > $count_in){
           $tail = substr($$buf, $offset + $count_in);
       }
    }

    # remaining unhandled case: $offset < 0 && -$offset > $buflen
    $$buf = $head.$string_in.$tail;
    return $count_in;
}

# READLINE this
#      This method will be called when the handle is read from via .
#      The method should return undef when there is no more data.

sub READLINE {
    my $self = shift;
    return if (@_);
    my $count_in = 0;
    my $string_in = "";
    my $match = "";
    my $was;

    if (wantarray) {
	my @lines;
        for (;;) {
            last if ($was = $self->reset_error);	# dummy, currently
	    if ($self->stty_icanon) {
	        ($count_in, $string_in) = $self->read_vmin(255);
                last if (! defined $count_in);
	    }
	    else {
                $string_in = $self->streamline($self->{"_SIZE"});
                last if (! defined $string_in);
	        $match = $self->matchclear;
                if ( ($string_in ne "") || ($match ne "") ) {
		    $string_in .= $match;
                }
	    }
            push (@lines, $string_in);
	    last if ($string_in =~ /$self->{"_CLASTLINE"}/s);
        }
	return @lines if (@lines);
        return;
    }
    else {
	my $last_icanon = $self->stty_icanon;
        $self->stty_icanon(1);
        for (;;) {
            last if ($was = $self->reset_error);	# dummy, currently
            $string_in = $self->lookfor($self->{"_SIZE"});
            last if (! defined $string_in);
	    $match = $self->matchclear;
            if ( ($string_in ne "") || ($match ne "") ) {
		$string_in .= $match; # traditional  behavior
	        $self->stty_icanon(0);
	        return $string_in;
	    }
        }
	$self->stty_icanon($last_icanon);
        return;
    }
}

# GETC this
#      This method will be called when the getc function is called.

sub GETC {
    my $self = shift;
    my ($count, $in) = $self->read(1);
    if ($count == 1) {
        return $in;
    }
    return;
}

# CLOSE this
#      This method will be called when the handle is closed via the close
#      function.

sub CLOSE {
    my $self = shift;
    $self->write_drain;
    my $success = $self->close;
    if ($Babble) { printf "CLOSE result:%d\n", $success; }
    return $success;
}

# FILENO this
#	This method will be called if we ever need the FD from the handle

sub FILENO {
    my $self = shift;
    return $self->{FD};
}

1;  # so the require or use succeeds

__END__