lib/Stem/Msg.pm

   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 ;