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