[urisagit/Stem.git] / lib / Stem / Msg.pm

#  File: Stem/Msg.pm

#  This file is part of Stem.
#  Copyright (C) 1999, 2000, 2001 Stem Systems, Inc.

#  Stem is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.

#  Stem is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.

#  You should have received a copy of the GNU General Public License
#  along with Stem; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

#  For a license to use the Stem under conditions other than those
#  described here, to purchase support for this software, or to purchase a
#  commercial warranty contract, please contact Stem Systems at:

#       Stem Systems, Inc.		781-643-7504
#  	79 Everett St.			info@stemsystems.com
#  	Arlington, MA 02474
#  	USA

package Stem::Msg ;

use strict ;
use Carp ;

use Stem::Route qw( lookup_cell ) ;
use Stem::Trace 'log' => 'stem_status', 'sub' => 'TraceStatus' ;
use Stem::Trace 'log' => 'stem_error' , 'sub' => 'TraceError' ;
use Stem::Trace 'log' => 'stem_msg'   , 'sub' => 'TraceMsg' ;

my $msg_id = 0;

my $attr_spec = [

	{
		'name'		=> 'type',
		'help'		=> <<HELP,
This is the type of the message. It is used to select the delivery method in
the addressed Cell.
HELP
	},

	{
		'name'		=> 'cmd',
		'help'		=> <<HELP,
This is used for the delivery method if the message type is 'cmd'.
HELP
	},
	{
		'name'		=> 'reply_type',
		'default'	=> 'response',
		'help'		=> <<HELP,
This is the type that will be used in a reply message.
HELP
	},

	{
		'name'		=> 'data',
		'help'		=> <<HELP,
This is the data the message is carrying. It should (almost) always be
a reference.
HELP
	},

	{
		'name'		=> 'log',
		'help'		=> <<HELP,
This is the name of the log in a log type message.
HELP
	},

	{
		'name'		=> 'status',
		'help'		=> <<HELP,
This is the status in a status message.
HELP
	},

	{
		'name'		=> 'ack_req',
		'type'		=> 'boolean',
		'help'		=> <<HELP,
This flag means when this message is delivered, a 'msg_ack' message
sent back as a reply.
HELP
	},

	{
		'name'		=> 'in_portal',
		'help'		=> <<HELP,
This is the name of the Stem::Portal that received this message.
HELP
	},
	{
		'name'		=> 'msg_id',
		'help'		=> <<HELP,
A unique id for the message.
HELP
	},
	{
		'name'		=> 'reply_id',
		'help'		=> <<HELP,
For replies, this is the msg_id of the message being replied to.
HELP
	},
] ;

# get the plain (non-address) attributes for the AUTOLOAD and the
# message dumper

my %is_plain_attr = map { $_->{'name'}, 1 } @{$attr_spec} ;

# add the address types and parts to our attribute spec with callbacks
# for parsing

# lists of the address types and parts

my @addr_types = qw( to from reply_to ) ;
my @addr_parts = qw( hub cell target ) ;

# these are used to grab the types and parts from the method names in AUTOLOAD

my $type_regex = '(' . join( '|', @addr_types ) . ')' ;
my $part_regex = '(' . join( '|', @addr_parts ) . ')' ;

# build all the accessor methods as closures

{
	no strict 'refs' ;

	foreach my $attr ( map $_->{'name'}, @{$attr_spec} ) {

		*{$attr} = sub {

			$_[0]->{$attr} = $_[1] if @_ > 1 ;
			return $_[0]->{$attr}
		} ;
	}

	foreach my $type ( @addr_types ) {

		*{$type} = sub {
			my $self = shift ;
			$self->{ $type } = shift if @_ ;
			return $self->{ $type } ;
		} ;

##########
# WORKAROUND
# this array seems to be needed. i found a bug when i used
# a scalar and bumped it. the closures all had the value of 3.
##########

		my @part_nums = ( 0, 1, 2 ) ;

		foreach my $part ( @addr_parts ) {

			my $part_num = shift @part_nums ;

			*{"${type}_$part"} = sub {
				my $self = shift ;

# split the address for this type of address (to,from,reply_to)

				my @parts = split_address( $self->{$type} ) ;


				if ( @_ ) {

					$parts[ $part_num ] = shift ;

					$self->{$type} =
						make_address_string( @parts ) ;
				}
#print "PART $type $part_num [$parts[ $part_num ]]\n" if $type eq 'from' ;

				return $parts[ $part_num ] ;
			} ;
		}
	}
}

