File Coverage

blib/lib/Lirc/Client.pm

Criterion	Covered	Total	%
statement	153	167	91.6
branch	72	120	60.0
condition	16	25	64.0
subroutine	16	18	88.8
pod	7	10	70.0
total	264	340	77.6

package Lirc::Client;

# ABSTRACT: A client library for the Linux Infrared Remote Control

use strict;
use warnings;
use Moo;
use Carp;
use IO::Socket;
use File::Path::Expand;

our $VERSION = '2.02';

has prog => ( is => 'ro', required => 1 );   # the program name from lircrc file
has rcfile => ( is => 'ro', default => sub { "$ENV{HOME}/.lircrc" } );
has dev => ( is => 'ro', default => sub { '/dev/lircd' } );    # lircd device
has debug => ( is => 'ro', default => sub { 0 } );    # instance debug flag
has fake  => ( is => 'ro', default => sub { 0 } );    # fake the lirc connection
has sock          => ( is => 'rw' );                          # the lircd socket
has mode          => ( is => 'rw', default => sub { '' } );
has _in_block     => ( is => 'rw', default => sub { 0 } );
has _commands     => ( is => 'rw', default => sub { {} } );
has _startup_mode => ( is => 'rw' );
has _buf          => ( is => 'rw', default => sub { '' } );

sub BUILD {
    my $self = shift;

    if ( $self->fake ) {
        $self->sock( \*STDIN );
    } else {
        $self->sock(
            IO::Socket->new(
                Domain => &AF_UNIX,
                Type   => SOCK_STREAM,
                Peer   => $self->dev,
            ) ) or croak "couldn't connect to $self->dev: $!";
    }

    $self->_parse_lircrc( $self->rcfile );
    $self->mode( $self->_startup_mode ) if defined $self->_startup_mode;
    return 1;
}

sub BUILDARGS {
    my ( $class, @args ) = @_;

    my $cfg       = {};
    my @arg_names = qw{prog rcfile dev debug fake};    # get any passed by order

    carp
      "positional parameters for constructor is depreciated and will be removed from a future version"
      if @args and ref $args[0] ne 'HASH';

    while ( @args and ref $args[0] ne 'HASH' ) {
        my $arg_name = shift @arg_names;
        my $arg_val  = shift @args;
        $cfg->{$arg_name} = $arg_val if defined $arg_val;
    }

    if ( ref $args[0] eq 'HASH' ) {
        $cfg = { %$cfg, %{ shift @args } };    # Merge the two hashes
    }

    croak "new expects list of args or hash ref of named args" if @args;
    return $cfg;
}

sub clean_up {
    my $self = shift;

    if ( defined $self->sock ) {
        close $self->sock unless $self->fake;
    }

    return;
}

sub _parse_lircrc {    ## no critic
    my ( $self, $rcfilename ) = @_;

    open( my $rcfile, '<', $rcfilename )
      or croak "couldn't open lircrc file ($rcfilename): $!";

    my $in_block = 0;
    my $cur_mode = '';
    my $ops      = {};

    while (<$rcfile>) {
        s/^\s*#.*$//g;    # remove commented lines
        chomp;
        print "> ($rcfilename) ($cur_mode) $_\n" if $self->debug;

        ## begin block
        /^\s*begin\s*$/i && do {
            $in_block && croak "Found begin inside a block in line: $_\n";
            $in_block = 1;
            next;
        };

        ## end block
        /^\s*end\s*$/i && do {
            croak "found end outside of a block in line: $_\n" unless $in_block;

            if ( defined $ops->{flags} && $ops->{flags} =~ /\bstartup_mode\b/ )
            {
                croak "startup_mode flag given without a mode line"
                  unless defined $ops->{mode};
                $self->_startup_mode( $ops->{mode} );
                next;
            }

            croak "end of block found without a prog code at line: $_\n"
              unless defined $ops->{prog};
            $ops->{remote} ||= '*';
            my $key = join '-', $ops->{remote}, $ops->{button}, $cur_mode;
            my $val = $ops;

            $in_block = 0;
            $ops      = {};

            next unless $val->{prog} eq $self->prog;

            $self->_commands->{$key} = $val;

            next;
        };

        ## token = arg
        /^\s*([\w-]+)\s*=\s*(.*?)\s*$/ && do {
            my ( $tok, $act ) = ( $1, $2 );
            croak "unknown token found in rc file: $_\n"
              unless $tok =~ /^(prog|remote|button|repeat|config|mode|flags)$/i;
            $ops->{$tok} = $act;

            next;
        };

        ## begin mode
        /^\s*begin\s*([\w-]+)\s*$/i && do {
            croak "found embedded mode line: $_\n" if $1 && $cur_mode;
            $self->_startup_mode($1) if $1 eq $self->prog;
            $cur_mode = $1;
            next;
        };

        ## end mode
        /^\s*end\s*([\w-]+)\s*$/i && do {
            croak "end $1: found inside a begin/end block" if $in_block;
            croak "end $1: found without associated begin mode"
              unless $cur_mode eq $1;

            $cur_mode = '';
            next;
        };

        ## include file
        /^include\s+(.*)\s*$/ && do {
            my $file = $1;
            $file =~ s/^["<]|[">]$//g;
            $file = eval { expand_filename($file) };
            croak "error parsing include statement: $_\n" if $@;
            croak "could not find file ($file) in include: $_\n"
              unless -r $file;
            $self->_parse_lircrc($file);
            next;
        };

        ## blank lines
        /^\s*$/ && next;

        ## unrecognized
        croak sprintf "Couldn't parse lircrc file (%s) error in line: %s\n",
          $self->rcfile, $_;
    }
    close $rcfile;

    return;
}

