File Coverage

blib/lib/Hardware/PortScanner.pm

Criterion	Covered	Total	%
statement	129	422	30.5
branch	35	162	21.6
condition	3	20	15.0
subroutine	17	35	48.5
pod	7	9	77.7
total	191	648	29.4

#!/usr/bin/perl

package Hardware::PortScanner;

our $debug = 0;

our $IsWin = 1 if ( $^O eq 'MSWin32' );

if ($IsWin) {
    require Win32::SerialPort;
    Win32::SerialPort::debug( "true", "True" ) if ($debug);
}
else {
    require Device::SerialPort;
    Device::SerialPort::debug( "true", "True" ) if ($debug);
}

use Data::Dumper;    # Remove before production

# $Data::Dumper::Useqq = 1; # Remove before production

use Carp;

# $Carp::Verbose = 0;

use strict;
use warnings;

our $VERSION;
$VERSION = '0.51';

# PortScanner constructor

sub new(;@) {
    my $serial = bless( {} );
    my $class = shift if ( $_[0] =~ /::/ );
    my $parm;
    my $value;
    my $parm_found;

    # Default

    $serial->{MAX_PORT} = 20;

    # Parse Parameters

    while ( $parm = uc shift ) {
        $parm_found = 0;
        $value      = shift;

        if ( $parm eq "MAX_PORT" ) {
            $value =~ s/^COM//i;

            if ( $value !~ /^\d+$/ ) {
                croak "ERROR: (new): MAX_PORT \$value\" must be a number\n";
            }
            $serial->{MAX_PORT} = $value;
            $parm_found++;
        }

        if ( !$parm_found ) {
            croak "Parmeter passed to new() \"$parm\" is not valid\n";
        }
    }

    # These must be here - they are not for show

    # This one can be changed
    $serial->{READ_CONST_TIME} = 100;    # in msecs

    # This one can be changed but it will mess up our wait time calculations (since it is ignored)
    $serial->{READ_CHAR_TIME} = 0;       # in msecs

    return $serial;
}

# Creates the port name from a com number portably

sub _get_com_device_name($) {
    my $serial   = shift;
    my $com_port = shift;

    if ($IsWin) {

        # Yea, this is some weird windows crap
        return '\\\\.\\' . "COM$com_port";
    }
    else {
        return sprintf( '/dev/ttyS%d', $com_port - 1 );
    }

}

# get a connection to a port portably

sub _get_com_connection($;$) {
    my $serial   = shift;
    my $com_port = shift;
    my $quite    = shift || 1;
    my $com_device_name;
    my $PortObj;

    $com_device_name = $serial->_get_com_device_name($com_port);

    {
        local $SIG{__WARN__} = sub {
            my $err;

            if ( grep { $_ =~ /can.t getattr:/ } @_ ) {
                $err = "      Warning: (get_connection): " . join( " ", @_ );
                $err =~ s/\015?\012$//;
                $serial->_add_scan_log($err);
            }
            else {
                print STDERR @_;
            }
            return 1;
        };

        if ($IsWin) {
            $PortObj = new Win32::SerialPort( "$com_device_name", $quite );

        }
        else {
            $PortObj = new Device::SerialPort( "$com_device_name", $quite );
        }
    }

    return $PortObj;

}

# Internal method to collect messages for scan_log

sub _add_scan_log($) {
    my $serial = shift;
    push( @{ $serial->{SCAN_LOG} }, @_ );

    print "DEBUG: $_[0] \n" if ($debug);
}

sub scan_log($) {
    my $serial   = shift;
    my @scan_log = ();

    @{ $serial->{SCAN_LOG} } = () if ( !defined( $serial->{SCAN_LOG} ) );

    foreach ( @{ $serial->{SCAN_LOG} } ) {
        s/\015/\\r/g;
        s/\012/\\n/g;
        s/\011/\\t/g;
        push( @scan_log, $_ );
    }

    return @scan_log;
}

sub scan_report() {
    my $serial = shift;

    foreach ( $serial->scan_log ) {
        print "$_\n";
    }
}