# used for faster parsing.

my @attrs = qw( to from reply_to type cmd reply_type log data ) ;

sub new {

	my( $class ) = shift ;

# 	my $self = Stem::Class::parse_args( $attr_spec, @_ ) ;
# 	return $self unless ref $self ;

#print "A [$_]\n" for @_ ;

	my %args = @_ ;

#use YAML ;
#print Dump \%args ;

	my $self = bless { map { exists $args{$_} ?
				( $_ => $args{$_} ) : () } @attrs } ;

#print $self->dump( 'NEW' ) ;

	$self->{'type'} = 'cmd' if exists $self->{'cmd'} ;

        $self->{'msg_id'} ||= $class->_new_msg_id;

#	TraceMsg "MSG: [$_] => [$args{$_}]\n" for sort keys %args ;

#	TraceMsg $self->dump( 'new MSG' ) ;

	return( $self ) ;
}

sub _new_msg_id {

	my( $class ) = shift ;

        $msg_id = 0 if $msg_id == 2 ** 31;

        return ++$msg_id;
}

sub clone {

	my( $self ) = shift ;

	my $msg = Stem::Msg->new(
			 ( map { exists $self->{$_} ?
				( $_, $self->{$_} ) : () }
				@addr_types, keys %is_plain_attr ),
			 @_
	) ;

#	TraceMsg $self->dump( 'self' ) ;
#	TraceMsg $msg->dump( 'clone' ) ;

	return $msg ;
}

sub split_address {

# return an empty address if no input

	return( '', '', '' ) unless @_ && $_[0] ;

# parse out the address parts so 

# the cell part can be a token or a class name with :: between tokens.
# delimiter can be /, @, -, or : with : being the convention
# this is how triplets 
# hub:cell:target

#print "SPLIT IN [$_[0]]\n" ;

	$_[0] =~ m{
			^		# beginning of string
			(?:		# group /hub:/
			   (\w*)	# grab /hub/
			   ([:/@-])	# grab any common delimiter
			)?		# hub: is optional
			(		# grab /cell/
			   (?:\w+|::)+	# group cell (token or class name)
			)		# /cell/ is required
			(?:		# group /:target/
			   \2		# match first delimiter
			   (\w*)	# grab /target/
			)?		# :target is optional
			$}x		# end of string

# an bad address can be checked with @_ == 1 as a proper address is
# always 3. 

		 or return "bad string address" ;

# we return the list of hub, cell, target and give back nice null strings if 
# needed.

#print "SPLIT ", join( '--', $1 || '', $3, $4 || '' ), "\n" ;

	return( $1 || '', $3, $4 || '' ) ;
}

# sub address_string {

# 	my( $addr ) = @_ ;

# #use YAML ;
# #print "ADDR [$addr]", Dump( $addr ) ;
# 	return $addr unless ref $addr ;

# 	return 'BAD ADDRESS' unless ref $addr eq 'HASH' ;

# 	return $addr->{'cell'} if keys %{$addr} == 1 && $addr->{'cell'} ;

# 	return join ':', map { $_ || '' } @{$addr}{qw( hub cell target ) } ;
# }

sub make_address_string {

 	my( $hub, $cell_name, $target ) = @_ ;

	$hub = '' unless defined $hub ;
	$target = '' unless defined $target ;

	return $cell_name unless length $hub || length $target ;

 	return join ':', $hub, $cell_name, $target ;
}

sub reply {

	my( $self ) = shift ;

#	TraceMsg "Reply [$self]" ;

#	TraceMsg $self->dump( 'reply self' ) ;

#print $self->dump( 'reply self' ) ;

	my $to = $self->{'reply_to'} || $self->{'from'} ;
	my $from = $self->{'to'} ;

	my $reply_msg = Stem::Msg->new(
				'to'	=> $to,
				'from'	=> $from,
				'type'	=> $self->{'reply_type'} || 'response',
                                'reply_id' => $self->{'msg_id'},
				@_
	) ;

#	TraceMsg $reply_msg->dump( 'new reply' ) ;
#$reply_msg->dump( 'new reply' ) ;

	return( $reply_msg ) ;
}

