initial
[Netio230B.git] / 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