sub num_found_devices($) {
    my $serial = shift;

    return defined( $serial->{FOUND_DEVICE} ) ? scalar( @{ $serial->{FOUND_DEVICE} } ) : 0;
}

sub found_devices($) {
    my $serial = shift;

    return defined( $serial->{FOUND_DEVICE} ) ? @{ $serial->{FOUND_DEVICE} } : ();
}

sub connection($) {
    my $serial = shift;

    return $serial->{CONNECTION};
}

sub available_com_ports(;@) {
    my $serial = shift;
    my $com_port;
    my $com_device_name;
    my @ports;
    my $PortObj;

    for ( $com_port = 1 ; $com_port <= $serial->{MAX_PORT} ; $com_port++ ) {

        $PortObj = $serial->_get_com_connection($com_port);

        if ($PortObj) {
            push( @ports, $com_port );
            $PortObj->close;
            undef $PortObj;
        }

        undef $PortObj;    # Just extra safe measure
    }

    return @ports;
}

sub scan_ports(;@) {
    my $serial = shift;
    my $com_port;
    my $com_device_name;
    my $PortObj;
    my $feedback;
    my $count_in;
    my $send;
    my $baud;
    my $parm;
    my $value;
    my $key;
    my ( $databits, $parity, $stopbits, $handshake );
    my $setting;
    my $device;
    my $config = $serial->{SEARCH_PARM} = {};
    my $parm_found;
    my $read_iterations;
    my $iterations;
    my $chars = 0;
    my ( $bytes_read, $data_read );
    my $waited;

    $serial->_add_scan_log("Scan Ports Request");
    $serial->_add_scan_log("==================");

    # Parse parameters

    while ( $parm = uc shift ) {
        $value      = shift;
        $parm_found = 0;

        $key = "BAUD";
        if ( $parm eq $key ) {
            if ( ref $value eq "ARRAY" ) {
                @{ $config->{$key} } = @{$value};
            }
            elsif ( ref $value eq "" ) {
                @{ $config->{$key} } = ($value);
            }
            else {
                croak "ERROR: (scan_ports): $key value must be either a SCALAR or ARRAY REF\n";
            }

            foreach ( @{ $config->{$key} } ) {
                if ( !/^\d+$/ ) {
                    croak "ERROR: (scan_ports): BAUD rate \$_\" not valid\n";
                }
            }
            $parm_found++;
        }

        $key = "COM";
        if ( $parm eq $key ) {

            if ( ref $value eq "ARRAY" ) {
                @{ $config->{$key} } = map { s/^COM(\d+)/$1/; $_; } @{$value};
            }
            elsif ( ref $value eq "" ) {
                @{ $config->{$key} } = map { s/^COM(\d+)/$1/; $_; } ($value);
            }
            else {
                croak "ERROR: (scan_ports): $key value must be either a SCALAR or ARRAY REF\n";
            }

            foreach ( @{ $config->{$key} } ) {
                if ( !( /^\d+$/ && $_ > 0 && $_ <= 50 ) ) {
                    croak "ERROR: (scan_ports): COM port \"$_\" not valid\n";
                }
            }
            $parm_found++;
        }

        $key = "SETTING";
        if ( $parm eq $key ) {
            foreach ( ref $value eq "ARRAY" ? @{$value} : ($value) ) {

                $value = uc $value;
                if (/^([5678])([NEO])([12])([NRX])?$/) {
                    no warnings;

                    $databits  = $1;
                    $parity    = $2 eq "E" ? "even" : ( $2 eq "O" ? "odd" : "none" );
                    $stopbits  = $3;
                    $handshake = $4 eq "R" ? "rts" : ( $4 eq "X" ? "xoff" : "none" );

                    push(
                        @{ $config->{SETTING} },
                        {
                            DATABITS  => $databits,
                            PARITY    => $parity,
                            STOPBITS  => $stopbits,
                            HANDSHAKE => $handshake,
                            SETTING   => $_
                        }
                    );
                }
                else {
                    croak "ERROR: (scan_ports): SETTING value of \"$_\" is not valid\n";
                }
            }
            $parm_found++;
        }

        $key = "MAX_WAIT";
        if ( $parm eq $key ) {
            if ( $value !~ /^\d+$/ && $value !~ /^\d+[.]\d+$/ ) {
                croak "ERROR: (scan_ports): $key value must be an integer or float in seconds\n";
            }

            if ( ref $value eq "" ) {
                $config->{$key} = $value;
            }
            else {
                croak "ERROR: (scan_ports): $key value must be a SCALAR\n";
            }
            $parm_found++;
        }

        $key = "TEST_STRING";
        if ( $parm eq $key ) {
            if ( ref $value eq "" ) {
                $config->{$key} = $value;
            }
            else {
                croak "ERROR: (scan_ports): $key value must be a SCALAR\n";
            }
            $parm_found++;
        }

        $key = "VALID_REPLY_RE";
        if ( $parm eq $key ) {
            if ( ref $value eq "" ) {
                $config->{$key} = qr/$value/;
            }
            else {
                croak "ERROR: (scan_ports): $key value must be a SCALAR\n";
            }
            $parm_found++;
        }

        if ( !$parm_found ) {
            croak "ERROR: (scan_ports): Parameter \"$parm\" is not valid for scan port\n";
        }

    }

    if ( !exists( $config->{TEST_STRING} ) || !exists( $config->{VALID_REPLY_RE} ) ) {
        croak "ERROR: (scan_ports): TEST_STRING and VALID_REPLY must be provided to scan_ports\n";
    }

    # Handle Default when certain parms were not provided

    if ( !exists( $config->{BAUD} ) ) {
        @{ $config->{BAUD} } = (qw/1200 2400 4800 9600 19200 38400 57600 115200/);
    }

    if ( !exists( $config->{COM} ) ) {
        @{ $config->{COM} } = ( 1 .. $serial->{MAX_PORT} );
    }

    if ( !exists( $config->{SETTING} ) ) {

        # Default for setting when not provided

        push(
            @{ $config->{SETTING} },
            {
                DATABITS  => 8,
                PARITY    => "none",
                STOPBITS  => 1,
                HANDSHAKE => "none",
                SETTING   => "8N1"
            }
        );
    }

    # Figure the number of read iterations is needed

    if ( exists( $config->{MAX_WAIT} ) ) {
        $serial->_add_scan_log("(Max Wait set at $config->{MAX_WAIT})");
        $read_iterations = int( $config->{MAX_WAIT} / ( $serial->{READ_CONST_TIME} / 1000 ) );
        $read_iterations = 1 if ( $read_iterations < 1 );

    }
    else {

        # Must always go though the loop once
        $read_iterations = 1;
    }

    # Begin Scan of Com Ports

  PORT:
    foreach $com_port ( sort { $a <=> $b } @{ $config->{COM} } ) {

        $com_device_name = $serial->_get_com_device_name($com_port);
        $serial->_add_scan_log("Scan Port COM${com_port} @ $com_device_name");

        # Baud rates are attempted from highest to lowest because some
        # might be using a virtual COM via USB and it "looks" nicer to
        # see the faster buad rate (virtual USB com ports dont care about baud rates or settings)

      BAUD:
        foreach $baud ( sort { $b <=> $a } @{ $config->{BAUD} } ) {
            $serial->_add_scan_log("   Checking with baudrate of $baud");

          SETTING:
            foreach $setting ( sort { $b <=> $a } @{ $config->{SETTING} } ) {
                $serial->_add_scan_log("      Checking with setting of $setting->{SETTING}");
                $PortObj = $serial->_get_com_connection($com_port);

                if ($PortObj) {

                    #$PortObj->user_msg("ON");
                    if ( !$PortObj->baudrate($baud) ) {

                        # If *::SerialPort says this baudrate is invalid then go to the next one
                        # (eg. Dont keep scanning it at other settings)
                        $serial->_add_scan_log("      Warning: Baud rate of $baud is not valid for this com port - skipping to next one");
                        next BAUD;
                    }

                    $PortObj->databits( $setting->{DATABITS} );
                    $PortObj->parity( $setting->{PARITY} );
                    $PortObj->stopbits( $setting->{STOPBITS} );
                    $PortObj->handshake( $setting->{HANDSHAKE} );

                    # Just kept this based on *::SerialPort examples
                    $PortObj->buffers( 4096, 4096 );

                    if ( $PortObj->write_settings ) {

                        # Ok, port is available, now is it our device?

                        $PortObj->write( $config->{TEST_STRING} );

                        $serial->_add_scan_log("         Sending test string \"$config->{TEST_STRING}\"");

                        # Due to a bug or something, this locks up
                        # on Windows sometimes

                        $PortObj->read_char_time( $serial->{READ_CHAR_TIME} );
                        $PortObj->read_const_time( $serial->{READ_CONST_TIME} );

                        $feedback = "";

                        # Calculated outside loops for performance

                        $waited = 0;

                        # Wait a maximum amount of time to get expected output but move on
                        # if we dont get it in the alloted amount of time.  This also protects
                        # us from a device just spewing data.

                        for ( $iterations = 1 ; $iterations <= $read_iterations ; $iterations++ ) {

                            # Read from the port
                            ( $bytes_read, $data_read ) = $PortObj->read(255);    # docs say this must be 255 always
                            $waited += $serial->{READ_CONST_TIME};

                            if ( $bytes_read > 0 ) {
                                $feedback .= $data_read;

                                # This is what makes this loop faster
                                last if ( $feedback =~ /$config->{VALID_REPLY_RE}/ );
                            }
                        }

                        $feedback =~ s/\015?\012$//;

                        $serial->_add_scan_log( sprintf( "         Received back from device \"%s\" (Waited %.2f secs)", $feedback, $waited / 1000 ) );

                        if ( $feedback =~ /$config->{VALID_REPLY_RE}/ ) {

                            # Get a new "device" and store all the properties in it

                            $device = Hardware::PortScanner::Device->new_device($serial);

                            $device->com_port("COM${com_port}");
                            $device->baudrate($baud);
                            $device->databits( $setting->{DATABITS} );
                            $device->parity( $setting->{PARITY} );
                            $device->stopbits( $setting->{STOPBITS} );
                            $device->handshake( $setting->{HANDSHAKE} );
                            $device->port_name($com_device_name);
                            $device->setting( $setting->{SETTING} );
                            $device->{VALID_REPLY} = $feedback;
                            $device->{TEST_STRING} = $config->{TEST_STRING};
                            $device->{MAX_WAIT}    = $config->{MAX_WAIT} if ( exists( $config->{MAX_WAIT} ) );

                            push( @{ $serial->{FOUND_DEVICE} }, $device );

                            # Since this device was found, skip scanning on this port anymore

                            $serial->_add_scan_log("         Matched valid reply RE so returning");
                            last BAUD;
                        }
                    }

                    $PortObj->close;
                    undef $PortObj;

                }    # PortObj
                else {
                    $serial->_add_scan_log("   Com Port $com_port appears not to be available - skipping to next port");
                    next PORT;
                }
            }    # Setting
        }    # Baud
    }    # Com Port

}