#####################
#####################
# add forward method which clones the old msg and just updates the to address.
#
# work needs to be done on from/origin parts and who sets them
#####################
#####################


sub error {

	my( $self, $err_text ) = @_ ;

#	TraceError "ERR [$self] [$err_text]" ;

	my $err_msg = $self->reply( 'type' => 'error',
				    'data' => \$err_text ) ;

#	TraceError $err_msg->dump( 'error' ) ;

	return( $err_msg ) ;
}


########################################
########################################
# from/origin address will be set if none by looking up the cell that
# is currently be called with a message. or use
# Stem::Event::current_object which is set before every event
# delivery.
########################################
########################################


my @msg_queue ;

sub dispatch {

	my( $self ) = @_ ;

warn( caller(), $self->dump() ) and die
		'Msg: No To Address' unless $self->{'to'} ;
warn( caller(), $self->dump() ) and die
		'Msg: No From Address' unless $self->{'from'} ;


#  $self->deliver() ;
#  return ;

#  	unless ( @msg_queue ) {
	unless ( ref ( $self ) ) {
		 $self = Stem::Msg->new( @_ ) ;
	}
#  		Stem::Event::Plain->new( 'object' => __PACKAGE__,
#  					 'method' => 'deliver_msg_queue' ) ;
#  	}
	return "missing to attr in msg" unless $self ->{"to"} ;
	return "missing from attr in msg" unless $self ->{"from"} ;
	return "missing type attr in msg" unless $self ->{"type"} ;
	push @msg_queue, $self ;
}

sub process_queue {

	while( @msg_queue ) {

		my $msg = shift @msg_queue ;

#print $msg->dump( 'PROCESS' ) ;
		my $err = $msg->_deliver() ;

		if ( $err ) {

			my $err_text = "Undelivered:\n$err" ;
#print $err_text, $msg->dump( 'ERR' ) ;
			TraceError $msg->dump( "$err_text" ) ;

		}
	}
}

sub _deliver {

	my( $self ) = @_ ;

#print $self->dump( "DELIVER" ) ;

	my( $to_hub, $cell_name, $target ) = split_address( $self->{'to'} ) ;

	unless( $cell_name ) {

		return <<ERR ;
Can't deliver to bad address: '$self->{'to'}'
ERR
	}

#print "H [$to_hub] C [$cell_name] T [$target]\n" ;

	if ( $to_hub && $Stem::Vars::Hub_name ) {

		if ( $to_hub eq $Stem::Vars::Hub_name ) {

			if ( my $cell = lookup_cell( $cell_name, $target ) ) {

				return $self->_deliver_to_cell( $cell ) ;
			}

			return <<ERR ;
Can't find cell $cell_name in local hub $to_hub
ERR
		}

		return $self->send_to_portal( $to_hub ) ;
	}

# no hub, see if we can deliver to a local cell 

	if ( my $cell = lookup_cell( $cell_name, $target ) ) {

		return $self->_deliver_to_cell( $cell ) ;
	}

# see if this came in from a portal

	if ( $self->{'in_portal'} ) {

		return "message from another Hub can't be delivered" ;
	}

# not a local cell or named hub, send it to DEFAULT portal

	my $err = $self->send_to_portal() ;
	return $err if $err ;

	return ;
}

sub send_to_portal {

	my( $self, $to_hub ) = @_ ;

	eval {

		Stem::Portal::send_msg( $self, $to_hub ) ;
	} ;

	return "No Stem::Portal Cell was configured" if $@ ;

	return ;
}


sub _find_local_cell {

	my ( $self ) = @_ ;

	my $cell_name	= $self->{'to'}{'cell'} ;
	my $target	= $self->{'to'}{'target'} ;

	return lookup_cell( $cell_name, $target ) ;
}

