File Coverage

blib/lib/Device/CurrentCost.pm

Criterion	Covered	Total	%
statement	114	114	100.0
branch	35	38	92.1
condition	17	20	85.0
subroutine	24	25	96.0
pod	10	10	100.0
total	200	207	96.6

use strict;
use warnings;
package Device::CurrentCost;
$Device::CurrentCost::VERSION = '1.232151';
# ABSTRACT: Perl modules for Current Cost energy monitors


use constant DEBUG => $ENV{DEVICE_CURRENT_COST_DEBUG};

use Carp qw/croak carp/;
use Device::CurrentCost::Constants;
use Device::CurrentCost::Message;
use Device::SerialPort;
use Fcntl;
use IO::Handle;
use IO::Select;
use Symbol qw(gensym);
use Time::HiRes;


sub new {
  my ($pkg, %p) = @_;
  my $self = bless {
                    buf => '',
                    discard_timeout => 1,
                    type => CURRENT_COST_ENVY,
                    history_callback => sub {},
                    %p
                   }, $pkg;
  croak $pkg.q{->new: 'device' parameter is required}
    unless (exists $p{device} or exists $p{filehandle});
  $self->open();
  $self;
}


sub device { shift->{device} }


sub type { shift->{type} }


sub baud {
  my $self = shift;
  defined $self->{baud} ? $self->{baud} :
    $self->type == CURRENT_COST_CLASSIC ? 9600 : 57600;
}


sub filehandle { shift->{filehandle} }


sub serial_port { shift->{serial_port} }


sub open {
  my $self = shift;

  my $fh = $self->filehandle;
  unless ($fh) {
    my $dev = $self->device;
    print STDERR 'Opening serial port: ', $dev, "\n" if DEBUG;
    my $fh = gensym();
    my $s = tie *$fh, 'Device::SerialPort', $dev or
      croak "Could not tie serial port, $dev, to file handle: $!";
    foreach my $setting ([ baudrate => $self->baud ],
                         [ databits => 8 ],
                         [ parity => 'none' ],
                         [ stopbits => 1 ],
                         [ datatype => 'raw' ]) {
      my ($setter, @v) = @$setting;
      $s->$setter(@v);
    }
    $s->write_settings();
    sysopen($fh, $dev, O_RDWR|O_NOCTTY|O_NDELAY) or
      croak "sysopen of '$dev' failed: $!";
    $self->{serial_port} = $s;
    $self->{filehandle} = $fh;
  }
  $self->filehandle;
}


sub read {
  my ($self, $timeout) = @_;
  my $res = $self->read_one(\$self->{buf});
  return $res if (defined $res);
  $self->_discard_buffer_check();
  my $fh = $self->filehandle;
  my $sel = IO::Select->new($fh);
  do {
    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((ref $self).'->read: '.(defined $bytes ? 'closed' : 'error: '.$!));
    }
    print STDERR 'Read ', $bytes, "bytes\n" if DEBUG;
    $res = $self->read_one(\$self->{buf});
    return $res if (defined $res);
  } while (1);
}


sub read_one {
  my ($self, $rbuf) = @_;
  return unless ($$rbuf);
  print STDERR 'Read one from !', $$rbuf, "!\n" if DEBUG;
  if ($$rbuf =~ s!^.*?(.*?)[\r\n ]*!!s) {
    my $msg = Device::CurrentCost::Message->new(message => $1);
    my $t = $self->_time_now;
    if ($msg->has_history) {
      my $new = $msg->history;
      my $our= $self->{history} || ($self->{history} = {});
      foreach my $sensor (sort keys %$new) {
        foreach my $interval (sort keys %{$new->{$sensor}}) {
          foreach my $age (keys %{$new->{$sensor}->{$interval}}) {
            $our->{$sensor}->{$interval}->{pending}->{$age} =
              0+$new->{$sensor}->{$interval}->{$age};
          }
          if (exists $our->{$sensor}->{$interval}->{pending}->{1} ||
              ($interval eq 'hours' &&
               (exists $our->{$sensor}->{$interval}->{pending}->{4} ||
                exists $our->{$sensor}->{$interval}->{pending}->{2}))) {
            my $entries = keys %{$our->{$sensor}->{$interval}->{pending}};
            if ($entries == { years => 4, months => 21, # envy
                              days => 90, hours => 372 }->{$interval} ||
                $entries == { years => 4, months => 12, # classic
                              days => 31, hours => 13 }->{$interval}) {
              %{$our->{$sensor}->{$interval}->{current}} =
                %{$our->{$sensor}->{$interval}->{pending}};
              $our->{$sensor}->{$interval}->{time} = $t;
              $self->{history_callback}->($sensor, $interval,
                   $our->{$sensor}->{$interval}->{current});
            }
            $our->{$sensor}->{$interval}->{pending} = {};
          }
        }
      }
    }
    return $msg;
  } else {
    return;
  }
}


sub sensor_history {
  my ($self, $sensor, $interval) = @_;
  return unless (exists $self->{history}->{$sensor}->{$interval}->{current});
  return {
          time => $self->{history}->{$sensor}->{$interval}->{time},
          data => $self->{history}->{$sensor}->{$interval}->{current}
         };
}

sub _discard_buffer_check {
  my $self = shift;
  if ($self->{buf} ne '' &&
      $self->{_last_read} < ($self->_time_now - $self->{discard_timeout})) {
    carp "Discarding '", $self->{buf}, "'";
    $self->{buf} = '';
  }
}

sub _time_now {
  Time::HiRes::time;
}

1;

__END__