view release on metacpan or  search on metacpan

lib/Agent/TCLI/Transport/Base.pm  view on Meta::CPAN

package Agent::TCLI::Transport::Base;

=pod

=head1 NAME

Agent::TCLI::Transport::Base - Base Class for transports

=head1 SYNOPSIS

Use as a base class for a Agent::TCLI::Transport

=head1 DESCRIPTION

=over

=back

=head1 GETTING STARTED

=cut

# General setup {{{
use warnings;
use strict;
use Carp;

use POE;
use Agent::TCLI::Control;
use Agent::TCLI::Request;
require Agent::TCLI::Base;

use Object::InsideOut qw( Agent::TCLI::Base );

use Data::Dump qw(pp);
use YAML qw(freeze thaw);

our $VERSION = '0.031.'.sprintf "%04d", (qw($Id: Base.pm 62 2007-05-03 15:55:17Z hacker $))[2];

=head2 ATTRIBUTES

The following attributes may be accessed through a combined mutator.
If the attribute is an array type, then additional array mutators are
available and described below.

=over

=item controls

A hash of the active controls
B<controls> will only accept hash objects.

=cut
my @controls 	:Field
				:All('controls')
				:Type('hash');

=item alias

An alias that the session will be run under. Alias can't be
changed after starting.

=cut
my @alias		:Field
				:Get('alias');

=item peers

An array of peers
B<set_peers> will only accept ARRAYREF type values.

=cut
my @peers		:Field
				:All('peers')
				:Type('ARRAY');

# Holds our session data. Made weak per Merlyn
# http://poe.perl.org/?POE_Cookbook/Object_Methods.
# We also don't take session on init.
my @session		:Field
				:Arg('session')
				:Get('session')
				:Weak;

=item control_options

A hash of options to pass to a new control object. These are passed
straight through as is. See Agent::TCLI::Control for information
about the options.
B<control_options> will only accept HASHREF type values.

=cut
my @control_options	:Field
					:All('control_options')
					:Type('HASHREF');

# Standard class utils are inherited

=item Arrays

Attributes that are typed as arrays also support the following mutators for
the lazy:
B<shift_&gt;field&lt;> - works the same as I<shift>, returing the shifted member.
B<unshift_&gt;field&lt;(list)> - works the same as I<unshift>.
B<pop_&gt;field&lt;> - works the same as I<pop>, returing the popped member.
B<push_&gt;field&lt;(list)> - works the same as I<push>.
B<depth_&gt;field&lt;> - returns the curent size of the array.

=cut

my %init_args :InitArgs = (
    'alias' => {
        'Default'		=> 'base',
    	'Field'			=> \@alias,
    },
);

##u_ subs can't be private if used in %init_args
##named u_ to sort nicer in Eclipse
#sub u_is_text {
#	return (
#		 validate_pos( @_, { type => Params::Validate::SCALAR | Params::Validate::SCALARREF } )
#		 )
#}
#sub u_is_num {
#	return (
#		 Scalar::Utils->looks_like_number($_[0])
#		 )
#}
#sub u_is_int {
#         my $arg = $_[0];
#         return (Scalar::Util::looks_like_number($arg) &&
#                 (int($arg) == $arg));
#     }

=back

=head2 METHODS

These methods may be used as is, or subclasses may use them as
starting point.

=over

=cut

sub _init :Init {
	my ($self, $args) = @_;

}

=item _start

Get things rolling.

=cut

sub _start :Cumulative {
  my ($kernel,  $self, $session) =
    @_[KERNEL, OBJECT,  SESSION];

	# are we up before OIO has finished initializing object?
	if (!defined( $self->alias ))
	{
    $self->Verbose("_start: OIO not started delaying ",0);
		$kernel->call('_start');
		return;
	}

	# There is only one command object per TCLI
    $kernel->alias_set($self->alias);

    $self->Verbose("_start: Starting alias(".$self->alias.")",0);

} # End sub start

=item _stop

Mostly just a placeholder.

=cut

sub _stop :Cumulative {
  my ($kernel,  $self, $session) =
    @_[KERNEL, OBJECT,  SESSION];
    $self->Verbose("stop: ".$self->name." stopping " ,1);
}

=item _child

Just a placeholder.

=cut

sub _child {
  my ($kernel,  $self, $session, $id, $error) =
    @_[KERNEL, OBJECT,  SESSION, ARG1, ARG2 ];

   $self->Verbose("child: id($id) error($error)") if (defined($error));
}

=item _shutdown

Forcibly shutdown

=cut

sub _shutdown :Cumulative {
    my ($kernel,  $self, $session) =
    @_[KERNEL, OBJECT,  SESSION];
	# TODO, do some proper signal handling
	# especially reconnect on HUP and something on INT

	$self->Verbose('_shutdown: dropping controls',1, $self->controls);

	if ( defined( $self->controls ) )
	{
		foreach my $control ( values %{$self->controls} )
		{
			$kernel->post( $control->id() => '_shutdown' );
			delete(  $self->controls->{ $control->id }  );
		}
	}

	$self->Verbose("_shutdown: removing alarms",1,$kernel->alarm_remove_all() );

    $kernel->alias_remove( $self->alias );

    return("_shutdown ".$self->alias  );
}

sub ControlExecute {
	my ($kernel,  $self, $control, $request ) =
	  @_[KERNEL, OBJECT,     ARG0,     ARG1 ];
	$self->Verbose("ControlExecute: control(".$control->id.") req(".$request->id.") ");

	# Sometimes, control has not started, so we wiat if we have to.
	if ( defined($control->start_time) )
	{
		$kernel->post( $control->id() => 'Execute' => $request );
	}
	else
	{
		$kernel->delay('ControlExecute' => 1 => $control, $request );
	}
}

=item PackRequest

This object method is used by transports to prepare a request for transmssion.

Currently the code is taking a lazy approach and using Perl's YAML and OIO->dump to
safely freeze and thaw the request/responses for Internet transport.
By standardizing these routines in the Base class, more elegant methods
may be transparently enabled in the future.

=cut
# TODO review XEP on this, esp version numbers and best practices.

sub PackRequest {
	my ($self, $request) = @_;
	my $dump = $request->dump();

	# Take out the Base to save space since we're ignore this at the other end.
	delete $dump->[1]{'Agent::TCLI::Base'};

	my $packed_request = freeze($dump);
	return($packed_request);
}

=item PackResponse

This object method is used by transports to prepare a reseponse for transmssion.
See PackRequest for more details.

=cut

sub PackResponse {
	my ($self, $response) = @_;
	my $dump = $response->dump();

	# Take out the Base to save space since we're ignore this at the other end.
	delete $dump->[1]{'Agent::TCLI::Base'};

	# freeze does not terminate the yaml
	my $packed_response = freeze($dump);
	return($packed_response);
}

=item UnpackRequest

This object method is used by transports to unpack a request from transmssion.
See PackRequest for more details.

=cut

sub UnpackRequest {
	my ($self, $packed_request) = @_;