sub _deliver_to_cell {

	my ( $self, $cell ) = @_ ;

# set the method 

	my $method = ( $self->{'type'} eq 'cmd' ) ?
				"$self->{'cmd'}_cmd" :
				"$self->{'type'}_in" ;

#print "METH: $method\n" ;

# check if we can deliver there or to msg_in

	unless ( $cell->can( $method ) ) {

		return $self->dump( <<DUMP ) unless( $cell->can( 'msg_in' ) ) ;
missing message delivery methods '$method' and 'msg_in'
DUMP

		$method = 'msg_in' ;
	}

	TraceMsg "MSG to $cell $method" ;

	my @response = $cell->$method( $self ) ;

#print "RESP [@response]\n" ;

# if we get a response then return it in a message

	if ( @response && $self->{'type'} eq 'cmd' ) {

# make the response data a reference

		my $response = shift @response ;
		my $data = ( ref $response ) ? $response : \$response ;

#print $self->dump( 'CMD msg' ) ;
		my $reply_msg = $self->reply(
					'data' => $data,
		) ;

#print $reply_msg->dump( 'AUTO REPONSE' ) ;

		$reply_msg->dispatch() ;
	}

	if ( $self->{'ack_req'} ) {

		my $reply_msg = $self->reply( 'type' => 'msg_ack' ) ;

		$reply_msg->dispatch() ;
	}

	return ;
}

# dump a message for debugging

