X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst%2FDispatcher.pm;h=08a4248e0d4f066513d76e02c629515dcb44ead7;hp=fd176156bbf349ca8ec8a9eec5969c59af5ed5ee;hb=7b442de55a57592a0a9f09db2e85b135bb0c123f;hpb=d91474f509dab7dce4c3e4328e674ab9fea29284

diff --git a/lib/Catalyst/Dispatcher.pm b/lib/Catalyst/Dispatcher.pm
index fd17615..08a4248 100644
--- a/lib/Catalyst/Dispatcher.pm
+++ b/lib/Catalyst/Dispatcher.pm
@@ -10,30 +10,32 @@ use Catalyst::Action;
 use Catalyst::ActionContainer;
 use Catalyst::DispatchType::Default;
 use Catalyst::DispatchType::Index;
+use Catalyst::Utils;
 use Text::SimpleTable;
 use Tree::Simple;
 use Tree::Simple::Visitor::FindByPath;
-use Scalar::Util ();
 
-#do these belong as package vars or should we build these via a builder method?
+use namespace::clean -except => 'meta';
+
+# Refactoring note:
+# do these belong as package vars or should we build these via a builder method?
+# See Catalyst-Plugin-Server for them being added to, which should be much less ugly.
+
 # Preload these action types
 our @PRELOAD = qw/Index Path Regex/;
 
 # Postload these action types
 our @POSTLOAD = qw/Default/;
 
-# FIXME - All of these should be _private attributes, and should have public accessors
-#         which warn about back-compat if you use them.
-has tree => (is => 'rw');
-has dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1);
-has registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1);
-has method_action_class => (is => 'rw', default => 'Catalyst::Action');
-has action_container_class => (is => 'rw', default => 'Catalyst::ActionContainer');
-has action_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
-has container_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
-# END FIXME
-
+# Note - see back-compat methods at end of file.
+has _tree => (is => 'rw', builder => '_build__tree');
+has _dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1);
+has _registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1);
+has _method_action_class => (is => 'rw', default => 'Catalyst::Action');
+has _action_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
+has _container_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
 has preload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@PRELOAD] });
+
 has postload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@POSTLOAD] });
 
 # Wrap accessors so you can assign a list and it will capture a list ref.
@@ -44,8 +46,6 @@ around qw/preload_dispatch_types postload_dispatch_types/ => sub {
     return $self->$orig(@_);
 };
 
-no Moose;
-
 =head1 NAME
 
 Catalyst::Dispatcher - The Catalyst Dispatcher
@@ -61,19 +61,19 @@ application based on the attributes you set.
 
 =head1 METHODS
 
-=head2 new 
+=head2 new
 
 Construct a new dispatcher.
 
 =cut
 
