home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / MultiDispatch.pm < prev    next >
Encoding:
Perl POD Document  |  2003-02-01  |  12.2 KB  |  480 lines
  1. =head1 NAME
  2.  
  3. POE::Session::MultiDispatch - Callback dispatch for session events.
  4.  
  5. =head1 SYNOPSIS
  6.  
  7.   use POE qw[Session::MultiDispatch];
  8.   
  9.   my $session = POE::Session::MultiDispatch->create(
  10.     inline_states  => { _start => \&_start },
  11.     package_states => [ ... ],
  12.     object_states  => [ ... ],
  13.   );
  14.  
  15.   sub _start {
  16.     # Execute Foo::Bar's _start state first.
  17.     $_[SESSION]->first( _start => 'Foo::Bar' );
  18.     $_[SESSION]->stop;
  19.   }
  20.  
  21.   # run Foo::Bar's done state last.
  22.   $session->last( done => 'Foo::Bar' );
  23.  
  24.   $poe_kernel->run;
  25.   exit 0;
  26.  
  27. =head1 DESCRIPTION
  28.  
  29. POE::Session::MultiDispatch is a drop in replacement for
  30. L<POE::Session|POE::Session> that adds callback dispatch functionality
  31. to POE sessions.  Each event may have multiple handlers associated with
  32. it.  Fine control over the order of execution is available using helper
  33. methods that extend the interface of a POE::Session.
  34.  
  35. POE::Session::MultiDispatch uses POE::Session as a base class.  When
  36. multiple callbacks are registered for an event, only the last callback
  37. survives, all the others are clobbered.  POE::Session::MultiDispatch is
  38. much nicer to your registered callbacks, it keeps them all in the order
  39. they were defined.  When an event is triggered, all the callbacks are
  40. then executed in that same order (unless you muck around with said order).
  41.  
  42. Just what is the order?  Last I checked it is C<inline_states>,
  43. C<package_states>, and C<object_states>.  As you can probably tell, that
  44. order is by no means documented (here or anywhere else) as something that
  45. is stead fast and solid.  You should be careful and know what you're doing
  46. if you intend to care too much about the order.  Having said that, my
  47. guess is that it won't change.  But don't take my word for it.
  48.  
  49. All the real heavy lifting is still done in POE::Session.  The interface
  50. is exactly the same with the exception of the following additions.
  51. Please read the POE::Session documentation for details on working with
  52. POE sessions.
  53.  
  54. =cut
  55.  
  56. package POE::Session::MultiDispatch;
  57. #
  58. # $Revision: 1.3 $
  59. # $Id: MultiDispatch.pm,v 1.3 2003/02/01 21:53:45 cwest Exp $
  60. #
  61. use strict;
  62. $^W = 1; # At least for development.
  63.  
  64. use vars qw($VERSION);
  65. $VERSION = (qw$Revision: 1.3 $)[1];
  66.  
  67. use Carp qw(carp croak);
  68. use base qw[POE::Session];
  69.  
  70.  
  71. =head2 Methods
  72.  
  73. These methods have been added to POE::Sessions's interface.  They
  74. can be accessed from an event by using the session object stored
  75. in C<$_[SESSION]>.  Alternativley, you can use the object returned
  76. when calling C<create()> to call these methods.
  77.  
  78. =over 4
  79.  
  80. =item stop
  81.  
  82. C<stop()> tells the session dispatcher to stop processing callbacks
  83. for this event, after the current one is finished processing.
  84.  
  85. =cut
  86.  
  87. sub stop {
  88.   my ($self) = @_;
  89.   
  90.   $self->[POE::Session::SE_OPTIONS]->{stop} = 1;
  91. }
  92.  
  93. =pod
  94.  
  95. =item go
  96.  
  97. C<go()> tells the session dispatcher to continue processing callbacks
  98. for this event.
  99.  
  100. =cut
  101.  
  102. sub go {
  103.   my ($self) = @_;
  104.  
  105.   $self->[POE::Session::SE_OPTIONS]->{stop} = 0;
  106. }
  107.  
  108. =pod
  109.  
  110. =item status
  111.  
  112. C<status()> returns the current status of the event.  It returns true
  113. if the callback stack is set to be stopped, false if we're still going
  114. through.
  115.  
  116. =cut
  117.  
  118. sub status {
  119.   my ($self) = @_;
  120.  
  121.   $self->[POE::Session::SE_OPTIONS]->{stop} || 0;
  122. }
  123.  
  124. =pod
  125.  
  126. =item up EVENT, STATE, DIFFERENCE
  127.  
  128. C<up()> moves a state up in the calling order for an event.  The
  129. difference is how far up to move it, the default is 1.  A state is
  130. given by name.
  131.  
  132. Inline states don't usually have a name, so one is assigned.  Names
  133. follow the convention 'inline_state_N' where 'N' is a number, zero
  134. indexed.  Package states are named using the package name.  Object
  135. states are named using the object name.
  136.  
  137. =cut
  138.  
  139. sub up {
  140.   my ($self, $event, $state, $difference) = @_;
  141.   croak "No event name passed to up()" unless $event;
  142.   croak "No state name passed to up()" unless $state;
  143.   $difference ||= 1;
  144.   $state = 'inline_state_0' if $state eq 'inline_state';
  145.   my $location = $self->_get_event_location( $event );
  146.  
  147.   my $handlers = $location->{$event};
  148.  
  149.   my $pos = $self->state_location( $state, $handlers );
  150.   my $newpos = $pos - $difference;
  151.   $newpos = 0 if $newpos < 0;
  152.   
  153.   @{$handlers}[$pos, $newpos] = @{$handlers}[$newpos,$pos];
  154.   
  155.   $location->{$event} = $handlers;
  156.   
  157.   return 1;
  158. }
  159.  
  160. =pod
  161.  
  162. =item down EVENT, STATE, DIFFERENCE
  163.  
  164. C<down()> moves a state down in the calling order for an event.  The
  165. difference is how far down to move it, the default is 1.  A state is
  166. given by name.
  167.  
  168. =cut
  169.  
  170. sub down {
  171.   my ($self, $event, $state, $difference) = @_;
  172.   croak "No event name passed to down()" unless $event;
  173.   croak "No state name passed to down()" unless $state;
  174.   $difference ||= 1;
  175.   $state = 'inline_state_0' if $state eq 'inline_state';
  176.   my $location = $self->_get_event_location( $event );
  177.  
  178.   my $handlers = $location->{$event};
  179.  
  180.   my $pos = $self->state_location( $state, $handlers );
  181.   my $newpos = $pos + $difference;
  182.   $newpos = $#{$handlers} if $newpos > $#{$handlers};
  183.   
  184.   @{$handlers}[$pos, $newpos] = @{$handlers}[$newpos,$pos];
  185.   
  186.   $location->{$event} = $handlers;
  187.   
  188.   return 1;
  189. }
  190.  
  191. =pod
  192.  
  193. =item first EVENT, STATE
  194.  
  195. C<first()> moves a state to the beginning of the callback stack.
  196.  
  197. =cut
  198.  
  199. sub first {
  200.   my ($self, $event, $state) = @_;
  201.   croak "No event name passed to up()" unless $event;
  202.   croak "No state name passed to up()" unless $state;
  203.  
  204.   $state = 'inline_state_0' if $state eq 'inline_state';
  205.   my $location = $self->_get_event_location( $event );
  206.  
  207.   my $handlers = $location->{$event};
  208.  
  209.   my $pos = $self->state_location( $state, $handlers );
  210.   
  211.   @{$handlers}[$pos, 0] = @{$handlers}[0,$pos];
  212.   
  213.   $location->{$event} = $handlers;
  214.   
  215.   return 1;
  216. }
  217.  
  218. =item last EVENT, STATE
  219.  
  220. C<last()> moves a state to the end of the callback stack.
  221.  
  222. =cut
  223.  
  224. sub last {
  225.   my ($self, $event, $state) = @_;
  226.   croak "No event name passed to up()" unless $event;
  227.   croak "No state name passed to up()" unless $state;
  228.  
  229.   $state = 'inline_state_0' if $state eq 'inline_state';
  230.   my $location = $self->_get_event_location( $event );
  231.  
  232.   my $handlers = $location->{$event};
  233.  
  234.   my $pos = $self->state_location( $state, $handlers );
  235.   
  236.   @{$handlers}[$pos, $#{$handlers}] = @{$handlers}[$#{$handlers}, $pos];
  237.   
  238.   $location->{$event} = $handlers;
  239.   
  240.   return 1;
  241. }
  242.  
  243. =item swap EVENT, STATE1, STATE2
  244.  
  245. C<swap()> well... swaps the position of two states.
  246.  
  247. =cut
  248.  
  249. sub swap {
  250.   my ($self, $event, $state1, $state2) = @_;
  251.   croak "No event name passed to down()" unless $event;
  252.   croak "Not enough states passed to down()" unless $state1 && $state2;
  253.  
  254.   my $location = $self->_get_event_location( $event );
  255.  
  256.   my $handlers = $location->{$event};
  257.  
  258.   my $pos1 = $self->state_location( $state1, $handlers );
  259.   my $pos2 = $self->state_location( $state2, $handlers );
  260.  
  261.   @{$handlers}[$pos1, $pos2] = @{$handlers}[$pos2,$pos1];
  262.   
  263.   $location->{$event} = $handlers;
  264.   
  265.   return 1;
  266. }
  267.  
  268. =pod
  269.  
  270. =back
  271.  
  272. =cut
  273.  
  274. # internal stuff
  275. sub _get_event_location {
  276.   my ($self, $event) = @_;
  277.  
  278.   return
  279.       exists $self->[POE::Session::SE_OPTIONS]->{+__PACKAGE__}->{$event} ?
  280.       $self->[POE::Session::SE_OPTIONS]->{+__PACKAGE__} :
  281.       $self->[POE::Session::SE_STATES];
  282. }
  283.  
  284. sub state_location {
  285.   my ($self, $state, $handlers) = @_;
  286.   my $pos    = undef;
  287.   my $inline = 0;
  288.   my $count  = 0;
  289.   foreach (@$handlers) {
  290.     if ( ref($_) eq 'CODE' ) {
  291.         my $name = "inline_state_$inline";
  292.         if ( $name eq $state ) {
  293.         $pos = $count;
  294.         last;
  295.       } else {
  296.         $inline++;
  297.       }
  298.     } else {
  299.       my ($name, $code) = @$_;
  300.       if ( $name eq $state || $name->isa( $state ) ) {
  301.         $pos = $count;
  302.         last;
  303.       }
  304.     }
  305.     $count++;
  306.   }
  307.   return $pos;  
  308. }
  309.  
  310. sub _invoke_state {
  311.   my ($self, $source_session, $state, $etc, $file, $line) = @_;
  312.  
  313.   my $handlers = $self->[POE::Session::SE_STATES]->{$state}
  314.     || $self->[POE::Session::SE_STATES]->{POE::Session::EN_DEFAULT};
  315.   $self->[POE::Session::SE_OPTIONS]->{+__PACKAGE__}->{$state} = $handlers;
  316.  
  317.   if ( $handlers ) {
  318.     foreach (@$handlers) {
  319.       if ( $self->status == 1 ) {
  320.         $self->go;
  321.         last;
  322.       }
  323.       $self->[POE::Session::SE_STATES]->{$state} = $_;
  324.       $self->SUPER::_invoke_state(@_[1..$#_]);
  325.     }
  326.   } else {
  327.     $self->SUPER::_invoke_state(@_[1..$#_]);
  328.   }
  329.  
  330.   $self->[POE::Session::SE_STATES]->{$state}
  331.     = delete $self->[POE::Session::SE_OPTIONS]->{+__PACKAGE__}->{$state};
  332.   
  333.   return undef;
  334. }
  335.  
  336. sub register_state {
  337.   my ($self, $name, $handler, $method) = @_;
  338.   $method = $name unless defined $method;
  339.  
  340.   if ($name eq POE::Session::EN_SIGNAL) {
  341.  
  342.     # Report the problem outside POE.
  343.     my $caller_level = 0;
  344.     local $Carp::CarpLevel = 1;
  345.     while ( (caller $caller_level)[0] =~ /^POE::/ ) {
  346.       $caller_level++;
  347.       $Carp::CarpLevel++;
  348.     }
  349.  
  350.     carp( "The _signal event is deprecated.  ",
  351.           "Please use sig() to register a signal handler"
  352.         );
  353.   }
  354.  
  355.   # There is a handler, so add the state to the event.
  356.  
  357.   if ($handler) {
  358.  
  359.     # Coderef handlers are inline states.
  360.  
  361.     if (ref($handler) eq 'CODE') {
  362.       carp( "adding state($name) for session(",
  363.             $POE::Kernel::poe_kernel->ID_session_to_id($self), ")"
  364.           )
  365.         if ( $self->[POE::Session::SE_OPTIONS]->{+POE::Session::OPT_DEBUG} );
  366.       if ( ref($self->[POE::Session::SE_STATES]->{$name}) eq 'ARRAY' || ! $self->[POE::Session::SE_STATES]->{$name} ) {
  367.         push @{ $self->[POE::Session::SE_STATES]->{$name} }, $handler;
  368.       } else {
  369.         # ReadWrite wheel seems to be determined to do this, plus,
  370.         # it does make sense.
  371.         $self->[POE::Session::SE_STATES]->{$name} = $handler;
  372.       }
  373.     }
  374.  
  375.     # Non-coderef handlers may be package or object states.  See if
  376.     # the method belongs to the handler.
  377.  
  378.     elsif ($handler->can($method)) {
  379.       carp( "adding state($name) for session(",
  380.             $POE::Kernel::poe_kernel->ID_session_to_id($self), ")"
  381.           )
  382.         if ( $self->[POE::Session::SE_OPTIONS]->{+POE::Session::OPT_DEBUG} );
  383.       push @{ $self->[POE::Session::SE_STATES]->{$name} }, [ $handler, $method ];
  384.     }
  385.  
  386.     # Something's wrong.  This code also seems wrong, since
  387.     # ref($handler) can't be 'CODE'.
  388.  
  389.     else {
  390.       if ( (ref($handler) eq 'CODE') and
  391.            $self->[POE::Session::SE_OPTIONS]->{+POE::Session::OPT_TRACE}
  392.          ) {
  393.         carp( $POE::Kernel::poe_kernel->ID_session_to_id($self),
  394.               " : state($name) is not a proper ref - not registered"
  395.             )
  396.       }
  397.       else {
  398.         unless ($handler->can($method)) {
  399.           if (length ref($handler)) {
  400.             croak "object $handler does not have a '$method' method"
  401.           }
  402.           else {
  403.             croak "package $handler does not have a '$method' method";
  404.           }
  405.         }
  406.       }
  407.     }
  408.   }
  409.  
  410.   # No handler.  Delete the state!
  411.  
  412.   else {
  413.     delete $self->[POE::Session::SE_STATES]->{$name};
  414.   }
  415. }
  416.  
  417. 1;
  418.  
  419. __END__
  420.  
  421. =pod
  422.  
  423. =head1 BUGS
  424.  
  425. No doubt.
  426.  
  427. See http://rt.cpan.org to report bugs.
  428.  
  429. =head2 Known Issues
  430.  
  431. The following is what I would consider known issues.
  432.  
  433. =over 4
  434.  
  435. =item
  436.  
  437. Updates to the call stack take place right away.  When moving a state
  438. for an event down in the stack, during that event, it will be called twice.
  439. I think that isn't a good idea.
  440.  
  441. =item
  442.  
  443. You can call C<stop()> and C<go()> from outside an event callback.  This
  444. is not useful and will almost guarantee a suprise when it's time to start
  445. POE.
  446.  
  447. =item
  448.  
  449. I'm sure I can guess reasonable defaults for C<up()>, C<down()>, C<first()>,
  450. C<last()>, and event C<swap> if I wanted to, but I haven't even tried.  This
  451. would be most useful.
  452.  
  453. =item
  454.  
  455. Obviously the testing suite is more than lacking, but it does check some
  456. basics, and it gives an example of usage.  Please help me write more.
  457.  
  458. =back
  459.  
  460. =head1 AUTHOR
  461.  
  462. Casey West <casey@geeknest.com>
  463.  
  464. =head1 THANKS
  465.  
  466. Matt Cashner -- Many features inspired by his earlier modle,
  467. POE::Session::Cascading.
  468.  
  469. =head1 COPYRIGHT
  470.  
  471. Copyright (c) 2003 Casey West.  All rights reserved.  This program 
  472. is free software; you can redistribute it and/or modify it under the same 
  473. terms as Perl itself.
  474.  
  475. =head1 SEE ALSO
  476.  
  477. L<perl>, L<POE::Session>, L<POE>.
  478.  
  479. =cut
  480.