fix root default thingie jayk gave me, sanitize Paths at registration time better

[catagits/Catalyst-Runtime.git] / lib / Catalyst / Dispatcher.pm

diff --git a/lib/Catalyst/Dispatcher.pm b/lib/Catalyst/Dispatcher.pm
index 6e182fa..680a76b 100644 (file)
--- a/lib/Catalyst/Dispatcher.pm
+++ b/lib/Catalyst/Dispatcher.pm
@@ -15,6 +15,8 @@ use Text::SimpleTable;
 use Tree::Simple;
 use Tree::Simple::Visitor::FindByPath;
 
+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.
@@ -26,7 +28,7 @@ our @PRELOAD = qw/Index Path Regex/;
 our @POSTLOAD = qw/Default/;
 
 # Note - see back-compat methods at end of file.
-has _tree => (is => 'rw');
+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');
@@ -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
@@ -236,6 +236,7 @@ Documented in L<Catalyst>
 
 sub forward {
     my $self = shift;
+    no warnings 'recursion';
     $self->_do_forward(forward => @_);
 }
 
@@ -253,9 +254,9 @@ sub _do_forward {
         return 0;
     }
 
-    no warnings 'recursion';
 
     local $c->request->{arguments} = $args;
+    no warnings 'recursion';
     $action->dispatch( $c );
 
     return $c->state;
@@ -369,9 +370,7 @@ sub prepare_action {
 
   DESCEND: while (@path) {
         $path = join '/', @path;
-        $path =~ s#^/##;
-
-        $path = '' if $path eq '/';    # Root action
+        $path =~ s#^/+##;
 
         # Check out dispatch types to see if any will handle the path at
         # this level
@@ -410,9 +409,9 @@ sub get_action {
     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
 
@@ -458,9 +457,6 @@ sub get_containers {
     }
 
     return reverse grep { defined } @containers, $self->_container_hash->{''};
-
-    #return (split '/', $namespace); # isnt this more clear?
-    my @parts = split '/', $namespace;
 }
 
 =head2 $self->uri_for_action($action, \@captures)
@@ -530,9 +526,29 @@ sub register {
         }
     }
 
+    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;
@@ -656,7 +672,14 @@ sub _load_dispatch_types {
     return @loaded;
 }
 
-# Dont document this until someone else is happy with beaviour. Ash 2009/03/16
+=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) = @_;
 
@@ -684,12 +707,12 @@ use Moose;
 # 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 
+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;
@@ -699,17 +722,18 @@ foreach my $public_method_name (qw/
         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 = blessed(shift);
-            $package_hash{$class}++ || do { 
-                warn("Class $class is calling the deprecated method Catalyst::Dispatcher::$public_method_name,\n"
-                    . "this will be removed in Catalyst 5.9X");
+            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.
 
-no Moose;
 __PACKAGE__->meta->make_immutable;
 
 =head2 meta
@@ -722,7 +746,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