lib/Netio230B.pm

   1 package Netio230B;
   2 use strict;
   3 use warnings;
   4 use LWP::UserAgent;
   5 use Data::Dumper;
   6 use Time::HiRes;
   7 use DateTime;
   8 use Moose;
   9
  10 =head1 NAME
  11
  12 Netio230B - Control your NETIO-230B PDU with perl
  13
  14 =head1 VERSION
  15
  16 Version 0.01
  17
  18 =cut
  19
  20 our $VERSION = '0.01';
  21
  22 =head1 SYNOPSIS
  23
  24     use Netio230B;
  25     use Data::Dumper;
  26
  27     my $foo = Netio230B->new(device => "192.168.1.22",
  28                              username => "admin",
  29                              password => "admin");
  30     # get port states
  31     my @allports = $foo->get_device_configuration();
  32     print Dumper(@allports);
  33
  34 =cut
  35 =head1 DESCRIPTION
  36
  37 The Netio230B is a power distribution unit which can be controled via LAN
  38 see http://www.koukaam.se/showproduct.php?article_id=1502
  39
  40 =head2 REMARKS
  41
  42 This module was build and tested against the firmware version 3.12 of the
  43 Netio230B device. This firmware seems to contain some bugs which manifest in
  44 hanging requests and sometimes requests which do not hang but return an empty
  45 result. Those issues are "handled" using a timeout for the requests
  46 and sending the request again and again (max 10 times).
  47
  48 Since I upgraded to version 4.1 (which in it self was a PITA, you have to to
  49 it with Internet Explorer or it will fail...) I have not seen this behavior
  50 again.
  51
  52 =head2 AUTHENTICATION
  53
  54 At the moment only open authentication method supported.
  55
  56
  57 =cut
  58
  59 my @ports;
  60 my $base_url;
  61 my $ua = LWP::UserAgent->new;
  62
  63 =head1 ATTRIBUTES
  64
  65 =head2 device
  66
  67 Hostname or IP adress of the device.
  68 =cut
  69 has 'device' => (
  70     is       => 'ro',
  71     isa      => 'Str',
  72     required => 1,
  73 );
  74
  75 =head2 username
  76
  77 Username used to login at the device.
  78 =cut
  79 has 'username' => (
  80     is       => 'ro',
  81     isa      => 'Str',
  82     required => 1,
  83 );
  84
  85 =head2 password
  86
  87 Password used to login at the device.
  88 =cut
  89 has 'password' => (
  90     is       => 'ro',
  91     isa      => 'Str',
  92     required => 1,
  93 );
  94
  95 =head2 logging
  96
  97 If set to '1' the module logs to STDOUT what it is doing.
  98 Default value is '0' (no logging).
  99 =cut
 100 has 'logging' => (
 101     is       => 'rw',
 102     isa      => 'Bool',
 103     required => 0,
 104     default  => 0,
 105 );
 106
 107 =head2 timeout
 108
 109 Timeout in seconds before a request is resent.
 110 Default value is '1' (1 second).
 111 =cut
 112 has 'timeout' => (
 113     is       => 'rw',
 114     isa      => 'Int',
 115     required => 0,
 116     default  => 1,
 117     trigger  => \&_set_timeout,
 118 );
 119
 120 =head1 METHODS
 121
 122 =head2 get_device_configuration
 123
 124 Returns an array containing the current state of the PDU. Each entry is
 125 either 1 (active) or 0 (inactive):
 126
 127     my @state = $foo->get_device_configuration();
 128     print "port 2 state is '".$port[1]."'\n";
 129
 130 =cut
 131 sub get_device_configuration {
 132     my ($self) = @_;
 133     $self->_log("requesting port configuration.");
 134     my $url    = $base_url . "port=list";
 135     my $result = $self->_get($url);
 136     @ports = split( ' ', $result );
 137     return @ports;
 138 }
 139
 140 =head2 get_port_state
 141
 142 Gets the current state of a single port.
 143
 144     my $state = $foo->get_port_state(2);
 145     print ("Current state of port 2 is '$state'.\n");
 146
 147 =cut
 148
 149 sub get_port_state {
 150     my ( $self, $port ) = @_;
 151     $self->_log("get_port_state(port=$port)");
 152     $self->get_device_configuration();
 153     my $state = $ports[ $port - 1 ];
 154     $self->_log("port '$port' has state '$state'");
 155     return $state;
 156 }
 157
 158 =head2 enable_port
 159
 160 Activates a single port.
 161
 162     # enabel port #4
 163     $foo->enable_port(4);
 164 =cut
 165 sub enable_port {
 166     my ( $self, $port ) = @_;
 167     die("Port number missing. Can not enable") unless $port;
 168     $self->_log("enable_port(port=$port)");
 169     $self->get_device_configuration();
 170     if ( $ports[ $port - 1 ] != 1 ) {
 171         $self->set_port( $port, 1, @ports );
 172     }
 173 }
 174
 175 =head2 disable_port
 176
 177 Deactivates a single port.
 178
 179     # disabel port #4
 180     $foo->disable_port(4);
 181 =cut
 182 sub disable_port {
 183     my ( $self, $port ) = @_;
 184     die("Port number missing. Can not enable") unless $port;
 185     $self->_log("disable_port(port=$port)");
 186     $self->get_device_configuration();
 187     if ( $ports[ $port - 1 ] != 0 ) {
 188         $ports[ $port - 1 ] = 0;
 189         $self->_run_cmd();
 190     }
 191 }
 192
 193 =head2 set_port
 194
 195 Sets the state of a port. Where state is one of '1', '0', 'u' or 'i'.
 196
 197 This may be used to interrupt the port:
 198
 199     #send interrupt command
 200     $foo->set_port(2, 'i');
 201 =cut
 202
 203 sub set_port {
 204     my ( $self, $port, $state ) = @_;
 205     die("Port number missing. Can not enable")     unless $port;
 206     die("State to set is missing. Can not enable") unless $port;
 207     die("State '$state' is not known.")            unless $state =~ m/[10ui]/;
 208
 209     $self->_log("set_port(port=$port,state=$state)");
 210     $self->get_device_configuration();
 211     $ports[ $port - 1 ] = $state;
 212     $self->_run_cmd();
 213 }
 214
 215 =head2 disable_all
 216
 217 Deactivates all ports.
 218
 219     # disabel all
 220     $foo->disable_all();
 221 =cut
 222 sub disable_all {
 223     my ($self) = @_;
 224     $self->_log("disable_all()");
 225     @ports = ( 0, 0, 0, 0 );
 226     $self->_run_cmd();
 227 }
 228
 229 =head2 enable_all
 230
 231 Activates all ports.
 232
 233     # enable all ports
 234     $foo->enable_all();
 235 =cut
 236 sub enable_all {
 237     my ($self) = @_;
 238     $self->_log("enable_all()");
 239     @ports = ( 1, 1, 1, 1 );
 240     $self->_run_cmd();
 241 }
 242
 243
 244
 245 sub _rm_enclosing_htmltag {
 246     my ($str) = @_;
 247     return "" unless $str;
 248     $str =~ s/<html> *//;
 249     $str =~ s/ *<\/html>//;
 250     return $str;
 251 }
 252
 253 sub BUILD {
 254     my $self = shift;
 255     $self->_set_timeout( $self->timeout );
 256     $self->_build_control_url();
 257 #   $self->get_device_configuration();
 258 }
 259
 260 sub _set_timeout {
 261     my ( $self, $newtimeout, $old ) = @_;
 262     my $mess = "using timeout '$newtimeout'";
 263     if ($old) {
 264         $mess .= " instead of '$old'";
 265     }
 266     $self->_log( $mess . "." );
 267     $ua->timeout($newtimeout);
 268 }
 269
 270 sub _log {
 271     my ( $self, $logstring ) = @_;
 272     if ( $self->logging ) {
 273         my $timestr = DateTime->now()->strftime("%F %T");
 274         print $timestr . " Netio230B[" . $self->device . "]: $logstring\n";
 275     }
 276 }
 277
 278 sub _build_control_url {
 279     my ($self) = @_;
 280     $base_url =
 281           "http://"
 282         . $self->device
 283         . "/tgi/control.tgi?" . "l=p:"
 284         . $self->username . ":"
 285         . $self->password . "&";
 286 }
 287
 288 sub _run_cmd {
 289     my ($self) = @_;
 290     my $url = $base_url . "port=" . join( '', @ports );
 291     my $result = $self->_get($url);
 292 }
 293
 294 sub _get {
 295     my ( $self, $url ) = @_;
 296     $self->_log("request '$url'.");
 297     my $result;
 298     for ( my $count = 1; $count <= 10; $count++ ) {
 299         $result = $ua->get($url);
 300         my $status = $result->code . " " . $result->message;
 301         if ( $result->is_error ) {
 302             $self->_log( "resending because: " . $status );
 303         }
 304         elsif ( $result->decoded_content() eq "" ) {
 305             $self->_log(
 306                 "resending because decoded answer was empty: " . $status );
 307         }
 308         else {
 309             last;
 310         }
 311     }
 312     my $decoded = $result->decoded_content();
 313     my $rem     = _rm_enclosing_htmltag($decoded);
 314     $self->_log("answer: '$rem'");
 315     return $rem;
 316 }
 317
 318 =head1 AUTHOR
 319
 320 Tobias Maier, C<< <diespambox at gmx.net> >>
 321
 322 =head1 BUGS
 323
 324 Please report any bugs or feature requests to C<bug-netio230b at rt.cpan.org>, or through
 325 the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Netio230B>.  I will be notified, and then you'll
 326 automatically be notified of progress on your bug as I make changes.
 327
 328
 329
 330
 331 =head1 SUPPORT
 332
 333 You can find documentation for this module with the perldoc command.
 334
 335     perldoc Netio230B
 336
 337
 338 You can also look for information at:
 339
 340 =over 4
 341
 342 =item * RT: CPAN's request tracker (report bugs here)
 343
 344 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Netio230B>
 345
 346 =item * Search CPAN
 347
 348 L<http://search.cpan.org/dist/Netio230B/>
 349
 350 =back
 351
 352
 353
 354 =head1 LICENSE AND COPYRIGHT
 355
 356 This program is distributed under the WTFPL License:
 357
 358 DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
 359 Version 2, December 2004
 360
 361 Copyright 2012 Tobias Maier, C<< <diespambox at gmx.net> >>
 362
 363 Everyone is permitted to copy and distribute verbatim or modified
 364 copies of this license document, and changing it is allowed as long
 365 as the name is changed.
 366
 367 DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING,
 368 DISTRIBUTION AND MODIFICATION
 369
 370 0. You just DO WHAT THE FUCK YOU WANT TO.
 371
 372 =cut
 373
 374 1;    # End of Netio230B