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 # $self->_command2action( $c, $command [, \@arguments ] )
 131 # Search for an action, from the command and returns C<($action, $args)> on
 132 # success. Returns C<(0)> on error.
 133
 134 sub _command2action {
 135     my ( $self, $c, $command, @extra_params ) = @_;
 136
 137     unless ($command) {
 138         $c->log->debug('Nothing to go to') if $c->debug;
 139         return 0;
 140     }
 141
 142     my @args;
 143
 144     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
 145         @args = @{ pop @extra_params }
 146     } else {
 147         # this is a copy, it may take some abuse from
 148         # ->_invoke_as_path if the path had trailing parts
 149         @args = @{ $c->request->arguments };
 150     }
 151
 152     my $action;
 153
 154     # go to a string path ("/foo/bar/gorch")
 155     # or action object which stringifies to that
 156     $action = $self->_invoke_as_path( $c, "$command", \@args );
 157
 158     # go to a component ( "MyApp::*::Foo" or $c->component("...")
 159     # - a path or an object)
 160     unless ($action) {
 161         my $method = @extra_params ? $extra_params[0] : "process";
 162         $action = $self->_invoke_as_component( $c, $command, $method );
 163     }
 164
 165     return $action, \@args;
 166 }
 167
 168 =head2 $self->forward( $c, $command [, \@arguments ] )
 169
 170 Documented in L<Catalyst>
 171
 172 =cut
 173
 174 sub forward {
 175     my $self = shift;
 176     my ( $c, $command ) = @_;
 177     my ( $action, $args ) = $self->_command2action(@_);
 178
 179     unless ($action) {
 180         my $error =
 181             qq/Couldn't forward to command "$command": /
 182           . qq/Invalid action or component./;
 183         $c->error($error);
 184         $c->log->debug($error) if $c->debug;
 185         return 0;
 186     }
 187
 188     local $c->request->{arguments} = $args;
 189     $action->dispatch( $c );
 190
 191     return $c->state;
 192 }
 193
 194 sub _action_rel2abs {
 195     my ( $self, $c, $path ) = @_;
 196
 197     unless ( $path =~ m#^/# ) {
 198         my $namespace = $c->stack->[-1]->namespace;
 199         $path = "$namespace/$path";
 200     }
 201
 202     $path =~ s#^/##;
 203     return $path;
 204 }
 205
 206 sub _invoke_as_path {
 207     my ( $self, $c, $rel_path, $args ) = @_;
 208
 209     my $path = $self->_action_rel2abs( $c, $rel_path );
 210
 211     my ( $tail, @extra_args );
 212     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 213     {                           # allow $path to be empty
 214         if ( my $action = $c->get_action( $tail, $path ) ) {
 215             push @$args, @extra_args;
 216             return $action;
 217         }
 218         else {
 219             return
 220               unless $path
 221               ; # if a match on the global namespace failed then the whole lookup failed
 222         }
 223
 224         unshift @extra_args, $tail;
 225     }
 226 }
 227
 228 sub _find_component_class {
 229     my ( $self, $c, $component ) = @_;
 230
 231     return ref($component)
 232       || ref( $c->component($component) )
 233       || $c->component($component);
 234 }
 235
 236 sub _invoke_as_component {
 237     my ( $self, $c, $component, $method ) = @_;
 238
 239     my $class = $self->_find_component_class( $c, $component ) || return 0;
 240
 241     if ( my $code = $class->can($method) ) {
 242         return $self->method_action_class->new(
 243             {
 244                 name      => $method,
 245                 code      => $code,
 246                 reverse   => "$class->$method",
 247                 class     => $class,
 248                 namespace => Catalyst::Utils::class2prefix(
 249                     $class, $c->config->{case_sensitive}
 250                 ),
 251             }
 252         );
 253     }
 254     else {
 255         my $error =
 256           qq/Couldn't forward to "$class". Does not implement "$method"/;
 257         $c->error($error);
 258         $c->log->debug($error)
 259           if $c->debug;
 260         return 0;
 261     }
 262 }
 263
 264 =head2 $self->prepare_action($c)
 265
 266 Find an dispatch type that matches $c->req->path, and set args from it.
 267
 268 =cut
 269
 270 sub prepare_action {
 271     my ( $self, $c ) = @_;
 272     my $path = $c->req->path;
 273     my @path = split /\//, $c->req->path;
 274     $c->req->args( \my @args );
 275
 276     unshift( @path, '' );    # Root action
 277
 278   DESCEND: while (@path) {
 279         $path = join '/', @path;
 280         $path =~ s#^/##;
 281
 282         $path = '' if $path eq '/';    # Root action
 283
 284         # Check out dispatch types to see if any will handle the path at
 285         # this level
 286
 287         foreach my $type ( @{ $self->dispatch_types } ) {
 288             last DESCEND if $type->match( $c, $path );
 289         }
 290
 291         # If not, move the last part path to args
 292         my $arg = pop(@path);
 293         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 294         unshift @args, $arg;
 295     }
 296
 297     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$c->req->captures||[]};
 298
 299     $c->log->debug( 'Path is "' . $c->req->match . '"' )
 300       if ( $c->debug && length $c->req->match );
 301
 302     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 303       if ( $c->debug && @args );
 304 }
 305
 306 =head2 $self->get_action( $action, $namespace )
 307
 308 returns a named action from a given namespace.
 309
 310 =cut
 311
 312 sub get_action {
 313     my ( $self, $name, $namespace ) = @_;
 314     return unless $name;
 315
 316     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 317
 318     return $self->action_hash->{"$namespace/$name"};
 319 }
 320
 321 =head2 $self->get_action_by_path( $path );
 322
 323 Returns the named action by its full path.
 324
 325 =cut
 326
 327 sub get_action_by_path {
 328     my ( $self, $path ) = @_;
 329     $path =~ s/^\///;
 330     $path = "/$path" unless $path =~ /\//;
 331     $self->action_hash->{$path};
 332 }
 333
 334 =head2 $self->get_actions( $c, $action, $namespace )
 335
 336 =cut
 337
 338 sub get_actions {
 339     my ( $self, $c, $action, $namespace ) = @_;
 340     return [] unless $action;
 341
 342     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 343
 344     my @match = $self->get_containers($namespace);
 345
 346     return map { $_->get_action($action) } @match;
 347 }
 348
 349 =head2 $self->get_containers( $namespace )
 350
 351 Return all the action containers for a given namespace, inclusive
 352
 353 =cut
 354
 355 sub get_containers {
 356     my ( $self, $namespace ) = @_;
 357     $namespace ||= '';
 358     $namespace = '' if $namespace eq '/';
 359
 360     my @containers;
 361
 362     if ( length $namespace ) {
 363         do {
 364             push @containers, $self->container_hash->{$namespace};
 365         } while ( $namespace =~ s#/[^/]+$## );
 366     }
 367
 368     return reverse grep { defined } @containers, $self->container_hash->{''};
 369
 370     my @parts = split '/', $namespace;
 371 }
 372
 373 =head2 $self->uri_for_action($action, \@captures)
 374
 375 Takes a Catalyst::Action object and action parameters and returns a URI
 376 part such that if $c->req->path were this URI part, this action would be
 377 dispatched to with $c->req->captures set to the supplied arrayref.
 378
 379 If the action object is not available for external dispatch or the dispatcher
 380 cannot determine an appropriate URI, this method will return undef.
 381
 382 =cut
 383
 384 sub uri_for_action {
 385     my ( $self, $action, $captures) = @_;
 386     $captures ||= [];
 387     foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
 388         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 389         return( $uri eq '' ? '/' : $uri )
 390             if defined($uri);
 391     }
 392     return undef;
 393 }
 394
 395 =head2 $self->register( $c, $action )
 396
 397 Make sure all required dispatch types for this action are loaded, then
 398 pass the action to our dispatch types so they can register it if required.
 399 Also, set up the tree with the action containers.
 400
 401 =cut
 402
 403 sub register {
 404     my ( $self, $c, $action ) = @_;
 405
 406     my $registered = $self->registered_dispatch_types;
 407
 408     my $priv = 0;
 409     foreach my $key ( keys %{ $action->attributes } ) {
 410         next if $key eq 'Private';
 411         my $class = "Catalyst::DispatchType::$key";
 412         unless ( $registered->{$class} ) {
 413             eval "require $class";
 414             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 415             $registered->{$class} = 1;
 416         }
 417     }
 418
 419     # Pass the action to our dispatch types so they can register it if reqd.
 420     foreach my $type ( @{ $self->dispatch_types } ) {
 421         $type->register( $c, $action );
 422     }
 423
 424     my $namespace = $action->namespace;
 425     my $name      = $action->name;
 426
 427     my $container = $self->_find_or_create_action_container($namespace);
 428
 429     # Set the method value
 430     $container->add_action($action);
 431
 432     $self->action_hash->{"$namespace/$name"} = $action;
 433     $self->container_hash->{$namespace} = $container;
 434 }
 435
 436 sub _find_or_create_action_container {
 437     my ( $self, $namespace ) = @_;
 438
 439     my $tree ||= $self->tree;
 440
 441     return $tree->getNodeValue unless $namespace;
 442
 443     my @namespace = split '/', $namespace;
 444     return $self->_find_or_create_namespace_node( $tree, @namespace )
 445       ->getNodeValue;
 446 }
 447
 448 sub _find_or_create_namespace_node {
 449     my ( $self, $parent, $part, @namespace ) = @_;
 450
 451     return $parent unless $part;
 452
 453     my $child =
 454       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 455
 456     unless ($child) {
 457         my $container = Catalyst::ActionContainer->new($part);
 458         $parent->addChild( $child = Tree::Simple->new($container) );
 459     }
 460
 461     $self->_find_or_create_namespace_node( $child, @namespace );
 462 }
 463
 464 =head2 $self->setup_actions( $class, $context )
 465
 466
 467 =cut
 468
 469 sub setup_actions {
 470     my ( $self, $c ) = @_;
 471
 472     $self->dispatch_types( [] );
 473     $self->registered_dispatch_types( {} );
 474     $self->method_action_class('Catalyst::Action');
 475     $self->action_container_class('Catalyst::ActionContainer');
 476
 477     my @classes =
 478       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 479     @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
 480
 481     foreach my $comp ( values %{ $c->components } ) {
 482         $comp->register_actions($c) if $comp->can('register_actions');
 483     }
 484
 485     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 486
 487     return unless $c->debug;
 488
 489     my $privates = Text::SimpleTable->new(
 490         [ 20, 'Private' ],
 491         [ 36, 'Class' ],
 492         [ 12, 'Method' ]
 493     );
 494
 495     my $has_private = 0;
 496     my $walker = sub {
 497         my ( $walker, $parent, $prefix ) = @_;
 498         $prefix .= $parent->getNodeValue || '';
 499         $prefix .= '/' unless $prefix =~ /\/$/;
 500         my $node = $parent->getNodeValue->actions;
 501
 502         for my $action ( keys %{$node} ) {
 503             my $action_obj = $node->{$action};
 504             next
 505               if ( ( $action =~ /^_.*/ )
 506                 && ( !$c->config->{show_internal_actions} ) );
 507             $privates->row( "$prefix$action", $action_obj->class, $action );
 508             $has_private = 1;
 509         }
 510
 511         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 512     };
 513
 514     $walker->( $walker, $self->tree, '' );
 515     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 516       if $has_private;
 517
 518     # List all public actions
 519     $_->list($c) for @{ $self->dispatch_types };
 520 }
 521
 522 sub _load_dispatch_types {
 523     my ( $self, @types ) = @_;
 524
 525     my @loaded;
 526
 527     # Preload action types
 528     for my $type (@types) {
 529         my $class =
 530           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 531         eval "require $class";
 532         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 533           if $@;
 534         push @{ $self->dispatch_types }, $class->new;
 535
 536         push @loaded, $class;
 537     }
 538
 539     return @loaded;
 540 }
 541
 542 =head1 AUTHORS
 543
 544 Catalyst Contributors, see Catalyst.pm
 545
 546 =head1 COPYRIGHT
 547
 548 This program is free software, you can redistribute it and/or modify it under
 549 the same terms as Perl itself.
 550
 551 =cut
 552
 553 1;