sub recognized_commands {
    my $self = shift;

    return $self->_commands;
}

sub _get_lines {
    my $self = shift;

    # what is in the buffer now?
    printf "buffer1=%s\n", $self->_buf if $self->debug;

    # read anything in the pipe
    my $buf;
    my $status = sysread( $self->sock, $buf, 512 );
    ( carp "bad status from read" and return ) unless defined $status;

    # what is in the buffer after the read?
    $self->{_buf} .= $buf;
    print "buffer2=%s\n", $self->_buf if $self->debug;

    # separate the lines, leaving partial lines on _buf
    my @lines;
    push @lines, $1 while ( $self->{_buf} =~ s/^(.+)\n// );    ## no critic
           # while() tests that s/// matched

    return @lines;
}

sub nextcodes {
    return shift->next_codes();
}

sub next_codes {
    my $self = shift;

    my @lines = $self->_get_lines;
    print "==", join( ", ", map { defined $_ ? $_ : "undef" } @lines ), "\n"
      if $self->debug;
    return () unless scalar @lines;
    my @commands = ();
    for my $line (@lines) {
        chomp $line;
        print "Line: $line\n" if $self->debug;
        my $command = $self->parse_line($line);
        print "Command: ", ( defined $command ? $command : "undef" ), "\n"
          if $self->debug;
        push @commands, $command if defined $command;
    }
    return @commands;
}

sub nextcode {
    return shift->next_code();
}

sub next_code {
    my $self = shift;

    my $fh = $self->sock;
    while ( defined( my $line = <$fh> ) ) {
        chomp $line;
        print "Line: $line\n" if $self->debug;
        my $command = $self->parse_line($line);
        print "Command: ", ( defined $command ? $command : "undef" ), "\n"
          if $self->debug;
        return $command if defined $command;
    }
    return;    # no command found and lirc exited?
}

sub parse_line {    ## parse a line read from lircd
    my $self = shift;
    $_ = shift;

    printf "> (%s) %s\n", $self->_in_block, $_ if $self->debug;

    # Take care of response blocks
    ## Right Lirc::Client doesn't support LIST or VERSION, so we can ignore
    ## Responses that come inside a block
    if (/^\s*BEGIN\s*$/) {
        croak "got BEGIN inside a block from lircd: $_" if $self->_in_block;
        $self->_in_block(1);
        return;
    }
    if (/^\s*END\s*$/) {
        croak "got END outside a block from lircd: $_" if !$self->_in_block;
        $self->_in_block(0);
        return;
    }
    return if $self->_in_block;

    # Decipher IR Command
    # http://www.lirc.org/html/technical.html#applications
    #
    my ( $hex, $repeat, $button, $remote ) = split /\s+/;
    defined $button and length $button or do {
        carp "Unable to decode.\n";
        return;
    };

    my $commands = $self->_commands;
    my $cur_mode = $self->mode;
    my $command =
         $commands->{"$remote-$button-$cur_mode"}
      || $commands->{"*-$button-$cur_mode"}
      || $commands->{"$remote-*-$cur_mode"};
    defined $command or return;

    my $rep_count =
      $command->{repeat};    # default repeat count is 0 (ignore repeated keys)
    return if $rep_count ? hex($repeat) % $rep_count : hex $repeat;

    if ( defined $command->{flags} && $command->{flags} =~ /\bmode\b/ ) {
        $self->mode('');
    }
    if ( defined $command->{mode} ) { $self->mode( $command->{mode} ); }

    return unless defined $command->{config};
    printf ">> %s accepted --> %s\n", $button, $command->{config}
      if $self->debug;
    return $command->{config};
}

sub DEMOLISH {
    my $self = shift;
    print __PACKAGE__, ": DEMOLISH\n" if $self->debug;

    $self->clean_up;
    return;
}

1;

__END__