a bit of code clarification in the dispatcher
[catagits/Catalyst-Runtime.git] / lib / Catalyst / Dispatcher.pm
CommitLineData
68a748b9 1package Catalyst::Dispatcher;
1abd6db7 2
3use strict;
fbcc39ad 4use base 'Class::Accessor::Fast';
a2f2cde9 5use Catalyst::Exception;
f05af9ba 6use Catalyst::Utils;
fbcc39ad 7use Catalyst::Action;
b7aebc12 8use Catalyst::ActionContainer;
b96f127f 9use Catalyst::DispatchType::Default;
bcccee4e 10use Catalyst::DispatchType::Index;
87b85407 11use Text::SimpleTable;
1abd6db7 12use Tree::Simple;
13use Tree::Simple::Visitor::FindByPath;
e72f8f51 14use Scalar::Util ();
1abd6db7 15
fbcc39ad 16# Stringify to class
17use overload '""' => sub { return ref shift }, fallback => 1;
18
49070d25 19__PACKAGE__->mk_accessors(
20 qw/tree dispatch_types registered_dispatch_types
e7bb8d33 21 method_action_class action_container_class
22 preload_dispatch_types postload_dispatch_types
a13e21ab 23 action_hash container_hash
9e81ba44 24 /
49070d25 25);
6d030e6f 26
27# Preload these action types
61a9002d 28our @PRELOAD = qw/Index Path Regex/;
1abd6db7 29
2d1d8f91 30# Postload these action types
61a9002d 31our @POSTLOAD = qw/Default/;
2d1d8f91 32
1abd6db7 33=head1 NAME
34
9c053379 35Catalyst::Dispatcher - The Catalyst Dispatcher
1abd6db7 36
37=head1 SYNOPSIS
38
39See L<Catalyst>.
40
41=head1 DESCRIPTION
42
4ab87e27 43This is the class that maps public urls to actions in your Catalyst
44application based on the attributes you set.
45
1abd6db7 46=head1 METHODS
47
76ddf86b 48=head2 new
4ab87e27 49
50Construct a new dispatcher.
51
e7bb8d33 52=cut
53
54sub new {
9e81ba44 55 my $self = shift;
e7bb8d33 56 my $class = ref($self) || $self;
9e81ba44 57
58 my $obj = $class->SUPER::new(@_);
59
e7bb8d33 60 # set the default pre- and and postloads
9e81ba44 61 $obj->preload_dispatch_types( \@PRELOAD );
e7bb8d33 62 $obj->postload_dispatch_types( \@POSTLOAD );
a13e21ab 63 $obj->action_hash( {} );
64 $obj->container_hash( {} );
65
66 # Create the root node of the tree
67 my $container =
68 Catalyst::ActionContainer->new( { part => '/', actions => {} } );
69 $obj->tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
70
9e81ba44 71 return $obj;
e7bb8d33 72}
73
74=head2 $self->preload_dispatch_types
75
76An arrayref of pre-loaded dispatchtype classes
77
78Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
79To use a custom class outside the regular C<Catalyst> namespace, prefix
80it with a C<+>, like so:
81
82 +My::Dispatch::Type
83
84=head2 $self->postload_dispatch_types
85
86An arrayref of post-loaded dispatchtype classes
87
88Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
89To use a custom class outside the regular C<Catalyst> namespace, prefix
90it with a C<+>, like so:
91
92 +My::Dispatch::Type
93
b5ecfcf0 94=head2 $self->detach( $c, $command [, \@arguments ] )
6ef62eb2 95
4ab87e27 96Documented in L<Catalyst>
97
6ef62eb2 98=cut
99
100sub detach {
fbcc39ad 101 my ( $self, $c, $command, @args ) = @_;
bd7d2e94 102 $c->forward( $command, @args ) if $command;
fbcc39ad 103 die $Catalyst::DETACH;
6ef62eb2 104}
105
b5ecfcf0 106=head2 $self->dispatch($c)
1abd6db7 107
4ab87e27 108Delegate the dispatch to the action that matched the url, or return a
109message about unknown resource
110
111
1abd6db7 112=cut
113
114sub dispatch {
fbcc39ad 115 my ( $self, $c ) = @_;
66e28e3f 116 if ( $c->action ) {
28591cd7 117 $c->forward( join( '/', '', $c->action->namespace, '_DISPATCH' ) );
fbcc39ad 118 }
119
120 else {
1abd6db7 121 my $path = $c->req->path;
122 my $error = $path
123 ? qq/Unknown resource "$path"/
124 : "No default action defined";
125 $c->log->error($error) if $c->debug;
126 $c->error($error);
127 }
128}
129
b5ecfcf0 130=head2 $self->forward( $c, $command [, \@arguments ] )
1abd6db7 131
4ab87e27 132Documented in L<Catalyst>
133
1abd6db7 134=cut
135
136sub forward {
e72f8f51 137 my ( $self, $c, $command, @extra_params ) = @_;
99fe1710 138
1abd6db7 139 unless ($command) {
140 $c->log->debug('Nothing to forward to') if $c->debug;
141 return 0;
142 }
99fe1710 143
e72f8f51 144 my @args;
145
146 if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
147 @args = @{ pop @extra_params }
148 } else {
149 # this is a copy, it may take some abuse from ->_invoke_as_path if the path had trailing parts
150 @args = @{ $c->request->arguments };
151 }
152
153 my $action;
154
155 # forward to a string path ("/foo/bar/gorch") or action object which stringifies to that
156 $action = $self->_invoke_as_path( $c, "$command", \@args );
99fe1710 157
e72f8f51 158 # forward to a component ( "MyApp::*::Foo" or $c->component("...") - a path or an object)
159 unless ($action) {
160 my $method = @extra_params ? $extra_params[0] : "process";
161 $action = $self->_invoke_as_component( $c, $command, $method );
162 }
99fe1710 163
99fe1710 164
e540158b 165 unless ($action) {
166 my $error =
167 qq/Couldn't forward to command "$command": /
168 . qq/Invalid action or component./;
169 $c->error($error);
170 $c->log->debug($error) if $c->debug;
171 return 0;
172 }
bd7d2e94 173
e540158b 174 #push @$args, @_;
adb53907 175
e72f8f51 176 local $c->request->{arguments} = \@args;
b8f669f3 177 $action->dispatch( $c );
99fe1710 178
1abd6db7 179 return $c->state;
180}
181
adb53907 182sub _action_rel2abs {
e540158b 183 my ( $self, $c, $path ) = @_;
184
185 unless ( $path =~ m#^/# ) {
186 my $namespace = $c->stack->[-1]->namespace;
187 $path = "$namespace/$path";
188 }
189
190 $path =~ s#^/##;
191 return $path;
adb53907 192}
193
194sub _invoke_as_path {
e540158b 195 my ( $self, $c, $rel_path, $args ) = @_;
196
e540158b 197 my $path = $self->_action_rel2abs( $c, $rel_path );
198
199 my ( $tail, @extra_args );
200 while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
201 { # allow $path to be empty
202 if ( my $action = $c->get_action( $tail, $path ) ) {
203 push @$args, @extra_args;
204 return $action;
205 }
206 else {
207 return
208 unless $path
209 ; # if a match on the global namespace failed then the whole lookup failed
210 }
211
212 unshift @extra_args, $tail;
213 }
adb53907 214}
215
216sub _find_component_class {
e540158b 217 my ( $self, $c, $component ) = @_;
adb53907 218
e540158b 219 return ref($component)
220 || ref( $c->component($component) )
221 || $c->component($component);
adb53907 222}
223
224sub _invoke_as_component {
e540158b 225 my ( $self, $c, $component, $method ) = @_;
226
227 my $class = $self->_find_component_class( $c, $component ) || return 0;
e540158b 228
229 if ( my $code = $class->can($method) ) {
230 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 my $error =
244 qq/Couldn't forward to "$class". Does not implement "$method"/;
245 $c->error($error);
246 $c->log->debug($error)
247 if $c->debug;
248 return 0;
249 }
adb53907 250}
251
b5ecfcf0 252=head2 $self->prepare_action($c)
fbcc39ad 253
4ab87e27 254Find an dispatch type that matches $c->req->path, and set args from it.
255
fbcc39ad 256=cut
257
258sub prepare_action {
259 my ( $self, $c ) = @_;
260 my $path = $c->req->path;
261 my @path = split /\//, $c->req->path;
262 $c->req->args( \my @args );
263
61a9002d 264 unshift( @path, '' ); # Root action
78d760bb 265
b96f127f 266 DESCEND: while (@path) {
fbcc39ad 267 $path = join '/', @path;
61a9002d 268 $path =~ s#^/##;
fbcc39ad 269
61a9002d 270 $path = '' if $path eq '/'; # Root action
78d760bb 271
22f3a8dd 272 # Check out dispatch types to see if any will handle the path at
273 # this level
274
78d760bb 275 foreach my $type ( @{ $self->dispatch_types } ) {
2633d7dc 276 last DESCEND if $type->match( $c, $path );
66e28e3f 277 }
b96f127f 278
22f3a8dd 279 # If not, move the last part path to args
4082e678 280 my $arg = pop(@path);
281 $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
282 unshift @args, $arg;
fbcc39ad 283 }
284
e3a13771 285 $c->log->debug( 'Path is "' . $c->req->match . '"' )
286 if ( $c->debug && $c->req->match );
287
fbcc39ad 288 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
289 if ( $c->debug && @args );
290}
291
b5ecfcf0 292=head2 $self->get_action( $action, $namespace )
1abd6db7 293
4ab87e27 294returns a named action from a given namespace.
295
1abd6db7 296=cut
297
298sub get_action {
bcd1002b 299 my ( $self, $name, $namespace ) = @_;
79a3189a 300 return unless $name;
3d0d6d21 301
28928de9 302 $namespace = join( "/", grep { length } split '/', $namespace || "" );
99fe1710 303
a13e21ab 304 return $self->action_hash->{"$namespace/$name"};
1abd6db7 305}
306
34d28dfd 307=head2 $self->get_action_by_path( $path );
308
309Returns the named action by its full path.
3d0d6d21 310
34d28dfd 311=cut
3d0d6d21 312
313sub get_action_by_path {
314 my ( $self, $path ) = @_;
28928de9 315 $path = "/$path" unless $path =~ /\//;
3d0d6d21 316 $self->action_hash->{$path};
317}
318
b5ecfcf0 319=head2 $self->get_actions( $c, $action, $namespace )
a9dc674c 320
321=cut
322
323sub get_actions {
324 my ( $self, $c, $action, $namespace ) = @_;
325 return [] unless $action;
3d0d6d21 326
28928de9 327 $namespace = join( "/", grep { length } split '/', $namespace || "" );
a9dc674c 328
329 my @match = $self->get_containers($namespace);
330
684d10ed 331 return map { $_->get_action($action) } @match;
a9dc674c 332}
333
b5ecfcf0 334=head2 $self->get_containers( $namespace )
cfd04b0c 335
4ab87e27 336Return all the action containers for a given namespace, inclusive
337
cfd04b0c 338=cut
339
340sub get_containers {
341 my ( $self, $namespace ) = @_;
a13e21ab 342 $namespace ||= '';
343 $namespace = '' if $namespace eq '/';
cfd04b0c 344
a13e21ab 345 my @containers;
cfd04b0c 346
7f23827b 347 if ( length $namespace ) {
348 do {
349 push @containers, $self->container_hash->{$namespace};
350 } while ( $namespace =~ s#/[^/]+$## );
351 }
90ce41ba 352
a13e21ab 353 return reverse grep { defined } @containers, $self->container_hash->{''};
90ce41ba 354
a13e21ab 355 my @parts = split '/', $namespace;
cfd04b0c 356}
357
b5ecfcf0 358=head2 $self->register( $c, $action )
aad72cc9 359
4ab87e27 360Make sure all required dispatch types for this action are loaded, then
361pass the action to our dispatch types so they can register it if required.
362Also, set up the tree with the action containers.
363
aad72cc9 364=cut
365
79a3189a 366sub register {
367 my ( $self, $c, $action ) = @_;
368
694d15f1 369 my $registered = $self->registered_dispatch_types;
370
371 my $priv = 0;
372 foreach my $key ( keys %{ $action->attributes } ) {
373 $priv++ if $key eq 'Private';
374 my $class = "Catalyst::DispatchType::$key";
375 unless ( $registered->{$class} ) {
376 eval "require $class";
377 push( @{ $self->dispatch_types }, $class->new ) unless $@;
378 $registered->{$class} = 1;
379 }
380 }
381
382 # Pass the action to our dispatch types so they can register it if reqd.
01ce0928 383 my $reg = 0;
384 foreach my $type ( @{ $self->dispatch_types } ) {
385 $reg++ if $type->register( $c, $action );
694d15f1 386 }
387
388 return unless $reg + $priv;
389
79a3189a 390 my $namespace = $action->namespace;
a13e21ab 391 my $name = $action->name;
c7116517 392
a13e21ab 393 my $container = $self->find_or_create_action_container($namespace);
15e9b5dd 394
395 # Set the method value
a13e21ab 396 $container->add_action($action);
c7116517 397
a13e21ab 398 $self->action_hash->{"$namespace/$name"} = $action;
399 $self->container_hash->{$namespace} = $container;
15e9b5dd 400}
401
a13e21ab 402sub find_or_create_action_container {
403 my ( $self, $namespace ) = @_;
404
405 my $tree ||= $self->tree;
99fe1710 406
a13e21ab 407 return $tree->getNodeValue unless $namespace;
78d760bb 408
a13e21ab 409 my @namespace = split '/', $namespace;
410 return $self->_find_or_create_namespace_node( $tree, @namespace )
411 ->getNodeValue;
8505565b 412}
90ce41ba 413
8505565b 414sub _find_or_create_namespace_node {
a13e21ab 415 my ( $self, $parent, $part, @namespace ) = @_;
78d760bb 416
a13e21ab 417 return $parent unless $part;
8505565b 418
a13e21ab 419 my $child =
420 ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
8505565b 421
a13e21ab 422 unless ($child) {
423 my $container = Catalyst::ActionContainer->new($part);
424 $parent->addChild( $child = Tree::Simple->new($container) );
425 }
99fe1710 426
a13e21ab 427 $self->_find_or_create_namespace_node( $child, @namespace );
1abd6db7 428}
429
4ab87e27 430=head2 $self->setup_actions( $class, $context )
431
1abd6db7 432
433=cut
434
435sub setup_actions {
11bd4e3e 436 my ( $self, $c ) = @_;
99fe1710 437
6d030e6f 438 $self->dispatch_types( [] );
91d4abc5 439 $self->registered_dispatch_types( {} );
49070d25 440 $self->method_action_class('Catalyst::Action');
441 $self->action_container_class('Catalyst::ActionContainer');
12e28165 442
9e81ba44 443 my @classes =
444 $self->do_load_dispatch_types( @{ $self->preload_dispatch_types } );
445 @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
b96f127f 446
49070d25 447 foreach my $comp ( values %{ $c->components } ) {
448 $comp->register_actions($c) if $comp->can('register_actions');
1abd6db7 449 }
e494bd6b 450
9e81ba44 451 $self->do_load_dispatch_types( @{ $self->postload_dispatch_types } );
6d030e6f 452
11bd4e3e 453 return unless $c->debug;
99fe1710 454
684d10ed 455 my $privates = Text::SimpleTable->new(
dbf03873 456 [ 20, 'Private' ],
34d28dfd 457 [ 36, 'Class' ],
dbf03873 458 [ 12, 'Method' ]
684d10ed 459 );
99fe1710 460
87b85407 461 my $has_private = 0;
1abd6db7 462 my $walker = sub {
463 my ( $walker, $parent, $prefix ) = @_;
464 $prefix .= $parent->getNodeValue || '';
465 $prefix .= '/' unless $prefix =~ /\/$/;
b7aebc12 466 my $node = $parent->getNodeValue->actions;
99fe1710 467
78d760bb 468 for my $action ( keys %{$node} ) {
b7aebc12 469 my $action_obj = $node->{$action};
b0bb11ec 470 next
471 if ( ( $action =~ /^_.*/ )
472 && ( !$c->config->{show_internal_actions} ) );
684d10ed 473 $privates->row( "$prefix$action", $action_obj->class, $action );
87b85407 474 $has_private = 1;
1abd6db7 475 }
99fe1710 476
1abd6db7 477 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
478 };
99fe1710 479
1abd6db7 480 $walker->( $walker, $self->tree, '' );
11bd4e3e 481 $c->log->debug( "Loaded Private actions:\n" . $privates->draw )
49070d25 482 if ($has_private);
99fe1710 483
a9cbd748 484 # List all public actions
11bd4e3e 485 $_->list($c) for @{ $self->dispatch_types };
1abd6db7 486}
487
9e81ba44 488sub do_load_dispatch_types {
489 my ( $self, @types ) = @_;
490
491 my @loaded;
492
493 # Preload action types
494 for my $type (@types) {
495 my $class =
496 ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
497 eval "require $class";
498 Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
499 if $@;
500 push @{ $self->dispatch_types }, $class->new;
501
502 push @loaded, $class;
503 }
504
a13e21ab 505 return @loaded;
9e81ba44 506}
507
1abd6db7 508=head1 AUTHOR
509
510Sebastian Riedel, C<sri@cpan.org>
158c88c0 511Matt S Trout, C<mst@shadowcatsystems.co.uk>
1abd6db7 512
513=head1 COPYRIGHT
514
515This program is free software, you can redistribute it and/or modify it under
516the same terms as Perl itself.
517
518=cut
519
5201;