ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/RCU/RCU.pm
Revision: 1.1
Committed: Sun Nov 6 17:17:37 2005 UTC (19 years ago) by root
Branch: MAIN
CVS Tags: HEAD
Log Message:
*** empty log message ***

File Contents

# 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