Next action

lib/Catalyst.pm

@@ -150,6 +150,13 @@ sub composed_response_class {
 
 has namespace => (is => 'rw');
 
+has _last_action_state => (is => 'rw', predicate=>'has_last_action_state');
+
+sub last_action_state {
+  my ($c) = @_;
+  return $c->has_last_action_state ? @{ $c->_last_action_state() } : ();
+}
+
 sub depth { scalar @{ shift->stack || [] }; }
 sub comp { shift->component(@_) }
 
@@ -2045,7 +2052,6 @@ via $c->error.
 sub execute {
     my ( $c, $class, $code ) = @_;
     $class = $c->component($class) || $class;
-    #$c->state(0);
 
     if ( $c->depth >= $RECURSION ) {
         my $action = $code->reverse();
@@ -2064,8 +2070,13 @@ sub execute {
     no warnings 'recursion';
     # N.B. This used to be combined, but I have seen $c get clobbered if so, and
     #      I have no idea how, ergo $ret (which appears to fix the issue)
-    eval { my $ret = $code->execute( $class, $c, @{ $c->req->args } ) || 0; $c->state( $ret ) };
-
+    eval {
+      my @ret = $code->execute($class, $c, @{ $c->req->args }); 
+      my $ret = scalar(@ret) > 1 ? @ret : $ret[0]||0;
+      $c->_last_action_state(\@ret);
+      $c->state($ret);
+    };
+
     $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
 
     my $last = pop( @{ $c->stack } );
@@ -2097,7 +2108,6 @@ sub execute {
             }
             $c->error($error);
         }
-        #$c->state(0);
     }
     return $c->state;
 }
@@ -2392,8 +2402,18 @@ sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
 Gets all actions of a given name in a namespace and all parent
 namespaces.
 
+=head2 $c->action_for( $action_private_name )
+
+Returns the action which matches the full private name or nothing if there's no
+matching action
+
 =cut
 
+sub action_for {
+    my ($c, $action_private_name) = @_ ;
+    return $c->dispatcher->get_action_by_path($action_private_name);
+}
+
 sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
 
 =head2 $app->handle_request( @arguments )

lib/Catalyst/ActionChain.pm

@@ -4,6 +4,13 @@ use Moose;
 extends qw(Catalyst::Action);
 
 has chain => (is => 'rw');
+has _current_chain_actions => (is=>'rw', init_arg=>undef, predicate=>'_has_current_chain_actions');
+has _chain_last_action => (is=>'rw', init_arg=>undef, predicate=>'_has_chain_last_action', clearer=>'_clear_chain_last_action');
+has _chain_captures => (is=>'rw', init_arg=>undef);
+has _chain_original_args => (is=>'rw', init_arg=>undef, clearer=>'_clear_chain_original_args');
+has _chain_next_args => (is=>'rw', init_arg=>undef, predicate=>'_has_chain_next_args', clearer=>'_clear_chain_next_args');
+has _context => (is => 'rw', weak_ref => 1);
+
 no Moose;
 
 =head1 NAME
@@ -27,23 +34,64 @@ sub dispatch {
     my @captures = @{$c->req->captures||[]};
     my @chain = @{ $self->chain };
     my $last = pop(@chain);
-    foreach my $action ( @chain ) {
-        my @args;
-        if (my $cap = $action->number_of_captures) {
-          @args = splice(@captures, 0, $cap);
-        }
-        local $c->request->{arguments} = \@args;
-        $action->dispatch( $c );
-
-        # break the chain if exception occurs in the middle of chain.  We
-        # check the global config flag 'abort_chain_on_error_fix', but this
-        # is now considered true by default, so unless someone explicitly sets
-        # it to false we default it to true (if its not defined).
-        my $abort = defined($c->config->{abort_chain_on_error_fix}) ?
-          $c->config->{abort_chain_on_error_fix} : 1;
-        return if ($c->has_errors && $abort);
+
+    $self->_current_chain_actions(\@chain);
+    $self->_chain_last_action($last);
+    $self->_chain_captures(\@captures);
+    $self->_chain_original_args($c->request->{arguments});
+    $self->_context($c);
+    $self->_dispatch_chain_actions($c);
+}
+
+sub next {
+    my ($self, @args) = @_;
+    my $ctx = $self->_context;
+
+    if($self->_has_chain_last_action) {
+        @args ? $self->_chain_next_args(\@args) : $self->_chain_next_args([]);
+        $self->_dispatch_chain_actions($ctx);
+    } else {
+        $ctx->action->chain->[-1]->next($ctx, @args) if $ctx->action->chain->[-1]->can('next');
     }
-    $last->dispatch( $c );
+
+    return $ctx->last_action_state if $ctx->has_last_action_state;
+}
+
+sub _dispatch_chain_actions {
+    my ($self, $c) = @_;
+    while( @{$self->_current_chain_actions||[]}) {
+        $self->_dispatch_chain_action($c);
+        return if $self->_abort_needed($c);        
+    }
+    if($self->_has_chain_last_action) {
+        $c->request->{arguments} = $self->_chain_original_args;
+        $self->_clear_chain_original_args;
+        unshift @{$c->request->{arguments}}, @{ $self->_chain_next_args} if $self->_has_chain_next_args;
+        $self->_clear_chain_next_args;
+        my $last_action = $self->_chain_last_action;
+        $self->_clear_chain_last_action;
+        $last_action->dispatch($c);
+    }
+}
+
+sub _dispatch_chain_action {
+    my ($self, $c) = @_;
+    my ($action, @remaining_actions) = @{ $self->_current_chain_actions||[] };
+    $self->_current_chain_actions(\@remaining_actions);
+    my @args;
+    if (my $cap = $action->number_of_captures) {
+        @args = splice(@{ $self->_chain_captures||[] }, 0, $cap);
+    }
+    unshift @args, @{ $self->_chain_next_args} if $self->_has_chain_next_args;
+    $self->_clear_chain_next_args;
+    local $c->request->{arguments} = \@args;
+    $action->dispatch( $c );
+}
+
+sub _abort_needed {
+    my ($self, $c) = @_;
+    my $abort = defined($c->config->{abort_chain_on_error_fix}) ? $c->config->{abort_chain_on_error_fix} : 1;
+    return 1 if ($c->has_errors && $abort); 
 }
 
 sub from_chain {

lib/Catalyst/Controller.pm

@@ -514,6 +514,8 @@ sub _parse_Chained_attr {
             my @levels = split '/', $rel;
 
             $value = '/'.join('/', @parts[0 .. $#parts - @levels], $rest);
+        } elsif ($value =~ /^\*/) {
+          $value = "/$value";
         } elsif ($value !~ m/^\//) {
             my $action_ns = $self->action_namespace($c);
 

lib/Catalyst/DispatchType/Chained.pm

@@ -278,25 +278,31 @@ sub recurse_match {
                 next TRY_ACTION unless $action->match_captures($c, \@captures);
 
                 # try the remaining parts against children of this action
-                my ($actions, $captures, $action_parts, $n_pathparts) = $self->recurse_match(
-                                             $c, '/'.$action->reverse, \@parts
-                                           );
-                #    No best action currently
-                # OR The action has less parts
-                # OR The action has equal parts but less captured data (ergo more defined)
-                if ($actions    &&
-                    (!$best_action                                 ||
-                     $#$action_parts < $#{$best_action->{parts}}   ||
-                     ($#$action_parts == $#{$best_action->{parts}} &&
-                      $#$captures < $#{$best_action->{captures}} &&
-                      $n_pathparts > $best_action->{n_pathparts}))) {
-                    my @pathparts = split /\//, $action->attributes->{PathPart}->[0];
-                    $best_action = {
-                        actions => [ $action, @$actions ],
-                        captures=> [ @captures, @$captures ],
-                        parts   => $action_parts,
-                        n_pathparts => scalar(@pathparts) + $n_pathparts,
-                    };
+                my @action_names = ($action->reverse);
+                # try Name first if that exists and then short circuit out
+                unshift @action_names, map { "*${_}"} @{$action->attributes->{Name}} if exists $action->attributes->{Name};
+
+                foreach my $action_name (@action_names) {
+                    my ($actions, $captures, $action_parts, $n_pathparts) = $self->recurse_match(
+                                                 $c, '/'.$action_name, \@parts
+                                               );
+                    #    No best action currently
+                    # OR The action has less parts
+                    # OR The action has equal parts but less captured data (ergo more defined)
+                    if ($actions    &&
+                        (!$best_action                                 ||
+                         $#$action_parts < $#{$best_action->{parts}}   ||
+                         ($#$action_parts == $#{$best_action->{parts}} &&
+                          $#$captures < $#{$best_action->{captures}} &&
+                          $n_pathparts > $best_action->{n_pathparts}))) {
+                        my @pathparts = split /\//, $action->attributes->{PathPart}->[0];
+                        $best_action = {
+                            actions => [ $action, @$actions ],
+                            captures=> [ @captures, @$captures ],
+                            parts   => $action_parts,
+                            n_pathparts => scalar(@pathparts) + $n_pathparts,
+                        };
+                    }
                 }
             }
             else {
@@ -399,6 +405,11 @@ sub register {
 
     $self->_actions->{'/'.$action->reverse} = $action;
 
+    if(my ($name) = @{$action->attributes->{Name}||[]}) {
+        die "Named action '$name' is already defined" if exists $self->_actions->{"/*$name"};
+        $self->_actions->{"/*$name"} = $action;
+    }
+
     if (exists $action->attributes->{Args} and exists $action->attributes->{CaptureArgs}) {
         Catalyst::Exception->throw(
           "Combining Args and CaptureArgs attributes not supported registering " .

lib/Catalyst/Dispatcher.pm

@@ -297,6 +297,7 @@ sub _action_rel2abs {
 sub _invoke_as_path {
     my ( $self, $c, $rel_path, $args ) = @_;
 
+    return $c->action_for($rel_path) if $rel_path =~ m/^\*/;
     my $path = $self->_action_rel2abs( $c, $rel_path );
 
     my ( $tail, @extra_args );
@@ -585,6 +586,14 @@ sub register {
 
     $self->_action_hash->{"$namespace/$name"} = $action;
     $self->_container_hash->{$namespace} = $container;
+
+    # Named Actions
+    if(my (@names) = @{$action->attributes->{Name}||[]}) {
+        foreach my $name (@names) {
+            die "Named action '$name' is already defined" if $self->_action_hash->{"/*$name"};
+            $self->_action_hash->{"/*$name"} = $action;
+        }
+    }
 }
 
 sub _find_or_create_action_container {

t/next-action.t

@@ -0,0 +1,133 @@
+{
+    package MyApp::Controller::Root;
+    $INC{'MyApp/Controller/Root.pm'} = __FILE__;
+
+    use warnings;
+    use strict;
+    use base 'Catalyst::Controller';
+
+    sub root :Chained(/) PathPart('') CaptureArgs(0) {
+        my ($self, $c) = @_;
+        my @a = (1);
+        @a = $c->action->next(@a);
+        push @a, 7;
+        $c->response->body(join ',',@a);
+    }
+
+      sub a :Chained(root) PathPart('a') CaptureArgs(0) {
+          my ($self, $c, @a) = @_;
+          push @a, 2;
+          @a = $c->action->next(@a);
+          push @a, 6;
+          return @a;
+      }
+
+          sub b :Chained(a) PathPart('b') CaptureArgs(1) {
+              my ($self, $c, @a) = @_;
+              push @a, 3;
+              @a = $c->action->next(@a);
+              push @a, 5;
+              return @a;
+          }
+
+              sub c :Chained(b) PathPart('c') Args(0) {
+                  my ($self, $c, @a) = @_;
+                  push @a, 4;
+                  return @a;
+              }
+
+
+    MyApp::Controller::Root->config(namespace=>'');
+
+    package MyApp::Controller::Home;
+    $INC{'MyApp/Controller/Home.pm'} = __FILE__;
+
+    use warnings;
+    use strict;
+    use base 'Catalyst::Controller';
+    use Data::Dumper;
+
+    sub root :Chained(/) PathPart('') CaptureArgs(0) {
+      my ($self, $c) = @_;
+      my @a = $c->action->next;
+      $c->res->body(Dumper [ [@a], [ $c->state ] ]);
+    }
+
+      sub d :Chained(root) PathPart(d) Args(0) {
+        my ($self, $c) = @_;
+        return 1,2,3;
+      }
+
+      sub e :Chained(root) PathPart(e) Args(0) {
+        my ($self, $c) = @_;
+        return 'foo';
+      }
+
+      sub f :Chained(root) PathPart(f) Args(0) {
+        my ($self, $c) = @_;
+        return bar => 1, baz => [3,4,5];
+      }
+
+    package MyApp;
+    use Catalyst;
+
+    MyApp->setup;
+}
+
+use Test::More;
+use Catalyst::Test 'MyApp';
+
+{
+  ok my $res = request '/a/b/99/c';
+  is $res->content, '1,2,99,3,4,5,6,7';
+}
+
+{
+  ok my $res = request '/d';
+  my $data = eval $res->content;
+  is_deeply $data, [
+    [
+      1,
+      2,
+      3,
+    ],
+    [
+      3,
+    ],
+  ];
+}
+
+{
+  ok my $res = request '/e';
+  my $data = eval $res->content;
+  is_deeply $data, [
+    [
+      "foo",
+    ],
+    [
+      "foo",
+    ],
+  ];
+}
+
+{
+  ok my $res = request '/f';
+  my $data = eval $res->content;
+  is_deeply $data, [
+    [
+      "bar",
+      1,
+      "baz",
+      [
+        3,
+        4,
+        5,
+      ],
+    ],
+    [
+      4,
+    ],
+  ];
+}
+
+done_testing;