line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
1
|
|
|
1
|
|
9115
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
34
|
|
2
|
1
|
|
|
1
|
|
3
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
100
|
|
3
|
|
|
|
|
|
|
package Device::W800; |
4
|
|
|
|
|
|
|
$Device::W800::VERSION = '1.163170'; |
5
|
|
|
|
|
|
|
# ABSTRACT: Module to support W800 RF receiver |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
32
|
use 5.006; |
|
1
|
|
|
|
|
7
|
|
9
|
1
|
|
|
1
|
|
12
|
use constant DEBUG => $ENV{DEVICE_W800_DEBUG}; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
139
|
|
10
|
1
|
|
|
1
|
|
8
|
use Carp qw/croak/; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
107
|
|
11
|
1
|
|
|
1
|
|
7
|
use base 'Device::RFXCOM::RX'; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
1292
|
|
12
|
1
|
|
|
1
|
|
8
|
use Device::RFXCOM::Response; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
538
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
sub new { |
16
|
2
|
|
|
2
|
1
|
583
|
my ($pkg, %p) = @_; |
17
|
2
|
|
|
|
|
5
|
my @plugins; |
18
|
|
|
|
|
|
|
# TODO: Make 32-bit support a class method on the decoder so |
19
|
|
|
|
|
|
|
# this process (to restrict the plugins to a useful set) is |
20
|
|
|
|
|
|
|
# encapsulated better. |
21
|
2
|
|
|
|
|
7
|
foreach my $decoder (qw/RFXSensor X10 X10Security/) { |
22
|
6
|
|
|
|
|
15
|
my $module = 'Device::RFXCOM::Decoder::'.$decoder; |
23
|
6
|
|
|
|
|
14
|
my $file = 'Device/RFXCOM/Decoder/'.$decoder.'.pm'; |
24
|
6
|
|
|
|
|
1627
|
require $file; import $module; |
|
6
|
|
|
|
|
192
|
|
25
|
6
|
|
|
|
|
33
|
push @plugins, $module->new(); |
26
|
|
|
|
|
|
|
} |
27
|
2
|
|
|
|
|
24
|
$pkg->SUPER::new(device => '/dev/w800', plugins => \@plugins, %p); |
28
|
|
|
|
|
|
|
} |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
sub _write { |
31
|
1
|
|
|
1
|
|
769
|
croak "Writes not supported for W800: @_\n"; |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
1
|
|
|
sub _write_now { |
35
|
|
|
|
|
|
|
# do nothing |
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
sub _init { |
39
|
1
|
|
|
1
|
|
5
|
my $self = shift; |
40
|
1
|
|
|
|
|
9
|
$self->{init} = 1; |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
sub read_one { |
45
|
5
|
|
|
5
|
1
|
13
|
my ($self, $rbuf) = @_; |
46
|
5
|
100
|
|
|
|
25
|
return unless ($$rbuf); |
47
|
|
|
|
|
|
|
|
48
|
4
|
|
|
|
|
10
|
print STDERR "rbuf=", (unpack "H*", $$rbuf), "\n" if DEBUG; |
49
|
4
|
|
|
|
|
10
|
my $bits = 32; |
50
|
4
|
|
|
|
|
7
|
my $length = 4; |
51
|
4
|
|
|
|
|
104
|
my %result = |
52
|
|
|
|
|
|
|
( |
53
|
|
|
|
|
|
|
master => 1, |
54
|
|
|
|
|
|
|
header_byte => $bits, |
55
|
|
|
|
|
|
|
type => 'unknown', |
56
|
|
|
|
|
|
|
); |
57
|
4
|
|
|
|
|
8
|
my $msg = ''; |
58
|
4
|
|
|
|
|
6
|
my @bytes; |
59
|
|
|
|
|
|
|
|
60
|
4
|
100
|
|
|
|
28
|
return if (length $$rbuf < $length); |
61
|
|
|
|
|
|
|
|
62
|
2
|
|
|
|
|
10
|
$msg = substr $$rbuf, 0, $length, ''; # message from buffer |
63
|
2
|
|
|
|
|
16
|
@bytes = unpack 'C*', $msg; |
64
|
|
|
|
|
|
|
|
65
|
2
|
|
|
|
|
14
|
$result{key} = $bits.'!'.$msg; |
66
|
2
|
|
|
|
|
19
|
my $entry = $self->_cache_get(\%result); |
67
|
2
|
100
|
|
|
|
21
|
if ($entry) { |
68
|
1
|
|
|
|
|
4
|
print STDERR "using cache entry\n" if DEBUG; |
69
|
1
|
|
|
|
|
3
|
@result{qw/messages type/} = @{$entry->{result}}{qw/messages type/}; |
|
1
|
|
|
|
|
8
|
|
70
|
1
|
|
|
|
|
8
|
$self->_cache_set(\%result); |
71
|
|
|
|
|
|
|
} else { |
72
|
1
|
|
|
|
|
9
|
foreach my $decoder (@{$self->{plugins}}) { |
|
1
|
|
|
|
|
7
|
|
73
|
2
|
100
|
|
|
|
19
|
my $matched = $decoder->decode($self, $msg, \@bytes, $bits, \%result) |
74
|
|
|
|
|
|
|
or next; |
75
|
1
|
|
|
|
|
14
|
($result{type} = lc ref $decoder) =~ s/.*:://; |
76
|
1
|
|
|
|
|
4
|
last; |
77
|
|
|
|
|
|
|
} |
78
|
1
|
|
|
|
|
95
|
$self->_cache_set(\%result); |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
2
|
|
|
|
|
16
|
@result{qw/data bytes/} = ($msg, \@bytes); |
82
|
2
|
|
|
|
|
108
|
return Device::RFXCOM::Response->new(%result); |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
1; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
__END__ |