use strict;
use warnings;

use Win32::SerialPort;
use Getopt::Long;

# Strings with comport names
my $arg_com_a; 
my $arg_com_b;

GetOptions(
    'a:s' => \$arg_com_a,  # a should be the Belkin
    'b:s' => \$arg_com_b,  # we vary b to find out what's up
) or die "Bad command line options\n";


# Create a serial port object for the test
my $com_a = Win32::SerialPort->new( $arg_com_a )
    or die "Error opening $arg_com_a $!\n";
configure_comport($com_a);

my $com_b;  # a globalto store the b serial port object in.

# Begin testing.
foreach my $baudrate (qw( 9600 4800 2400 1200 600 300 )) {

    print "\nA-$arg_com_a: 9600 \tB-$arg_com_b: $baudrate\n";
    print '-'x30 . "\n";

    $com_b = Win32::SerialPort->new( $arg_com_b )
        or die "Error opening $arg_com_b $!\n";
    configure_comport($com_b, $baudrate);
    $com_b->write_settings; # This fails under XP


    test_send();

    test_recv();

    $com_b = undef;

}

exit;

# ==================================================================

# test_send ======================================
# Try sending data from A to B.
sub test_send {
    my $test_out = "ABCDEFG 1234567\n";

    $com_a->write($test_out);
    my $test_in = read_data($com_b, 5) || "";

    # read_data() excludes the lookfor() characters (in this case \n),
+ so we chomp to make it possible for the test strings to match
    chomp $test_out; 

    if ( $test_out eq $test_in ) {
        print "A TX\tSUCCESS: $test_in\n";
    } else {
        print "A TX\t->$test_out<-\nB RX\t->$test_in<-\n\n";
    }

}
# END test_send ==================================


# test_recv ======================================
# Try recieving data sent from B. 
sub test_recv {
    my $test_out = "ABCDEFG 1234567\n";

    $com_b->write($test_out);
    my $test_in = read_data($com_a, 5) || "";

    # read_data() excludes the lookfor() characters (in this case \n),
+ so we chomp to make it possible for the test strings to match
    chomp $test_out;
    
    if ( $test_out eq $test_in ) {
        print "B TX\tSUCCESS: $test_in\n";
    } else {
        print "B TX\t->$test_out<-\nA RX\t->$test_in<-\n\n";
    }

}
# END test_recv ==================================
  

# read_data ======================================
# Attempt to read data from a serial port object.
# First argument is a serial port object.
# Second argument is the timeout period in seconds.
sub read_data {
    my $p = shift;
    my $timeout = shift || 1;
    
    # Store timeout time in millisecond ticks.
    $timeout = $p->get_tick_count + (1000 * $timeout);

    $p->lookclear;  # Clear lookfor buffers
    my $gotit = "";

    while(1) {
        # polls until we have a line of data
        return unless ( defined ($gotit = $p->streamline) );
        if ($gotit ne "") {
            my ($found, $end, $pattern, $instead) = $p->lastlook;
            return "$gotit";
        }
        # or an error
        return if ($p->reset_error);
    if ($p->get_tick_count > $timeout) {
            my ($match, $after, $pattern, $instead) = $p->lastlook;
            return ;
        }
    }
}
# END read_data ==================================


# configure_comport ==============================
# Apply a standard configuration to a comport.
# First argument is a serial port object.
# Second argument is baudrate, defaults to 9600.
sub configure_comport {
    my $p = shift;
    my $baudrate = shift || 9600;

    $p->baudrate($baudrate);
    $p->parity('none');
    $p->databits(8);
    $p->stopbits(1);
    $p->handshake('none');

    $p->xon_limit(100);      # bytes left in buffer
    $p->xoff_limit(100);     # space left in buffer
    $p->xon_char(0x11);
    $p->xoff_char(0x13);
    $p->eof_char(0x0);
    $p->event_char(0x0);
    $p->error_char(0);       # for parity errors

    $p->buffers(4096, 4096);  # read, write

    $p->read_interval(100);    # max time between read char (milliseco
+nds)
    $p->read_char_time(5);     # avg time between read char
    $p->read_const_time(100);  # total = (avg * bytes) + const 
    $p->write_char_time(5);
    $p->write_const_time(100);

    $p->error_msg(1);
    $p->user_msg(1);

    $p->binary(1);      # Win2K really likes this to be true.

    # Match line endings.
    $p->are_match( 
        "\n",
    );

    $p->write_settings; # This fails under XP

}
# END configure_comport ====================
[download]

C:\Documents and Settings\Mark\Desktop>serialkiller.pl -a=COM5 -b=COM1

A-COM5: 9600    B-COM1: 9600
------------------------------
Break Signal detected
A TX    ->ABCDEFG 1234567<-
B RX    -><-

B TX    ->ABCDEFG 1234567<-
A RX    -><-


A-COM5: 9600    B-COM1: 4800
------------------------------
Framing Error detected
A TX    ->ABCDEFG 1234567<-
B RX    -><-

B TX    ->ABCDEFG 1234567<-
A RX    -><-


A-COM5: 9600    B-COM1: 2400
------------------------------
Framing Error detected
A TX    ->ABCDEFG 1234567<-
B RX    -><-

B TX    ->ABCDEFG 1234567<-
A RX    -><-


A-COM5: 9600    B-COM1: 1200
------------------------------
A TX    SUCCESS: ABCDEFG 1234567
B TX    SUCCESS: ABCDEFG 1234567

A-COM5: 9600    B-COM1: 600
------------------------------
Framing Error detected
A TX    ->ABCDEFG 1234567<-
B RX    -><-

B TX    ->ABCDEFG 1234567<-
A RX    -><-


A-COM5: 9600    B-COM1: 300
------------------------------
A TX    ->ABCDEFG 1234567<-
B RX    -><-

B TX    ->ABCDEFG 1234567<-
A RX    -><-