cvsroot/RCU/RCU.pm

=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<RCU::Receipts> 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<interface> must be an interface
specification similar to DBI's DSN:

 RCU:ifname:arg:arg...

Examples:
low-level interface (without C<RCU::> 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<RCU::Event>.

=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<RCU::Event>), return a cooked
keycode and a repeat count (initial keypress = 0, increasing while the
key is pressed). If C<get> 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<RCU::Event|RCU::Event>.

=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{""}{"<default>"}[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<RCU::Interface> 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<get> always returns an event, waiting if neccessary, while C<poll> only
checks for an event: If one is pending it is returned, otherwise C<poll>
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<RCU::Irman>, L<RCU::Lirc>.

=head1 AUTHOR

This perl extension was written by Marc Lehmann <schmorp@schmorp.de>.

=head1 BUGS

No send interface.

=cut


Revision:	1.1
Committed:	Sun Nov 6 17:17:37 2005 UTC (20 years, 10 months ago) by root
Branch:	MAIN
CVS Tags:	HEAD
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			RCU - Remote Control Unit Interface
4
5			=head1 SYNOPSIS
6
7			use RCU;
8
9			=head1 DESCRIPTION
10
11			This module provides a generic interface to remote control units (only
12			receivers at the moment, as I cannot test more). It only provides an
13			abstract management interface, other modules are required for the hardware
14			access (RCU::Irman and RCU::Lirc are included, however).
15
16			=head2 GETTING STARTED
17
18			Please read L<RCU::Receipts> to get some idea on how to proceed after you
19			installed the module (testing & standard techniques).
20
21			=head1 THE RCU CLASS
22
23			The RCU class provides a general interface to anything you might want to
24			do to, it represents your application.
25
26			=over 4
27
28			=cut
29
30			package RCU;
31
32			$VERSION = 0.021;
33
34			use Carp;
35
36			=item $rcu = new RCU "interface-spec"
37
38			Creates a new RCU application. C<interface> must be an interface
39			specification similar to DBI's DSN:
40
41			RCU:ifname:arg:arg...
42
43			Examples:
44			low-level interface (without C<RCU::> prefix) or an arrayref containing
45			name and constructor arguments. If the interface name has a C<::> prefix
46			it will be used as-is (without that prefix, of course).
47
48			For a much better interface, see L<RCU::Event>.
49
50			=cut
51
52			sub new {
53			my $class = shift;
54			my $if = shift;
55			my $self = bless {}, $class;
56
57			my ($rcu, $ifname, @ifargs) = split /:/, $if;
58			$rcu eq "RCU" or croak "unknown interface name syntax";
59			$ifname = "RCU::$ifname";
60			do { eval "require $ifname"; die $@ if $@ } unless exists ${"$ifname\::"}{VERSION}; # best bet
61			$self->{if} = $ifname->new(@ifargs);
62
63			$self;
64			}
65
66			=item $rcu->interface
67
68			Return the RCU::Interface object used by this RCU object.
69
70			=cut
71
72			sub interface {
73			$_[0]->{if};
74			}
75
76			=item ($keycode, $repeat) = $rcu->get
77
78			=item ($keycode, $repeat) = $rcu->poll
79
80			Simplified interface to the RCU (See also L<RCU::Event>), return a cooked
81			keycode and a repeat count (initial keypress = 0, increasing while the
82			key is pressed). If C<get> is called in scalar context it only returns
83			unrepeated keycodes.
84
85			This interface is problematic: no key-up events are generated, and
86			the repeat events occur pseudo-randomly and have no time relation
87			between each other, so better use the event-based interface provided by
88			L<RCU::Event\|RCU::Event>.
89
90			=cut
91
92			$some_key;
93			$last_key;
94			$next_time;
95			$last_repeat;
96
97			sub _poll {
98			my $self = shift;
99			my @code = @_;
100			return unless @code;
101			my $now = shift @code;
102			my $key = $RCU::Key::db{$code[0]}
103			\|\| ($RCU::Key::db{$code[1]} \|\|= new RCU::Key
104			$some_key->[0] \|\| $RCU::Key::db{""}{"<default>"}[0] \|\| {},
105			$code[1]);
106
107			my $repeat_min = $key->[0]{repeat_min} \|\| 1;
108			my $repeat_freq = $key->[0]{repeat_freq} \|\| 0.2;
109			if ($last_key == $key) {
110			if ($now <= $next_time) {
111			$last_repeat++;
112			} else {
113			$last_repeat = 0;
114			}
115			} else {
116			$last_repeat = 0;
117			}
118			$some_key = $last_key = $key;
119			$next_time = $now + $repeat_freq;
120			if ($last_repeat && $last_repeat < $repeat_min) {
121			return;
122			} else {
123			my $repeat = $last_repeat >= $repeat_min ? $last_repeat - $repeat_min + 1 : 0;
124			return ($key->[2] \|\| $key->[1], $repeat);
125			}
126			}
127
128			sub poll {
129			my $self = shift;
130			$self->_poll($self->{if}->poll);
131			}
132
133			sub get {
134			my $self = shift;
135			while() {
136			my @code = $self->_poll($self->{if}->get);
137			if (@code) {
138			return @code if wantarray;
139			return $code[0] unless $code[0];
140			}
141			}
142			}
143
144
145			=back
146
147			=head1 THE RCU::Key CLASS
148
149			This class collects information about rcu keys.
150
151			=cut
152
153			package RCU::Key;
154
155			sub new {
156			my $class = shift;
157			my ($def, $cooked) = @_;
158			bless [$def, $cooked], $class;
159			}
160
161			# RCU key database management
162
163			%db;
164
165			# $rcu{rcu_name}->{raw\|cooked}->key;
166
167			# $def, $cooked
168
169			sub add_key {
170			my ($def, $raw, $cooked) = @_;
171			return $db{$def->{rcu_name}}{$raw} = new RCU::Key $def, $cooked;
172			}
173
174			package RCU::Config::Parser;
175
176			my $def;
177			my @def;
178
179			sub def(&) {
180			my $sub = shift;
181			push @def, $def;
182			$def = $def ? {%$def} : {};
183			&$sub;
184			}
185
186			sub rcu_name($) {
187			$def->{rcu_name} = shift;
188			}
189
190			sub repeat_freq($) {
191			$def->{repeat_freq} = shift;
192			}
193
194			sub repeat_min($) {
195			$def->{repeat_min} = shift;
196			}
197
198			sub key($;$) {
199			my ($raw, $cooked) = @_;
200			RCU::Key::add_key($def, $raw, $cooked \|\| $raw);
201			}
202
203			=head1 THE RCU::Interface CLASS
204
205			C<RCU::Interface> provides the base class for all rcu interfaces, it is rarely used directly.
206
207			=over 4
208
209			=cut
210
211			package RCU::Interface;
212
213			use Carp;
214
215			sub new {
216			my $class = shift;
217			my $self = bless {}, $class;
218			$self;
219			}
220
221			=item fd
222
223			Return a unix filehandle that can be polled, or -1 if this is not
224			possible.
225
226			=item ($time, $raw, $cooked) = $if->get
227
228			=item ($time, $raw, $cooked) = $if->poll
229
230			Wait until a RCU event happens and return it. If the device can translate
231			raw keys events (e.g. hex key codes) into meaningful names ("cooked" keys)
232			it will return the cooked name as second value, otherwise both return
233			values are identical.
234
235			C<get> always returns an event, waiting if neccessary, while C<poll> only
236			checks for an event: If one is pending it is returned, otherwise C<poll>
237			returns nothing.
238
239			=cut
240
241			# do get emulation for interfaces that don't have get. slow but who cares, anyway
242
243			sub get {
244			my $self = shift;
245			my $fd = $self->fd;
246			$fd >= 0 or croak ref($self)."::get cannot be emulated without an fd method";
247			my @code;
248			while (!(@code = $self->poll)) {
249			my $in = ""; vec ($in, $fd, 1) = 1;
250			select $in, undef, undef, undef;
251			}
252			wantarray ? @code : $code[1];
253			}
254
255			1;
256
257			=back
258
259			=head1 SEE ALSO
260
261			L<RCU::Irman>, L<RCU::Lirc>.
262
263			=head1 AUTHOR
264
265			This perl extension was written by Marc Lehmann <schmorp@schmorp.de>.
266
267			=head1 BUGS
268
269			No send interface.
270
271			=cut
272
273
274
275
276