Less lies in the deprecated block comment in Dispatcher.pm as it's throwing people off
[catagits/Catalyst-Runtime.git] / lib / Catalyst / Dispatcher.pm
1 package Catalyst::Dispatcher;
2
3 use Moose;
4 use Class::MOP;
5 with 'MooseX::Emulate::Class::Accessor::Fast';
6
7 use Catalyst::Exception;
8 use Catalyst::Utils;
9 use Catalyst::Action;
10 use Catalyst::ActionContainer;
11 use Catalyst::DispatchType::Default;
12 use Catalyst::DispatchType::Index;
13 use Catalyst::Utils;
14 use Text::SimpleTable;
15 use Tree::Simple;
16 use Tree::Simple::Visitor::FindByPath;
17
18 use namespace::clean -except => 'meta';
19
20 # Refactoring note:
21 # do these belong as package vars or should we build these via a builder method?
22 # See Catalyst-Plugin-Server for them being added to, which should be much less ugly.
23
24 # Preload these action types
25 our @PRELOAD = qw/Index Path Regex/;
26
27 # Postload these action types
28 our @POSTLOAD = qw/Default/;
29
30 # Note - see back-compat methods at end of file.
31 has _tree => (is => 'rw', builder => '_build__tree');
32 has _dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1);
33 has _registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1);
34 has _method_action_class => (is => 'rw', default => 'Catalyst::Action');
35 has _action_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
36 has _container_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
37
38 my %dispatch_types = ( pre => \@PRELOAD, post => \@POSTLOAD );
39 foreach my $type (keys %dispatch_types) {
40     has $type . "load_dispatch_types" => (
41         is => 'rw', required => 1, lazy => 1, default => sub { $dispatch_types{$type} },
42         traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute'], # List assignment is CAF style
43     );
44 }
45
46 =head1 NAME
47
48 Catalyst::Dispatcher - The Catalyst Dispatcher
49
50 =head1 SYNOPSIS
51
52 See L<Catalyst>.
53
54 =head1 DESCRIPTION
55
56 This is the class that maps public urls to actions in your Catalyst
57 application based on the attributes you set.
58
59 =head1 METHODS
60
61 =head2 new
62
63 Construct a new dispatcher.
64
65 =cut
66
67 sub _build__tree {
68   my ($self) = @_;
69
70   my $container =
71     Catalyst::ActionContainer->new( { part => '/', actions => {} } );
72
73   return Tree::Simple->new($container, Tree::Simple->ROOT);
74 }
75
76 =head2 $self->preload_dispatch_types
77
78 An arrayref of pre-loaded dispatchtype classes
79
80 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
81 To use a custom class outside the regular C<Catalyst> namespace, prefix
82 it with a C<+>, like so:
83
84     +My::Dispatch::Type
85
86 =head2 $self->postload_dispatch_types
87
88 An arrayref of post-loaded dispatchtype classes
89
90 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
91 To use a custom class outside the regular C<Catalyst> namespace, prefix
92 it with a C<+>, like so:
93
94     +My::Dispatch::Type
95
96 =head2 $self->dispatch($c)
97
98 Delegate the dispatch to the action that matched the url, or return a
99 message about unknown resource
100
101 =cut
102
103 sub dispatch {
104     my ( $self, $c ) = @_;
105     if ( my $action = $c->action ) {
106         $c->forward( join( '/', '', $action->namespace, '_DISPATCH' ) );
107     }
108     else {
109         my $path  = $c->req->path;
110         my $error = $path
111           ? qq/Unknown resource "$path"/
112           : "No default action defined";
113         $c->log->error($error) if $c->debug;
114         $c->error($error);
115     }
116 }
117
118 # $self->_command2action( $c, $command [, \@arguments ] )
119 # $self->_command2action( $c, $command [, \@captures, \@arguments ] )
120 # Search for an action, from the command and returns C<($action, $args, $captures)> on
121 # success. Returns C<(0)> on error.
122
123 sub _command2action {
124     my ( $self, $c, $command, @extra_params ) = @_;
125
126     unless ($command) {
127         $c->log->debug('Nothing to go to') if $c->debug;
128         return 0;
129     }
130
131     my (@args, @captures);
132
133     if ( ref( $extra_params[-2] ) eq 'ARRAY' ) {
134         @captures = @{ pop @extra_params };
135     }
136
137     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
138         @args = @{ pop @extra_params }
139     } else {
140         # this is a copy, it may take some abuse from
141         # ->_invoke_as_path if the path had trailing parts
142         @args = @{ $c->request->arguments };
143     }
144
145     my $action;
146
147     # go to a string path ("/foo/bar/gorch")
148     # or action object
149     if (blessed($command) && $command->isa('Catalyst::Action')) {
150         $action = $command;
151     }
152     else {
153         $action = $self->_invoke_as_path( $c, "$command", \@args );
154     }
155
156     # go to a component ( "MyApp::*::Foo" or $c->component("...")
157     # - a path or an object)
158     unless ($action) {
159         my $method = @extra_params ? $extra_params[0] : "process";
160         $action = $self->_invoke_as_component( $c, $command, $method );
161     }
162
163     return $action, \@args, \@captures;
164 }
165
166 =head2 $self->visit( $c, $command [, \@arguments ] )
167
168 Documented in L<Catalyst>
169
170 =cut
171
172 sub visit {
173     my $self = shift;
174     $self->_do_visit('visit', @_);
175 }
176
177 sub _do_visit {
178     my $self = shift;
179     my $opname = shift;
180     my ( $c, $command ) = @_;
181     my ( $action, $args, $captures ) = $self->_command2action(@_);
182     my $error = qq/Couldn't $opname("$command"): /;
183
184     if (!$action) {
185         $error .= qq/Couldn't $opname to command "$command": /
186                  .qq/Invalid action or component./;
187     }
188     elsif (!defined $action->namespace) {
189         $error .= qq/Action has no namespace: cannot $opname() to a plain /
190                  .qq/method or component, must be an :Action of some sort./
191     }
192     elsif (!$action->class->can('_DISPATCH')) {
193         $error .= qq/Action cannot _DISPATCH. /
194                  .qq/Did you try to $opname() a non-controller action?/;
195     }
196     else {
197         $error = q();
198     }
199
200     if($error) {
201         $c->error($error);
202         $c->log->debug($error) if $c->debug;
203         return 0;
204     }
205
206     $action = $self->expand_action($action);
207
208     local $c->request->{arguments} = $args;
209     local $c->request->{captures}  = $captures;
210     local $c->{namespace} = $action->{'namespace'};
211     local $c->{action} = $action;
212
213     $self->dispatch($c);
214 }
215
216 =head2 $self->go( $c, $command [, \@arguments ] )
217
218 Documented in L<Catalyst>
219
220 =cut
221
222 sub go {
223     my $self = shift;
224     $self->_do_visit('go', @_);
225     Catalyst::Exception::Go->throw;
226 }
227
228 =head2 $self->forward( $c, $command [, \@arguments ] )
229
230 Documented in L<Catalyst>
231
232 =cut
233
234 sub forward {
235     my $self = shift;
236     no warnings 'recursion';
237     $self->_do_forward(forward => @_);
238 }
239
240 sub _do_forward {
241     my $self = shift;
242     my $opname = shift;
243     my ( $c, $command ) = @_;
244     my ( $action, $args, $captures ) = $self->_command2action(@_);
245
246     if (!$action) {
247         my $error .= qq/Couldn't $opname to command "$command": /
248                     .qq/Invalid action or component./;
249         $c->error($error);
250         $c->log->debug($error) if $c->debug;
251         return 0;
252     }
253
254
255     local $c->request->{arguments} = $args;
256     no warnings 'recursion';
257     $action->dispatch( $c );
258
259     return $c->state;
260 }
261
262 =head2 $self->detach( $c, $command [, \@arguments ] )
263
264 Documented in L<Catalyst>
265
266 =cut
267
268 sub detach {
269     my ( $self, $c, $command, @args ) = @_;
270     $self->_do_forward(detach => $c, $command, @args ) if $command;
271     Catalyst::Exception::Detach->throw;
272 }
273
274 sub _action_rel2abs {
275     my ( $self, $c, $path ) = @_;
276
277     unless ( $path =~ m#^/# ) {
278         my $namespace = $c->stack->[-1]->namespace;
279         $path = "$namespace/$path";
280     }
281
282     $path =~ s#^/##;
283     return $path;
284 }
285
286 sub _invoke_as_path {
287     my ( $self, $c, $rel_path, $args ) = @_;
288
289     my $path = $self->_action_rel2abs( $c, $rel_path );
290
291     my ( $tail, @extra_args );
292     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
293     {                           # allow $path to be empty
294         if ( my $action = $c->get_action( $tail, $path ) ) {
295             push @$args, @extra_args;
296             return $action;
297         }
298         else {
299             return
300               unless $path
301               ; # if a match on the global namespace failed then the whole lookup failed
302         }
303
304         unshift @extra_args, $tail;
305     }
306 }
307
308 sub _find_component {
309     my ( $self, $c, $component ) = @_;
310
311     # fugly, why doesn't ->component('MyApp') work?
312     return $c if ($component eq blessed($c));
313
314     return blessed($component)
315         ? $component
316         : $c->component($component);
317 }
318
319 sub _invoke_as_component {
320     my ( $self, $c, $component_or_class, $method ) = @_;
321
322     my $component = $self->_find_component($c, $component_or_class);
323     my $component_class = blessed $component || return 0;
324
325     if (my $code = $component_class->can('action_for')) {
326         my $possible_action = $component->$code($method);
327         return $possible_action if $possible_action;
328     }
329
330     if ( my $code = $component_class->can($method) ) {
331         return $self->_method_action_class->new(
332             {
333                 name      => $method,
334                 code      => $code,
335                 reverse   => "$component_class->$method",
336                 class     => $component_class,
337                 namespace => Catalyst::Utils::class2prefix(
338                     $component_class, $c->config->{case_sensitive}
339                 ),
340             }
341         );
342     }
343     else {
344         my $error =
345           qq/Couldn't forward to "$component_class". Does not implement "$method"/;
346         $c->error($error);
347         $c->log->debug($error)
348           if $c->debug;
349         return 0;
350     }
351 }
352
353 =head2 $self->prepare_action($c)
354
355 Find an dispatch type that matches $c->req->path, and set args from it.
356
357 =cut
358
359 sub prepare_action {
360     my ( $self, $c ) = @_;
361     my $req = $c->req;
362     my $path = $req->path;
363     my @path = split /\//, $req->path;
364     $req->args( \my @args );
365
366     unshift( @path, '' );    # Root action
367
368   DESCEND: while (@path) {
369         $path = join '/', @path;
370         $path =~ s#^/+##;
371
372         # Check out dispatch types to see if any will handle the path at
373         # this level
374
375         foreach my $type ( @{ $self->_dispatch_types } ) {
376             last DESCEND if $type->match( $c, $path );
377         }
378
379         # If not, move the last part path to args
380         my $arg = pop(@path);
381         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
382         unshift @args, $arg;
383     }
384
385     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
386
387     $c->log->debug( 'Path is "' . $req->match . '"' )
388       if ( $c->debug && defined $req->match && length $req->match );
389
390     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
391       if ( $c->debug && @args );
392 }
393
394 =head2 $self->get_action( $action, $namespace )
395
396 returns a named action from a given namespace.
397
398 =cut
399
400 sub get_action {
401     my ( $self, $name, $namespace ) = @_;
402     return unless $name;
403
404     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
405
406     return $self->_action_hash->{"${namespace}/${name}"};
407 }
408
409 =head2 $self->get_action_by_path( $path );
410
411 Returns the named action by its full private path.
412
413 =cut
414
415 sub get_action_by_path {
416     my ( $self, $path ) = @_;
417     $path =~ s/^\///;
418     $path = "/$path" unless $path =~ /\//;
419     $self->_action_hash->{$path};
420 }
421
422 =head2 $self->get_actions( $c, $action, $namespace )
423
424 =cut
425
426 sub get_actions {
427     my ( $self, $c, $action, $namespace ) = @_;
428     return [] unless $action;
429
430     $namespace = join( "/", grep { length } split '/', $namespace || "" );
431
432     my @match = $self->get_containers($namespace);
433
434     return map { $_->get_action($action) } @match;
435 }
436
437 =head2 $self->get_containers( $namespace )
438
439 Return all the action containers for a given namespace, inclusive
440
441 =cut
442
443 sub get_containers {
444     my ( $self, $namespace ) = @_;
445     $namespace ||= '';
446     $namespace = '' if $namespace eq '/';
447
448     my @containers;
449
450     if ( length $namespace ) {
451         do {
452             push @containers, $self->_container_hash->{$namespace};
453         } while ( $namespace =~ s#/[^/]+$## );
454     }
455
456     return reverse grep { defined } @containers, $self->_container_hash->{''};
457 }
458
459 =head2 $self->uri_for_action($action, \@captures)
460
461 Takes a Catalyst::Action object and action parameters and returns a URI
462 part such that if $c->req->path were this URI part, this action would be
463 dispatched to with $c->req->captures set to the supplied arrayref.
464
465 If the action object is not available for external dispatch or the dispatcher
466 cannot determine an appropriate URI, this method will return undef.
467
468 =cut
469
470 sub uri_for_action {
471     my ( $self, $action, $captures) = @_;
472     $captures ||= [];
473     foreach my $dispatch_type ( @{ $self->_dispatch_types } ) {
474         my $uri = $dispatch_type->uri_for_action( $action, $captures );
475         return( $uri eq '' ? '/' : $uri )
476             if defined($uri);
477     }
478     return undef;
479 }
480
481 =head2 expand_action
482
483 expand an action into a full representation of the dispatch.
484 mostly useful for chained, other actions will just return a
485 single action.
486
487 =cut
488
489 sub expand_action {
490     my ($self, $action) = @_;
491
492     foreach my $dispatch_type (@{ $self->_dispatch_types }) {
493         my $expanded = $dispatch_type->expand_action($action);
494         return $expanded if $expanded;
495     }
496
497     return $action;
498 }
499
500 =head2 $self->register( $c, $action )
501
502 Make sure all required dispatch types for this action are loaded, then
503 pass the action to our dispatch types so they can register it if required.
504 Also, set up the tree with the action containers.
505
506 =cut
507
508 sub register {
509     my ( $self, $c, $action ) = @_;
510
511     my $registered = $self->_registered_dispatch_types;
512
513     #my $priv = 0; #seems to be unused
514     foreach my $key ( keys %{ $action->attributes } ) {
515         next if $key eq 'Private';
516         my $class = "Catalyst::DispatchType::$key";
517         unless ( $registered->{$class} ) {
518             # FIXME - Some error checking and re-throwing needed here, as
519             #         we eat exceptions loading dispatch types.
520             eval { Class::MOP::load_class($class) };
521             push( @{ $self->_dispatch_types }, $class->new ) unless $@;
522             $registered->{$class} = 1;
523         }
524     }
525
526     my @dtypes = @{ $self->_dispatch_types };
527     my @normal_dtypes;
528     my @low_precedence_dtypes;
529
530     for my $type ( @dtypes ) {
531         if ($type->_is_low_precedence) {
532             push @low_precedence_dtypes, $type;
533         } else {
534             push @normal_dtypes, $type;
535         }
536     }
537
538     # Pass the action to our dispatch types so they can register it if reqd.
539     my $was_registered = 0;
540     foreach my $type ( @normal_dtypes ) {
541         $was_registered = 1 if $type->register( $c, $action );
542     }
543
544     if (not $was_registered) {
545         foreach my $type ( @low_precedence_dtypes ) {
546             $type->register( $c, $action );
547         }
548     }
549
550     my $namespace = $action->namespace;
551     my $name      = $action->name;
552
553     my $container = $self->_find_or_create_action_container($namespace);
554
555     # Set the method value
556     $container->add_action($action);
557
558     $self->_action_hash->{"$namespace/$name"} = $action;
559     $self->_container_hash->{$namespace} = $container;
560 }
561
562 sub _find_or_create_action_container {
563     my ( $self, $namespace ) = @_;
564
565     my $tree ||= $self->_tree;
566
567     return $tree->getNodeValue unless $namespace;
568
569     my @namespace = split '/', $namespace;
570     return $self->_find_or_create_namespace_node( $tree, @namespace )
571       ->getNodeValue;
572 }
573
574 sub _find_or_create_namespace_node {
575     my ( $self, $parent, $part, @namespace ) = @_;
576
577     return $parent unless $part;
578
579     my $child =
580       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
581
582     unless ($child) {
583         my $container = Catalyst::ActionContainer->new($part);
584         $parent->addChild( $child = Tree::Simple->new($container) );
585     }
586
587     $self->_find_or_create_namespace_node( $child, @namespace );
588 }
589
590 =head2 $self->setup_actions( $class, $context )
591
592 Loads all of the preload dispatch types, registers their actions and then
593 loads all of the postload dispatch types, and iterates over the tree of
594 actions, displaying the debug information if appropriate.
595
596 =cut
597
598 sub setup_actions {
599     my ( $self, $c ) = @_;
600
601     my @classes =
602       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
603     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
604
605     foreach my $comp ( values %{ $c->components } ) {
606         $comp->register_actions($c) if $comp->can('register_actions');
607     }
608
609     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
610
611     return unless $c->debug;
612     $self->_display_action_tables($c);
613 }
614
615 sub _display_action_tables {
616     my ($self, $c) = @_;
617
618     my $column_width = Catalyst::Utils::term_width() - 20 - 36 - 12;
619     my $privates = Text::SimpleTable->new(
620         [ 20, 'Private' ], [ 36, 'Class' ], [ $column_width, 'Method' ]
621     );
622
623     my $has_private = 0;
624     my $walker = sub {
625         my ( $walker, $parent, $prefix ) = @_;
626         $prefix .= $parent->getNodeValue || '';
627         $prefix .= '/' unless $prefix =~ /\/$/;
628         my $node = $parent->getNodeValue->actions;
629
630         for my $action ( keys %{$node} ) {
631             my $action_obj = $node->{$action};
632             next
633               if ( ( $action =~ /^_.*/ )
634                 && ( !$c->config->{show_internal_actions} ) );
635             $privates->row( "$prefix$action", $action_obj->class, $action );
636             $has_private = 1;
637         }
638
639         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
640     };
641
642     $walker->( $walker, $self->_tree, '' );
643     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
644       if $has_private;
645
646     # List all public actions
647     $_->list($c) for @{ $self->_dispatch_types };
648 }
649
650 sub _load_dispatch_types {
651     my ( $self, @types ) = @_;
652
653     my @loaded;
654     # Preload action types
655     for my $type (@types) {
656         # first param is undef because we cannot get the appclass
657         my $class = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $type);
658
659         eval { Class::MOP::load_class($class) };
660         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
661           if $@;
662         push @{ $self->_dispatch_types }, $class->new;
663
664         push @loaded, $class;
665     }
666
667     return @loaded;
668 }
669
670 =head2 $self->dispatch_type( $type )
671
672 Get the DispatchType object of the relevant type, i.e. passing C<$type> of
673 C<Chained> would return a L<Catalyst::DispatchType::Chained> object (assuming
674 of course it's being used.)
675
676 =cut
677
678 sub dispatch_type {
679     my ($self, $name) = @_;
680
681     # first param is undef because we cannot get the appclass
682     $name = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $name);
683
684     for (@{ $self->_dispatch_types }) {
685         return $_ if ref($_) eq $name;
686     }
687     return undef;
688 }
689
690 use Moose;
691
692 # 5.70 backwards compatibility hacks.
693
694 # Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
695 # need the methods here which *should* be private..
696
697 # You should be able to use get_actions or get_containers appropriately
698 # instead of relying on these methods which expose implementation details
699 # of the dispatcher..
700 #
701 # IRC backlog included below, please come ask if this doesn't work for you.
702 #
703 # <@t0m> 5.80, the state of. There are things in the dispatcher which have
704 #        been deprecated, that we yell at anyone for using, which there isn't
705 #        a good alternative for yet..
706 # <@mst> er, get_actions/get_containers provides that doesn't it?
707 # <@mst> DispatchTypes are loaded on demand anyway
708 # <@t0m> I'm thinking of things like _tree which is aliased to 'tree' with
709 #        warnings otherwise shit breaks.. We're issuing warnings about the
710 #        correct set of things which you shouldn't be calling..
711 # <@mst> right
712 # <@mst> basically, I don't see there's a need for a replacement for anything
713 # <@mst> it was never a good idea to call ->tree
714 # <@mst> nothingmuch was the only one who did AFAIK
715 # <@mst> and he admitted it was a hack ;)
716
717 # See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
718
719 # Alias _method_name to method_name, add a before modifier to warn..
720 foreach my $public_method_name (qw/
721         tree
722         dispatch_types
723         registered_dispatch_types
724         method_action_class
725         action_hash
726         container_hash
727     /) {
728     my $private_method_name = '_' . $public_method_name;
729     my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
730     $meta->add_method($public_method_name, $meta->get_method($private_method_name));
731     {
732         my %package_hash; # Only warn once per method, per package. These are infrequent enough that
733                           # I haven't provided a way to disable them, patches welcome.
734         $meta->add_before_method_modifier($public_method_name, sub {
735             my $class = caller(2);
736             chomp($class);
737             $package_hash{$class}++ || do {
738                 warn("Class $class is calling the deprecated method\n"
739                     . "  Catalyst::Dispatcher::$public_method_name,\n"
740                     . "  this will be removed in Catalyst 5.9X\n");
741             };
742         });
743     }
744 }
745 # End 5.70 backwards compatibility hacks.
746
747 __PACKAGE__->meta->make_immutable;
748
749 =head2 meta
750
751 Provided by Moose
752
753 =head1 AUTHORS
754
755 Catalyst Contributors, see Catalyst.pm
756
757 =head1 COPYRIGHT
758
759 This library is free software. You can redistribute it and/or modify it under
760 the same terms as Perl itself.
761
762 =cut
763
764 1;