File Coverage

blib/lib/POE/Event/Message/Header.pm

Criterion	Covered	Total	%
statement	12	108	11.1
branch	0	60	0.0
condition	0	51	0.0
subroutine	4	35	11.4
pod	7	30	23.3
total	23	284	8.1

# -*- Perl -*-
#
# File:  POE/Event/Message/Header.pm
# Desc:  A generic network message header class to use as a starting point.
# Date:  Mon Oct 10 10:10:59 2005
# Stat:  Prototype, Experimental
#
package POE::Event::Message::Header;
use 5.006;
use strict;
use warnings;

our $PACK    = __PACKAGE__;
our $VERSION = '0.04';
### @ISA     = qw( );

### POE::Kernel;                      ## Don't use POE here!
use POE::Event::Message::UniqueID;

my $IdClass = "POE::Event::Message::UniqueID";

sub new
{   my($self,$hRef) = @_;

    $self = bless {}, ref($self)||$self;

    if ($hRef and $hRef =~ /HASH/) {
	foreach (keys %$hRef) { $self->{$_} = $hRef->{$_} }

	$self->set('r2id', $self->id() ||0 )   unless $self->r2id();

    } else {

	# $self->set('r2id', undef );         # InResponseTo message id
	# $self->set('ttl',  undef );         # message TimeToLive
	# $self->set('type', undef );         # message type
    }

    $self->set('id', $IdClass->generate() );  # guaranteed unique message id

    return $self;
}

sub set    { $_[0]->{$_[1]}=$_[2]         }   # Note that the 'param' method
sub get    { return( $_[0]->{$_[1]}||"" ) }   #    combines 'set' and 'get'
sub param  { $_[2] ? $_[0]->{$_[1]}=$_[2] : return( $_[0]->{$_[1]}||"" )  }
sub setErr { return( $_[0]->{STATUS}=$_[1]||0, $_[0]->{ERROR}=$_[2]||"" ) }
sub status { return( $_[0]->{STATUS}||0, $_[0]->{ERROR}||"" )             }
sub stat   { ( wantarray ? ($_[0]->{ERROR}||"") : ($_[0]->{STATUS} ||0) ) }
sub err    { return($_[0]->{ERROR}||"")                                   }
sub del    { delete $_[0]->{$_[1]} }

*delete = \&del;
*reset  = \&del;

sub id     { $_[0]->get('id')            }    # unique message ID
sub r2id   { $_[0]->get('r2id')          }    # orig. msg ID, in a response
sub ttl    { $_[0]->param('ttl',  $_[1]) }    # message time-to-live
sub type   { $_[0]->param('type', $_[1]) }    # message type  (reply | bcast)
sub mode   { $_[0]->param('mode', $_[1]) }    # response mode (post | call)

*rid       = \&r2id;
*origId    = \&r2id;

*setType   = \&type;     # Type:  reply or bcast  (default: reply)
*getType   = \&type;     # Type:  reply or bcast  (default: reply)

*setMode   = \&mode;     # Mode:  post  or call   (default: post)
*getMode   = \&mode;     # Mode:  post  or call   (default: post)

#-----------------------------------------------------------------------
# Self routing messages without CODE refs, suitable for Filtering.
# Keep first implementation simple (if you call allowing multiple
# "RouteBack" destinations simple :-), and anticipate extensions.
#
#   $message->header->addRouteBack( $mode, $service, $event, @args );
#
#      $mode defaults to "post",
#      $service defaults to "current_active",
#      and "initial state" @args are optionsl

# NOTE: these are LIFO stacks, and are "pushed" when "add" methods are
# used and "popped" when "del" methods are used. See the "Message"
# class for the various methods that make use of these stacks.

sub addRouteTo         { shift->_addRouting( "RouteTo",   undef, undef, @_ ) }
sub addRouteBack       { shift->_addRouting( "RouteBack", undef, undef, @_ ) }
sub addRemoteRouteTo   { shift->_addRouting( "RouteTo",   @_               ) }
sub addRemoteRouteBack { shift->_addRouting( "RouteBack", @_               ) }

