File Coverage

blib/lib/Catalyst/Dispatcher.pm
Criterion Covered Total %
statement 214 242 88.4
branch 56 82 68.3
condition 20 34 58.8
subroutine 32 34 94.1
pod 12 12 100.0
total 334 404 82.7


line stmt bran cond sub pod time code
1             package Catalyst::Dispatcher;
2              
3 48     48   698 use strict;
  48         506  
  48         775  
4 48     48   726 use base 'Class::Accessor::Fast';
  48         446  
  48         749  
5 48     48   863 use Catalyst::Exception;
  48         511  
  48         1037  
6 48     48   813 use Catalyst::Utils;
  48         465  
  48         1315  
7 48     48   1470 use Catalyst::Action;
  48         538  
  48         3742  
8 48     48   3824 use Catalyst::ActionContainer;
  48         610  
  48         1119  
9 48     48   1430 use Catalyst::DispatchType::Default;
  48         544  
  48         1390  
10 48     48   3267 use Catalyst::DispatchType::Index;
  48         722  
  48         1702  
11 48     48   991 use Text::SimpleTable;
  48         637  
  48         1292  
12 48     48   2513 use Tree::Simple;
  48         645  
  48         1095  
13 48     48   2757 use Tree::Simple::Visitor::FindByPath;
  48         517  
  48         1102  
14 48     48   948 use Scalar::Util ();
  48         457  
  48         497  
15              
16             # Stringify to class
17 48     48   815 use overload '""' => sub { return ref shift }, fallback => 1;
  48     0   448  
  48         767  
  0         0  