sub connect_to_device(@) {
    my $serial = shift;
    my $PortObj;
    my $port;
    my $baud;
    my $config = {};
    my $parm;
    my $value;
    my $key;
    my ( $databits, $parity, $stopbits, $handshake );
    my $setting;
    my $device;
    my $parm_found;

    # If there is a connection then remove it so this method is
    # reentrant

    if ( defined( $serial->{CONNECTION} ) ) {
        $serial->{CONNECTION}->close;
        undef $serial->{CONNECTION};
    }

    # Handle no parameters by assuming the user wants to connect to the only
    # device found by faking the passing of "DEVICE => $device" if one
    # and only one was found

    if ( scalar(@_) == 0 ) {
        if ( $serial->num_found_devices == 1 ) {
            @_ = ( "DEVICE", ( $serial->found_devices )[0] );
        }
        elsif ( $serial->num_found_devices == 0 ) {
            croak "ERROR: (connect_to_device): No devices were found or not scanned - cannot auto-connect\n";
        }
        else {
            croak "ERROR: (connect_to_device): More than one device was found - cannot auto-connect\n";
        }
    }

    # Handle the normal parameters

    while ( $parm = uc shift ) {
        $value      = shift;
        $parm_found = 0;

        $key = "BAUD";
        if ( $parm eq $key ) {
            if ( ref $value eq "" ) {
                $config->{$key} = $value;
            }
            else {
                croak "ERROR: (connect_to_device): $key value must be a SCALAR\n";
            }

            # Must be all digits.  We don't check the actual value because we will
            # let the *::SerialPort determine validity

            if ( $config->{$key} !~ /^\d+$/ ) {
                croak "ERROR: (connect_to_device): BAUD rate \"$value\" not valid\n";
            }
            $parm_found++;
        }

        $key = "COM";
        if ( $parm eq $key ) {

            if ( ref $value eq "" ) {

                # Handle the format of "COM5" or just "5"
                $value =~ s/^COM(\d+)/$1/i;
                $config->{$key} = $value;
            }
            else {
                croak "ERROR: (connect_to_device): $key value must be a SCALAR\n";
            }

            if ( !( $value =~ /^\d+$/ && $value > 0 && $value <= 50 ) ) {
                croak "ERROR: (connect_to_device): COM port\"$value\" not valid\n";
            }

            $config->{PORTNAME} = $serial->_get_com_device_name($value);

            $parm_found++;
        }

        $key = "SETTING";
        if ( $parm eq $key ) {
            $value = uc $value;
            if ( $value =~ /^([5678])([NEO])([12])([NRX])?$/ ) {
                no warnings;

                # Convert our setting format to domain expected by *::SerialPort

                $databits  = $1;
                $parity    = $2 eq "E" ? "even" : ( $2 eq "O" ? "odd" : "none" );
                $stopbits  = $3;
                $handshake = $4 eq "R" ? "rts" : ( $4 eq "X" ? "xoff" : "none" );

                $config->{SETTING} = {
                    DATABITS  => $databits,
                    PARITY    => $parity,
                    STOPBITS  => $stopbits,
                    HANDSHAKE => $handshake,
                    SETTING   => $value
                };
            }
            else {
                croak "ERROR: (connect_to_device): SETTING value of \"$value\" is not valid \n";
            }
            $parm_found++;
        }

        $key = "DEVICE";
        if ( $parm eq $key ) {
            $device = $value;

            if ( !defined($device) ) {
                croak "ERROR: (connect_to_device): device specified is undefined\n";
            }

            # Get the port configuration info from the device

            $config->{BAUD} = $device->baudrate;
            $config->{COM}  = $device->com_port;
            $config->{COM} =~ s/^COM(\d+)/$1/i;
            $config->{PORTNAME}             = $device->port_name;
            $config->{SETTING}->{DATABITS}  = $device->databits;
            $config->{SETTING}->{PARITY}    = $device->parity;
            $config->{SETTING}->{STOPBITS}  = $device->stopbits;
            $config->{SETTING}->{HANDSHAKE} = $device->handshake;
            $config->{SETTING}->{SETTING}   = $device->setting;

            $parm_found++;
        }

        # Check for unsupported options

        if ( !$parm_found ) {
            croak "ERROR: (connect_to_device): Parameter \"$parm\" is not valid for scan_port\n";
        }

    }

    # Baud is required to have been determined

    if ( !exists( $config->{BAUD} ) ) {
        croak "ERROR: (connect_to_device): Baud rate not specified or identifiable\n";
    }

    # Com Port is required to have been determined

    if ( !exists( $config->{COM} ) ) {
        croak "ERROR: (connect_to_device): Com port not specified or identifiable\n";
    }

    # Settings can be defaulted to most common if not specified

    if ( !exists( $config->{SETTING} ) ) {
        $config->{SETTING} = {
            DATABITS  => 8,
            PARITY    => "none",
            STOPBITS  => 1,
            HANDSHAKE => "none",
            SETTING   => "8N1"
        };
    }

    # Attempt to get connection to serial port

    $PortObj = $serial->_get_com_connection( $config->{COM}, 1 );

    if ($PortObj) {

        $PortObj->user_msg("ON");    # Should this be on?

        $PortObj->databits( $config->{SETTING}->{DATABITS} );
        $PortObj->baudrate( $config->{BAUD} );
        $PortObj->parity( $config->{SETTING}->{PARITY} );
        $PortObj->stopbits( $config->{SETTING}->{STOPBITS} );
        $PortObj->handshake( $config->{SETTING}->{HANDSHAKE} );
        $PortObj->buffers( 4096, 4096 );    # Better default?

        if ( !$PortObj->write_settings ) {

            # Getting this error is a little strange IF the device parameter was used

            croak "ERROR: (connect_to_device): Failed to write_settings to com port ($config->{COM})!\n";
            $PortObj->close;
            undef $PortObj;
        }

        # Store connection in meta-data
        $serial->{CONNECTION} = $PortObj;
    }
    else {
        croak "ERROR: (connect_to_device): Failed to connect to known com port ($config->{COM})!\n";
    }

    return 1;
}

