File Coverage

blib/lib/Device/Osram/Lightify/Light.pm
Criterion Covered Total %
statement 12 156 7.6
branch 0 12 0.0
condition 0 7 0.0
subroutine 4 19 21.0
pod 14 14 100.0
total 30 208 14.4


line stmt bran cond sub pod time code
1              
2             =head1 NAME
3            
4             Device::Osram::Lightify::Light - The interface to a single light
5            
6             =head1 DESCRIPTION
7            
8             This module allows a single Osram lightify light to be manipulated.
9            
10             Objects are not expected to be constructed manually, instead
11             they are discovered dynmically via communication with the hub.
12            
13             =cut
14              
15             =head1 SYNOPSIS
16            
17             use Device::Osram::Lightify;
18            
19             my $tmp = Device::Osram::Lightify::Hub->new( host => "1.2.3.4" );
20            
21             # Show all nodes we found
22             # (Stringification means we dump all the state here.)
23             foreach my $light ( $tmp->lights() ) {
24             print $light;
25             }
26            
27             =cut
28              
29             =head1 DESCRIPTION
30            
31             This module allows basic control of an Osram Lightify light.
32            
33             =cut
34              
35             =head1 METHODS
36            
37             =cut
38              
39 1     1   6 use strict;
  1         1  
  1         25  
40 1     1   4 use warnings;
  1         1  
  1         30  
41              
42             package Device::Osram::Lightify::Light;
43              
44 1     1   341 use Encode 'decode';
  1         7300  
  1         57  
45              
46             #
47             # Allow our object to treated as a string.
48             #
49 1     1   775 use overload '""' => 'stringify';
  1         706  
  1         4  
