lib/Catalyst/Dispatcher.pm

   1 package Catalyst::Dispatcher;
   2
   3 use strict;
   4 use base 'Class::Accessor::Fast';
   5 use Catalyst::Exception;
   6 use Catalyst::Utils;
   7 use Catalyst::Action;
   8 use Catalyst::ActionContainer;
   9 use Catalyst::DispatchType::Default;
  10 use Catalyst::DispatchType::Index;
  11 use Text::SimpleTable;
  12 use Tree::Simple;
  13 use Tree::Simple::Visitor::FindByPath;
  14 use Scalar::Util ();
  15
  16 # Stringify to class
  17 use overload '""' => sub { return ref shift }, fallback => 1;
  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     my $self  = shift;
  56     my $class = ref($self) || $self;
  57
  58     my $obj = $class->SUPER::new(@_);
  59
  60     # set the default pre- and and postloads
  61     $obj->preload_dispatch_types( \@PRELOAD );
  62     $obj->postload_dispatch_types( \@POSTLOAD );
  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
  71     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     my ( $self, $c, $command, @args ) = @_;
 102     $c->forward( $command, @args ) if $command;
 103     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     my ( $self, $c ) = @_;
 116     if ( $c->action ) {
 117         $c->forward( join( '/', '', $c->action->namespace, '_DISPATCH' ) );
 118     }
 119
 120     else {
 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
 130 =head2 $self->forward( $c, $command [, \@arguments ] )
 131
 132 Documented in L<Catalyst>
 133
 134 =cut
 135
 136 sub forward {
 137     my ( $self, $c, $command, @extra_params ) = @_;
 138
 139     unless ($command) {
 140         $c->log->debug('Nothing to forward to') if $c->debug;
 141         return 0;
 142     }
 143
 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 );
 157
 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     }
 163
 164
 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     }
 173
 174     #push @$args, @_;
 175
 176     local $c->request->{arguments} = \@args;
 177     $action->dispatch( $c );
 178
 179     return $c->state;
 180 }
 181
 182 sub _action_rel2abs {
 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;
 192 }
 193
 194 sub _invoke_as_path {
 195     my ( $self, $c, $rel_path, $args ) = @_;
 196
 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     }
 214 }
 215
 216 sub _find_component_class {
 217     my ( $self, $c, $component ) = @_;
 218
 219     return ref($component)
 220       || ref( $c->component($component) )
 221       || $c->component($component);
 222 }
 223
 224 sub _invoke_as_component {
 225     my ( $self, $c, $component, $method ) = @_;
 226
 227     my $class = $self->_find_component_class( $c, $component ) || return 0;
 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     }
 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     my ( $self, $c ) = @_;
 260     my $path = $c->req->path;
 261     my @path = split /\//, $c->req->path;
 262     $c->req->args( \my @args );
 263
 264     unshift( @path, '' );    # Root action
 265
 266   DESCEND: while (@path) {
 267         $path = join '/', @path;
 268         $path =~ s#^/##;
 269
 270         $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         foreach my $type ( @{ $self->dispatch_types } ) {
 276             last DESCEND if $type->match( $c, $path );
 277         }
 278
 279         # If not, move the last part path to args
 280         my $arg = pop(@path);
 281         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 282         unshift @args, $arg;
 283     }
 284
 285     $c->log->debug( 'Path is "' . $c->req->match . '"' )
 286       if ( $c->debug && $c->req->match );
 287
 288     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 289       if ( $c->debug && @args );
 290 }
 291
 292 =head2 $self->get_action( $action, $namespace )
 293
 294 returns a named action from a given namespace.
 295
 296 =cut
 297
 298 sub get_action {
 299     my ( $self, $name, $namespace ) = @_;
 300     return unless $name;
 301
 302     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 303
 304     return $self->action_hash->{"$namespace/$name"};
 305 }
 306
 307 =head2 $self->get_action_by_path( $path );
 308
 309 Returns the named action by its full path.
 310
 311 =cut
 312
 313 sub get_action_by_path {
 314     my ( $self, $path ) = @_;
 315     $path =~ s/^\///;
 316     $path = "/$path" unless $path =~ /\//;
 317     $self->action_hash->{$path};
 318 }
 319
 320 =head2 $self->get_actions( $c, $action, $namespace )
 321
 322 =cut
 323
 324 sub get_actions {
 325     my ( $self, $c, $action, $namespace ) = @_;
 326     return [] unless $action;
 327
 328     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 329
 330     my @match = $self->get_containers($namespace);
 331
 332     return map { $_->get_action($action) } @match;
 333 }
 334
 335 =head2 $self->get_containers( $namespace )
 336
 337 Return all the action containers for a given namespace, inclusive
 338
 339 =cut
 340
 341 sub get_containers {
 342     my ( $self, $namespace ) = @_;
 343     $namespace ||= '';
 344     $namespace = '' if $namespace eq '/';
 345
 346     my @containers;
 347
 348     if ( length $namespace ) {
 349         do {
 350             push @containers, $self->container_hash->{$namespace};
 351         } while ( $namespace =~ s#/[^/]+$## );
 352     }
 353
 354     return reverse grep { defined } @containers, $self->container_hash->{''};
 355
 356     my @parts = split '/', $namespace;
 357 }
 358
 359 =head2 $self->uri_for_action($action, \@captures)
 360
 361 Takes a Catalyst::Action object and action parameters and returns a URI
 362 part such that if $c->req->path were this URI part, this action would be
 363 dispatched to with $c->req->captures set to the supplied arrayref.
 364
 365 If the action object is not available for external dispatch or the dispatcher
 366 cannot determine an appropriate URI, this method will return undef.
 367
 368 =cut
 369
 370 sub uri_for_action {
 371     my ( $self, $action, $captures) = @_;
 372     $captures ||= [];
 373     foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
 374         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 375         return( $uri eq '' ? '/' : $uri )
 376             if defined($uri);
 377     }
 378     return undef;
 379 }
 380
 381 =head2 $self->register( $c, $action )
 382
 383 Make sure all required dispatch types for this action are loaded, then
 384 pass the action to our dispatch types so they can register it if required.
 385 Also, set up the tree with the action containers.
 386
 387 =cut
 388
 389 sub register {
 390     my ( $self, $c, $action ) = @_;
 391
 392     my $registered = $self->registered_dispatch_types;
 393
 394     my $priv = 0;
 395     foreach my $key ( keys %{ $action->attributes } ) {
 396         next if $key eq 'Private';
 397         my $class = "Catalyst::DispatchType::$key";
 398         unless ( $registered->{$class} ) {
 399             eval "require $class";
 400             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 401             $registered->{$class} = 1;
 402         }
 403     }
 404
 405     # Pass the action to our dispatch types so they can register it if reqd.
 406     foreach my $type ( @{ $self->dispatch_types } ) {
 407         $type->register( $c, $action );
 408     }
 409
 410     my $namespace = $action->namespace;
 411     my $name      = $action->name;
 412
 413     my $container = $self->_find_or_create_action_container($namespace);
 414
 415     # Set the method value
 416     $container->add_action($action);
 417
 418     $self->action_hash->{"$namespace/$name"} = $action;
 419     $self->container_hash->{$namespace} = $container;
 420 }
 421
 422 sub _find_or_create_action_container {
 423     my ( $self, $namespace ) = @_;
 424
 425     my $tree ||= $self->tree;
 426
 427     return $tree->getNodeValue unless $namespace;
 428
 429     my @namespace = split '/', $namespace;
 430     return $self->_find_or_create_namespace_node( $tree, @namespace )
 431       ->getNodeValue;
 432 }
 433
 434 sub _find_or_create_namespace_node {
 435     my ( $self, $parent, $part, @namespace ) = @_;
 436
 437     return $parent unless $part;
 438
 439     my $child =
 440       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 441
 442     unless ($child) {
 443         my $container = Catalyst::ActionContainer->new($part);
 444         $parent->addChild( $child = Tree::Simple->new($container) );
 445     }
 446
 447     $self->_find_or_create_namespace_node( $child, @namespace );
 448 }
 449
 450 =head2 $self->setup_actions( $class, $context )
 451
 452
 453 =cut
 454
 455 sub setup_actions {
 456     my ( $self, $c ) = @_;
 457
 458     $self->dispatch_types( [] );
 459     $self->registered_dispatch_types( {} );
 460     $self->method_action_class('Catalyst::Action');
 461     $self->action_container_class('Catalyst::ActionContainer');
 462
 463     my @classes =
 464       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 465     @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
 466
 467     foreach my $comp ( values %{ $c->components } ) {
 468         $comp->register_actions($c) if $comp->can('register_actions');
 469     }
 470
 471     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 472
 473     return unless $c->debug;
 474
 475     my $privates = Text::SimpleTable->new(
 476         [ 20, 'Private' ],
 477         [ 36, 'Class' ],
 478         [ 12, 'Method' ]
 479     );
 480
 481     my $has_private = 0;
 482     my $walker = sub {
 483         my ( $walker, $parent, $prefix ) = @_;
 484         $prefix .= $parent->getNodeValue || '';
 485         $prefix .= '/' unless $prefix =~ /\/$/;
 486         my $node = $parent->getNodeValue->actions;
 487
 488         for my $action ( keys %{$node} ) {
 489             my $action_obj = $node->{$action};
 490             next
 491               if ( ( $action =~ /^_.*/ )
 492                 && ( !$c->config->{show_internal_actions} ) );
 493             $privates->row( "$prefix$action", $action_obj->class, $action );
 494             $has_private = 1;
 495         }
 496
 497         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 498     };
 499
 500     $walker->( $walker, $self->tree, '' );
 501     $c->log->debug( "Loaded Private actions:\n" . $privates->draw )
 502       if ($has_private);
 503
 504     # List all public actions
 505     $_->list($c) for @{ $self->dispatch_types };
 506 }
 507
 508 sub _load_dispatch_types {
 509     my ( $self, @types ) = @_;
 510
 511     my @loaded;
 512
 513     # Preload action types
 514     for my $type (@types) {
 515         my $class =
 516           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 517         eval "require $class";
 518         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 519           if $@;
 520         push @{ $self->dispatch_types }, $class->new;
 521
 522         push @loaded, $class;
 523     }
 524
 525     return @loaded;
 526 }
 527
 528 =head1 AUTHOR
 529
 530 Sebastian Riedel, C<sri@cpan.org>
 531 Matt S Trout, C<mst@shadowcatsystems.co.uk>
 532
 533 =head1 COPYRIGHT
 534
 535 This program is free software, you can redistribute it and/or modify it under
 536 the same terms as Perl itself.
 537
 538 =cut
 539
 540 1;