# Circular references are used to handle them during garbage collection

sub DESTROY() {

    # Remove the child (device) reference so we will
    # not have circular references

    $_[0]->{FOUND_DEVICE} = undef;
    $_[0]->{CONNECTION}   = undef;

}

# Devices have there own package but I didnot want to have an additional
# module file so ... two in one

package Hardware::PortScanner::Device;

use Data::Dumper;    # Remove before production
use Carp;

$Data::Dumper::Useqq = 1;    # Remove before production

use strict;
use warnings;

# Get connection to device.  Used PortScanner method by same name

sub connect_to_device($) {
    my $device = shift;
    my $serial = $device->{SERIAL};

    return $serial->connect_to_device( DEVICE => $device );

}

# Constructor for new device

sub new_device($) {
    my $device = bless( {}, __PACKAGE__ );
    my $serial;
    my $class;

    if ( ref $_[0] ) {
        $serial = shift;
    }
    else {
        $class  = shift;
        $serial = shift;
    }

    $device->{SERIAL_OBJ} = $serial;

    return $device;
}

# Return/set baudrate for device

sub baudrate(;$) {
    my $device   = shift;
    my $att_name = "BAUD";

    if ( $_[0] ) {
        $device->{$att_name} = shift;
    }

    return $device->{$att_name};
}

