File Coverage

blib/lib/Device/RFXCOM/RX.pm

Criterion	Covered	Total	%
statement	115	117	98.2
branch	37	42	88.1
condition	9	15	60.0
subroutine	19	19	100.0
pod	3	3	100.0
total	183	196	93.3

use strict;
use warnings;
package Device::RFXCOM::RX;
$Device::RFXCOM::RX::VERSION = '1.163170';
# ABSTRACT: Module to support RFXCOM RF receiver


use 5.006;
use constant {
  DEBUG => $ENV{DEVICE_RFXCOM_RX_DEBUG},
  TESTING => $ENV{DEVICE_RFXCOM_RX_TESTING},
};
use base 'Device::RFXCOM::Base';
use Carp qw/croak/;
use IO::Handle;
use IO::Select;
use Device::RFXCOM::Response;
use Module::Pluggable
  search_path => 'Device::RFXCOM::Decoder',
  instantiate => 'new';


sub new {
  my $pkg = shift;
  $pkg->SUPER::_new(device => '/dev/rfxcom-rx', @_);
}

sub _init {
  my ($self, $cb) = @_;
  $self->_write(hex => 'F020', desc => 'version check');
  $self->_write(hex => 'F02A', desc => 'enable all possible receiving modes');
  $self->_write(hex => 'F041', desc => 'variable length with visonic',
                callback => $cb || $self->{init_callback});
  $self->{init} = 1;
}


sub read {
  my ($self, $timeout) = @_;
  my $res = $self->read_one(\$self->{_buf});
  return $res if (defined $res);
  $self->_discard_buffer_check() if ($self->{_buf} ne '');
  $self->_discard_dup_cache_check();
  my $fh = $self->filehandle;
  my $sel = IO::Select->new($fh);
 REDO:
  my $start = $self->_time_now;
  $sel->can_read($timeout) or return;
  my $bytes = sysread $fh, $self->{_buf}, 2048, length $self->{_buf};
  $self->{_last_read} = $self->_time_now;
  $timeout -= $self->{_last_read} - $start if (defined $timeout);
  unless ($bytes) {
    croak defined $bytes ? 'closed' : 'error: '.$!;
  }
  $res = $self->read_one(\$self->{_buf});
  $self->_write_now() if (defined $res);
  goto REDO unless ($res);
  return $res;
}



sub read_one {
  my ($self, $rbuf) = @_;
  return unless ($$rbuf);

  print STDERR "rbuf=", (unpack "H*", $$rbuf), "\n" if DEBUG;
  my $header_byte = unpack "C", $$rbuf;
  my %result =
    (
     header_byte => $header_byte,
     type => 'unknown',
    );
  $result{master} = !($header_byte&0x80);
  my $bits = $header_byte & 0x7f;
  my $msg = '';
  my @bytes;
  if (exists $self->{_waiting} && $header_byte == 0x4d) {

    print STDERR "got version check response\n" if DEBUG;
    $msg = $$rbuf;
    substr $msg, 0, 1, '';
    $$rbuf = '';
    $result{type} = 'version';
    @bytes = unpack 'C*', $msg;

  } elsif (exists $self->{_waiting} &&
           ( $header_byte == 0x2c || $header_byte == 0x41 )) {

    print STDERR "got mode response\n" if DEBUG;
    substr $$rbuf, 0, 1, '';
    $result{type} = 'mode';

  } elsif ($bits == 0) {

    print STDERR "got empty message\n" if DEBUG;
    substr $$rbuf, 0, 1, '';
    $result{type} = 'empty';

  } else {

    my $length = $bits / 8;

    print STDERR "bits=$bits length=$length\n" if DEBUG;
    return if (length $$rbuf < 1 + $length);

    if ($length != int $length) {
      $length = 1 + int $length;
    }

    $msg = substr $$rbuf, 0, 1 + $length, ''; # message from buffer
    substr $msg, 0, 1, '';
    @bytes = unpack 'C*', $msg;

    $result{key} = $bits.'!'.$msg;
    my $entry = $self->_cache_get(\%result);
    if ($entry) {
      print STDERR "using cache entry\n" if DEBUG;
      @result{qw/messages type/} = @{$entry->{result}}{qw/messages type/};
      $self->_cache_set(\%result);
    } else {
      foreach my $decoder (@{$self->{plugins}}) {
        my $matched = $decoder->decode($self, $msg, \@bytes, $bits, \%result)
          or next;
        ($result{type} = lc ref $decoder) =~ s/.*:://;
        last;
      }
      $self->_cache_set(\%result);
    }
  }

  @result{qw/data bytes/} = ($msg, \@bytes);
  return Device::RFXCOM::Response->new(%result);
}

sub _cache_get {
  my ($self, $result) = @_;
  $self->{_cache}->{$result->{key}};
}

sub _cache_set {
  my ($self, $result) = @_;
  return if ($result->{dont_cache});
  my $entry = $self->{_cache}->{$result->{key}};
  if ($entry) {
    $result->{duplicate} = 1 if ($self->_cache_is_duplicate($entry));
    $entry->{t} = $self->_time_now;
    return $entry;
  }
  $self->{_cache}->{$result->{key}} =
    {
     result => $result,
     t => $self->_time_now,
    };
}

sub _cache_is_duplicate {
  my ($self, $entry) = @_;
  ($self->_time_now - $entry->{t}) < $self->{dup_timeout};
}

sub _discard_buffer_check {
  my $self = shift;
  if ($self->{_buf} ne '' &&
      $self->{_last_read} < ($self->_time_now - $self->{discard_timeout})) {
    $self->{_buf} = '';
  }
}

sub _discard_dup_cache_check {
  my $self = shift;
  if ($self->{_last_read} < ($self->_time_now - $self->{dup_timeout})) {
    $self->{_cache} = {};
  }
}

1;

__END__