sub dump {

	my( $self, $label, $deep ) = @_ ;

	require Data::Dumper ;

	my $dump = '' ;
	$label ||= 'UNKNOWN' ;

	my( $file_name, $line_num ) = (caller)[1,2] ;

	$dump .= <<LABEL ;

>>>>
MSG Dump at Line $line_num in $file_name
$label = {
LABEL

	foreach my $type ( @addr_types ) {

		my $addr = $self->{$type} ;

		next unless $addr ;

		my $addr_text = $addr || 'NONE' ;

		$dump .= "\t$type\t=> $addr_text\n" ;
	}

	foreach my $attr ( sort keys %is_plain_attr ) {

		next unless exists $self->{$attr} ;

		my $tab = ( length $attr > 4 ) ? "" : "\t" ;

		my( $val_text, $q, $ret ) ; 

		if ( $deep || $attr eq 'data' ) {

			$val_text = Data::Dumper::Dumper( $self->{$attr} ) ;

			$val_text =~ s/^.+?=// ;
			$val_text =~ s/;\n?$// ;
			$val_text =~ s/^\s+/\t\t/gm ;
			$val_text =~ s/^\s*([{}])/\t$1/gm ;

			$q = '' ;
			$ret = "\n" ;
		}
		else {
			$val_text = $self->{$attr} ;
			$q = $val_text =~ /\D/ ? "'" : '' ;
			$ret = '' ;
		}

		$dump .= <<ATTR ;
	$attr$tab	=> $ret$q$val_text$q,
ATTR

	}

	$dump .= "}\n<<<<\n\n" ;

	return($dump) ;
}

1 ;
Commit	Line	Data
4536f655	1	# File: Stem/Msg.pm
	2
	3	# This file is part of Stem.
	4	# Copyright (C) 1999, 2000, 2001 Stem Systems, Inc.
	5
	6	# Stem is free software; you can redistribute it and/or modify
	7	# it under the terms of the GNU General Public License as published by
	8	# the Free Software Foundation; either version 2 of the License, or
	9	# (at your option) any later version.
	10
	11	# Stem is distributed in the hope that it will be useful,
	12	# but WITHOUT ANY WARRANTY; without even the implied warranty of
	13	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	# GNU General Public License for more details.
	15
	16	# You should have received a copy of the GNU General Public License
	17	# along with Stem; if not, write to the Free Software
	18	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	19
	20	# For a license to use the Stem under conditions other than those
	21	# described here, to purchase support for this software, or to purchase a
	22	# commercial warranty contract, please contact Stem Systems at:
	23
	24	# Stem Systems, Inc. 781-643-7504
	25	# 79 Everett St. info@stemsystems.com
	26	# Arlington, MA 02474
	27	# USA
	28
	29	package Stem::Msg ;
	30
	31	use strict ;
	32	use Carp ;
	33
	34	use Stem::Route qw( lookup_cell ) ;
	35	use Stem::Trace 'log' => 'stem_status', 'sub' => 'TraceStatus' ;
	36	use Stem::Trace 'log' => 'stem_error' , 'sub' => 'TraceError' ;
	37	use Stem::Trace 'log' => 'stem_msg' , 'sub' => 'TraceMsg' ;
	38
	39	my $msg_id = 0;
	40
	41	my $attr_spec = [
	42
	43	{
	44	'name' => 'type',
	45	'help' => <<HELP,
	46	This is the type of the message. It is used to select the delivery method in
	47	the addressed Cell.
	48	HELP
	49	},
	50
	51	{
	52	'name' => 'cmd',
	53	'help' => <<HELP,
	54	This is used for the delivery method if the message type is 'cmd'.
	55	HELP
	56	},
	57	{
	58	'name' => 'reply_type',
	59	'default' => 'response',
	60	'help' => <<HELP,
	61	This is the type that will be used in a reply message.
	62	HELP
	63	},
	64
65	{
66	'name' => 'data',
67	'help' => <<HELP,
68	This is the data the message is carrying. It should (almost) always be
69	a reference.
70	HELP
71	},
72
73	{
74	'name' => 'log',
75	'help' => <<HELP,
76	This is the name of the log in a log type message.
77	HELP
78	},
79
80	{
81	'name' => 'status',
82	'help' => <<HELP,
83	This is the status in a status message.
84	HELP
85	},
86
87	{
88	'name' => 'ack_req',
89	'type' => 'boolean',
90	'help' => <<HELP,
91	This flag means when this message is delivered, a 'msg_ack' message
92	sent back as a reply.
93	HELP
94	},
95
96	{
97	'name' => 'in_portal',
98	'help' => <<HELP,
99	This is the name of the Stem::Portal that received this message.
100	HELP
101	},
102	{
103	'name' => 'msg_id',
104	'help' => <<HELP,
105	A unique id for the message.
106	HELP
107	},
108	{
109	'name' => 'reply_id',
110	'help' => <<HELP,
111	For replies, this is the msg_id of the message being replied to.
112	HELP
113	},
114	] ;
115
116	# get the plain (non-address) attributes for the AUTOLOAD and the
117	# message dumper
118
119	my %is_plain_attr = map { $_->{'name'}, 1 } @{$attr_spec} ;
120
121	# add the address types and parts to our attribute spec with callbacks
122	# for parsing
123
124	# lists of the address types and parts
125
126	my @addr_types = qw( to from reply_to ) ;
127	my @addr_parts = qw( hub cell target ) ;
128
129	# these are used to grab the types and parts from the method names in AUTOLOAD
130
131	my $type_regex = '(' . join( '\|', @addr_types ) . ')' ;
132	my $part_regex = '(' . join( '\|', @addr_parts ) . ')' ;
133
134	# build all the accessor methods as closures
135
136	{
137	no strict 'refs' ;
138
139	foreach my $attr ( map $_->{'name'}, @{$attr_spec} ) {
140
141	*{$attr} = sub {
142
143	$_[0]->{$attr} = $_[1] if @_ > 1 ;
144	return $_[0]->{$attr}
145	} ;
146	}
147
148	foreach my $type ( @addr_types ) {
149
150	*{$type} = sub {
151	my $self = shift ;
152	$self->{ $type } = shift if @_ ;
153	return $self->{ $type } ;
154	} ;
155
156	##########
157	# WORKAROUND
158	# this array seems to be needed. i found a bug when i used
159	# a scalar and bumped it. the closures all had the value of 3.
160	##########
161
162	my @part_nums = ( 0, 1, 2 ) ;
163
164	foreach my $part ( @addr_parts ) {
165
166	my $part_num = shift @part_nums ;
167
168	*{"${type}_$part"} = sub {
169	my $self = shift ;
170
171	# split the address for this type of address (to,from,reply_to)
172
173	my @parts = split_address( $self->{$type} ) ;
174
175
176	if ( @_ ) {
177
178	$parts[ $part_num ] = shift ;
179
180	$self->{$type} =
181	make_address_string( @parts ) ;
182	}
183	#print "PART $type $part_num [$parts[ $part_num ]]\n" if $type eq 'from' ;
184
185	return $parts[ $part_num ] ;
186	} ;
187	}
188	}
189	}
190
191	# used for faster parsing.
192
193	my @attrs = qw( to from reply_to type cmd reply_type log data ) ;
194
195	sub new {
196
197	my( $class ) = shift ;
198
199	# my $self = Stem::Class::parse_args( $attr_spec, @_ ) ;
200	# return $self unless ref $self ;
201
202	#print "A [$_]\n" for @_ ;
203
204	my %args = @_ ;
205
206	#use YAML ;
207	#print Dump \%args ;
208
209	my $self = bless { map { exists $args{$_} ?
210	( $_ => $args{$_} ) : () } @attrs } ;
211
212	#print $self->dump( 'NEW' ) ;
213
214	$self->{'type'} = 'cmd' if exists $self->{'cmd'} ;
215
216	$self->{'msg_id'} \|\|= $class->_new_msg_id;
217
218	# TraceMsg "MSG: [$_] => [$args{$_}]\n" for sort keys %args ;
219
220	# TraceMsg $self->dump( 'new MSG' ) ;
221
222	return( $self ) ;
223	}
224
225	sub _new_msg_id {
226
227	my( $class ) = shift ;
228
229	$msg_id = 0 if $msg_id == 2 ** 31;
230
231	return ++$msg_id;
232	}
233
234	sub clone {
235
236	my( $self ) = shift ;
237
238	my $msg = Stem::Msg->new(
239	( map { exists $self->{$_} ?
240	( $_, $self->{$_} ) : () }
241	@addr_types, keys %is_plain_attr ),
242	@_
243	) ;
244
245	# TraceMsg $self->dump( 'self' ) ;
246	# TraceMsg $msg->dump( 'clone' ) ;
247
248	return $msg ;
249	}
250
251	sub split_address {
252
253	# return an empty address if no input
254
255	return( '', '', '' ) unless @_ && $_[0] ;
256
257	# parse out the address parts so
258
259	# the cell part can be a token or a class name with :: between tokens.
260	# delimiter can be /, @, -, or : with : being the convention
261	# this is how triplets
262	# hub:cell:target
263
264	#print "SPLIT IN [$_[0]]\n" ;
265
266	$_[0] =~ m{
267	^ # beginning of string
268	(?: # group /hub:/
269	(\w*) # grab /hub/
270	([:/@-]) # grab any common delimiter
271	)? # hub: is optional
272	( # grab /cell/
273	(?:\w+\|::)+ # group cell (token or class name)
274	) # /cell/ is required
275	(?: # group /:target/
276	\2 # match first delimiter
277	(\w*) # grab /target/
278	)? # :target is optional
279	$}x # end of string
280
281	# an bad address can be checked with @_ == 1 as a proper address is
282	# always 3.
283
284	or return "bad string address" ;
285
286	# we return the list of hub, cell, target and give back nice null strings if
287	# needed.
288
289	#print "SPLIT ", join( '--', $1 \|\| '', $3, $4 \|\| '' ), "\n" ;
290
291	return( $1 \|\| '', $3, $4 \|\| '' ) ;
292	}
293
294	# sub address_string {
295
296	# my( $addr ) = @_ ;
297
298	# #use YAML ;
299	# #print "ADDR [$addr]", Dump( $addr ) ;
300	# return $addr unless ref $addr ;
301
302	# return 'BAD ADDRESS' unless ref $addr eq 'HASH' ;
303
304	# return $addr->{'cell'} if keys %{$addr} == 1 && $addr->{'cell'} ;
305
306	# return join ':', map { $_ \|\| '' } @{$addr}{qw( hub cell target ) } ;
307	# }
308
309	sub make_address_string {
310
311	my( $hub, $cell_name, $target ) = @_ ;
312
313	$hub = '' unless defined $hub ;
314	$target = '' unless defined $target ;
315
316	return $cell_name unless length $hub \|\| length $target ;
317
318	return join ':', $hub, $cell_name, $target ;
319	}
320
321	sub reply {
322
323	my( $self ) = shift ;
324
325	# TraceMsg "Reply [$self]" ;
326
327	# TraceMsg $self->dump( 'reply self' ) ;
328
329	#print $self->dump( 'reply self' ) ;
330
331	my $to = $self->{'reply_to'} \|\| $self->{'from'} ;
332	my $from = $self->{'to'} ;
333
334	my $reply_msg = Stem::Msg->new(
335	'to' => $to,
336	'from' => $from,
337	'type' => $self->{'reply_type'} \|\| 'response',
338	'reply_id' => $self->{'msg_id'},
339	@_
340	) ;
341
342	# TraceMsg $reply_msg->dump( 'new reply' ) ;
343	#$reply_msg->dump( 'new reply' ) ;
344
345	return( $reply_msg ) ;
346	}
347
348	#####################
349	#####################
350	# add forward method which clones the old msg and just updates the to address.
351	#
352	# work needs to be done on from/origin parts and who sets them
353	#####################
354	#####################
355
356
357	sub error {
358
359	my( $self, $err_text ) = @_ ;
360
361	# TraceError "ERR [$self] [$err_text]" ;
362
363	my $err_msg = $self->reply( 'type' => 'error',
364	'data' => \$err_text ) ;
365
366	# TraceError $err_msg->dump( 'error' ) ;
367
368	return( $err_msg ) ;
369	}
370
371
372	########################################
373	########################################
374	# from/origin address will be set if none by looking up the cell that
375	# is currently be called with a message. or use
376	# Stem::Event::current_object which is set before every event
377	# delivery.
378	########################################
379	########################################
380
381
382	my @msg_queue ;
383
384	sub dispatch {
385
386	my( $self ) = @_ ;
387
388	warn( caller(), $self->dump() ) and die
389	'Msg: No To Address' unless $self->{'to'} ;
390	warn( caller(), $self->dump() ) and die
391	'Msg: No From Address' unless $self->{'from'} ;
392
393
394	# $self->deliver() ;
395	# return ;
396
397	# unless ( @msg_queue ) {
398	unless ( ref ( $self ) ) {
399	$self = Stem::Msg->new( @_ ) ;
400	}
401	# Stem::Event::Plain->new( 'object' => __PACKAGE__,
402	# 'method' => 'deliver_msg_queue' ) ;
403	# }
404	return "missing to attr in msg" unless $self ->{"to"} ;
405	return "missing from attr in msg" unless $self ->{"from"} ;
406	return "missing type attr in msg" unless $self ->{"type"} ;
407	push @msg_queue, $self ;
408	}
409
410	sub process_queue {
411
412	while( @msg_queue ) {
413
414	my $msg = shift @msg_queue ;
415
416	#print $msg->dump( 'PROCESS' ) ;
417	my $err = $msg->_deliver() ;
418
419	if ( $err ) {
420
421	my $err_text = "Undelivered:\n$err" ;
422	#print $err_text, $msg->dump( 'ERR' ) ;
423	TraceError $msg->dump( "$err_text" ) ;
424
425	}
426	}
427	}
428
429	sub _deliver {
430
431	my( $self ) = @_ ;
432
433	#print $self->dump( "DELIVER" ) ;
434
435	my( $to_hub, $cell_name, $target ) = split_address( $self->{'to'} ) ;
436
437	unless( $cell_name ) {
438
439	return <<ERR ;
440	Can't deliver to bad address: '$self->{'to'}'
441	ERR
442	}
443
444	#print "H [$to_hub] C [$cell_name] T [$target]\n" ;
445
446	if ( $to_hub && $Stem::Vars::Hub_name ) {
447
448	if ( $to_hub eq $Stem::Vars::Hub_name ) {
449
450	if ( my $cell = lookup_cell( $cell_name, $target ) ) {
451
452	return $self->_deliver_to_cell( $cell ) ;
453	}
454
455	return <<ERR ;
456	Can't find cell $cell_name in local hub $to_hub
457	ERR
458	}
459
460	return $self->send_to_portal( $to_hub ) ;
461	}
462
463	# no hub, see if we can deliver to a local cell
464
465	if ( my $cell = lookup_cell( $cell_name, $target ) ) {
466
467	return $self->_deliver_to_cell( $cell ) ;
468	}
469
470	# see if this came in from a portal
471
472	if ( $self->{'in_portal'} ) {
473
474	return "message from another Hub can't be delivered" ;
475	}
476
477	# not a local cell or named hub, send it to DEFAULT portal
478
479	my $err = $self->send_to_portal() ;
480	return $err if $err ;
481
482	return ;
483	}
484
485	sub send_to_portal {
486
487	my( $self, $to_hub ) = @_ ;
488
489	eval {
490
491	Stem::Portal::send_msg( $self, $to_hub ) ;
492	} ;
493
494	return "No Stem::Portal Cell was configured" if $@ ;
495
496	return ;
497	}
498
499
500	sub _find_local_cell {
501
502	my ( $self ) = @_ ;
503
504	my $cell_name = $self->{'to'}{'cell'} ;
505	my $target = $self->{'to'}{'target'} ;
506
507	return lookup_cell( $cell_name, $target ) ;
508	}
509
510	sub _deliver_to_cell {
511
512	my ( $self, $cell ) = @_ ;
513
514	# set the method
515
516	my $method = ( $self->{'type'} eq 'cmd' ) ?
517	"$self->{'cmd'}_cmd" :
518	"$self->{'type'}_in" ;
519
520	#print "METH: $method\n" ;
521
522	# check if we can deliver there or to msg_in
523
524	unless ( $cell->can( $method ) ) {
525
526	return $self->dump( <<DUMP ) unless( $cell->can( 'msg_in' ) ) ;
527	missing message delivery methods '$method' and 'msg_in'
528	DUMP
529
530	$method = 'msg_in' ;
531	}
532
533	TraceMsg "MSG to $cell $method" ;
534
535	my @response = $cell->$method( $self ) ;
536
537	#print "RESP [@response]\n" ;
538
539	# if we get a response then return it in a message
540
541	if ( @response && $self->{'type'} eq 'cmd' ) {
542
543	# make the response data a reference
544
545	my $response = shift @response ;
546	my $data = ( ref $response ) ? $response : \$response ;
547
548	#print $self->dump( 'CMD msg' ) ;
549	my $reply_msg = $self->reply(
550	'data' => $data,
551	) ;
552
553	#print $reply_msg->dump( 'AUTO REPONSE' ) ;
554
555	$reply_msg->dispatch() ;
556	}
557
558	if ( $self->{'ack_req'} ) {
559
560	my $reply_msg = $self->reply( 'type' => 'msg_ack' ) ;
561
562	$reply_msg->dispatch() ;
563	}
564
565	return ;
566	}
567
568	# dump a message for debugging
569
570	sub dump {
571
572	my( $self, $label, $deep ) = @_ ;
573
574	require Data::Dumper ;
575
576	my $dump = '' ;
577	$label \|\|= 'UNKNOWN' ;
578
579	my( $file_name, $line_num ) = (caller)[1,2] ;
580
581	$dump .= <<LABEL ;
582
583	>>>>
584	MSG Dump at Line $line_num in $file_name
585	$label = {
586	LABEL
587
588	foreach my $type ( @addr_types ) {
589
590	my $addr = $self->{$type} ;
591
592	next unless $addr ;
593
594	my $addr_text = $addr \|\| 'NONE' ;
595
596	$dump .= "\t$type\t=> $addr_text\n" ;
597	}
598
599	foreach my $attr ( sort keys %is_plain_attr ) {
600
601	next unless exists $self->{$attr} ;
602
603	my $tab = ( length $attr > 4 ) ? "" : "\t" ;
604
605	my( $val_text, $q, $ret ) ;
606
607	if ( $deep \|\| $attr eq 'data' ) {
608
609	$val_text = Data::Dumper::Dumper( $self->{$attr} ) ;
610
611	$val_text =~ s/^.+?=// ;
612	$val_text =~ s/;\n?$// ;
613	$val_text =~ s/^\s+/\t\t/gm ;
614	$val_text =~ s/^\s*([{}])/\t$1/gm ;
615
616	$q = '' ;
617	$ret = "\n" ;
618	}
619	else {
620	$val_text = $self->{$attr} ;
621	$q = $val_text =~ /\D/ ? "'" : '' ;
622	$ret = '' ;
623	}
624
625	$dump .= <<ATTR ;
626	$attr$tab => $ret$q$val_text$q,
627	ATTR
628
629	}
630
631	$dump .= "}\n<<<<\n\n" ;
632
633	return($dump) ;
634	}
635
636	1 ;