File Coverage

blib/lib/Net/PJLink.pm
Criterion Covered Total %
statement 249 334 74.5
branch 64 104 61.5
condition 15 27 55.5
subroutine 40 42 95.2
pod 21 21 100.0
total 389 528 73.6


line stmt bran cond sub pod time code
1             package Net::PJLink;
2              
3 21     21   546318 use 5.008_001;
  21         69  
  21         857  
4 21     21   109 use warnings;
  21         51  
  21         629  
5 21     21   198 use strict;
  21         47  
  21         689  
6              
7 21     21   127 use Exporter;
  21         42  
  21         1120  
8 21     21   121 use Digest::MD5;
  21         43  
  21         632  
9 21     21   42416 use IO::Socket::INET;
  21         719928  
  21         197  
10 21     21   51059 use IO::Select;
  21         34760  
  21         994  
11 21     21   21393 use Switch;
  21         714315  
  21         147  
12 21     21   5690695 use Carp;
  21         80  
  21         2785  
13              
14             # internal constants
15             use constant {
16 21         4920 PJLINK_PORT => 4352,
17             PJLINK_C_HEADER => '%1',
18             PJLINK_A_HEADER => 'PJLINK ',
19             CONNECT_TIMEOUT => 0.05,
20             RECEIVE_TIMEOUT => 5,
21 21     21   405 };
  21         60  
22              
23             our @ISA = qw( Exporter );
24              
25             =head1 NAME
26              
27             Net::PJLink - PJLink protocol implementation
28              
29             =head1 VERSION
30              
31             Version 1.02
32              
33             =cut
34              
35             our $VERSION = '1.02';
36              
37              
38             =head1 SYNOPSIS
39              
40             Net::PJLink is a pure perl implementation of the PJLink protocol (L) version 1.00, Class 1.
41             This is a standard protocol for communicating with network-capable projectors.
42             Net::PJLink uses an object-oriented style, with an object representing a group of one or more projectors.
43             An object has methods corresponding to the commands in the PJLink protocol specification.
44              
45             use Net::PJLink;
46              
47             my $prj = Net::PJLink->new(
48             host => [ '10.0.0.1', '10.0.0.2' ],
49             keep_alive => 1,
50             );
51              
52             $prj->set_power(1); # turn on projectors
53              
54             $prj->set_audio_mute(1); # mute sound
55              
56             # retreive the current input being used
57             my $input = $prj->get_input();
58             if ($input->{'10.0.0.1'}->[0] == Net::PJLink::INPUT_RGB) {
59             print "RGB input number " . $input->{'10.0.0.1'}->[1];
60             print " is active on projector 1.";
61             }
62              
63             # close network connections to the projectors
64             $prj->close_all_connections;
65              
66             =head1 EXPORTS
67              
68             Net::PJLink uses constants to represent status codes sent to and received from projectors.
69             These constants can be used like C, or imported
70             into the local namespace by using the Exporter tag C<:RESPONSES>.
71              
72             use Net::PJLink qw( :RESPONSES );
73              
74             my $prj = Net::PJLink->new(
75             host => '192.168.1.10'
76             );
77             if ($prj->get_power() == POWER_ON) {
78             print "Projector is on.";
79             }
80              
81             The two lists below describe each symbol that is exported by the C<:RESPONSES> tag.
82              
83             =head2 Command Response Constants
84              
85             These are general status codes that are common to many projector commands.
86              
87             =over 4
88              
89             =item * C
90              
91             The command succeeded.
92              
93             =item * C
94              
95             Status is "warning".
96              
97             =item * C
98              
99             Status is "error".
100              
101             =item * C
102              
103             The command could not be recognized or is not supported by the projector.
104             This could happen because the projector is deviating from the specification, the message is getting corrupted, or there is a bug in this module.
105              
106             =item * C
107              
108             An invalid parameter was given in the command.
109              
110             =item * C
111              
112             The command is not available at this time (e.g. projector is on standby, warming up, etc.).
113              
114             =item * C
115              
116             A projector failure occurred when processing the command.
117              
118             =item * C
119              
120             A network connection to the projector could not be established.
121              
122             =item * C
123              
124             Authentication failed.
125              
126             =item * C
127              
128             A response from the projector was not received.
129              
130             =item * C
131              
132             The projector's response was received, but could not be understood.
133             This could happen because the projector is deviating from the specification, the message is getting corrupted, or there is a bug in this module.
134              
135             =back
136              
137             =cut
138              
139             use constant {
140 21         3474 OK => 0, #'OK',
141             ERR_COMMAND => -1, #'ERR1',
142             ERR_PARAMETER => -2, #'ERR2',
143             ERR_UNAVL_TIME => -3, #'ERR3',
144             ERR_PRJT_FAIL => -4, #'ERR4',
145             ERR_NETWORK => -5,
146             ERR_AUTH => -6,
147             WARNING => -7,
148             ERROR => -8,
149             ERR_TIMEOUT => -9,
150             ERR_PARSE => -10,
151 21     21   128 };
  21         42  
