File Coverage

blib/lib/ZWave/Protocol.pm
Criterion Covered Total %
statement 20 110 18.1
branch 0 20 0.0
condition 0 3 0.0
subroutine 6 17 35.2
pod 8 12 66.6
total 34 162 20.9


line stmt bran cond sub pod time code
1             package ZWave::Protocol;
2 1     1   555 use strict;
  1         2  
  1         22  
3 1     1   4 use warnings;
  1         2  
  1         27  
4 1     1   1238 use Log::Log4perl qw(:easy);
  1         53738  
  1         5  
5 1     1   1799 use Device::SerialPort;
  1         34593  
  1         66  
6 1     1   2852337 use Moo;
  1         19648  
  1         7  
7              
8             our $VERSION = "0.03";
9              
10             has device => ( is => 'rw', default => sub { "/dev/ttyUSB0" } );
11             has error => ( is => 'rw' );
12             has port => ( is => 'rw' );
13             has read_timeout_ms => ( is => 'rw', default => sub { "200" } );
14             has ack_timeout_ms => ( is => 'rw', default => sub { "5000" } );
15              
16             sub connect {
17 0     0 1 0 my( $self ) = @_;
18              
19 0         0 my $port = Device::SerialPort->new( $self->device, 1 );
20              
21 0 0       0 if( !defined $port ) {
22 0         0 ERROR "Can't connect to ", $self->device;
23 0         0 return undef;
24             }
25              
26 0         0 $port->baudrate( 115200 );
27 0         0 $port->databits( 8 );
28 0         0 $port->parity( "none" );
29 0         0 $port->stopbits( 1 );
30 0         0 $port->handshake( "none" );
31 0         0 $port->dtr_active( 1 );
32              
33 0         0 $port->error_msg( 1 );
34 0         0 $port->user_msg( 0 );
35              
36 0 0       0 $port->write_settings or
37             die "Failed to initialize USB port " . $self->device . ": $@";
38              
39 0         0 $self->port( $port );
40              
41 0         0 return 1;
42             }
43              
44             sub checksum {
45 1     1 1 10 my( $self, @bytes ) = @_;
46              
47 1         1 my $checksum = 0xFF;
48              
49             # x-or all elements but the first one
50 1         5 for my $byte ( splice @bytes, 1, @bytes - 1 ) {
51 2         4 $checksum ^= $byte;
52             }
53              
54 1         3 return $checksum;
55             }
56              
57             sub packet_dump {
58 0     0 0   my( $self, $packet ) = @_;
59              
60 0           my @bytes = unpack "C*", $packet;
61              
62 0           return $self->bytes_dump( @bytes );
63             }
64              
65             sub bytes_dump {
66 0     0 0   my( $self, @bytes ) = @_;
67              
68 0           my $string = "";
69              
70 0           for my $byte ( @bytes ) {
71 0 0         if( length $string ) {
72 0           $string .= " ";
73             }
74 0           $string .= sprintf "%02x", $byte;
75             }
76              
77 0           return "[ $string ]";
78             }
79              
80             sub request_packet {
81 0     0 1   my( $self, @payload ) = @_;
82              
83 0           my $length = @payload + 1;
84              
85 0           my @bytes = ( 0x1, $length, @payload );
86 0           my $checksum = $self->checksum( @bytes );
87              
88 0           DEBUG "Checksum of ", $self->bytes_dump( @bytes ), " is ",
89             $self->bytes_dump( $checksum );
90              
91 0           push @bytes, $checksum;
92              
93 0           return pack "C*", @bytes;
94             }
95              
96             sub payload_send {
97 0     0 1   my( $self, @payload ) = @_;
98              
99 0           my $request = $self->request_packet( @payload );
100              
101 0           DEBUG "Sending request: ", $self->packet_dump( $request );
102              
103 0 0         if( !$self->port->write( $request ) ) {
104 0           $self->error( "Failed to send payload " .
105             $self->bytes_dump( @payload ) . ": $@" );
106 0           return undef;
107             }
108              
109 0           return 1;
110             }
111              
112             sub ack_recv {
113 0     0 1   my( $self ) = @_;
114              
115 0           DEBUG "Waiting for ACK";
116              
117 0           my $packet = $self->packet_recv( );
118 0           my @bytes = unpack "C*", $packet;
119              
120 0           DEBUG "ACK bytes: ", $self->bytes_dump( @bytes );
121              
122 0 0         if( @bytes == 0 ) {
123 0           INFO "Received nothing";
124 0           return 0;
125             }
126              
127 0 0 0       if( defined $bytes[ 0 ] and $bytes[ 0 ] == 6 ) {
128 0           INFO "Received ACK";
129 0           $self->ack_send();
130 0           return 1;
131             }
132              
133 0           INFO "Received non-ACK";
134              
135 0           return undef;
136             }
137              
138             sub ack_send {
139 0     0 1   my( $self, $node_id ) = @_;
140              
141 0           INFO "Sending ACK";
142 0           $self->port->write( pack( "C", 6 ) );
143              
144 0           return 1;
145             }
146              
147             sub payload_transmit {
148 0     0 1   my( $self, @payload ) = @_;
149              
150 0 0         if( !$self->payload_send( @payload ) ) {
151 0           return undef;
152             }
153              
154 0 0         if( !$self->ack_recv() ) {
155 0           $self->error( "Failed to receive ack for sent payload @payload: $@" );
156 0           return undef;
157             }
158              
159 0           return 1;
160             }
161              
162             sub error_process {
163 0     0 0   my( $self, $string ) = @_;
164              
165 0           local $Log::Log4perl::caller_depth =
166             $Log::Log4perl::caller_depth + 1;
167              
168 0           ERROR $string;
169 0           $self->error( $string );
170              
171 0           return 1;
172             }
173              
174             sub packet_recv {
175 0     0 0   my( $self ) = @_;
176              
177 0           $self->port->read_const_time( $self->read_timeout_ms );
178              
179             # read one byte at a time until there's no more
180 0           my $sofar = "";
181 0           while( 1 ) {
182 0           my( $count, $bytes ) = $self->port->read( 1 );
183 0           DEBUG "Read $count bytes: ", $self->packet_dump( $bytes );
184 0           $sofar .= $bytes;
185 0 0         if( !$count ) {
186 0           last;
187             }
188             }
189              
190 0           DEBUG "Read packet: ", $self->packet_dump( $sofar );
191              
192 0           return $sofar;
193             }
194              
195             sub payload_recv {
196 0     0 1   my( $self ) = @_;
197              
198 0           my @bytes = unpack "C*", $self->packet_recv;
199              
200 0           my( $type, $len, @rest ) = @bytes;
201              
202 0           my $checksum = pop @rest;
203              
204 0 0         if( $checksum != $self->checksum( $len, @rest ) ) {
205 0           $self->error_process( "Received package with invalid checksum: " .
206             $self->bytes_dump( @bytes ) . " (checksum should be " .
207             $self->bytes_dump( $checksum ) . ")" );
208 0           return undef;
209             }
210              
211 0           DEBUG "Received payload: ", $self->bytes_dump( @rest );
212              
213 0           return @rest;
214             }
215              
216             1;
217              
218             __END__