# Return/set setting for device

sub setting(;$) {
    my $device   = shift;
    my $att_name = "SETTING";

    if ( $_[0] ) {
        $device->{$att_name} = shift;
    }

    return $device->{$att_name};
}

# Return/set databits for device

sub databits(;$) {
    my $device   = shift;
    my $att_name = "DATABITS";

    if ( $_[0] ) {
        $device->{$att_name} = shift;
    }

    return $device->{$att_name};
}

# Return/set stopbits for device

sub stopbits(;$) {
    my $device   = shift;
    my $att_name = "STOPBITS";

    if ( $_[0] ) {
        $device->{$att_name} = shift;
    }

    return $device->{$att_name};
}

# Return/set parity for device

sub parity(;$) {
    my $device   = shift;
    my $att_name = "PARITY";

    if ( $_[0] ) {
        $device->{$att_name} = shift;
    }

    return $device->{$att_name};
}

# Return/set handshake for device

sub handshake(;$) {
    my $device   = shift;
    my $att_name = "HANDSHAKE";

    if ( $_[0] ) {
        $device->{$att_name} = shift;
    }

    return $device->{$att_name};
}

# Return/set com_port for device

sub com_port(;$) {
    my $device   = shift;
    my $att_name = "COM";

    if ( $_[0] ) {
        $device->{$att_name} = shift;
        $device->{$att_name} =~ s/^\d+$/COM&/;
    }

    return $device->{$att_name};
}

# Return/set port_name for device

sub port_name(;$) {
    my $device   = shift;
    my $att_name = "PORTNAME";

    if ( $_[0] ) {
        $device->{$att_name} = shift;
    }

    return $device->{$att_name};
}

# Circular references are used to handle them during garbage collection

sub DESTROY() {

    # Remove the parent (serial) reference so we will
    # not have circular references

    $_[0]->{SERIAL} = undef;
}

1;

__END__