File Coverage

blib/lib/IPC/Serial.pm

Criterion	Covered	Total	%
statement	20	101	19.8
branch	0	40	0.0
condition	0	3	0.0
subroutine	7	14	50.0
pod	4	4	100.0
total	31	162	19.1

# -*-cperl-*-
#
# IPC::Serial - Simple message passing over serial ports
# Copyright (c) Ashish Gulhati
#
# $Id: lib/IPC/Serial.pm v1.007 Tue Oct 16 22:52:29 PDT 2018 $

use strict;

package IPC::Serial;

use 5.008001;
use warnings;
use strict;

use Device::SerialPort qw(:STAT);
use Digest::MD5 qw(md5_hex);

use vars qw( $VERSION $AUTOLOAD );

our ( $VERSION ) = '$Revision: 1.007 $' =~ /\s+([\d\.]+)/;

sub new {
  my $class = shift;
  my %args = @_;
  return undef unless $args{Port};
  return unless my $port = new Device::SerialPort ($args{Port});
  $port->read_char_time(0);     # don't wait for each character
  $port->read_const_time(10);   # 10 ms per unfulfilled "read" call
  $port->user_msg('ON');
  $port->databits(8);
  $port->baudrate(115200);
  $port->parity("none");
  $port->stopbits(1);
  $port->handshake("none");
  bless { Port => $port }, $class;
}

sub getmsg {
  my ($self, $idletimeout, $ack, $check) = @_;
  my ($buffer, $chars, $rcvd) = ('');
  until ($rcvd) {
    $buffer = '';
    if (defined $self->{savefragment}) { $buffer .= $self->{savefragment}; delete $self->{savefragment}; }
    my $timeout = $idletimeout;
    while ($timeout and $buffer !~ /\S\n/) {
      my ($count,$saw) = $self->{Port}->read(1024);
      if ($count > 0) {
	$buffer .= $saw;
	last if $buffer =~ /\S\n/;
	$timeout = $idletimeout;
      }
      else {
	$timeout--;
      }
    }
    if ($buffer =~ /\n/) {
      my $buf = $buffer;
      $buffer =~ s/^\s*(.+?)\:\n(.*)$/$1/s;
      my ($trailing, $cksum, $msg) = ($2);
      $self->{savefragment} .= $trailing if $trailing =~ /\S+/;
      if ($buffer =~ /(.+):(.*)/) {
	if ($2) {                        # Checksum attached
	  unless ($check) {
	    if ($ack) {                  # But wasn't expected. We seem to have missed an ACK
	      return 'ERR';
	    }
	  }
	  ($msg, $cksum) = ($1, $2);
	  if (_cksum($msg) eq $cksum) {   # Valid checksum, all good
	    $self->sendmsg('OK');
	    $buffer = $msg;
	    $rcvd = 1;
	  }
	  else {                         # Checksum mismatch
	    $self->_diag("GM B:$buffer\nBB:$buf\nM:$msg\nH:$cksum\n");
	    $self->sendmsg('ERR');
	  }
	}
	elsif ($check) {                 # No checksum but was expected, Error.
	  $self->_diag("GM B:$buffer\nBB:$buf\nM:$msg\nH:$cksum\n");
	  next if $buffer eq 'OK:';      # Ignore if it's a stray OK we missed
	  $self->sendmsg('ERR');
	}
	else {                           # No checksum in sent message, not expected
	  $buffer =~ s/\:$//;
	  $rcvd = 1;
	}
      }
      else {                             # No colon in sent message, serial ate it
	$self->_diag("GM B:$buffer\nBB:$buf\nM:$msg\nH:$cksum\n");
	$self->sendmsg('ERR');
      }
    }
    else {                               # Timed out waiting for response.
      $self->{savefragment} = $buffer if $buffer =~ /\S+/;
      return $ack ? 'ERR' : undef;       #  If we were waiting for an ACK, this is an error
    }
  }
  $buffer =~ s/(?
  return $buffer;
}

sub sendmsg {
  my ($self,$msg,$cksum) = @_;
  $self->_diag("sendmsg:$msg:\n");
  $msg =~ s/\;/\;\;/g; $msg =~ s/\:/\;/g;
  my $hexhash = $cksum ? _cksum($msg) : '';
  my $ack = ''; my $i = 1;
  while ($ack ne 'OK') {
    $self->_diag("sendmsg:$i:$msg:\n"); $i++;
    $self->{Port}->write("$msg:$hexhash:\n\n\n\n");
    $ack = $cksum ? $self->getmsg(100, 1, 0) : 'OK';
  }
  return 1;
}

sub close {
  my $self = shift;
  $self->port->close;
}

sub _cksum {
  md5_hex(shift);
}

sub _diag {
  my $self = shift;
  print STDERR @_;
}

sub AUTOLOAD {
  my $self = shift; (my $auto = $AUTOLOAD) =~ s/.*:://;
  return if $auto eq 'DESTROY';
  if ($auto =~ /^(port)$/x) {
    return $self->{"\u$auto"};
  }
  else {
    die "Could not AUTOLOAD method $auto.";
  }
}

1; # End of IPC::Serial

=head1 NAME

IPC::Serial - Simple message passing over serial ports

=head1 VERSION

 $Revision: 1.007 $
 $Date: Tue Oct 16 22:52:29 PDT 2018 $

=head1 SYNOPSIS

Simple message passing over serial ports.

    use IPC::Serial;

    my $serial1 = new IPC::Serial (Port => '/dev/cua00');
    my $serial2 = new IPC::Serial (Port => '/dev/cua01');

    $serial1->sendmsg("Hello there!");
    my $msg = $serial2->getmsg;

=head1 METHODS

=head2 new

=head2 getmsg

=head2 sendmsg

=head2 close

=head1 AUTHOR

Ashish Gulhati, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc IPC::Serial

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back

=head1 LICENSE AND COPYRIGHT

Copyright (c) Ashish Gulhati.

This software package is Open Software; you can use, redistribute,
and/or modify it under the terms of the Open Artistic License 2.0.

Please see L for the full license
terms, and ensure that the license grant applies to you before using
or modifying this software. By using or modifying this software, you
indicate your agreement with the license terms.