3 # This file is part of Stem.
4 # Copyright (C) 1999, 2000, 2001 Stem Systems, Inc.
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.
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.
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
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:
24 # Stem Systems, Inc. 781-643-7504
25 # 79 Everett St. info@stemsystems.com
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' ;
46 This is the type of the message. It is used to select the delivery method in
54 This is used for the delivery method if the message type is 'cmd'.
58 'name' => 'reply_type',
59 'default' => 'response',
61 This is the type that will be used in a reply message.
68 This is the data the message is carrying. It should (almost) always be
76 This is the name of the log in a log type message.
83 This is the status in a status message.
91 This flag means when this message is delivered, a 'msg_ack' message
97 'name' => 'in_portal',
99 This is the name of the Stem::Portal that received this message.
105 A unique id for the message.
109 'name' => 'reply_id',
111 For replies, this is the msg_id of the message being replied to.
116 # get the plain (non-address) attributes for the AUTOLOAD and the
119 my %is_plain_attr = map { $_->{'name'}, 1 } @{$attr_spec} ;
121 # add the address types and parts to our attribute spec with callbacks
124 # lists of the address types and parts
126 my @addr_types = qw( to from reply_to ) ;
127 my @addr_parts = qw( hub cell target ) ;
129 # these are used to grab the types and parts from the method names in AUTOLOAD
131 my $type_regex = '(' . join( '|', @addr_types ) . ')' ;
132 my $part_regex = '(' . join( '|', @addr_parts ) . ')' ;
134 # build all the accessor methods as closures
139 foreach my $attr ( map $_->{'name'}, @{$attr_spec} ) {
143 $_[0]->{$attr} = $_[1] if @_ > 1 ;
144 return $_[0]->{$attr}
148 foreach my $type ( @addr_types ) {
152 $self->{ $type } = shift if @_ ;
153 return $self->{ $type } ;
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.
162 my @part_nums = ( 0, 1, 2 ) ;
164 foreach my $part ( @addr_parts ) {
166 my $part_num = shift @part_nums ;
168 *{"${type}_$part"} = sub {
171 # split the address for this type of address (to,from,reply_to)
173 my @parts = split_address( $self->{$type} ) ;
178 $parts[ $part_num ] = shift ;
181 make_address_string( @parts ) ;
183 #print "PART $type $part_num [$parts[ $part_num ]]\n" if $type eq 'from' ;
185 return $parts[ $part_num ] ;
191 # used for faster parsing.
193 my @attrs = qw( to from reply_to type cmd reply_type log data ) ;
197 my( $class ) = shift ;
199 # my $self = Stem::Class::parse_args( $attr_spec, @_ ) ;
200 # return $self unless ref $self ;
202 #print "A [$_]\n" for @_ ;
209 my $self = bless { map { exists $args{$_} ?
210 ( $_ => $args{$_} ) : () } @attrs } ;
212 #print $self->dump( 'NEW' ) ;
214 $self->{'type'} = 'cmd' if exists $self->{'cmd'} ;
216 $self->{'msg_id'} ||= $class->_new_msg_id;
218 # TraceMsg "MSG: [$_] => [$args{$_}]\n" for sort keys %args ;
220 # TraceMsg $self->dump( 'new MSG' ) ;
227 my( $class ) = shift ;
229 $msg_id = 0 if $msg_id == 2 ** 31;
236 my( $self ) = shift ;
238 my $msg = Stem::Msg->new(
239 ( map { exists $self->{$_} ?
240 ( $_, $self->{$_} ) : () }
241 @addr_types, keys %is_plain_attr ),
245 # TraceMsg $self->dump( 'self' ) ;
246 # TraceMsg $msg->dump( 'clone' ) ;
253 # return an empty address if no input
255 return( '', '', '' ) unless @_ && $_[0] ;
257 # parse out the address parts so
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
264 #print "SPLIT IN [$_[0]]\n" ;
267 ^ # beginning of string
270 ([:/@-]) # grab any common delimiter
271 )? # hub: is optional
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
281 # an bad address can be checked with @_ == 1 as a proper address is
284 or return "bad string address" ;
286 # we return the list of hub, cell, target and give back nice null strings if
289 #print "SPLIT ", join( '--', $1 || '', $3, $4 || '' ), "\n" ;
291 return( $1 || '', $3, $4 || '' ) ;
294 # sub address_string {
299 # #print "ADDR [$addr]", Dump( $addr ) ;
300 # return $addr unless ref $addr ;
302 # return 'BAD ADDRESS' unless ref $addr eq 'HASH' ;
304 # return $addr->{'cell'} if keys %{$addr} == 1 && $addr->{'cell'} ;
306 # return join ':', map { $_ || '' } @{$addr}{qw( hub cell target ) } ;
309 sub make_address_string {
311 my( $hub, $cell_name, $target ) = @_ ;
313 $hub = '' unless defined $hub ;
314 $target = '' unless defined $target ;
316 return $cell_name unless length $hub || length $target ;
318 return join ':', $hub, $cell_name, $target ;
323 my( $self ) = shift ;
325 # TraceMsg "Reply [$self]" ;
327 # TraceMsg $self->dump( 'reply self' ) ;
329 #print $self->dump( 'reply self' ) ;
331 my $to = $self->{'reply_to'} || $self->{'from'} ;
332 my $from = $self->{'to'} ;
334 my $reply_msg = Stem::Msg->new(
337 'type' => $self->{'reply_type'} || 'response',
338 'reply_id' => $self->{'msg_id'},
342 # TraceMsg $reply_msg->dump( 'new reply' ) ;
343 #$reply_msg->dump( 'new reply' ) ;
345 return( $reply_msg ) ;
348 #####################
349 #####################
350 # add forward method which clones the old msg and just updates the to address.
352 # work needs to be done on from/origin parts and who sets them
353 #####################
354 #####################
359 my( $self, $err_text ) = @_ ;
361 # TraceError "ERR [$self] [$err_text]" ;
363 my $err_msg = $self->reply( 'type' => 'error',
364 'data' => \$err_text ) ;
366 # TraceError $err_msg->dump( 'error' ) ;
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
378 ########################################
379 ########################################
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'} ;
397 # unless ( @msg_queue ) {
398 unless ( ref ( $self ) ) {
399 $self = Stem::Msg->new( @_ ) ;
401 # Stem::Event::Plain->new( 'object' => __PACKAGE__,
402 # 'method' => 'deliver_msg_queue' ) ;
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 ;
412 while( @msg_queue ) {
414 my $msg = shift @msg_queue ;
416 #print $msg->dump( 'PROCESS' ) ;
417 my $err = $msg->_deliver() ;
421 my $err_text = "Undelivered:\n$err" ;
422 #print $err_text, $msg->dump( 'ERR' ) ;
423 TraceError $msg->dump( "$err_text" ) ;
433 #print $self->dump( "DELIVER" ) ;
435 my( $to_hub, $cell_name, $target ) = split_address( $self->{'to'} ) ;
437 unless( $cell_name ) {
440 Can't deliver to bad address: '$self->{'to'}'
444 #print "H [$to_hub] C [$cell_name] T [$target]\n" ;
446 if ( $to_hub && $Stem::Vars::Hub_name ) {
448 if ( $to_hub eq $Stem::Vars::Hub_name ) {
450 if ( my $cell = lookup_cell( $cell_name, $target ) ) {
452 return $self->_deliver_to_cell( $cell ) ;
456 Can't find cell $cell_name in local hub $to_hub
460 return $self->send_to_portal( $to_hub ) ;
463 # no hub, see if we can deliver to a local cell
465 if ( my $cell = lookup_cell( $cell_name, $target ) ) {
467 return $self->_deliver_to_cell( $cell ) ;
470 # see if this came in from a portal
472 if ( $self->{'in_portal'} ) {
474 return "message from another Hub can't be delivered" ;
477 # not a local cell or named hub, send it to DEFAULT portal
479 my $err = $self->send_to_portal() ;
480 return $err if $err ;
487 my( $self, $to_hub ) = @_ ;
491 Stem::Portal::send_msg( $self, $to_hub ) ;
494 return "No Stem::Portal Cell was configured" if $@ ;
500 sub _find_local_cell {
504 my $cell_name = $self->{'to'}{'cell'} ;
505 my $target = $self->{'to'}{'target'} ;
507 return lookup_cell( $cell_name, $target ) ;
510 sub _deliver_to_cell {
512 my ( $self, $cell ) = @_ ;
516 my $method = ( $self->{'type'} eq 'cmd' ) ?
517 "$self->{'cmd'}_cmd" :
518 "$self->{'type'}_in" ;
520 #print "METH: $method\n" ;
522 # check if we can deliver there or to msg_in
524 unless ( $cell->can( $method ) ) {
526 return $self->dump( <<DUMP ) unless( $cell->can( 'msg_in' ) ) ;
527 missing message delivery methods '$method' and 'msg_in'
533 TraceMsg "MSG to $cell $method" ;
535 my @response = $cell->$method( $self ) ;
537 #print "RESP [@response]\n" ;
539 # if we get a response then return it in a message
541 if ( @response && $self->{'type'} eq 'cmd' ) {
543 # make the response data a reference
545 my $response = shift @response ;
546 my $data = ( ref $response ) ? $response : \$response ;
548 #print $self->dump( 'CMD msg' ) ;
549 my $reply_msg = $self->reply(
553 #print $reply_msg->dump( 'AUTO REPONSE' ) ;
555 $reply_msg->dispatch() ;
558 if ( $self->{'ack_req'} ) {
560 my $reply_msg = $self->reply( 'type' => 'msg_ack' ) ;
562 $reply_msg->dispatch() ;
568 # dump a message for debugging
572 my( $self, $label, $deep ) = @_ ;
574 require Data::Dumper ;
577 $label ||= 'UNKNOWN' ;
579 my( $file_name, $line_num ) = (caller)[1,2] ;
584 MSG Dump at Line $line_num in $file_name
588 foreach my $type ( @addr_types ) {
590 my $addr = $self->{$type} ;
594 my $addr_text = $addr || 'NONE' ;
596 $dump .= "\t$type\t=> $addr_text\n" ;
599 foreach my $attr ( sort keys %is_plain_attr ) {
601 next unless exists $self->{$attr} ;
603 my $tab = ( length $attr > 4 ) ? "" : "\t" ;
605 my( $val_text, $q, $ret ) ;
607 if ( $deep || $attr eq 'data' ) {
609 $val_text = Data::Dumper::Dumper( $self->{$attr} ) ;
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 ;
620 $val_text = $self->{$attr} ;
621 $q = $val_text =~ /\D/ ? "'" : '' ;
626 $attr$tab => $ret$q$val_text$q,
631 $dump .= "}\n<<<<\n\n" ;