File Coverage

blib/lib/RCU.pm

Criterion	Covered	Total	%
statement	6	71	8.4
branch	0	28	0.0
condition	0	16	0.0
subroutine	2	16	12.5
pod	4	4	100.0
total	12	135	8.8

=head1 NAME

RCU - Remote Control Unit Interface

=head1 SYNOPSIS

   use RCU;

=head1 DESCRIPTION

This module provides a generic interface to remote control units (only
receivers at the moment, as I cannot test more). It only provides an
abstract management interface, other modules are required for the hardware
access (RCU::Irman and RCU::Lirc are included, however).

=head2 GETTING STARTED

Please read L to get some idea on how to proceed after you
installed the module (testing & standard techniques).

=head1 THE RCU CLASS

The RCU class provides a general interface to anything you might want to
do to, it represents your application.

=over 4

=cut

package RCU;

$VERSION = 0.021;

use Carp;

=item $rcu = new RCU "interface-spec"

Creates a new RCU application. C must be an interface
specification similar to DBI's DSN:

 RCU:ifname:arg:arg...

Examples:
low-level interface (without C prefix) or an arrayref containing
name and constructor arguments. If the interface name has a C<::> prefix
it will be used as-is (without that prefix, of course).

For a much better interface, see L.

=cut

sub new {
   my $class = shift;
   my $if = shift;
   my $self = bless {}, $class;

   my ($rcu, $ifname, @ifargs) = split /:/, $if;
   $rcu eq "RCU" or croak "unknown interface name syntax";
   $ifname = "RCU::$ifname";
   do { eval "require $ifname"; die $@ if $@ } unless exists ${"$ifname\::"}{VERSION}; # best bet
   $self->{if} = $ifname->new(@ifargs);

   $self;
}

=item $rcu->interface

Return the RCU::Interface object used by this RCU object.

=cut

sub interface {
   $_[0]->{if};
}

=item ($keycode, $repeat) = $rcu->get

=item ($keycode, $repeat) = $rcu->poll

Simplified interface to the RCU (See also L), return a cooked
keycode and a repeat count (initial keypress = 0, increasing while the
key is pressed). If C is called in scalar context it only returns
unrepeated keycodes.

This interface is problematic: no key-up events are generated, and
the repeat events occur pseudo-randomly and have no time relation
between each other, so better use the event-based interface provided by
L.

=cut

$some_key;
$last_key;
$next_time;
$last_repeat;

sub _poll {
   my $self = shift;
   my @code = @_;
   return unless @code;
   my $now = shift @code;
   my $key = $RCU::Key::db{$code[0]}
             || ($RCU::Key::db{$code[1]} ||= new RCU::Key
                   $some_key->[0] || $RCU::Key::db{""}{""}[0] || {},
                   $code[1]);

   my $repeat_min  = $key->[0]{repeat_min} || 1;
   my $repeat_freq = $key->[0]{repeat_freq} || 0.2;
   if ($last_key == $key) {
      if ($now <= $next_time) {
         $last_repeat++;
      } else {
         $last_repeat = 0;
      }
   } else {
      $last_repeat = 0;
   }
   $some_key = $last_key = $key;
   $next_time = $now + $repeat_freq;
   if ($last_repeat && $last_repeat < $repeat_min) {
      return;
   } else {
      my $repeat = $last_repeat >= $repeat_min ? $last_repeat - $repeat_min + 1 : 0;
      return ($key->[2] || $key->[1], $repeat);
   }
}

sub poll {
   my $self = shift;
   $self->_poll($self->{if}->poll);
}

sub get {
   my $self = shift;
   while() {
     my @code = $self->_poll($self->{if}->get);
     if (@code) {
        return @code if wantarray;
        return $code[0] unless $code[0];
     }
   }
}


=back

=head1 THE RCU::Key CLASS

This class collects information about rcu keys.

=cut

package RCU::Key;

sub new {
   my $class = shift;
   my ($def, $cooked) = @_;
   bless [$def, $cooked], $class;
}

# RCU key database management

%db;

# $rcu{rcu_name}->{raw|cooked}->key;

# $def, $cooked

sub add_key {
   my ($def, $raw, $cooked) = @_;
   return $db{$def->{rcu_name}}{$raw} = new RCU::Key $def, $cooked;
}

package RCU::Config::Parser;

my $def;
my @def;

sub def(&) {
   my $sub = shift;
   push @def, $def;
   $def = $def ? {%$def} : {};
   &$sub;
}

sub rcu_name($) {
   $def->{rcu_name}    = shift;
}

sub repeat_freq($) {
   $def->{repeat_freq} = shift;
}

sub repeat_min($) {
   $def->{repeat_min}  = shift;
}

sub key($;$) {
   my ($raw, $cooked) = @_;
   RCU::Key::add_key($def, $raw, $cooked || $raw);
}

=head1 THE RCU::Interface CLASS

C provides the base class for all rcu interfaces, it is rarely used directly.

=over 4

=cut

package RCU::Interface;

use Carp;

sub new {
   my $class = shift;
   my $self = bless {}, $class;
   $self;
}

=item fd

Return a unix filehandle that can be polled, or -1 if this is not
possible.

=item ($time, $raw, $cooked) = $if->get

=item ($time, $raw, $cooked) = $if->poll

Wait until a RCU event happens and return it. If the device can translate
raw keys events (e.g. hex key codes) into meaningful names ("cooked" keys)
it will return the cooked name as second value, otherwise both return
values are identical.

C always returns an event, waiting if neccessary, while C only
checks for an event: If one is pending it is returned, otherwise C
returns nothing.

=cut

# do get emulation for interfaces that don't have get. slow but who cares, anyway

sub get {
   my $self = shift;
   my $fd = $self->fd;
   $fd >= 0 or croak ref($self)."::get cannot be emulated without an fd method";
   my @code;
   while (!(@code = $self->poll)) {
      my $in = ""; vec ($in, $fd, 1) = 1;
      select $in, undef, undef, undef;
   }
   wantarray ? @code : $code[1];
}

1;

=back

=head1 SEE ALSO

L, L.

=head1 AUTHOR

This perl extension was written by Marc Lehmann .

=head1 BUGS

No send interface.

=cut