18              
19             __PACKAGE__->mk_accessors(
20                 qw/tree dispatch_types registered_dispatch_types
21             method_action_class action_container_class
22             preload_dispatch_types postload_dispatch_types
23             action_hash container_hash
24             /
25             );
26              
27             # Preload these action types
28             our @PRELOAD = qw/Index Path Regex/;
29              
30             # Postload these action types
31             our @POSTLOAD = qw/Default/;
32              
33             =head1 NAME
34            
35             Catalyst::Dispatcher - The Catalyst Dispatcher
36            
37             =head1 SYNOPSIS
38            
39             See L<Catalyst>.
40            
41             =head1 DESCRIPTION
42            
43             This is the class that maps public urls to actions in your Catalyst
44             application based on the attributes you set.
45            
46             =head1 METHODS
47            
48             =head2 new
49            
50             Construct a new dispatcher.
51            
52             =cut
53              
54             sub new {
55 51     51 1 926     my $self = shift;
56 51   33     3628     my $class = ref($self) || $self;
57              
58 51         1773     my $obj = $class->SUPER::new(@_);
59              
60             # set the default pre- and and postloads
61 51         1556     $obj->preload_dispatch_types( \@PRELOAD );
62 51         776     $obj->postload_dispatch_types( \@POSTLOAD );
63 51         1531     $obj->action_hash( {} );
64 51         926     $obj->container_hash( {} );
65              
66             # Create the root node of the tree
67 51         1116     my $container =
68                   Catalyst::ActionContainer->new( { part => '/', actions => {} } );
69 51         1942     $obj->tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
70              
71 51         3882     return $obj;
72             }
73              
74             =head2 $self->preload_dispatch_types
75            
76             An arrayref of pre-loaded dispatchtype classes
77            
78             Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
79             To use a custom class outside the regular C<Catalyst> namespace, prefix
80             it with a C<+>, like so:
81            
82             +My::Dispatch::Type
83            
84             =head2 $self->postload_dispatch_types
85            
86             An arrayref of post-loaded dispatchtype classes
87            
88             Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
89             To use a custom class outside the regular C<Catalyst> namespace, prefix
90             it with a C<+>, like so:
91            
92             +My::Dispatch::Type
93            
94             =head2 $self->detach( $c, $command [, \@arguments ] )
95            
96             Documented in L<Catalyst>
97            
98             =cut
99              
100             sub detach {
101 12     12 1 943     my ( $self, $c, $command, @args ) = @_;
102 12 50       201     $c->forward( $command, @args ) if $command;
103 12         155     die $Catalyst::DETACH;
104             }
105              
106             =head2 $self->dispatch($c)
107            
108             Delegate the dispatch to the action that matched the url, or return a
109             message about unknown resource
110            
111            
112             =cut
113              
114             sub dispatch {
115 817     817 1 32313     my ( $self, $c ) = @_;
116 817 100       15134     if ( $c->action ) {
117 807         14432         $c->forward( join( '/', '', $c->action->namespace, '_DISPATCH' ) );
118                 }
119              
120                 else {
121 10         230         my $path = $c->req->path;
122 10 50       140         my $error = $path
123                       ? qq/Unknown resource "$path"/
124                       : "No default action defined";
125 10 50       125         $c->log->error($error) if $c->debug;
126 10         154         $c->error($error);
127                 }
128             }
129              
130             =head2 $self->forward( $c, $command [, \@arguments ] )
131            
132             Documented in L<Catalyst>
133            
134             =cut
135              
136             sub forward {
137 6199     6199 1 247360     my ( $self, $c, $command, @extra_params ) = @_;
138              
139 6199 50       87499     unless ($command) {
140 0 0       0         $c->log->debug('Nothing to forward to') if $c->debug;
141 0         0         return 0;
142                 }
143              
144 6199         76094     my @args;
145                 
146 6199 100       167846     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
147 8         75         @args = @{ pop @extra_params }
  8         88  
148                 } else {
149             # this is a copy, it may take some abuse from ->_invoke_as_path if the path had trailing parts
150 6191         70981         @args = @{ $c->request->arguments };
  6191         133402  
151                 }
152              
153 6199         79454     my $action;
154              
155             # forward to a string path ("/foo/bar/gorch") or action object which stringifies to that
156 6199         113906     $action = $self->_invoke_as_path( $c, "$command", \@args );
157              
158             # forward to a component ( "MyApp::*::Foo" or $c->component("...") - a path or an object)
159 6199 100       80585     unless ($action) {
160 120 100       1723         my $method = @extra_params ? $extra_params[0] : "process";
161 120         4752         $action = $self->_invoke_as_component( $c, $command, $method );
162                 }
163              
164              
165 6199 100       109888     unless ($action) {
166 1         15         my $error =
167                         qq/Couldn't forward to command "$command": /
168                       . qq/Invalid action or component./;
169 1         26         $c->error($error);
170 1 50       17         $c->log->debug($error) if $c->debug;
171 1         27         return 0;
172                 }
173              
174             #push @$args, @_;
175              
176 6198         108983     local $c->request->{arguments} = \@args;
177 6198         2282640     $action->dispatch( $c );
178              
179 6196         261705     return $c->state;
180             }
181              
182             sub _action_rel2abs {
183 6199     6199   73922     my ( $self, $c, $path ) = @_;
184              
185 6199 100       108237     unless ( $path =~ m#^/# ) {
186 5365         83695         my $namespace = $c->stack->[-1]->namespace;
187 5365         79298         $path = "$namespace/$path";
188                 }
189              
190 6199         699201     $path =~ s#^/##;
191 6199         89626     return $path;
192             }
193              
194             sub _invoke_as_path {
195 6199     6199   83911     my ( $self, $c, $rel_path, $args ) = @_;
196              
197 6199         97278     my $path = $self->_action_rel2abs( $c, $rel_path );
198              
199 6199         70508     my ( $tail, @extra_args );
200 6199         187671     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
201                 { # allow $path to be empty
202 6092 100       112450         if ( my $action = $c->get_action( $tail, $path ) ) {
203 6079         103400             push @$args, @extra_args;
204 6079         106356             return $action;
205                     }
206                     else {
207                         return
208 13 100       411               unless $path
209                           ; # if a match on the global namespace failed then the whole lookup failed
210                     }
211              
212 10         243         unshift @extra_args, $tail;
213                 }
214             }
215              
216             sub _find_component_class {
217 120     120   1194     my ( $self, $c, $component ) = @_;
218              
219 120   100     2988     return ref($component)
      100        
220                   || ref( $c->component($component) )
221                   || $c->component($component);
222             }
223              
224             sub _invoke_as_component {
225 120     120   1624     my ( $self, $c, $component, $method ) = @_;
226              
227 120   66     2532     my $class = $self->_find_component_class( $c, $component ) || return 0;
228              
229 119 50       2996     if ( my $code = $class->can($method) ) {
230 119         1766         return $self->method_action_class->new(
231                         {
232                             name => $method,
233                             code => $code,
234                             reverse => "$class->$method",
235                             class => $class,
236                             namespace => Catalyst::Utils::class2prefix(
237                                 $class, $c->config->{case_sensitive}
238                             ),
239                         }
240                     );
241                 }
242                 else {
243 0         0         my $error =
244                       qq/Couldn't forward to "$class". Does not implement "$method"/;
245 0         0         $c->error($error);
246 0 0       0         $c->log->debug($error)
247                       if $c->debug;
248 0         0         return 0;
249                 }
250             }
251              
252             =head2 $self->prepare_action($c)
253            
254             Find an dispatch type that matches $c->req->path, and set args from it.
255            
256             =cut
257              
258             sub prepare_action {
259 817     817 1 33448     my ( $self, $c ) = @_;
260 817         10883     my $path = $c->req->path;
261 817         21046     my @path = split /\//, $c->req->path;
262 817         40172     $c->req->args( \my @args );
263              
264 817         11189     unshift( @path, '' ); # Root action
265              
266 817         26840   DESCEND: while (@path) {
267 1317         19117         $path = join '/', @path;
268 1317         22018         $path =~ s#^/##;
269              
270 1317 50       14257         $path = '' if $path eq '/'; # Root action
271              
272             # Check out dispatch types to see if any will handle the path at
273             # this level
274              
275 1317         13261         foreach my $type ( @{ $self->dispatch_types } ) {
  1317         20865  
276 4751 100       109536             last DESCEND if $type->match( $c, $path );
277                     }
278              
279             # If not, move the last part path to args
280 512         5793         my $arg = pop(@path);
281 512         5888         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  82         1533  
282 512         7842         unshift @args, $arg;
283                 }
284              
285 817 50       8744     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for @{$c->req->captures||[]};
  817         11096  
  817         10740  
  30         548  
286              
287 817 50 33     19101     $c->log->debug( 'Path is "' . $c->req->match . '"' )
288                   if ( $c->debug && $c->req->match );
289              
290 817 50 33     16319     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
291                   if ( $c->debug && @args );
292             }
293              
294             =head2 $self->get_action( $action, $namespace )
295            
296             returns a named action from a given namespace.
297            
298             =cut
299              
300             sub get_action {
301 6913     6913 1 288984     my ( $self, $name, $namespace ) = @_;
302 6913 50       86459     return unless $name;
303              
304 6913   100     121269     $namespace = join( "/", grep { length } split '/', $namespace || "" );
  9185         112784  
305              
306 6913         126684     return $self->action_hash->{"$namespace/$name"};
307             }
308              
309             =head2 $self->get_action_by_path( $path );
310            
311             Returns the named action by its full path.
312            
313             =cut
314              
315             sub get_action_by_path {
316 9     9 1 115     my ( $self, $path ) = @_;
317 9         108     $path =~ s/^\///;
318 9 100       130     $path = "/$path" unless $path =~ /\//;
319 9         113     $self->action_hash->{$path};
320             }
321              
322             =head2 $self->get_actions( $c, $action, $namespace )
323            
324             =cut
325              
326             sub get_actions {
327 2485     2485 1 93400     my ( $self, $c, $action, $namespace ) = @_;
328 2485 50       31120     return [] unless $action;
329              
330 2485   100     40060     $namespace = join( "/", grep { length } split '/', $namespace || "" );
  4011         48430  
331              
332 2485         49172     my @match = $self->get_containers($namespace);
333              
334 2485         33661     return map { $_->get_action($action) } @match;
  6202         117840  
335             }
336              
337             =head2 $self->get_containers( $namespace )
338            
339             Return all the action containers for a given namespace, inclusive
340            
341             =cut
342              
343             sub get_containers {
344 2485     2485 1 29912     my ( $self, $namespace ) = @_;
345 2485   100     38175     $namespace ||= '';
346 2485 50       40540     $namespace = '' if $namespace eq '/';
347              
348 2485         29966     my @containers;
349              
350 2485 100       33925     if ( length $namespace ) {
351 2449         25513         do {
352 4011         101812             push @containers, $self->container_hash->{$namespace};
353                     } while ( $namespace =~ s#/[^/]+$## );
354                 }
355              
356 2485         74673     return reverse grep { defined } @containers, $self->container_hash->{''};
  6496         128950  
357              
358 0         0     my @parts = split '/', $namespace;
359             }
360              
361             =head2 $self->uri_for_action($action, \@captures)
362            
363             Takes a Catalyst::Action object and action parameters and returns a URI
364             part such that if $c->req->path were this URI part, this action would be
365             dispatched to with $c->req->captures set to the supplied arrayref.
366            
367             If the action object is not available for external dispatch or the dispatcher
368             cannot determine an appropriate URI, this method will return undef.
369            
370             =cut
371              
372             sub uri_for_action {
373 29     29 1 386     my ( $self, $action, $captures) = @_;
374 29   100     301     $captures ||= [];
375 29         246     foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
  29         335  
376 115         1725         my $uri = $dispatch_type->uri_for_action( $action, $captures );
377 115 100       2037         return( $uri eq '' ? '/' : $uri )
    100          
378                         if defined($uri);
379                 }
380 10         205     return undef;
381             }
382              
383             =head2 $self->register( $c, $action )
384            
385             Make sure all required dispatch types for this action are loaded, then
386             pass the action to our dispatch types so they can register it if required.
387             Also, set up the tree with the action containers.
388            
389             =cut
390              
391             sub register {
392 25049     25049 1 328980     my ( $self, $c, $action ) = @_;
393              
394 25049         376081     my $registered = $self->registered_dispatch_types;
395              
396 25049         317568     my $priv = 0;
397 25049         359514     foreach my $key ( keys %{ $action->attributes } ) {
  25049         381424  
398 32208 100       516832         next if $key eq 'Private';
399 15174         209465         my $class = "Catalyst::DispatchType::$key";
400 15174 100       235999         unless ( $registered->{$class} ) {
401 275         28607             eval "require $class";
402 275 100       8984             push( @{ $self->dispatch_types }, $class->new ) unless $@;
  47         1041  
403 275         4789             $registered->{$class} = 1;
404                     }
405                 }
406              
407             # Pass the action to our dispatch types so they can register it if reqd.
408 25049         365781     foreach my $type ( @{ $self->dispatch_types } ) {
  25049         906195  
409 96485         1813927         $type->register( $c, $action );
410                 }
411              
412 25048         462559     my $namespace = $action->namespace;
413 25048         386770     my $name = $action->name;
414              
415 25048         388999     my $container = $self->_find_or_create_action_container($namespace);
416              
417             # Set the method value
418 25048         425891     $container->add_action($action);
419              
420 25048         399136     $self->action_hash->{"$namespace/$name"} = $action;
421 25048         419377     $self->container_hash->{$namespace} = $container;
422             }
423              
424             sub _find_or_create_action_container {
425 25048     25048   358407     my ( $self, $namespace ) = @_;
426              
427 25048   33     478733     my $tree ||= $self->tree;
428              
429 25048 100       329589     return $tree->getNodeValue unless $namespace;
430              
431 23937         425371     my @namespace = split '/', $namespace;
432 23937         417918     return $self->_find_or_create_namespace_node( $tree, @namespace )
433                   ->getNodeValue;
434             }
435              
436             sub _find_or_create_namespace_node {
437 78999     78999   1089683     my ( $self, $parent, $part, @namespace ) = @_;
438              
439 78999 100       1294221     return $parent unless $part;
440              
441 337826         5138875     my $child =
442 55062         919276       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
443              
444 55062 100       1045453     unless ($child) {
445 2591         51816         my $container = Catalyst::ActionContainer->new($part);
446 2591         60932         $parent->addChild( $child = Tree::Simple->new($container) );
447                 }
448              
449 55062         780809     $self->_find_or_create_namespace_node( $child, @namespace );
450             }
451              
452             =head2 $self->setup_actions( $class, $context )
453            
454            
455             =cut
456              
457             sub setup_actions {
458 51     51 1 781     my ( $self, $c ) = @_;
459              
460 51         2276     $self->dispatch_types( [] );
461 51         2145     $self->registered_dispatch_types( {} );
462 51         717     $self->method_action_class('Catalyst::Action');
463 51         760     $self->action_container_class('Catalyst::ActionContainer');
464              
465 51         863     my @classes =
466 51         530       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
467 51         785     @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
  51         861  
468              
469 51         833     foreach my $comp ( values %{ $c->components } ) {
  51         850  
470 2755 100       144059         $comp->register_actions($c) if $comp->can('register_actions');
471                 }
472              
473 50         16974     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
  50         1570  
474              
475 50 50       3969     return unless $c->debug;
476              
477 0         0     my $privates = Text::SimpleTable->new(
478                     [ 20, 'Private' ],
479                     [ 36, 'Class' ],
480                     [ 12, 'Method' ]
481                 );
482              
483 0         0     my $has_private = 0;
484                 my $walker = sub {
485 0     0   0         my ( $walker, $parent, $prefix ) = @_;
486 0   0     0         $prefix .= $parent->getNodeValue || '';
487 0 0       0         $prefix .= '/' unless $prefix =~ /\/$/;
488 0         0         my $node = $parent->getNodeValue->actions;
489              
490 0         0         for my $action ( keys %{$node} ) {
  0         0  
491 0         0             my $action_obj = $node->{$action};
492                         next
493 0 0 0     0               if ( ( $action =~ /^_.*/ )
494                             && ( !$c->config->{show_internal_actions} ) );
495 0         0             $privates->row( "$prefix$action", $action_obj->class, $action );
496 0         0             $has_private = 1;
497                     }
498              
499 0         0         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
  0         0  
500 0         0     };
501              
502 0         0     $walker->( $walker, $self->tree, '' );
503 0 0       0     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
504                   if $has_private;
505              
506             # List all public actions
507 0         0     $_->list($c) for @{ $self->dispatch_types };
  0         0  
  0         0  
508             }
509              
510             sub _load_dispatch_types {
511 101     101   1315     my ( $self, @types ) = @_;
512              
513 101         956     my @loaded;
514              
515             # Preload action types
516 101         1008     for my $type (@types) {
517 203 50       2853         my $class =
518                       ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
519 203         15640         eval "require $class";
520 203 50       2931         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
521                       if $@;
522 203         5003         push @{ $self->dispatch_types }, $class->new;
  203         3240  
523              
524 203         3695         push @loaded, $class;
525                 }
526              
527 101         2282     return @loaded;
528             }
529              
530             =head1 AUTHOR
531            
532             Sebastian Riedel, C<sri@cpan.org>
533             Matt S Trout, C<mst@shadowcatsystems.co.uk>
534            
535             =head1 COPYRIGHT
536            
537             This program is free software, you can redistribute it and/or modify it under
538             the same terms as Perl itself.
539            
540             =cut
541              
542             1;
543