File Coverage

blib/lib/UPS/Nut.pm
Criterion Covered Total %
statement 26 389 6.6
branch 0 138 0.0
condition 0 52 0.0
subroutine 8 46 17.3
pod 1 23 4.3
total 35 648 5.4


line stmt bran cond sub pod time code
1             # UPS::Nut - a class to talk to a UPS via the Network Utility Tools upsd.
2             # Author - Kit Peters
3              
4             # ### changelog: made debug messages slightly more descriptive, improved
5             # ### changelog: comments in code
6             # ### changelog: Removed timeleft() function.
7              
8             package UPS::Nut;
9 1     1   667 use strict;
  1         2  
  1         30  
10 1     1   5 use Carp;
  1         1  
  1         77  
11 1     1   2753 use FileHandle;
  1         13110  
  1         6  
12 1     1   1504 use IO::Socket;
  1         19582  
  1         5  
13 1     1   3851 use IO::Select;
  1         1694  
  1         68  
14              
15             # The following globals dictate whether the accessors and instant-command
16             # functions are created.
17             # ### changelog: tie hash interface and AUTOLOAD contributed by
18             # ### changelog: Wayne Wylupski
19              
20             my $_eol = "\n";
21              
22             BEGIN {
23 1     1   7 use Exporter ();
  1         2  
  1         20  
24 1     1   5 use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  1         1  
  1         97  
25 1     1   2 $VERSION = 0.04; # $Id$
26 1         18 @ISA = qw(Exporter IO::Socket::INET);
27 1         2 @EXPORT = qw();
28 1         2 @EXPORT_OK = qw();
29 1         4476 %EXPORT_TAGS = ();
30             }
31              
32             sub new {
33             # Author: Kit Peters
34 0     0 1   my $proto = shift;
35 0   0       my $class = ref($proto) || $proto;
36 0           my %arg = @_; # hash of arguments
37 0           my $self = {}; # _initialize will fill it later
38 0           bless $self, $class;
39 0 0         unless ($self->_initialize(%arg)) { # can't initialize
40 0           carp "Can't initialize: $self->{err}";
41 0           return undef;
42             }
43 0           return $self;
44             }
45              
46             # accessor functions. Return a value if successful, return undef
47             # otherwise.
48              
49             sub BattPercent { # get battery percentage
50             # Author: Kit Peters
51 0     0 0   my $self = shift;
52 0           my $var = "BATTPCT";
53 0           return $self->Request($var);
54             }
55              
56             sub LoadPercent { # get load percentage
57             # Author: Kit Peters
58 0     0 0   my $self = shift;
59 0           my $var = "LOADPCT";
60 0           return $self->Request($var);
61             }
62              
63             sub LineVoltage { # get line voltage
64             # Author: Kit Peters
65 0     0 0   my $self = shift;
66 0           my $var = "UTILITY";
67 0           return $self->Request($var);
68             }
69              
70             sub Status { # get status of UPS
71             # Author: Kit Peters
72 0     0 0   my $self = shift;
73 0           my $var = "STATUS";
74 0           return $self->Request($var);
75             }
76              
77             sub Temperature { # get the internal temperature of UPS
78             # Author: Kit Peters
79 0     0 0   my $self = shift;
80 0           my $var = "UPSTEMP";
81 0           return $self->Request($var);
82             }
83              
84             # control functions: they control our relationship to upsd, and send
85             # commands to upsd.
86              
87             sub Login { # login to upsd, so that it won't shutdown unless we say we're
88             # ok. This should only be used if you're actually connected
89             # to the ups that upsd is monitoring.
90              
91             # Author: Kit Peters
92             # ### changelog: modified login logic a bit. Now it doesn't check to see
93             # ### changelog: if we got OK, ERR, or something else from upsd. It
94             # ### changelog: simply checks for a response beginning with OK from upsd.
95             # ### changelog: Anything else is an error.
96             #
97             # ### changelog: uses the new _send command
98             #
99 0     0 0   my $self = shift; # myself
100 0           my $user = shift; # username
101 0           my $pass = shift; # password
102 0           my $errmsg; # error message, sent to _debug and $self->{err}
103             my $ans; # scalar to hold responses from upsd
104              
105             # only attempt login if username and password given
106 0 0 0       if ((defined $user) && (defined $pass)) {
107              
108 0           $ans = $self->_send( "USERNAME $user");
109 0 0 0       if (defined $ans && $ans =~ /^OK/) { # username OK, send password
110              
111 0           $ans = $self->_send( "PASSWORD $pass");
112 0 0 0       if (defined $ans && $ans =~ /^OK/) { # password OK, attempt to login
113              
114 0           $ans = $self->_send( "LOGIN $self->{name}" );
115              
116             # ### changelog: 8/3/2002 - KP - modified login to send ups name w/LOGIN
117             # ### changelog: command
118              
119 0 0 0       if (defined $ans && $ans =~ /^OK/) { # Login successful.
120 0           $self->_debug("LOGIN successful.");
121 0           return 1;
122             }
123             }
124             }
125             }
126 0 0         if ( defined $ans )
127             {
128 0           $errmsg = "LOGIN failed. Last message from upsd: $ans";
129             }
130             else
131             {
132 0           $errmsg = "Network error: $!";
133             }
134 0           $self->_debug($errmsg);
135 0           $self->{err} = $errmsg;
136 0           return undef;
137             }
138              
139             sub Authenticate { # Announce to the UPS who we are to set up the proper
140             # management level. See upsd.conf man page for details.
141              
142             # Contributor: Wayne Wylupski
143 0     0 0   my $self = shift; # myself
144 0           my $user = shift; # username
145 0           my $pass = shift; # password
146              
147 0           my $errmsg; # error message, sent to _debug and $self->{err}
148             my $ans; # scalar to hold responses from upsd
149              
150             # only attempt authentication if username and password given
151 0 0 0       if ((defined $user) && (defined $pass)) {
152              
153 0           $ans = $self->_send( "USERNAME $user");
154 0 0 0       if (defined $ans && $ans =~ /^OK/) { # username OK, send password
155              
156 0           $ans = $self->_send( "PASSWORD $pass");
157 0 0 0       return 1 if (defined $ans && $ans =~ /^OK/);
158             }
159             }
160 0 0         if ( defined $ans )
161             {
162 0           $errmsg = "Authentication failed. Last message from upsd: $ans";
163             }
164             else
165             {
166 0           $errmsg = "Network error: $!";
167             }
168 0           $self->_debug($errmsg);
169 0           $self->{err} = $errmsg;
170 0           return undef;
171             }
172              
173             sub Logout { # logout of upsd
174             # Author: Kit Peters
175             # ### changelog: uses the new _send command
176             #
177 0     0 0   my $self = shift;
178 0 0         if ($self->{srvsock}) { # are we still connected to upsd?
179 0           my $ans = $self->_send( "LOGOUT" );
180 0           close ($self->{srvsock});
181 0           delete ($self->{srvsock});
182             }
183             }
184              
185             # internal functions. These are only used by UPS::Nut internally, so
186             # please don't use them otherwise. If you really think an internal
187             # function should be externalized, let me know.
188              
189             sub _initialize {
190             # Author: Kit Peters
191 0     0     my $self = shift;
192 0           my %arg = @_;
193 0   0       my $host = $arg{HOST} || 'localhost'; # Host running master upsd
194 0   0       my $port = $arg{PORT} || '3493'; # 3493 is IANA assigned port for NUT
195 0   0       my $proto = $arg{PROTO} || 'tcp'; # use tcp unless user tells us to
196 0   0       my $user = $arg{USERNAME} || undef; # username passed to upsd
197 0   0       my $pass = $arg{PASSWORD} || undef; # password passed to upsd
198 0   0       my $login = $arg{LOGIN} || 0; # login to upsd on init?
199              
200 0   0       $self->{name} = $arg{NAME} || 'default'; # UPS name in etc/ups.conf on $host
201 0   0       $self->{timeout} = $arg{TIMEOUT} || 30; # timeout
202 0   0       $self->{debug} = $arg{DEBUG} || 0; # debugging?
203 0   0       $self->{debugout} = $arg{DEBUGOUT} || undef; # where to send debug messages
204              
205 0           my $srvsock = $self->{srvsock} = # establish connection to upsd
206             IO::Socket::INET->new(
207             PeerAddr => $host,
208             PeerPort => $port,
209             Proto => $proto
210             );
211              
212 0 0         unless ( defined $srvsock) { # can't connect
213 0           $self->{err} = "Unable to connect via $proto to $host:$port: $!";
214 0           return undef;
215             }
216              
217 0           $self->{select} = IO::Select->new( $srvsock );
218              
219 0 0         if ($login) { # attempt login to upsd if that option is specified
220 0 0         if ($self->Login($user, $pass)) {
221 0           $self->_debug("Logged in successfully to upsd");
222             }
223             else {
224 0           $self->_debug("Login to upsd failed: $self->{err}");
225 0           carp "Login to upsd failed: $self->{err}";
226             }
227             }
228              
229             # get a hash of vars for both the TIE functions as well as for
230             # expanding vars.
231 0           %{$self->{vars}} = map{ $_ =>1 } $self->ListVars;
  0            
  0            
232              
233 0 0         unless ( defined $self->{vars} ) {
234 0           $self->{err} = "Network error: $!";
235 0           return undef;
236             }
237              
238 0           return $self;
239             }
240              
241             #
242             # _send
243             #
244             # Sends a command to the server and retrieves the results.
245             # If there was a network error, return undef; $! will contain the
246             # error.
247             sub _send
248             {
249             # Contributor: Wayne Wylupski
250 0     0     my $self = shift;
251 0           my $cmd = shift;
252 0           my @handles;
253             my $result; # undef by default
254              
255 0           my $socket = $self->{srvsock};
256 0           my $select = $self->{select};
257              
258 0           @handles = IO::Select->select( undef, $select, $select, $self->{timeout} );
259 0 0         return undef if ( !scalar $handles[1] );
260              
261 0           $socket->print( $cmd . $_eol );
262              
263 0           @handles = IO::Select->select( $select, undef, $select, $self->{timeout} );
264 0 0         return undef if ( !scalar $handles[0]);
265            
266 0           $result = $socket->getline;
267 0 0         return undef if ( !defined ( $result ) );
268 0           chomp $result;
269              
270 0           return $result;
271             }
272              
273             sub _getline
274             {
275             # Contributor: Wayne Wylupski
276 0     0     my $self = shift;
277 0           my $result; # undef by default
278              
279 0           my $socket = $self->{srvsock};
280 0           my $select = $self->{select};
281              
282             # Different versions of IO::Socket has different error detection routines.
283 0 0 0       return undef if ( $IO::Socket::{has_error} && $select->has_error(0) );
284 0 0 0       return undef if ( $IO::Socket::{has_exception} && $select->has_exception(0) );
285              
286 0           chomp ( $result = $socket->getline );
287 0           return $result;
288             }
289              
290             sub Request { # request a variable from the UPS
291             # Author: Kit Peters
292 0     0 0   my $self = shift;
293             # ### changelog: 8/3/2002 - KP - Request() now returns undef if not
294             # ### changelog: connected to upsd via $srvsock
295             # ### changelog: uses the new _send command
296             #
297 0           my $var = shift;
298 0           my $req = "REQ $var@" . $self->{name}; # build request
299 0           my $ans = $self->_send( $req );
300              
301 0 0         unless ( defined $ans )
302             {
303 0           $self->{err} = "Network error: $!";
304 0           return undef;
305             };
306              
307 0 0         if ($ans =~ /^ERR/) {
    0          
308 0           $self->{err} = "Error: $ans. Requested $var.";
309 0           return undef;
310             }
311             elsif ($ans =~ /^ANS/) {
312 0           my $checkvar; # to make sure the var we asked for is the var we got.
313             my $retval; # returned value for requested VAR
314 0           (undef, $checkvar, $retval) = split ' ', $ans, 3;
315             # get checkvar and retval from the answer
316 0           ($checkvar, undef) = split /@/, $checkvar, 2; # throw away "@"
317 0 0         if ($checkvar ne $var) { # did not get expected var
318 0           $self->{err} = "requested $var, received $checkvar";
319 0           return undef;
320             }
321 0           return $retval; # return the requested value
322             }
323             else { # unrecognized response
324 0           $self->{err} = "Unrecognized response from upsd: $ans";
325 0           return undef;
326             }
327             }
328              
329             sub ListRequest { # request variables in the form Name => Value
330             # Author: Kit Peters
331             # ### changelog: uses the new _send command
332             #
333 0     0 0   my $self = shift;
334 0           my @result = ();
335              
336 0           foreach my $var ( @_ )
337             {
338 0           my $req = "REQ $var@" . $self->{name}; # build request
339 0           my $ans = $self->_send( $req );
340              
341 0 0         unless ( defined $ans )
342             {
343 0           $self->{err} = "Network error: $!";
344 0           return ();
345             };
346              
347 0 0         if ($ans =~ /^ERR/) {
    0          
348 0           $self->{err} = "Error: $ans. Requested $var.";
349 0           return ();
350             }
351             elsif ($ans =~ /^ANS/) {
352 0           my $checkvar; # to make sure the var we asked for is the var we got.
353             my $retval; # returned value for requested VAR
354 0           (undef, $checkvar, $retval) = split ' ', $ans, 3;
355             # get checkvar and retval from the answer
356 0           ($checkvar, undef) = split /@/, $checkvar, 2; # throw away "@"
357 0 0         if ($checkvar ne $var) { # did not get expected var
358 0           $self->{err} = "requested $var, received $checkvar";
359 0           return ();
360             }
361 0           push @result, $var, $retval;
362             }
363             else { # unrecognized response
364 0           $self->{err} = "Unrecognized response from upsd: $ans";
365 0           return ();
366             }
367             }
368 0           return @result;
369             }
370              
371             sub Set {
372             # Contributor: Wayne Wylupski
373             # ### changelog: uses the new _send command
374             #
375 0     0 0   my $self = shift;
376 0           my $var = shift;
377 0           my $value = shift;
378              
379 0           my $req = "SET $var@" . $self->{name} . " " . $value; # build request
380 0           my $ans = $self->_send( $req );
381              
382 0 0         unless ( defined $ans )
383             {
384 0           $self->{err} = "Network error: $!";
385 0           return undef;
386             };
387              
388 0 0         if ($ans =~ /^ERR/) {
    0          
389 0           $self->{err} = "Error: $ans";
390 0           return undef;
391             }
392             elsif ($ans =~ /^OK/) {
393 0           return $value;
394             }
395             else { # unrecognized response
396 0           $self->{err} = "Unrecognized response from upsd: $ans";
397 0           return undef;
398             }
399             }
400              
401             sub FSD { # set forced shutdown flag
402             # Author: Kit Peters
403             # ### changelog: uses the new _send command
404             #
405 0     0 0   my $self = shift;
406              
407 0           my $req = "FSD " . $self->{name}; # build request
408 0           my $ans = $self->_send( $req );
409              
410 0 0         unless ( defined $ans )
411             {
412 0           $self->{err} = "Network error: $!";
413 0           return undef;
414             };
415              
416 0 0         if ($ans =~ /^ERR/) { # can't set forced shutdown flag
    0          
417 0           $self->{err} = "Can't set FSD flag. Upsd reports: $ans";
418 0           return undef;
419             }
420             elsif ($ans =~ /^OK FSD-SET/) { # forced shutdown flag set
421 0           $self->_debug("FSD flag set successfully.");
422 0           return 1;
423             }
424             else {
425 0           $self->{err} = "Unrecognized response from upsd: $ans";
426 0           return undef;
427             }
428             }
429              
430             sub InstCmd { # send instant command to ups
431             # Contributor: Wayne Wylupski
432 0     0 0   my $self = shift;
433              
434 0           chomp (my $cmd = shift);
435              
436 0           my $req = "INSTCMD " . $cmd . "@" . $self->{name};
437 0           my $ans = $self->_send( $req );
438              
439 0 0         unless ( defined $ans )
440             {
441 0           $self->{err} = "Network error: $!";
442 0           return undef;
443             };
444              
445 0 0         if ($ans =~ /^ERR/) { # error reported from upsd
    0          
446 0           $self->{err} = "Can't send instant command $cmd. Reason: $ans";
447 0           return undef;
448             }
449             elsif ($ans =~ /^OK/) { # command successful
450 0           $self->_debug("Instant command $cmd sent successfully.");
451 0           return 1;
452             }
453             else { # unrecognized response
454 0           $self->{err} = "Can't send instant command $cmd. Unrecognized response from upsd: $ans";
455 0           return undef;
456             }
457             }
458              
459             sub Enum
460             {
461             # Contributor: Wayne Wylupski
462 0     0 0   my $self = shift;
463 0           my $var = shift;
464              
465 0           my $req = "ENUM " . $var . "@" . $self->{name};
466 0           my $ans = $self->_send( $req );
467              
468 0 0         unless ( defined $ans )
469             {
470 0           $self->{err} = "Network error: $!";
471 0           return undef;
472             };
473              
474 0 0         if ($ans =~ /^ERR/) {
    0          
475 0           $self->{err} = "Error: $ans";
476 0           return undef;
477             }
478             elsif ($ans =~ /^ENUM /) { # command successfulQ
479 0           my ( $line, $option, $selected );
480 0           my @results;
481 0           while ( $line = $self->_getline )
482             {
483 0 0         if (($option, undef, $selected) = ( $line =~ /^OPTION (".*")( )?(SELECTED)?$/ ))
484             {
485 0           push @results, [ $option, $selected ];
486             }
487 0 0         last if ( $line =~ /^END/ );
488             }
489 0           $self->_debug("$req command sent successfully.");
490 0           return @results;
491             }
492             else { # unrecognized response
493 0           $self->{err} = "Can't send $req. Unrecognized response from upsd: $ans";
494 0           return undef;
495             }
496             }
497              
498             sub VarDesc
499             {
500             # Contributor: Wayne Wylupski
501 0     0 0   my $self = shift;
502 0           my $var = shift;
503              
504             # my $req = "VARDESC " . $var . "@" . $self->{name}; # NOT LIKE OTHER COMMANDS
505 0           my $req = "VARDESC " . $var ;
506 0           my $ans = $self->_send( $req );
507 0 0         unless ( defined $ans )
508             {
509 0           $self->{err} = "Network error: $!";
510 0           return undef;
511             };
512              
513 0 0         if ($ans =~ /^ERR/) {
    0          
514 0           $self->{err} = "Error: $ans";
515 0           return undef;
516             }
517             elsif ($ans =~ /^DESC/) { # command successful
518 0           $self->_debug("$req command sent successfully.");
519 0           ( undef, $ans ) = split ' ', $ans, 2;
520 0           return $ans;
521             }
522             else { # unrecognized response
523 0           $self->{err} = "Can't send $req. Unrecognized response from upsd: $ans";
524 0           return undef;
525             }
526             }
527              
528             sub VarType
529             {
530             # Contributor: Wayne Wylupski
531 0     0 0   my $self = shift;
532 0           my $var = shift;
533              
534 0           my $req = "VARTYPE " . $var . "@" . $self->{name};
535 0           my $ans = $self->_send( $req );
536 0 0         unless ( defined $ans )
537             {
538 0           $self->{err} = "Network error: $!";
539 0           return undef;
540             };
541              
542 0 0         if ($ans =~ /^ERR/) {
    0          
543 0           $self->{err} = "Error: $ans";
544 0           return undef;
545             }
546             elsif ($ans =~ /^TYPE/) { # command successful
547 0           $self->_debug("$req command sent successfully.");
548 0           ( undef, $ans ) = split ' ', $ans, 2;
549 0           return $ans;
550             }
551             else { # unrecognized response
552 0           $self->{err} = "Can't send $req. Unrecognized response from upsd: $ans";
553 0           return undef;
554             }
555             }
556              
557             sub InstCmdDesc
558             {
559             # Contributor: Wayne Wylupski
560 0     0 0   my $self = shift;
561 0           my $cmd = shift;
562              
563 0           my $req = "INSTCMDDESC " . $cmd . "@" . $self->{name};
564 0           my $ans = $self->_send( $req );
565 0 0         unless ( defined $ans )
566             {
567 0           $self->{err} = "Network error: $!";
568 0           return undef;
569             };
570              
571 0 0         if ($ans =~ /^ERR/) {
    0          
572 0           $self->{err} = "Error: $ans";
573 0           return undef;
574             }
575             elsif ($ans =~ /^DESC/) { # command successful
576 0           $self->_debug("$req command sent successfully.");
577 0           ( undef, $ans ) = split ' ', $ans, 2;
578 0           return $ans;
579             }
580             else { # unrecognized response
581 0           $self->{err} = "Can't send $req. Unrecognized response from upsd: $ans";
582 0           return undef;
583             }
584             }
585              
586             sub DESTROY { # destructor, all it does is call Logout
587             # Author: Kit Peters
588 0     0     my $self = shift;
589 0           $self->_debug("Object destroyed.");
590 0           $self->Logout();
591             }
592              
593             sub _debug { # print debug messages to stdout or file
594             # Author: Kit Peters
595 0     0     my $self = shift;
596 0 0         if ($self->{debug}) {
597 0           chomp (my $msg = shift);
598 0           my $out; # filehandle for output
599 0 0         if ($self->{debugout}) { # if filename is given, use that
600 0 0         $out = new FileHandle ($self->{debugout}, ">>") or warn "Error: $!";
601             }
602 0 0         if ($out) { # if out was set to a filehandle, create nifty timestamp
603 0           my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
604 0           $year = sprintf("%02d", $year % 100); # Y2.1K compliant, even!
605 0           my $timestamp = join '/', ($mon + 1), $mday, $year; # today
606 0           $timestamp .= " ";
607 0           $timestamp .= join ':', $hour, $min, $sec;
608 0           print $out "$timestamp $msg\n";
609             }
610 0           else { print "DEBUG: $msg\n"; } # otherwise, print to stdout
611             }
612             }
613              
614             sub Error { # what was the last thing that went bang?
615             # Author: Kit Peters
616 0     0 0   my $self = shift;
617 0 0         if ($self->{err}) { return $self->{err}; }
  0            
618 0           else { return "No error explanation available."; }
619             }
620              
621             sub ListVars { # get list of supported variables
622             # Author: Kit Peters
623             # ### changelog: uses the new _send command
624             #
625 0     0 0   my $self = shift;
626              
627 0           my $req = "LISTVARS " . $self->{name}; # build request
628 0           my $availvars = $self->_send( $req );
629              
630 0 0         unless ( defined $availvars )
631             {
632 0           $self->{err} = "Network error: $!";
633 0           return undef;
634             };
635              
636 0           my @vars = split( / /, $availvars );
637              
638 0 0         unless ( ( shift @vars ) =~ /^VARS/ ) {
639 0           $self->{err} = "Can't get var list. Upsd response: $availvars";
640 0           return undef;
641             }
642              
643 0 0         if ($vars[0] =~ m/@/ ) { shift @vars } # throw away $vars[0] if it's
  0            
644             # of the form "@"
645              
646 0           return @vars;
647             }
648              
649             sub ListRW { # get list of supported read/writeable variables
650             # Author: Kit Peters
651             # ### changelog: uses the new _send command
652             #
653 0     0 0   my $self = shift;
654              
655 0           my $req = "LISTRW " . $self->{name};
656 0           my $availvars = $self->_send( $req );
657              
658 0 0         unless ( defined $availvars )
659             {
660 0           $self->{err} = "Network error: $!";
661 0           return undef;
662             };
663              
664 0           my @vars = split( / /, $availvars );
665              
666 0 0         unless ( ( shift @vars ) =~ /^RW/ ) {
667 0           $self->{err} = "Can't get var list. Upsd response: $availvars";
668 0           return undef;
669             }
670              
671 0 0         if ($vars[0] =~ m/@/ ) { shift @vars } # throw away $vars[0] if it's
  0            
672             # of the form "@"
673              
674 0           return @vars;
675             }
676              
677             sub ListInstCmds { # check for available instant commands
678             # Contributor: Wayne Wylupski
679             # ### changelog: uses the new _send command
680             #
681 0     0 0   my $self = shift;
682              
683 0           my $req = "LISTINSTCMD " . $self->{name}; # build request
684 0           my $instcmds = $self->_send( $req );
685              
686 0 0         unless ( defined $instcmds )
687             {
688 0           $self->{err} = "Network error: $!";
689 0           return undef;
690             };
691              
692 0           my @instcmds = split( / /, $instcmds );
693              
694 0 0         unless ( ( shift @instcmds ) =~ /^INSTCMDS/ ) {
695 0           $self->{err} = "Can't get var list. Upsd response: $instcmds";
696 0           return undef;
697             }
698              
699 0 0         if ($instcmds[0] =~ m/@/ ) { shift @instcmds }
  0            
700             # throw away $instcmds[0] if it's of the form "@"
701              
702 0           return @instcmds;
703             }
704              
705             sub Master { # check for MASTER level access
706             # Author: Kit Peters
707             # ### changelog: uses the new _send command
708             #
709 0     0 0   my $self = shift;
710              
711 0           my $req = "MASTER " . $self->{name}; # build request
712 0           my $ans = $self->_send( $req );
713              
714 0 0         unless ( defined $ans )
715             {
716 0           $self->{err} = "Network error: $!";
717 0           return undef;
718             };
719              
720 0 0         if ($ans =~ /^OK/) { # access granted
721 0           $self->_debug("MASTER level access granted. Upsd reports: $ans");
722 0           return 1;
723             }
724             else { # access denied, or unrecognized reponse
725 0           $self->{err} = "MASTER level access denied. Upsd responded: $ans";
726             # ### changelog: 8/3/2002 - KP - Master() returns undef rather than 0 on
727             # ### failure. this makes it consistent with other methods
728 0           return undef;
729             }
730             }
731              
732             sub AUTOLOAD {
733             # Contributor: Wayne Wylupski
734 0     0     my $self = shift;
735 0           my $name = $UPS::Nut::AUTOLOAD;
736 0           $name =~ s/^.*:://;
737              
738             # for a change we will only load cmds if needed.
739 0 0         if (!defined $self->{cmds} )
740             {
741 0           %{$self->{cmds}} = map{ $_ =>1 } $self->ListInstCmds;
  0            
  0            
742             }
743              
744 0 0         croak "No such InstCmd: $name" if (! $self->{cmds}{$name} );
745            
746 0           return $self->InstCmd( $name );
747             }
748              
749             #-------------------------------------------------------------------------
750             # tie hash interface
751             #
752             # The variables of the array, including the hidden 'numlogins' can
753             # be accessed as a hash array through this method.
754             #
755             # Example:
756             # tie %ups, 'UPS::Nut',
757             # NAME => "myups",
758             # HOST => "somemachine.somewhere.com",
759             # ... # same options as new();
760             # ;
761             #
762             # $ups{UPSIDENT} = "MyUPS";
763             # print $ups{MFR}, " " $ups{MODEL}, "\n";
764             #
765             #-------------------------------------------------------------------------
766             sub TIEHASH {
767 0   0 0     my $class = shift || 'UPS::Nut';
768 0           return $class->new( @_ );
769             }
770              
771             sub FETCH {
772 0     0     my $self = shift;
773 0           my $key = shift;
774              
775 0           return $self->Request( $key );
776             }
777              
778             sub STORE {
779 0     0     my $self = shift;
780 0           my $key = shift;
781 0           my $value = shift;
782              
783 0           return $self->Set( $key, $value );
784             }
785              
786             sub DELETE {
787 0     0     croak "DELETE operation not supported";
788             }
789              
790             sub CLEAR {
791 0     0     croak "CLEAR operation not supported";
792             }
793              
794             sub EXISTS {
795 0     0     my $self = shift;
796 0           my $key = shift;
797 0           return exists $self->{vars}{$key};
798             }
799              
800             sub FIRSTKEY {
801 0     0     my $self = shift;
802 0           my $a = keys %{$self->{vars}};
  0            
803 0           return scalar each %{$self->{vars}};
  0            
804             }
805              
806             sub NEXTKEY {
807 0     0     my $self = shift;
808 0           return scalar each %{$self->{vars}};
  0            
809             }
810              
811             sub UNTIE {
812 0     0     $_[0]->Logout;
813             }
814              
815             =head1 NAME
816              
817             Nut - a module to talk to a UPS via NUT (Network UPS Tools) upsd
818              
819             =head1 SYNOPSIS
820              
821             use UPS::Nut;
822              
823             $ups = new UPS::Nut( NAME => "myups",
824             HOST => "somemachine.somewhere.com",
825             PORT => "3493",
826             USERNAME => "upsuser",
827             PASSWORD => "upspasswd",
828             TIMEOUT => 30,
829             DEBUG => 1,
830             DEBUGOUT => "/some/file/somewhere",
831             );
832             if ($ups->Status() =~ /OB/) {
833             print "Oh, no! Power failure!\n";
834             }
835              
836             tie %other_ups, 'UPS::Nut',
837             NAME => "myups",
838             HOST => "somemachine.somewhere.com",
839             ... # same options as new();
840             ;
841              
842             print $other_ups{MFR}, " ", $other_ups{MODEL}, "\n";
843              
844             =head1 DESCRIPTION
845              
846             This is an object-oriented (whoo!) interface between Perl and upsd from
847             the Network UPS Tools package (http://www.exploits.org/nut/). Note that
848             it only talks to upsd for you in a Perl-ish way. It doesn't continually
849             monitor the UPS.
850              
851             =head1 CONSTRUCTOR
852              
853             Shown with defaults: new UPS::Nut( NAME => "default",
854             HOST => "localhost",
855             PORT => "3493",
856             USERNAME => "",
857             PASSWORD => "",
858             DEBUG => 0,
859             DEBUGOUT => "",
860             );
861             * NAME is the name of the UPS to monitor, as specified in ups.conf
862             * HOST is the host running upsd
863             * PORT is the port that upsd is running on
864             * USERNAME and PASSWORD are those that you use to login to upsd. This
865             gives you the right to do certain things, as specified in upsd.conf.
866             * DEBUG turns on debugging output, set to 1 or 0
867             * DEBUGOUT is de thing you do when de s*** hits the fan. Actually, it's
868             the filename where you want debugging output to go. If it's not
869             specified, debugging output comes to standard output.
870              
871             =head1 Methods
872              
873             =head2 Methods for querying UPS status
874            
875             Request(varname)
876             returns value of the specified variable. Returns undef if variable
877             unsupported.
878              
879             Set(varname, value)
880             sets the value of the specified variable. Returns undef if variable
881             unsupported, or if variable cannot be set for some other reason. See
882             Authenticate() if you wish to use this function.
883              
884             BattPercent()
885             returns percentage of battery left. Returns undef if we can't get
886             battery percentage for some reason.
887              
888             LoadPercent()
889             returns percentage of the load on the UPS. Returns undef if load
890             percentage is unavailable.
891              
892             LineVoltage()
893             returns input line (e.g. the outlet) voltage. Returns undef if line
894             voltage is unavailable.
895              
896             Status()
897             returns UPS status, one of OL or OB. OL or OB may be followed by LB,
898             which signifies low battery state. OL or OB may also be followed by
899             FSD, which denotes that the forced shutdown state
900             ( see UPS::Nut->FSD() ) has been set on upsd. Returns undef if status
901             unavailable.
902              
903             Temperature()
904             returns UPS internal temperature. Returns undef if internal temperature
905             unavailable.
906              
907             =head2 Other methods
908              
909             These all operate on the UPS specified in the NAME argument to the
910             constructor.
911              
912             Authenticate( username, password )
913             With NUT certain operations are only available if the user has the
914             privilege. The program has to authenticate with one of the accounts
915             defined in upsd.conf.
916              
917             Master()
918             Use this to find out whether or not we have MASTER privileges for this
919             UPS. Returns 1 if we have MASTER privileges, returns 0 otherwise.
920              
921             ListVars()
922             Returns a list of all read-only variables supported by the UPS. Returns
923             undef if these are unavailable.
924              
925             ListRW()
926             Returns a list of all read/writeable variables supported by the UPS.
927             Returns undef if these are unavailable.
928              
929             ListInstCmds()
930             Returns a list of all instant commands supported by the UPS. Returns
931             undef if these are unavailable.
932              
933             InstCmd (command)
934             Send an instant command to the UPS. Returns 1 on success. Returns
935             undef if the command can't be completed.
936              
937             FSD()
938             Set the FSD (forced shutdown) flag for the UPS. This means that we're
939             planning on shutting down the UPS very soon, so the attached load should
940             be shut down as well. Returns 1 on success, returns undef on failure.
941             This cannot be unset, so don't set it unless you mean it.
942              
943             Error()
944             why did the previous operation fail? The answer is here. It will
945             return a concise, well-written, and brilliantly insightful few words as
946             to why whatever you just did went bang.
947              
948             =head1 AUTOLOAD
949              
950             The "instant commands" are available as methods of the UPS object. They
951             are AUTOLOADed when called. For example, if the instant command is FPTEST,
952             then it can be called by $ups->FPTEST.
953              
954             =head1 TIE Interface
955              
956             If you wish to simply query or set values, you can tie a hash value to
957             UPS::Nut and pass as extra options what you need to connect to the host.
958             If you need to exercise an occasional command, you may find the return
959             value of 'tie' useful, as in:
960              
961             my %ups;
962             my $ups_obj = tie %ups, 'UPS::Nut', HOSTNAME=>"firewall";
963            
964             print $ups{UPSIDENT}, "\n";
965              
966             $ups_obj->Authenticate( "user", "pass" );
967              
968             $ups{UPSIDENT} = "MyUPS";
969              
970             =head1 AUTHOR
971              
972             Kit Peters
973             perl@clownswilleatyou.com
974             http://www.awod.com/staff/kpeters/perl/
975              
976             =head1 CREDITS
977              
978             Developed with the kind support of A World Of Difference, Inc.
979            
980              
981             Many thanks to Ryan Jessen at CyberPower
982             Systems for much-needed assistance.
983              
984             Thanks to Wayne Wylupski for the code to make
985             accessor methods for all supported vars.
986              
987             =head1 LICENSE
988              
989             This module is distributed under the same license as Perl itself.
990              
991             =cut
992              
993             1;
994             __END__