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, 1 month ago) by root
Branch: MAIN
CVS Tags: HEAD
Log Message:
*** empty log message ***

File Contents

# Content
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