152              
153             =head2 Status Responses
154              
155             These values are returned from commands that request information from the projector.
156             See the documentation for each command to find out which values can be returned for that command.
157              
158             =over 4
159              
160             =item * C
161              
162             =item * C
163              
164             =item * C
165              
166             =item * C
167              
168             =item * C
169              
170             =item * C
171              
172             =item * C
173              
174             =item * C
175              
176             =item * C
177              
178             =item * C
179              
180             =item * C
181              
182             =back
183              
184             =cut
185              
186             use constant {
187 21         279285 POWER_OFF => 0,
188             POWER_ON => 1,
189             POWER_COOLING => 2,
190             POWER_WARMUP => 3,
191             INPUT_RGB => 1,
192             INPUT_VIDEO => 2,
193             INPUT_DIGITAL => 3,
194             INPUT_STORAGE => 4,
195             INPUT_NETWORK => 5,
196             MUTE_VIDEO => 1,
197             MUTE_AUDIO => 2,
198 21     21   125 };
  21         42  
199              
200             our @EXPORT_OK = qw(
201             POWER_OFF POWER_ON POWER_COOLING POWER_WARMUP
202             INPUT_RGB INPUT_VIDEO INPUT_DIGITAL INPUT_STORAGE INPUT_NETWORK
203             MUTE_VIDEO MUTE_AUDIO
204             ERR_COMMAND ERR_PARAMETER ERR_UNAVL_TIME ERR_PRJT_FAIL ERR_NETWORK ERR_AUTH
205             OK WARNING ERROR ERR_TIMEOUT ERR_PARSE
206             );
207             our %EXPORT_TAGS = (
208             RESPONSES => [qw(
209             POWER_OFF POWER_ON POWER_COOLING POWER_WARMUP
210             INPUT_RGB INPUT_VIDEO INPUT_DIGITAL INPUT_STORAGE INPUT_NETWORK
211             MUTE_VIDEO MUTE_AUDIO
212             ERR_COMMAND ERR_PARAMETER ERR_UNAVL_TIME ERR_PRJT_FAIL ERR_NETWORK ERR_AUTH
213             OK WARNING ERROR ERR_TIMEOUT ERR_PARSE
214             )]
215             );
216              
217              
218             # used internally
219             # list of command codes
220             my %COMMAND = (
221             power => 'POWR',
222             input => 'INPT',
223             mute => 'AVMT',
224             status => 'ERST',
225             lamp => 'LAMP',
226             input_list => 'INST',
227             name => 'NAME',
228             mfr => 'INF1',
229             prod_name => 'INF2',
230             prod_info => 'INFO',
231             class => 'CLSS',
232             );
233              
234             # used internally
235             # response codes that are translated
236             # into constants for all command responses
237             my %RESPONSE = (
238             'OK' => OK,
239             'ERR1' => ERR_COMMAND,
240             'ERR2' => ERR_PARAMETER,
241             'ERR3' => ERR_UNAVL_TIME,
242             'ERR4' => ERR_PRJT_FAIL,
243             );
244              
245             =head1 UTILITY METHODS
246              
247             =head2 new(...)
248              
249             use Net::PJLink;
250              
251             # Send commands to two hosts (batch mode),
252             # don't close the connection after each command,
253             # if a host cannot be contacted then remove it,
254             # wait up to 1 second for a connection to be opened
255             my $prj = Net::PJLink->new(
256             host => ['10.0.0.1', '10.0.0.2'],
257             try_once => 1,
258             keep_alive => 1,
259             connect_timeout => 1.0,
260             );
261              
262             Constructor for a new PJLink object.
263             It requires at least the C option to indicate where commands should be sent.
264             The full list of arguments:
265              
266             =over 4
267              
268             =item * host
269              
270             This can be either a string consisting of a hostname or an IP address, or an array of such strings.
271             If you want to add a whole subnet, use something like L to expand CIDR notation to an array of IP addresses.
272             Every command given to this object will be applied to all hosts, and replies will be returned in a hash indexed by hostname or IP address if more than one host was given.
273              
274             =item * try_once
275              
276             True/False. Default is false.
277             Automatically remove unresponsive hosts from the list of hosts.
278             This speeds up any subseqent commands that are issued by not waiting for network timeout on a host that is down.
279             If this option evaluates false, the list of hosts will never be automatically changed.
280              
281             =item * batch
282              
283             True/False.
284             Force "batch mode" to be enabled or disabled.
285             Batch mode is normally set automatically based on whether multiple hosts are being used.
286             With batch mode on, all results will be returned as a hash reference indexed by hostname or IP address.
287             If batch mode is disabled when commands are sent to multiple hosts, only one of the hosts' results will be returned (which one is unpredictable).
288              
289             =item * port
290              
291             Default is 4352, which is the standard PJLink port.
292             Connections will be made to this port on each host.
293              
294             =item * auth_password
295              
296             Set the password that will be used for authentication for those hosts that require it.
297             It must be 32 alphanumeric characters or less.
298             The password is not transmitted over the network; it is used to calculate an MD5 sum.
299              
300             =item * keep_alive
301              
302             True/False. Default is false.
303             If set, connections will not be closed automatically after a response is received.
304             This is useful when sending many commands.
305              
306             =item * connect_timeout
307              
308             The time (in seconds) to wait for a new TCP connection to be established.
309             Default is 0.5.
310             This may need to be changed, depending on your network and/or projector.
311             The default should provide good reliability, and be practical for a small number of projectors.
312             Using a value of 0.05 seems to work well for connecting to a large number of hosts over a fast network in a reasonable amount of time.
313             (Larger values can take a long time when connecting to each host in a /24 subnet.)
314              
315             =item * receive_timeout
316              
317             The time (in seconds) to wait for a reply to be received.
318             If this option is not specified, a default of 5 seconds is used.
319             The value needed here might vary greatly between different projector models.
320              
321             =back
322              
323             =cut
324              
325             sub new {
326 21     21 1 186326 my $class = shift;
327 21         60 my $self = {};
328 21         64 bless $self, $class;
329 21         126 my %args = @_;
330              
331 21 50       158 unless (defined $args{'host'}) {
332 0         0 carp "Missing 'host' argument";
333 0         0 return undef;
334             }
335 21         204 switch (ref $args{'host'}) {
  21         78  
  21         183  
  0         0  
336 21 50       2353 case '' {
  21         577  
337 21         217 $self->{'host'} = {$args{'host'} => 0};
338 21         211 }
  0         0  
  0         0  
  0         0  
339 0 0       0 case 'ARRAY' {
  0         0  
340 0         0 foreach (@{$args{'host'}}) {$self->{'host'}->{$_} = 0;}
  0         0  
  0         0  
341 0         0 }
  0         0  
  0         0  
  0         0  
342             else {
343 0         0 carp "Invalid 'host' argument";
344 0         0 return undef;
345             }
346             }
347 21         79 $self->{'batch'} = (scalar keys %{$self->{'host'}} > 1);
  21         102  
348 21 100       123 $self->{'try_once'} = $args{'try_once'} ? 1 : 0;
349 21 50       681 $self->{'batch'} = $args{'batch'} if (defined $args{'batch'});
350 21   100     130 $self->{'port'} = $args{'port'} || PJLINK_PORT;
351 21 50       102 $self->{'keep_alive'} = $args{'keep_alive'} ? 1 : 0;
352 21 100       82 $self->{'auth_password'} = $args{'auth_password'} if (defined $args{'auth_password'});
353 21   50     177 $self->{'connect_timeout'} = $args{'connect_timeout'} || CONNECT_TIMEOUT;
354 21   50     144 $self->{'receive_timeout'} = $args{'receive_timeout'} || RECEIVE_TIMEOUT;
355 21         102 return $self;
356             }
357              
358             # internal method
359             # Open a TCP connection
360             sub _open_connection {
361 170     170   332 my $self = shift;
362 170         257 my $host = shift;
363              
364 170 50       690 if ($self->{'host'}->{$host}) {
365 0         0 warn "Re-opening connection to $host";
366 0         0 $self->{'host'}->{$host}->close;
367             }
368 170         7403 my $socket = IO::Socket::INET->new(
369             PeerAddr => $host,
370             PeerPort => $self->{'port'},
371             Proto => 'tcp',
372             Timeout => $self->{'connect_timeout'},
373             );
374 170 100 66     214780 return 0 unless ($socket && $socket->connected);
375 153         2679 $socket->autoflush(1);
376 153         7185 $self->{'host'}->{$host} = $socket;
377 153         1165 return $socket;
378             }
379              
380             # internal method
381             # Check authentication status on a just-opened PJLink connection.
382             # If necessary, use auth_password to authenticate the connection.
383             sub _auth_connection {
384 153     153   330 my $self = shift;
385 153         272 my $host = shift;
386 153         197 my $resp;
387              
388             # undef if unknown host
389 153 50       517 return undef unless ($self->{'host'}->{$host});
390 153         350 my $cnx = $self->{'host'}->{$host};
391 153         2810 $cnx->recv($resp, 128);
392             # false, unless format is correct
393 153 50 33     83466 return 0 unless (defined $resp && $resp =~ /^PJLINK ([01])( ([0-9a-fA-F]+))?\x0d$/);
394             # true, no auth required
395 153 100       4369 return 1 if ($1 == 0);
396             # false, unless password is given
397 17 50       85 return 0 unless (defined $self->{'auth_password'});
398             # false, unless random number was received
399 17 50       408 return 0 unless ($3);
400              
401 17         238 my $digest = Digest::MD5::md5_hex($3 . $self->{'auth_password'});
402             # test command to verify that auth succeeded
403 17         102 $cnx->send($digest . "%1POWR ?\xd");
404 17         935 $cnx->recv($resp, 32);
405 17 50 33     2822 return 1 if (defined $resp && $resp =~ /^%1POWR=\d\x0d$/);
406             # don't close the connection yet,
407             # because auth might be tried with a
408             # different password
409 0         0 return 0;
410             }
411              
412             =head2 set_auth_password($pass)
413              
414             Set the password that will be used when connecting to a projector.
415             This will only apply to newly established connections.
416              
417             $prj->set_auth_password('secret');
418              
419             Returns 1 if successful, 0 otherwise (password is too long).
420              
421             =cut
422              
423             sub set_auth_password {
424 37     37 1 38412 my $self = shift;
425 37         75 my $pass = shift;
426 37 100 100     414 if (defined $pass && $pass !~ /^.{1,32}$/) {
427 1         219 carp "auth_password must be less than or equal to 32 bytes";
428 1         53 return 0;
429             } else {
430 36         126 $self->{'auth_password'} = $pass;
431 36         235 return 1;
432             }
433             }
434              
435             =head2 close_connection($host)
436              
437             Manually close the connection to one host, specified by hostname or IP address.
438             Returns 1 if the connection was found and closed, returns 0 otherwise.
439              
440             =cut
441              
442             sub close_connection {
443 0     0 1 0 my $self = shift;
444 0         0 my $host = shift;
445              
446 0 0       0 return 0 unless (defined $self->{'hosts'}->{$host});
447 0         0 $self->{'hosts'}->{$host}->close;
448 0         0 return 1;
449             }
450              
451             =head2 close_all_connections()
452              
453             Manually close all open connections that are managed by this instance.
454             This is usually used when the object has been created with the C option.
455              
456             =cut
457              
458             sub close_all_connections {
459 0     0 1 0 my $self = shift;
460 0 0       0 foreach (values %{$self->{'hosts'}}) { $_->close if ($_); }
  0         0  
  0         0  
461             }
462              
463             # internal method
464             # Build the command message and do some basic sanity
465             # checks on it.
466             sub _build_command {
467 182     182   6450 my $self = shift;
468 182         454 my $cmd = shift;
469 182         353 my $arg = shift;
470 182 50       1007 die("Invalid command name \"$cmd\"!") unless (defined $COMMAND{$cmd});
471 182 50       2417 die("Invalid characters in command argument!") if ($arg =~ /\x0d/);
472 182         2043 return PJLINK_C_HEADER . $COMMAND{$cmd} . ' ' . $arg . "\xd";
473             }
474              
475             # internal method
476             # Build and send a command string to all active hosts.
477             # The data must be sent separately to each host because
478             # the PJLink protocol requires the use of TCP connections.
479             # This code sends data to each host, then receives responses
480             # from each host. This is probably not the best way to handle
481             # the problem, and it will not work well with multiple
482             # hundreds of hosts (especially when many hosts are not
483             # reachable and thus cause a network timeout delay). This is
484             # because the first connections to be opened will timeout
485             # due to inactivity before the data can be received.
486             # Suggestions are welcome.
487             sub _send_command {
488 171     171   1908 my $self = shift;
489 171         1717 my $cmd = shift;
490 171         575 my $arg = shift;
491 171         6093 local $/ = "\xd";
492 171         389 my(%result, %name);
493 171         2961 my $payload = $self->_build_command($cmd, $arg);
494 171         3172 my $select = IO::Select->new();
495             # send loop: try to connect to each host and send data
496 171         5019 while (my($host, $cnx) = each %{$self->{'host'}}) {
  341         3755  
497 170         1494 $result{$host} = ERR_TIMEOUT;
498 170 50       1486 unless ($cnx) {
499 170 100       952 unless ($cnx = $self->_open_connection($host)) {
500 17         34 $result{$host} = ERR_NETWORK;
501 17 100       51 delete $self->{'host'}->{$host} if ($self->{'try_once'});
502 17         49 next;
503             }
504 153 50       3650 unless ($self->_auth_connection($host)) {
505 0         0 $result{$host} = ERR_AUTH;
506 0 0       0 delete $self->{'host'}->{$host} if ($self->{'try_once'});
507 0         0 next;
508             }
509             }
510 153         4352 $cnx->write($payload);
511 153         14339 $select->add($cnx);
512 153         7895 $name{$cnx} = $host;
513             }
514             # recv loop: check connections for responses until 5 second timeout
515 171         517 my $start_time = time;
516 171   66     1242 while ($select->count() && time - $start_time < $self->{'receive_timeout'}) {
517 153         3329 my @ready = $select->can_read($self->{'receive_timeout'});
518 153         355352 foreach my $cnx (@ready) {
519 153         819 my $host = $name{$cnx};
520 153         369 my $resp;
521 153         1096 my $status = $cnx->recv($resp, 256, MSG_DONTWAIT);
522 153 50       6383 next unless (defined $status);
523 153         1098 $select->remove($cnx);
524 153 50       7942 unless ($self->{'keep_alive'}) {
525 153         1021 $cnx->close;
526 153         39090 $self->{'host'}->{$host} = 0;
527             }
528 153         2015 $cmd = $COMMAND{$cmd};
529 153 50 33     10077 if (defined $resp && $resp =~ /^%1$cmd=(.*)\x0d$/) {
530 153 100       1245 if (defined $RESPONSE{$1}) {
531 82         1344 $result{$host} = $RESPONSE{$1};
532             } else {
533 71         1264 $result{$host} = $1;
534             }
535             } else {
536 0         0 $result{$host} = ERR_PARSE;
537             }
538             }
539             }
540             # return data
541 171 50       2211 if ($self->{'batch'}) {
542 0         0 return \%result;
543             } else {
544 171         613 (undef, my $result) = each %result;
545 171         6742 return $result;
546             }
547             }
548              
549             =head2 add_hosts($host1, ...)
550              
551             Takes arguments of the same form as the C option to the C constructor.
552             These hosts will be appended to the list of hosts that commands will be sent to.
553             Batch mode is enabled if appropriate.
554              
555             =cut
556              
557             sub add_hosts {
558 1     1 1 1320 my $self = shift;
559 1         4 foreach my $host (@_) {
560 2         4 switch (ref $host) {
  2         4  
  2         11  
  0         0  
561 2 100       39 case '' {
  1         22  
562 1         4 $self->{'host'}->{$host} = 0;
563 1         11 }
  0         0  
  0         0  
  0         0  
564 1 50       22 case 'ARRAY' {
  1         14  
565 1         56 foreach (@{$host}) {$self->{'host'}->{$_} = 0;}
  1         4  
  2         6  
566 1         11 }
  0         0  
  0         0  
  0         0  
567             else {
568 0         0 carp "Invalid argument";
569             }
570             }
571             }
572 1         2 $self->{'batch'} = (scalar keys %{$self->{'host'}} > 1);
  1         5  
573             }
574              
575             =head2 remove_hosts($host1, ...)
576              
577             Takes arguments of the same form as the C option to the C constructor.
578             These hosts will be removed from the list of hosts that commands will be sent to.
579             Batch mode is not changed by this function in order to avoid a surprise change in output format.
580              
581             =cut
582              
583             sub remove_hosts {
584 1     1 1 996 my $self = shift;
585 1         3 foreach my $host (@_) {
586 2         3 switch (ref $host) {
  2         4  
  2         7  
  0         0  
587 2 100       28 case '' {
  1         18  
588 1         3 delete $self->{'host'}->{$host};
589 1         9 }
  0         0  
  0         0  
  0         0  
590 1 50       15 case 'ARRAY' {
  1         12  
591 1         2 foreach (@{$host}) {delete $self->{'host'}->{$_};}
  1         3  
  2         6  
592 1         9 }
  0         0  
  0         0  
  0         0  
593             else {
594 0         0 carp "Invalid argument";
595             }
596             }
597             }
598             }
599              
600             =head1 PROJECTOR COMMAND METHODS
601              
602             These methods are all frontends for projector commands; calling them will issue the corresponding command immediately.
603             The actual return value of these functions depends on whether batch mode is enabled (it is automatically enabled when more than one host has been added).
604             If enabled, the return value of these functions will always be a hash reference, with the keys being hostnames or IP addresses and the values being the response received from that host.
605             To illustrate:
606              
607             $prj = Net::PJLink->new(host => '10.0.0.1');
608              
609             $prj->set_power(1);
610             # => 0
611              
612             $prj->add_hosts('10.0.0.2');
613              
614             $prj->set_power(1);
615             # => { '10.0.0.1' => 0, '10.0.0.2' => 0 }
616              
617             The return values described below for each method are the return values for each host.
618              
619             =head2 set_power($state)
620              
621             Turn power on or off.
622             If the single argument is true, turn on; if argument is false, turn off.
623             Returns one of C, C, C, C.
624              
625             =cut
626              
627             sub set_power {
628 50     50 1 3626 my $self = shift;
629 50 100       1470 my $status = ($_[0] ? '1' : '0');
630 50         773 return $self->_send_command('power', $status);
631             }
632              
633             =head2 get_power()
634              
635             Get the power status.
636             Returns one of C, C, C, C, C, or C.
637              
638             =cut
639              
640             sub get_power {
641 17     17 1 1543 my $self = shift;
642 17         1398 return $self->_send_command('power', '?');
643             }
644              
645             =head2 set_input($input_type, $number)
646              
647             Set the active input.
648             The first argument is the input type, which can be specified using one of the provided values:
649              
650             =over 4
651              
652             =item * C
653              
654             =item * C
655              
656             =item * C
657              
658             =item * C
659              
660             =item * C
661              
662             =back
663              
664             The second argument specifies which of the inputs of that type should be used.
665             For example, to use the second video input:
666              
667             $prj->set_input(Net::PJLink::INPUT_VIDEO, 2);
668              
669             See the C method for information on available inputs.
670             Returns one of C, C, C, or C.
671              
672             =cut
673              
674             sub set_input {
675 14     14 1 1232 my $self = shift;
676 14         199 my $value = shift;
677 14         107 my $number = shift;
678 14 50 33     1092 unless ($value =~ /^[1-9]$/ && $number =~ /^[1-9]$/) {
679 0         0 carp "Invalid argument";
680 0         0 return 0;
681             }
682 14         489 return $self->_send_command('input', "$value$number");
683             }
684              
685             =head2 get_input()
686              
687             Get the current active input.
688             An array reference is returned, with the first value being the input type and the second value indicating which input of that type.
689             Example:
690              
691             $prj->get_input();
692             # => [ 3, 1 ]
693              
694             The example response indicates that the first C source is active.
695              
696             =cut
697              
698             sub get_input {
699 13     13 1 1066 my $self = shift;
700             my $xform = sub {
701 13     13   39 local $_ = shift;
702 13 100       372 return $_ unless (/(\d)(\d)/);
703 12         888 return [$1, $2];
704 13         630 };
705 13         329 my $resp = $self->_send_command('input', '?');
706 13 50       160 if (not $self->{'batch'}) { return &$xform($resp); }
  13         88  
707 0         0 foreach (keys %$resp) { $resp->{$_} = &$xform($resp->{$_}); }
  0         0  
708 0         0 return $resp;
709             }
710              
711             =head2 set_audio_mute($state)
712              
713             Set audio mute on or off.
714             Returns one of C, C, C, or C.
715              
716             =cut
717              
718             sub set_audio_mute {
719 12     12 1 738 my $self = shift;
720 12 50       401 my $value = ($_[0] ? '1' : '0');
721 12         456 return $self->_send_command('mute', '2' . $value);
722             }
723              
724             =head2 set_video_mute($state)
725              
726             Set video mute on or off.
727             Returns one of C, C, C, or C.
728              
729             =cut
730              
731             sub set_video_mute {
732 11     11 1 852 my $self = shift;
733 11 100       375 my $value = ($_[0] ? '1' : '0');
734 11         426 return $self->_send_command('mute', '1' . $value);
735             }
736              
737             =head2 get_av_mute()
738              
739             Get the current status of audio and video mute.
740             An array reference is returned, with the first value being audio mute and the second being video mute.
741             If the command failed, C or C may be returned.
742              
743             =cut
744              
745             sub get_av_mute {
746 10     10 1 911 my $self = shift;
747             my $xform = sub {
748 10     10   31 local $_ = shift;
749 10 100       197 return $_ unless (/([123])([01])/);
750 9         18 switch ($1) {
  9         144  
  9         243  
  0         0  
751 9 50       765 case 1 { return [1-$2, $2]; }
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
752 9 50       333 case 2 { return [$2, 1-$2]; }
  9         171  
  9         648  
  0         0  
  0         0  
  0         0  
  0         0  
753 0 0       0 case 3 { return [$2, $2]; }
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
754             }
755 10         511 };
756 10         456 my $resp = $self->_send_command('mute', '?');
757 10 50       95 if (not $self->{'batch'}) { return &$xform($resp); }
  10         66  
758 0         0 foreach (keys %$resp) { $resp->{$_} = &$xform($resp->{$_}); }
  0         0  
759 0         0 return $resp;
760             }
761              
762             =head2 get_status()
763              
764             Get the health status of various parts of the projector.
765             A hash reference is returned, with the keys being the name of the part.
766              
767             $prj->get_status();
768             # => {
769             # 'fan' => 0,
770             # 'lamp' => 0,
771             # 'temp' => 0,
772             # 'cover' => 0,
773             # 'filter'=> -7,
774             # 'other' => 0,
775             # }
776              
777             The example response indicates that the projector's filter is in a C state, and all other areas are C.
778              
779             The values will be one of C, C, or C.
780              
781             Example for finding lamp health from multiple projectors:
782              
783             my $prj = Net::PJLink->new(
784             host => [ '192.168.1.1', '192.168.1.2' ],
785             );
786              
787             my $result = $prj->get_status();
788             while (my($host, $status) = each %$result) {
789             my $lamp = $status->{'lamp'};
790             print "The projector at $host has lamp status: ";
791             print $lamp == OK ? "ok\n" :
792             $lamp == WARNING ? "warning\n" :
793             $lamp == ERROR ? "error\n";
794             }
795              
796             =cut
797              
798             sub get_status {
799 9     9 1 791 my $self = shift;
800             my $xform = sub {
801 9     9   17 local $_ = shift;
802 9         270 my %xlate = (
803             '0' => OK,
804             '1' => WARNING,
805             '2' => ERROR,
806             );
807 9 100       263 return $_ unless (/(\d)(\d)(\d)(\d)(\d)(\d)/);
808             return {
809 8         1032 'fan' => $xlate{$1},
810             'lamp' => $xlate{$2},
811             'temp' => $xlate{$3},
812             'cover' => $xlate{$4},
813             'filter'=> $xlate{$5},
814             'other' => $xlate{$6},
815             };
816 9         566 };
817 9         309 my $resp = $self->_send_command('status', '?');
818 9 50       453 if (not $self->{'batch'}) { return &$xform($resp); }
  9         59  
819 0         0 foreach (keys %$resp) { $resp->{$_} = &$xform($resp->{$_}); }
  0         0  
820 0         0 return $resp;
821             }
822              
823             =head2 get_lamp_info()
824              
825             Get the status and hours used for each lamp. The return value is a data structure like:
826              
827             [
828             [ $status, $hours ],
829             ... # each lamp
830             ]
831              
832             For consistency, this structure is used even if the projector only has one lamp.
833              
834             C<$status> indicates whether the lamp is on or off (1 or 0). $hours is an integer indicating the total number of hours the lamp has been on.
835             If the command was not successful, C or C may be returned.
836              
837             =cut
838              
839             sub get_lamp_info {
840 8     8 1 814 my $self = shift;
841             my $xform = sub {
842 8     8   79 local $_ = shift;
843 8 100       243 return $_ unless (/((\d+)\s+([10]))+/);
844 7         70 my @lamps = split / /;
845 7         49 my @ret;
846 7         98 while (scalar @lamps) {
847 21         63 my($hours, $status) = splice @lamps, 0, 2;
848 21         175 push @ret, [$status, $hours];
849             }
850 7         427 return \@ret;
851 8         693 };
852 8         488 my $resp = $self->_send_command('lamp', '?');
853 8 50       89 if (not $self->{'batch'}) { return &$xform($resp); }
  8         115  
854 0         0 foreach (keys %$resp) { $resp->{$_} = &$xform($resp->{$_}); }
  0         0  
855 0         0 return $resp;
856             }
857              
858             =head2 get_input_list()
859              
860             Get a list of all available inputs. The return value is a data structure like:
861              
862             [
863             [ $type, $index ],
864             ... # each input
865             ]
866              
867             C<$type> corresponds to one of the five input types:
868              
869             =over 4
870              
871             =item * C
872              
873             =item * C
874              
875             =item * C
876              
877             =item * C
878              
879             =item * C
880              
881             =back
882              
883             C<$index> is the number of that type (i.e. C<[3, 3]> indicates the third digital input).
884             If the command was not successful, C or C may be returned.
885              
886             =cut
887              
888             sub get_input_list {
889 7     7 1 728 my $self = shift;
890             my $xform = sub {
891 7     7   27 local $_ = shift;
892 7 100       205 return $_ if (/^-?\d+$/);
893 6 50       294 return ERR_PARSE unless (/[1-5][1-9]( [1-5][1-9])*/);
894 6         144 my @inputs = split / /;
895 6         18 my @ret;
896 6         96 while (scalar @inputs) {
897 48         132 my $inp = shift @inputs;
898 48         498 $inp =~ /(\d)(\d)/;
899 48         474 push @ret, [$1, $2];
900             }
901 6         462 return \@ret;
902 7         355 };
903 7         335 my $resp = $self->_send_command('input_list', '?');
904 7 50       300 if (not $self->{'batch'}) { return &$xform($resp); }
  7         153  
905 0         0 foreach (keys %$resp) { $resp->{$_} = &$xform($resp->{$_}); }
  0         0  
906 0         0 return $resp;
907             }
908              
909             =head2 get_name()
910              
911             Get the projector name. Returns a string.
912             If the command was not successful, C or C may be returned.
913              
914             =cut
915              
916             sub get_name {
917 6     6 1 796 my $self = shift;
918 6         251 return $self->_send_command('name', '?');
919             }
920              
921             =head2 get_manufacturer()
922              
923             Get the manufacturer name. Returns a string.
924             If the command was not successful, C or C may be returned.
925              
926             =cut
927              
928             sub get_manufacturer {
929 5     5 1 1004 my $self = shift;
930 5         266 return $self->_send_command('mfr', '?');
931             }
932              
933             =head2 get_product_name()
934              
935             Get the product name. Returns a string.
936             If the command was not successful, C or C may be returned.
937              
938             =cut
939              
940             sub get_product_name {
941 4     4 1 768 my $self = shift;
942 4         170 return $self->_send_command('prod_name', '?');
943             }
944              
945             =head2 get_product_info()
946              
947             Get "other information". Returns a string.
948             If the command was not successful, C or C may be returned.
949              
950             =cut
951              
952             sub get_product_info {
953 3     3 1 702 my $self = shift;
954 3         122 return $self->_send_command('prod_info', '?');
955             }
956              
957             =head2 get_class()
958              
959             Get information on supported PJLink Class. Returns a single digit.
960             For example, returning "2" indicates that the projector is compatible with the PJLink Class 2 protocol.
961             The PJLink v.1.00 Class 1 specification only defines return values "1" and "2".
962             If the command was not successful, C or C may be returned.
963              
964             =cut
965              
966             sub get_class {
967 2     2 1 670 my $self = shift;
968 2         48 return $self->_send_command('class', '?');
969             }
970              
971             =head1 AUTHOR
972              
973             Kyle Emmons, C<< >>
974              
975             =head1 BUGS
976              
977             This module has only been tested on Panasonic PTFW100NTU projectors.
978              
979             The code for opening network connections may not work reliably for a large (~200) number of hosts.
980             This is due to network connections timing out before all hosts have been contacted.
981             If you encounter this problem, adjusting the C and C arguments may help.
982              
983             Please report any bugs or feature requests to C, or through
984             the web interface at L.
985             I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
986              
987              
988              
989              
990             =head1 SUPPORT
991              
992             You can find documentation for this module with the perldoc command.
993              
994             perldoc Net::PJLink
995              
996              
997             You can also look for information at:
998              
999             =over 4
1000              
1001             =item * RT: CPAN's request tracker
1002              
1003             L
1004              
1005             =item * AnnoCPAN: Annotated CPAN documentation
1006              
1007             L
1008              
1009             =item * CPAN Ratings
1010              
1011             L
1012              
1013             =item * Search CPAN
1014              
1015             L
1016              
1017             =back
1018              
1019             =head1 LICENSE AND COPYRIGHT
1020              
1021             Copyright 2010 Kyle Emmons.
1022              
1023             This program is free software; you can redistribute it and/or modify it
1024             under the terms of either: the GNU General Public License as published
1025             by the Free Software Foundation; or the Artistic License.
1026              
1027             See http://dev.perl.org/licenses/ for more information.
1028              
1029             The PJLink name is a trademark of Japan Business Machine and Information System Industries Association (JBMIA).
1030              
1031             =cut
1032              
1033             1; # End of Net::PJLink