50              
51              
52             =head2 new
53            
54             Create a new light-object.
55            
56             This is invoked by C<Hub:lights()> method, which will read a binary
57             string containing all the details of the light - we must then parse
58             it according to L<Device::Osram::Lightify::API>.
59            
60             =cut
61              
62             sub new
63             {
64 0     0 1       my ( $proto, %supplied ) = (@_);
65 0   0           my $class = ref($proto) || $proto;
66              
67 0               my $self = {};
68 0               bless( $self, $class );
69              
70              
71 0   0           $self->{ 'hub' } = $supplied{ 'hub' } || die "Missing 'hub' parameter";
72 0   0           $self->{ 'binary' } = $supplied{ 'binary' } ||
73                   die "Missing 'binary' parameter";
74              
75 0               $self->_decode_binary();
76 0               return $self;
77             }
78              
79              
80             =begin doc
81            
82             Internal method, parse the status of a light.
83            
84             =end doc
85            
86             =cut
87              
88             sub _decode_binary
89             {
90 0     0         my ($self) = (@_);
91              
92 0               my $buffer = $self->{ 'binary' };
93              
94             #
95             # my $str = $buffer;
96             # $str =~ s/(.)/sprintf("0x%x ",ord($1))/megs;
97             # print "HEX:" . $str . "\n";
98             #
99              
100             # Get the MAC
101 0               my $mac = substr( $buffer, 2, 8 );
102 0               foreach my $c ( reverse( split( //, $mac ) ) )
103                 {
104 0                   $self->{ 'mac' } .= sprintf( "%02x", ord($c) );
105 0                   $self->{ 'maddr' } .= $c;
106                 }
107 0               $self->{ 'maddr' } = reverse( $self->{ 'maddr' } );
108              
109             # Get the firmware-version
110 0               my $ver = substr( $buffer, 11, 4 );
111 0               foreach my $c ( split( //, $ver ) )
112                 {
113 0 0                 $self->{ 'version' } .= "." if ( $self->{ 'version' } );
114 0                   $self->{ 'version' } .= sprintf( "%x", ord($c) );
115                 }
116              
117 0 0             if ( ord( substr( $buffer, 18, 1 ) ) eq 1 )
118                 {
119 0                   $self->{ 'status' } = "on";
120                 }
121                 else
122                 {
123 0                   $self->{ 'status' } = "off";
124                 }
125              
126             # Brightness
127 0               $self->{ 'brightness' } = ord( substr( $buffer, 19, 1 ) );
128              
129             # Temperature in kelvins
130 0               my $k1 = ord( substr( $buffer, 20, 1 ) );
131 0               my $k2 = ord( substr( $buffer, 21, 1 ) );
132 0               $self->{ 'temperature' } = ( $k1 + ( 256 * $k2 ) );
133              
134             # R,G,B,W
135 0               $self->{ 'r' } = ord( substr( $buffer, 22, 1 ) );
136 0               $self->{ 'g' } = ord( substr( $buffer, 23, 1 ) );
137 0               $self->{ 'b' } = ord( substr( $buffer, 24, 1 ) );
138 0               $self->{ 'w' } = ord( substr( $buffer, 25, 1 ) );
139              
140             # The name of the bulb.
141 0               $self->{ 'name' } = decode 'UTF-8', substr( $buffer, 26, 15 );
142 0               $self->{ 'name' } =~ s/\0//g;
143             }
144              
145              
146              
147             =head2 brightness
148            
149             Get the brightness value of this light (0-100).
150            
151             =cut
152              
153             sub brightness
154             {
155 0     0 1       my ($self) = (@_);
156              
157 0               return ( $self->{ 'brightness' } );
158             }
159              
160              
161             =head2 mac
162            
163             Get the MAC address of this light.
164            
165             =cut
166              
167             sub mac
168             {
169 0     0 1       my ($self) = (@_);
170              
171 0               return ( $self->{ 'mac' } );
172             }
173              
174              
175             =head2 name
176            
177             Return the name of this light.
178            
179             =cut
180              
181             sub name
182             {
183 0     0 1       my ($self) = (@_);
184              
185 0               return ( $self->{ 'name' } );
186             }
187              
188              
189              
190             =head2 rgbw
191            
192             Return the current RGBW value of this light.
193            
194             =cut
195              
196             sub rgbw
197             {
198 0     0 1       my ($self) = (@_);
199              
200 0               my $x = "";
201 0               $x .= $self->{ 'r' };
202 0               $x .= ",";
203 0               $x .= $self->{ 'g' };
204 0               $x .= ",";
205 0               $x .= $self->{ 'b' };
206 0               $x .= ",";
207 0               $x .= $self->{ 'w' };
208              
209 0               return ($x);
210             }
211              
212              
213             =head2 status
214            
215             Is the light C<on> or C<off> ?
216            
217             =cut
218              
219             sub status
220             {
221 0     0 1       my ($self) = (@_);
222              
223 0               return ( $self->{ 'status' } );
224             }
225              
226              
227             =head2 temperature
228            
229             Get the temperature value of this light (2200-6500).
230            
231             =cut
232              
233             sub temperature
234             {
235 0     0 1       my ($self) = (@_);
236              
237 0               return ( $self->{ 'temperature' } );
238             }
239              
240              
241             =head2 version
242            
243             Get the firmware version of this light.
244            
245             =cut
246              
247             sub version
248             {
249 0     0 1       my ($self) = (@_);
250              
251 0               return ( $self->{ 'version' } );
252             }
253              
254              
255              
256             =head2 set_on
257            
258             Set this light to be "on".
259            
260             =cut
261              
262             sub set_on
263             {
264 0     0 1       my ($self) = (@_);
265              
266 0               my $parent = $self->{ 'hub' };
267 0               my $socket = $parent->{ '_socket' };
268              
269             # Prefix for sending a light on
270 0               my $x = "";
271 0               foreach my $char (qw! 0x0f 0x00 0x00 0x32 !)
272                 {
273 0                   $x .= chr( hex($char) );
274                 }
275              
276             # Add a time/session-token
277 0               $x .= $parent->_session_token();
278              
279             # MAC address - binary - in reverse
280 0               $x .= $self->{ 'maddr' };
281              
282             # Desired state: 1
283 0               $x .= chr( hex("0x01") );
284              
285 0               syswrite( $socket, $x, length($x) );
286              
287             # Read 8-byte header + 12-byte reply
288 0               my $buffer = $parent->_read(20);
289              
290 0               return $self;
291             }
292              
293              
294             =head2 set_off
295            
296             Set this light to be "off".
297            
298             =cut
299              
300             sub set_off
301             {
302 0     0 1       my ($self) = (@_);
303              
304 0               my $parent = $self->{ 'hub' };
305 0               my $socket = $parent->{ '_socket' };
306              
307             # Prefix for sending a light off
308 0               my $x = "";
309 0               foreach my $char (qw! 0x0f 0x00 0x00 0x32 !)
310                 {
311 0                   $x .= chr( hex($char) );
312                 }
313              
314             # Add a time/session-token
315 0               $x .= $parent->_session_token();
316              
317             # MAC address - binary - in reverse
318 0               $x .= $self->{ 'maddr' };
319              
320              
321             # Desired state: 0
322 0               $x .= chr( hex("0x00") );
323              
324 0               syswrite( $socket, $x, length($x) );
325              
326             # Read 8-byte header + 12-byte reply
327 0               my $buffer = $parent->_read(20);
328              
329 0               return $self;
330             }
331              
332              
333             =head2 set_brightness
334            
335             Set the brightness value of this light - valid values are 0-100.
336            
337             =cut
338              
339             sub set_brightness
340             {
341 0     0 1       my ( $self, $brightness ) = (@_);
342              
343 0 0             if ( $brightness < 0 )
344                 {
345 0                   $brightness = 0;
346                 }
347 0 0             if ( $brightness > 100 )
348                 {
349 0                   $brightness = 100;
350                 }
351              
352 0               my $parent = $self->{ 'hub' };
353 0               my $socket = $parent->{ '_socket' };
354              
355             # Prefix for changing the brightness.
356 0               my $x = "";
357 0               foreach my $char (qw! 11 00 00 31 !)
358                 {
359 0                   $x .= chr( hex($char) );
360                 }
361              
362             # Add a time/session-token
363 0               $x .= $parent->_session_token();
364              
365             # MAC address - binary - in reverse
366 0               $x .= $self->{ 'maddr' };
367              
368             # Desired brightness 0-100.
369 0               $x .= chr($brightness);
370              
371 0               $x .= chr( hex("0x00") );
372 0               $x .= chr( hex("0x00") );
373              
374 0               syswrite( $socket, $x, length($x) );
375              
376             # Read 8-byte header + 12-byte reply
377 0               my $buffer = $parent->_read(20);
378              
379 0               return $self;
380             }
381              
382              
383             =head2 set_rgbw
384            
385             Set the specified RGBW values of this light.
386            
387             =cut
388              
389             sub set_rgbw
390             {
391 0     0 1       my ( $self, $r, $g, $b, $w ) = (@_);
392              
393 0               my $parent = $self->{ 'hub' };
394 0               my $socket = $parent->{ '_socket' };
395              
396             # Prefix for changing the RGBW values.
397 0               my $x = "";
398 0               foreach my $char (qw! 0x14 0x00 0x00 0x36 !)
399                 {
400 0                   $x .= chr( hex($char) );
401                 }
402              
403              
404             # Add a time/session-token
405 0               $x .= $parent->_session_token();
406              
407             # MAC address - binary - in reverse
408 0               $x .= $self->{ 'maddr' };
409              
410             # The colours.
411 0               $x .= chr($r);
412 0               $x .= chr($g);
413 0               $x .= chr($b);
414 0               $x .= chr($w);
415              
416             # Two more bytes
417 0               $x .= chr( hex("0x00") );
418 0               $x .= chr( hex("0x00") );
419              
420 0               syswrite( $socket, $x, length($x) );
421              
422             # Read 8-byte header + 12-byte reply
423 0               my $buffer = $parent->_read(20);
424              
425 0               return $self;
426             }
427              
428              
429             =head2 set_temperature
430            
431             Set the specified temperature value for this light, in the range 2200-6500.
432            
433             =cut
434              
435             sub set_temperature
436             {
437 0     0 1       my ( $self, $temp ) = (@_);
438              
439 0               my $parent = $self->{ 'hub' };
440 0               my $socket = $parent->{ '_socket' };
441              
442 0 0             if ( $temp < 2200 )
443                 {
444 0                   $temp = 2200;
445                 }
446 0 0             if ( $temp > 6500 )
447                 {
448 0                   $temp = 6500;
449                 }
450              
451 0               my $t1 = $temp % 256;
452 0               my $t2 = ( $temp - $t1 ) / 256;
453              
454 0               my $x = "";
455 0               foreach my $char (qw! 0x12 0x00 0x00 0x33 !)
456                 {
457 0                   $x .= chr( hex($char) );
458                 }
459              
460             # Add a time/session-token
461 0               $x .= $parent->_session_token();
462              
463             # MAC address - binary - in reverse
464 0               $x .= $self->{ 'maddr' };
465              
466             # The temperature.
467 0               $x .= chr($t1);
468 0               $x .= chr($t2);
469              
470             # Two more bytes
471 0               $x .= chr( hex("0x00") );
472 0               $x .= chr( hex("0x00") );
473              
474 0               syswrite( $socket, $x, length($x) );
475              
476             # Read 8-byte header + 12-byte reply
477 0               my $buffer = $parent->_read(20);
478              
479 0               return $self;
480             }
481              
482              
483              
484             =head2 stringify
485            
486             Convert the record to a string, suitable for printing.
487            
488             =cut
489              
490             sub stringify
491             {
492 0     0 1       my ($self) = (@_);
493 0               my $txt = "";
494              
495 0               $txt .= "Name: " . $self->name() . "\n";
496 0               $txt .= "\tMAC:" . $self->mac() . "\n";
497 0               $txt .= "\tversion:" . $self->version() . "\n";
498 0               $txt .= "\tBrightness:" . $self->brightness() . "\n";
499 0               $txt .= "\tRGBW:" . $self->rgbw() . "\n";
500 0               $txt .= "\tTemperature:" . $self->temperature() . "\n";
501 0               $txt .= "\tStatus:" . $self->{ 'status' } . "\n";
502              
503 0               $txt;
504             }
505              
506             1;
507              
508              
509              
510             =head1 AUTHOR
511            
512             Steve Kemp <steve@steve.org.uk>
513            
514             =cut
515              
516             =head1 COPYRIGHT AND LICENSE
517            
518             Copyright (C) 2016 Steve Kemp <steve@steve.org.uk>.
519            
520             This library is free software. You can modify and or distribute it under
521             the same terms as Perl itself.
522            
523             =cut
524