package Netio230B;
use strict;
use warnings;
use LWP::UserAgent;
use Data::Dumper;
use Time::HiRes;
use DateTime;
use Moose;

=head1 NAME

Netio230B - Control your NETIO-230B PDU with perl

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=head1 SYNOPSIS

    use Netio230B;
    use Data::Dumper;

    my $foo = Netio230B->new(device => "192.168.1.22",
                             username => "admin",
                             password => "admin");
    # get port states
    my @allports = $foo->get_device_configuration();
    print Dumper(@allports);

=cut
=head1 DESCRIPTION

The Netio230B is a power distribution unit which can be controled via LAN
see http://www.koukaam.se/showproduct.php?article_id=1502

=head2 REMARKS

This module was build and tested against the firmware version 3.12 of the
Netio230B device. This firmware seems to contain some bugs which manifest in
hanging requests and sometimes requests which do not hang but return an empty
result. Those issues are "handled" using a timeout for the requests
and sending the request again and again (max 10 times).

Since I upgraded to version 4.1 (which in it self was a PITA, you have to to
it with Internet Explorer or it will fail...) I have not seen this behavior 
again. 

=head2 AUTHENTICATION

At the moment only open authentication method supported.


=cut

my @ports;
my $base_url;
my $ua = LWP::UserAgent->new;

=head1 ATTRIBUTES

=head2 device 

Hostname or IP adress of the device.
=cut
has 'device' => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
);

=head2 username 

Username used to login at the device.
=cut
has 'username' => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
);

=head2 password  

Password used to login at the device.
=cut
has 'password' => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
);

=head2 logging

If set to '1' the module logs to STDOUT what it is doing. 
Default value is '0' (no logging).
=cut
has 'logging' => (
    is       => 'rw',
    isa      => 'Bool',
    required => 0,
    default  => 0,
);

=head2 timeout

Timeout in seconds before a request is resent. 
Default value is '1' (1 second).
=cut
has 'timeout' => (
    is       => 'rw',
    isa      => 'Int',
    required => 0,
    default  => 1,
    trigger  => \&_set_timeout,
);

=head1 METHODS 

=head2 get_device_configuration

Returns an array containing the current state of the PDU. Each entry is 
either 1 (active) or 0 (inactive):

    my @state = $foo->get_device_configuration();
    print "port 2 state is '".$port[1]."'\n";
    
=cut
sub get_device_configuration {
    my ($self) = @_;
    $self->_log("requesting port configuration.");
    my $url    = $base_url . "port=list";
    my $result = $self->_get($url);
    @ports = split( ' ', $result );
    return @ports;
}

=head2 get_port_state

Gets the current state of a single port.

    my $state = $foo->get_port_state(2);
    print ("Current state of port 2 is '$state'.\n");

=cut

sub get_port_state {
    my ( $self, $port ) = @_;
    $self->_log("get_port_state(port=$port)");
    $self->get_device_configuration();
    my $state = $ports[ $port - 1 ];
    $self->_log("port '$port' has state '$state'");
    return $state;
}

=head2 enable_port

Activates a single port.

    # enabel port #4
    $foo->enable_port(4);
=cut
sub enable_port {
    my ( $self, $port ) = @_;
    die("Port number missing. Can not enable") unless $port;
    $self->_log("enable_port(port=$port)");
    $self->get_device_configuration();
    if ( $ports[ $port - 1 ] != 1 ) {
        $self->set_port( $port, 1, @ports );
    }
}

=head2 disable_port

Deactivates a single port.

    # disabel port #4
    $foo->disable_port(4);
=cut
sub disable_port {
    my ( $self, $port ) = @_;
    die("Port number missing. Can not enable") unless $port;
    $self->_log("disable_port(port=$port)");
    $self->get_device_configuration();
    if ( $ports[ $port - 1 ] != 0 ) {
        $ports[ $port - 1 ] = 0;
        $self->_run_cmd();
    }
}

