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 ; |