File Coverage

blib/lib/POE/Component/Client/BigBrother.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package POE::Component::Client::BigBrother;

use strict;
use warnings;

use Carp;
use POE qw< Component::Client::TCP >;

our $VERSION = '1.00';


#
# send()
# ----
sub send {
    my ($class, %param) = @_;

    # check for mandatory parameters
    my @mandatory = qw< host event command_type command_fields >;
    for my $name (@mandatory) {
        croak "error: $class requires a '$name' parameter"
            unless $param{$name};
    }

    # default values
    $param{port}    = 1984  unless defined $param{port};
    $param{timeout} = 10    unless defined $param{timeout};
    $param{retry}   = 2     unless defined $param{retry};

    # aliases
    my $field   = $param{command_fields};

    # check for mandatory fields common to all commands
    @mandatory = qw< host service message >;
    for my $name (@mandatory) {
        croak "error: '$param{command_type}' command requires a '$name' field"
            unless $field->{$name};
    }

    # check and adapt some values to Big Brother message format
    (my $host   = $field->{host}) =~ s/\./,/g;
    my $service = $field->{service};
    my $color   = $field->{color};
    my $offset  = $field->{offset} ? "+$field->{offset}" : "";

    # construct the Big Brother message
    if ($param{command_type} eq "status" or $param{command_type} eq "page") {
        $param{message} = "$param{command_type}$offset"
                        . " $host.$service $color $field->{message}";
    }
    elsif ($param{command_type} eq "disable") {
        $param{message} = "$param{command_type}$offset"
                        . " $host.$service $field->{duration} $field->{message}";
    }
    elsif ($param{command_type} eq "enable") {
        $param{message} = "$param{command_type}$offset"
                        . " $host.$service $field->{message}";
    }
    elsif ($param{command_type} eq "event") {
        $field->{activation} ||= time();
        $param{message} = join "", "event\n",
            map { "$_: $field->{$_}\n" } sort keys %$field;
    }
    else {
        croak "error: Unknown command type '$param{command_type}'"
    }

    # spawn a PoCo::Client::TCP to send the message
    POE::Component::Client::TCP->new(
        RemoteAddress   => $param{host},
        RemotePort      => $param{port},
        ConnectTimeout  => $param{timeout},
        Args            => [ { %param } ],

        Started         => sub {
            my ($kernel, $heap, $sender, $param)
                = @_[ KERNEL, HEAP, SENDER, ARG0 ];

            my $sender_id;

            # resolve sender session
            if ($param->{session}) {
                if (my $ref = $kernel->alias_resolve($param->{session})) {
                    $sender_id = $ref->ID;
                }
                else {
                    croak "error: Could not resolve 'session' to a valid "
                        . "POE session";
                }
            }
            else {
                $sender_id = $sender->ID;
            }

            # store some information in the heap
            $heap->{sender_id}  = $sender_id;           # sender session ID
            $heap->{retry}      = $param->{retry} + 1;  # number of retries left
            $heap->{param}      = $param;               # input parameters

            # store the future response in the heap
            $heap->{response} = {
                host    => $param->{host},
                message => $param->{message},
                context => $param->{context},
                success => 1,
            };
        },

        Connected       => sub {
            my ($kernel, $heap) = @_[ KERNEL, HEAP ];
            my $data = $heap->{param}{message};
            $heap->{server}->put($data);    # send the message
            $kernel->yield("shutdown");     # close the connection
        },

        ServerInput     => sub {}, # no input is expected from the server

        Disconnected    => sub {
            my ($kernel, $heap) = @_[ KERNEL, HEAP ];
            $kernel->yield("_send_response");
        },

        ConnectError    => sub {
            my ($kernel, $heap, $op, $errno, $errstr)
                = @_[ KERNEL, HEAP, ARG0..ARG2 ];

            $heap->{retry}--;

            if ($heap->{retry} > 0) {
                $kernel->yield("reconnect");
            }
            else {
                $heap->{response}{success}  = 0;
                $heap->{response}{error}    = "$op error $errno: $errstr";
                $kernel->yield("_send_response");
            }
        },

        InlineStates => {
            _send_response  => sub {
                my ($kernel, $heap) = @_[ KERNEL, HEAP ];

                my $session = $heap->{sender_id};
                my $event   = $heap->{param}{event};
                my $response= $heap->{response};

                # send the response to the send session
                $kernel->post($session, $event, $response);
            },
        },
    );
}


1;

__END__