sub _addRouting
{   my($self, $type, $host, $port, $mode, $service, $event, @args) = @_;

    if ($type !~ /^Route(To|Back)$/) {
	return $self->setErr(-1, "unknown 'type' ($type) in 'addRouting' method of '$PACK'");

    }

    $host ||= "";
    $port ||= "";
  # $mode ||= "post";
  ( $mode = $self->mode() || "post" ) unless ( $mode );

    if ($host and $port) {
	$service ||= "command";
	$event   ||= "dispatch";

    } elsif (! $service ) {
	if (! defined $INC{'POE/Kernel.pm'}) {
	    return $self->setErr(-1, "'POE::Kernel' module is not loaded in 'addRouteBack' method of '$PACK'");

	} else {
	    $service = POE::Kernel->get_active_session()->ID();
	}
    }

    ## warn "DEBUG: _addRouting: type='$type' mode='$mode' service='$service' event='$event'\n";

    if  (! ($service and $event) ) {
	return $self->setErr(-1, "missing 'service' and/or 'event' argument in 'addRouting' method of '$PACK'");
    }

    unshift @{ $self->{$type} }, [ $host,$port, $mode,$service,$event,@args ];
    return;
}

*unshiftRouteTo   = \&addRouteTo;       # add a RouteTo
*shiftRouteTo     = \&delRouteTo;       # del a RouteTo

*unshiftRouteBack = \&addRouteBack;     # add a RouteBack
*shiftRouteBack   = \&delRouteBack;     # del a Routeback

# FIX: syntax for "delRoute*" is clumsy when the lists are empty.

sub delRouteTo   { @{ (shift @{ $_[0]->{RouteTo}   } ||[]) } }
sub delRouteBack { @{ (shift @{ $_[0]->{RouteBack} } ||[]) } }

sub hasRouting   { ( ($_[0]->hasRouteTo()) || ($_[0]->hasRouteBack()) ) }

*getRouting   = \&hasRouting;
*getRouteTo   = \&hasRouteTo;
*getRouteBack = \&hasRouteBack;

sub hasRouteTo
{   my($self, $type) = @_;
    return undef  unless (defined $self->{"RouteTo"});
    return( $self->{'RouteTo'}->[ 0 ] );
}

sub hasRouteBack
{   my($self) = @_;
    return undef unless (defined $self->{"RouteBack"});
    return( $self->{'RouteBack'}->[ 0 ] );
}

sub nextRouteType
{   my($self) = @_;

    my $nextRoute = $self->hasRouteTo() || $self->hasRouteBack();

    return "remote" if ($nextRoute->[0] and $nextRoute->[1]);
    return ""       unless $nextRoute->[2];
    return "post"   if ($nextRoute->[2] =~ /^post/i);
    return "call"   if ($nextRoute->[2] =~ /^call/i);
    return "";
}

sub nextRouteIsRemote { ($_[0]->nextRouteType() eq "remote"      ? 1 : 0) }
sub nextRouteIsLocal  { ($_[0]->nextRouteType() =~ /(post|call)/ ? 1 : 0) }
sub nextRouteIsPost   { ($_[0]->nextRouteType() eq "post"        ? 1 : 0) }
sub nextRouteIsCall   { ($_[0]->nextRouteType() eq "call"        ? 1 : 0) }

#-----------------------------------------------------------------------

sub dump {
    my($self,$nohead)= @_;
    my($pack,$file,$line)=caller();
    my $text = "";
    unless ($nohead) {
	$text .= "DEBUG: ($PACK\:\:dump)\n  self='$self'\n";
	$text .= "CALLER $pack at line $line\n  ($file)\n";
    }
    my $value;
    foreach my $param (sort keys %$self) {
	$value = $self->{$param};
	$value = $self->zeroStr( $value, "" );  # handles value of "0"
	$text .= " $param = $value\n";
	# Kinda kludgy, might wanna fix this next bit.
	if ($param =~ /^Route(To|Back)$/) {
	    my $arrow = ( $param eq "RouteTo" ? "-->" : "<--" );
	    if (! @$value) {
		$text .= "  $arrow ((empty list))\n";
	        next;
	    }
	    foreach my $route (@$value) {
		$text .= "  $arrow '";
		foreach my $arg (@$route) {
		    $text .= ( $arg ? "$arg', '" : "', '" );
		}
		chop($text); chop($text); chop($text);
	    }
	    $text .= "\n"
	}
    }
    $text .= "_" x 25 ."\n";
    return($text);
}

sub zeroStr
{   my($self,$value,$undef) = @_;
    return $undef unless defined $value;
    return "0"    if (length($value) and ! $value);
    return $value;
}
#_________________________
1; # Required by require()

__END__