-sub BUILD {
-  my ($self, $params) = @_;
+sub _build__tree {
+  my ($self) = @_;
 
   my $container =
     Catalyst::ActionContainer->new( { part => '/', actions => {} } );
 
-  $self->tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
+  return Tree::Simple->new($container, Tree::Simple->ROOT);
 }
 
 =head2 $self->preload_dispatch_types
@@ -101,7 +101,6 @@ it with a C<+>, like so:
 Delegate the dispatch to the action that matched the url, or return a
 message about unknown resource
 
-
 =cut
 
 sub dispatch {
@@ -109,7 +108,6 @@ sub dispatch {
     if ( my $action = $c->action ) {
         $c->forward( join( '/', '', $action->namespace, '_DISPATCH' ) );
     }
-
     else {
         my $path  = $c->req->path;
         my $error = $path
@@ -121,7 +119,8 @@ sub dispatch {
 }
 
 # $self->_command2action( $c, $command [, \@arguments ] )
-# Search for an action, from the command and returns C<($action, $args)> on
+# $self->_command2action( $c, $command [, \@captures, \@arguments ] )
+# Search for an action, from the command and returns C<($action, $args, $captures)> on
 # success. Returns C<(0)> on error.
 
 sub _command2action {
@@ -132,7 +131,11 @@ sub _command2action {
         return 0;
     }
 
-    my @args;
+    my (@args, @captures);
+
+    if ( ref( $extra_params[-2] ) eq 'ARRAY' ) {
+        @captures = @{ pop @extra_params };
+    }
 
     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
         @args = @{ pop @extra_params }
@@ -146,7 +149,7 @@ sub _command2action {
 
     # go to a string path ("/foo/bar/gorch")
     # or action object
-    if (Scalar::Util::blessed($command) && $command->isa('Catalyst::Action')) {
+    if (blessed($command) && $command->isa('Catalyst::Action')) {
         $action = $command;
     }
     else {
@@ -160,7 +163,7 @@ sub _command2action {
         $action = $self->_invoke_as_component( $c, $command, $method );
     }
 
-    return $action, \@args;
+    return $action, \@args, \@captures;
 }
 
 =head2 $self->visit( $c, $command [, \@arguments ] )
@@ -178,7 +181,7 @@ sub _do_visit {
     my $self = shift;
     my $opname = shift;
     my ( $c, $command ) = @_;
-    my ( $action, $args ) = $self->_command2action(@_);
+    my ( $action, $args, $captures ) = $self->_command2action(@_);
     my $error = qq/Couldn't $opname("$command"): /;
 
     if (!$action) {
@@ -187,7 +190,7 @@ sub _do_visit {
     }
     elsif (!defined $action->namespace) {
         $error .= qq/Action has no namespace: cannot $opname() to a plain /
-                 .qq/method or component, must be a :Action or some sort./
+                 .qq/method or component, must be an :Action of some sort./
     }
     elsif (!$action->class->can('_DISPATCH')) {
         $error .= qq/Action cannot _DISPATCH. /
@@ -206,6 +209,7 @@ sub _do_visit {
     $action = $self->expand_action($action);
 
     local $c->request->{arguments} = $args;
+    local $c->request->{captures}  = $captures;
     local $c->{namespace} = $action->{'namespace'};
     local $c->{action} = $action;
 
@@ -232,6 +236,7 @@ Documented in L<Catalyst>
 
 sub forward {
     my $self = shift;
+    no warnings 'recursion';
     $self->_do_forward(forward => @_);
 }
 
@@ -239,7 +244,7 @@ sub _do_forward {
     my $self = shift;
     my $opname = shift;
     my ( $c, $command ) = @_;
-    my ( $action, $args ) = $self->_command2action(@_);
+    my ( $action, $args, $captures ) = $self->_command2action(@_);
 
     if (!$action) {
         my $error .= qq/Couldn't $opname to command "$command": /
@@ -249,12 +254,10 @@ sub _do_forward {
         return 0;
     }
 
-    no warnings 'recursion';
 
-    my $orig_args = $c->request->arguments();
-    $c->request->arguments($args);
+    local $c->request->{arguments} = $args;
+    no warnings 'recursion';
     $action->dispatch( $c );
-    $c->request->arguments($orig_args);
 
     return $c->state;
 }
@@ -305,35 +308,44 @@ sub _invoke_as_path {
     }
 }
 
-sub _find_component_class {
+sub _find_component {
     my ( $self, $c, $component ) = @_;
 
-    return ref($component)
-      || ref( $c->component($component) )
-      || $c->component($component);
+    # fugly, why doesn't ->component('MyApp') work?
+    return $c if ($component eq blessed($c));
+
+    return blessed($component)
+        ? $component
+        : $c->component($component);
 }
 
 sub _invoke_as_component {
-    my ( $self, $c, $component, $method ) = @_;
+    my ( $self, $c, $component_or_class, $method ) = @_;
+
+    my $component = $self->_find_component($c, $component_or_class);
+    my $component_class = blessed $component || return 0;
 
-    my $class = $self->_find_component_class( $c, $component ) || return 0;
+    if (my $code = $component_class->can('action_for')) {
+        my $possible_action = $component->$code($method);
+        return $possible_action if $possible_action;
+    }
 
-    if ( my $code = $class->can($method) ) {
-        return $self->method_action_class->new(
+    if ( my $code = $component_class->can($method) ) {
+        return $self->_method_action_class->new(
             {
                 name      => $method,
                 code      => $code,
-                reverse   => "$class->$method",
-                class     => $class,
+                reverse   => "$component_class->$method",
+                class     => $component_class,
                 namespace => Catalyst::Utils::class2prefix(
-                    $class, $c->config->{case_sensitive}
+                    $component_class, $c->config->{case_sensitive}
                 ),
             }
         );
     }
     else {
         my $error =
-          qq/Couldn't forward to "$class". Does not implement "$method"/;
+          qq/Couldn't forward to "$component_class". Does not implement "$method"/;
         $c->error($error);
         $c->log->debug($error)
           if $c->debug;
@@ -365,7 +377,7 @@ sub prepare_action {
         # Check out dispatch types to see if any will handle the path at
         # this level
 
-        foreach my $type ( @{ $self->dispatch_types } ) {
+        foreach my $type ( @{ $self->_dispatch_types } ) {
             last DESCEND if $type->match( $c, $path );
         }
 
@@ -396,12 +408,12 @@ sub get_action {
 
     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 
-    return $self->action_hash->{"${namespace}/${name}"};
+    return $self->_action_hash->{"${namespace}/${name}"};
 }
 
-=head2 $self->get_action_by_path( $path ); 
+=head2 $self->get_action_by_path( $path );
 
-Returns the named action by its full path. 
+Returns the named action by its full private path.
 
 =cut
 
@@ -409,7 +421,7 @@ sub get_action_by_path {
     my ( $self, $path ) = @_;
     $path =~ s/^\///;
     $path = "/$path" unless $path =~ /\//;
-    $self->action_hash->{$path};
+    $self->_action_hash->{$path};
 }
 
 =head2 $self->get_actions( $c, $action, $namespace )
@@ -442,11 +454,11 @@ sub get_containers {
 
     if ( length $namespace ) {
         do {
-            push @containers, $self->container_hash->{$namespace};
+            push @containers, $self->_container_hash->{$namespace};
         } while ( $namespace =~ s#/[^/]+$## );
     }
 
-    return reverse grep { defined } @containers, $self->container_hash->{''};
+    return reverse grep { defined } @containers, $self->_container_hash->{''};
 
     #return (split '/', $namespace); # isnt this more clear?
     my @parts = split '/', $namespace;
@@ -466,7 +478,7 @@ cannot determine an appropriate URI, this method will return undef.
 sub uri_for_action {
     my ( $self, $action, $captures) = @_;
     $captures ||= [];
-    foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
+    foreach my $dispatch_type ( @{ $self->_dispatch_types } ) {
         my $uri = $dispatch_type->uri_for_action( $action, $captures );
         return( $uri eq '' ? '/' : $uri )
             if defined($uri);
@@ -474,7 +486,7 @@ sub uri_for_action {
     return undef;
 }
 
-=head2 expand_action 
+=head2 expand_action
 
 expand an action into a full representation of the dispatch.
 mostly useful for chained, other actions will just return a
@@ -485,7 +497,7 @@ single action.
 sub expand_action {
     my ($self, $action) = @_;
 
-    foreach my $dispatch_type (@{ $self->dispatch_types }) {
+    foreach my $dispatch_type (@{ $self->_dispatch_types }) {
         my $expanded = $dispatch_type->expand_action($action);
         return $expanded if $expanded;
     }
@@ -504,23 +516,44 @@ Also, set up the tree with the action containers.
 sub register {
     my ( $self, $c, $action ) = @_;
 
-    my $registered = $self->registered_dispatch_types;
+    my $registered = $self->_registered_dispatch_types;
 
     #my $priv = 0; #seems to be unused
     foreach my $key ( keys %{ $action->attributes } ) {
         next if $key eq 'Private';
         my $class = "Catalyst::DispatchType::$key";
         unless ( $registered->{$class} ) {
-            #some error checking rethrowing here wouldn't hurt.
+            # FIXME - Some error checking and re-throwing needed here, as
+            #         we eat exceptions loading dispatch types.
             eval { Class::MOP::load_class($class) };
-            push( @{ $self->dispatch_types }, $class->new ) unless $@;
+            push( @{ $self->_dispatch_types }, $class->new ) unless $@;
             $registered->{$class} = 1;
         }
     }
 
+    my @dtypes = @{ $self->_dispatch_types };
+    my @normal_dtypes;
+    my @low_precedence_dtypes;
+
+    for my $type ( @dtypes ) {
+        if ($type->isa('Catalyst::DispatchType::Index') ||  
+            $type->isa('Catalyst::DispatchType::Default')) {
+            push @low_precedence_dtypes, $type;
+        } else {
+            push @normal_dtypes, $type;
+        }
+    }
+
     # Pass the action to our dispatch types so they can register it if reqd.
-    foreach my $type ( @{ $self->dispatch_types } ) {
-        $type->register( $c, $action );
+    my $was_registered = 0;
+    foreach my $type ( @normal_dtypes ) {
+        $was_registered = 1 if $type->register( $c, $action );
+    }
+
+    if (not $was_registered) {
+        foreach my $type ( @low_precedence_dtypes ) {
+            $type->register( $c, $action );
+        }
     }
 
     my $namespace = $action->namespace;
@@ -531,14 +564,14 @@ sub register {
     # Set the method value
     $container->add_action($action);
 
-    $self->action_hash->{"$namespace/$name"} = $action;
-    $self->container_hash->{$namespace} = $container;
+    $self->_action_hash->{"$namespace/$name"} = $action;
+    $self->_container_hash->{$namespace} = $container;
 }
 
 sub _find_or_create_action_container {
     my ( $self, $namespace ) = @_;
 
-    my $tree ||= $self->tree;
+    my $tree ||= $self->_tree;
 
     return $tree->getNodeValue unless $namespace;
 
@@ -565,16 +598,18 @@ sub _find_or_create_namespace_node {
 
 =head2 $self->setup_actions( $class, $context )
 
+Loads all of the preload dispatch types, registers their actions and then
+loads all of the postload dispatch types, and iterates over the tree of
+actions, displaying the debug information if appropriate.
 
 =cut
 
 sub setup_actions {
     my ( $self, $c ) = @_;
 
-
     my @classes =
       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
-    @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
+    @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 
     foreach my $comp ( values %{ $c->components } ) {
         $comp->register_actions($c) if $comp->can('register_actions');
@@ -583,11 +618,15 @@ sub setup_actions {
     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 
     return unless $c->debug;
+    $self->_display_action_tables($c);
+}
+
+sub _display_action_tables {
+    my ($self, $c) = @_;
 
+    my $column_width = Catalyst::Utils::term_width() - 20 - 36 - 12;
     my $privates = Text::SimpleTable->new(
-        [ 20, 'Private' ],
-        [ 36, 'Class' ],
-        [ 12, 'Method' ]
+        [ 20, 'Private' ], [ 36, 'Class' ], [ $column_width, 'Method' ]
     );
 
     my $has_private = 0;
@@ -609,12 +648,12 @@ sub setup_actions {
         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
     };
 
-    $walker->( $walker, $self->tree, '' );
+    $walker->( $walker, $self->_tree, '' );
     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
       if $has_private;
 
     # List all public actions
-    $_->list($c) for @{ $self->dispatch_types };
+    $_->list($c) for @{ $self->_dispatch_types };
 }
 
 sub _load_dispatch_types {
@@ -630,7 +669,7 @@ sub _load_dispatch_types {
         eval { Class::MOP::load_class($class) };
         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
           if $@;
-        push @{ $self->dispatch_types }, $class->new;
+        push @{ $self->_dispatch_types }, $class->new;
 
         push @loaded, $class;
     }
@@ -638,7 +677,68 @@ sub _load_dispatch_types {
     return @loaded;
 }
 
-no Moose;
+=head2 $self->dispatch_type( $type )
+
+Get the DispatchType object of the relevant type, i.e. passing C<$type> of
+C<Chained> would return a L<Catalyst::DispatchType::Chained> object (assuming
+of course it's being used.)
+
+=cut
+
+sub dispatch_type {
+    my ($self, $name) = @_;
+
+    unless ($name =~ s/^\+//) {
+        $name = "Catalyst::DispatchType::" . $name;
+    }
+
+    for (@{ $self->_dispatch_types }) {
+        return $_ if ref($_) eq $name;
+    }
+    return undef;
+}
+
+use Moose;
+
+# 5.70 backwards compatibility hacks.
+
+# Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
+# need the methods here which *should* be private..
+
+# However we can't really take them away until there is a sane API for
+# building actions and configuring / introspecting the dispatcher.
+# In 5.90, we should build that infrastructure, port the plugins which
+# use it, and then take the crap below away.
+# See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
+
+# Alias _method_name to method_name, add a before modifier to warn..
+foreach my $public_method_name (qw/
+        tree
+        dispatch_types
+        registered_dispatch_types
+        method_action_class
+        action_hash
+        container_hash
+    /) {
+    my $private_method_name = '_' . $public_method_name;
+    my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
+    $meta->add_method($public_method_name, $meta->get_method($private_method_name));
+    {
+        my %package_hash; # Only warn once per method, per package. These are infrequent enough that
+                          # I haven't provided a way to disable them, patches welcome.
+        $meta->add_before_method_modifier($public_method_name, sub {
+            my $class = caller(2);
+            chomp($class);
+            $package_hash{$class}++ || do {
+                warn("Class $class is calling the deprecated method\n"
+                    . "  Catalyst::Dispatcher::$public_method_name,\n"
+                    . "  this will be removed in Catalyst 5.9X\n");
+            };
+        });
+    }
+}
+# End 5.70 backwards compatibility hacks.
+
 __PACKAGE__->meta->make_immutable;
 
 =head2 meta
@@ -651,7 +751,7 @@ Catalyst Contributors, see Catalyst.pm
 
 =head1 COPYRIGHT
 
-This program is free software, you can redistribute it and/or modify it under
+This library is free software. You can redistribute it and/or modify it under
 the same terms as Perl itself.
 
 =cut