=head2 set_port

Sets the state of a port. Where state is one of '1', '0', 'u' or 'i'. 

This may be used to interrupt the port:

    #send interrupt command
    $foo->set_port(2, 'i');
=cut

sub set_port {
    my ( $self, $port, $state ) = @_;
    die("Port number missing. Can not enable")     unless $port;
    die("State to set is missing. Can not enable") unless $port;
    die("State '$state' is not known.")            unless $state =~ m/[10ui]/;

    $self->_log("set_port(port=$port,state=$state)");
    $self->get_device_configuration();
    $ports[ $port - 1 ] = $state;
    $self->_run_cmd();
}

=head2 disable_all 

Deactivates all ports.

    # disabel all 
    $foo->disable_all();
=cut
sub disable_all {
    my ($self) = @_;
    $self->_log("disable_all()");
    @ports = ( 0, 0, 0, 0 );
    $self->_run_cmd();
}

=head2 enable_all 

Activates all ports.

    # enable all ports
    $foo->enable_all();
=cut
sub enable_all {
    my ($self) = @_;
    $self->_log("enable_all()");
    @ports = ( 1, 1, 1, 1 );
    $self->_run_cmd();
}



sub _rm_enclosing_htmltag {
    my ($str) = @_;
    return "" unless $str;
    $str =~ s/<html> *//;
    $str =~ s/ *<\/html>//;
    return $str;
}

sub BUILD {
    my $self = shift;
    $self->_set_timeout( $self->timeout );
    $self->_build_control_url();
#   $self->get_device_configuration();
}

sub _set_timeout {
    my ( $self, $newtimeout, $old ) = @_;
    my $mess = "using timeout '$newtimeout'";
    if ($old) {
        $mess .= " instead of '$old'";
    }
    $self->_log( $mess . "." );
    $ua->timeout($newtimeout);
}

sub _log {
    my ( $self, $logstring ) = @_;
    if ( $self->logging ) {
        my $timestr = DateTime->now()->strftime("%F %T");
        print $timestr . " Netio230B[" . $self->device . "]: $logstring\n";
    }
}

sub _build_control_url {
    my ($self) = @_;
    $base_url =
          "http://"
        . $self->device
        . "/tgi/control.tgi?" . "l=p:"
        . $self->username . ":"
        . $self->password . "&";
}

sub _run_cmd {
    my ($self) = @_;
    my $url = $base_url . "port=" . join( '', @ports );
    my $result = $self->_get($url);
}

sub _get {
    my ( $self, $url ) = @_;
    $self->_log("request '$url'.");
    my $result;
    for ( my $count = 1; $count <= 10; $count++ ) {
        $result = $ua->get($url);
        my $status = $result->code . " " . $result->message;
        if ( $result->is_error ) {
            $self->_log( "resending because: " . $status );
        }
        elsif ( $result->decoded_content() eq "" ) {
            $self->_log(
                "resending because decoded answer was empty: " . $status );
        }
        else {
            last;
        }
    }
    my $decoded = $result->decoded_content();
    my $rem     = _rm_enclosing_htmltag($decoded);
    $self->_log("answer: '$rem'");
    return $rem;
}

=head1 AUTHOR

Tobias Maier, C<< <diespambox at gmx.net> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-netio230b at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Netio230B>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Netio230B


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Netio230B>

=item * Search CPAN

L<http://search.cpan.org/dist/Netio230B/>

=back



=head1 LICENSE AND COPYRIGHT

This program is distributed under the WTFPL License:

DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
Version 2, December 2004

Copyright 2012 Tobias Maier, C<< <diespambox at gmx.net> >>

Everyone is permitted to copy and distribute verbatim or modified
copies of this license document, and changing it is allowed as long
as the name is changed.

DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING,
DISTRIBUTION AND MODIFICATION

0. You just DO WHAT THE FUCK YOU WANT TO.

=cut

1;    # End of Netio230B
