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 if defined($uri);
 376     }
 377     return undef;
 378 }
 379
 380 =head2 $self->register( $c, $action )
 381
 382 Make sure all required dispatch types for this action are loaded, then
 383 pass the action to our dispatch types so they can register it if required.
 384 Also, set up the tree with the action containers.
 385
 386 =cut
 387
 388 sub register {
 389     my ( $self, $c, $action ) = @_;
 390
 391     my $registered = $self->registered_dispatch_types;
 392
 393     my $priv = 0;
 394     foreach my $key ( keys %{ $action->attributes } ) {
 395         next if $key eq 'Private';
 396         my $class = "Catalyst::DispatchType::$key";
 397         unless ( $registered->{$class} ) {
 398             eval "require $class";
 399             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 400             $registered->{$class} = 1;
 401         }
 402     }
 403
 404     # Pass the action to our dispatch types so they can register it if reqd.
 405     foreach my $type ( @{ $self->dispatch_types } ) {
 406         $type->register( $c, $action );
 407     }
 408
 409     my $namespace = $action->namespace;
 410     my $name      = $action->name;
 411
 412     my $container = $self->_find_or_create_action_container($namespace);
 413
 414     # Set the method value
 415     $container->add_action($action);
 416
 417     $self->action_hash->{"$namespace/$name"} = $action;
 418     $self->container_hash->{$namespace} = $container;
 419 }
 420
 421 sub _find_or_create_action_container {
 422     my ( $self, $namespace ) = @_;
 423
 424     my $tree ||= $self->tree;
 425
 426     return $tree->getNodeValue unless $namespace;
 427
 428     my @namespace = split '/', $namespace;
 429     return $self->_find_or_create_namespace_node( $tree, @namespace )
 430       ->getNodeValue;
 431 }
 432
 433 sub _find_or_create_namespace_node {
 434     my ( $self, $parent, $part, @namespace ) = @_;
 435
 436     return $parent unless $part;
 437
 438     my $child =
 439       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 440
 441     unless ($child) {
 442         my $container = Catalyst::ActionContainer->new($part);
 443         $parent->addChild( $child = Tree::Simple->new($container) );
 444     }
 445
 446     $self->_find_or_create_namespace_node( $child, @namespace );
 447 }
 448
 449 =head2 $self->setup_actions( $class, $context )
 450
 451
 452 =cut
 453
 454 sub setup_actions {
 455     my ( $self, $c ) = @_;
 456
 457     $self->dispatch_types( [] );
 458     $self->registered_dispatch_types( {} );
 459     $self->method_action_class('Catalyst::Action');
 460     $self->action_container_class('Catalyst::ActionContainer');
 461
 462     my @classes =
 463       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 464     @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
 465
 466     foreach my $comp ( values %{ $c->components } ) {
 467         $comp->register_actions($c) if $comp->can('register_actions');
 468     }
 469
 470     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 471
 472     return unless $c->debug;
 473
 474     my $privates = Text::SimpleTable->new(
 475         [ 20, 'Private' ],
 476         [ 36, 'Class' ],
 477         [ 12, 'Method' ]
 478     );
 479
 480     my $has_private = 0;
 481     my $walker = sub {
 482         my ( $walker, $parent, $prefix ) = @_;
 483         $prefix .= $parent->getNodeValue || '';
 484         $prefix .= '/' unless $prefix =~ /\/$/;
 485         my $node = $parent->getNodeValue->actions;
 486
 487         for my $action ( keys %{$node} ) {
 488             my $action_obj = $node->{$action};
 489             next
 490               if ( ( $action =~ /^_.*/ )
 491                 && ( !$c->config->{show_internal_actions} ) );
 492             $privates->row( "$prefix$action", $action_obj->class, $action );
 493             $has_private = 1;
 494         }
 495
 496         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 497     };
 498
 499     $walker->( $walker, $self->tree, '' );
 500     $c->log->debug( "Loaded Private actions:\n" . $privates->draw )
 501       if ($has_private);
 502
 503     # List all public actions
 504     $_->list($c) for @{ $self->dispatch_types };
 505 }
 506
 507 sub _load_dispatch_types {
 508     my ( $self, @types ) = @_;
 509
 510     my @loaded;
 511
 512     # Preload action types
 513     for my $type (@types) {
 514         my $class =
 515           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 516         eval "require $class";
 517         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 518           if $@;
 519         push @{ $self->dispatch_types }, $class->new;
 520
 521         push @loaded, $class;
 522     }
 523
 524     return @loaded;
 525 }
 526
 527 =head1 AUTHOR
 528
 529 Sebastian Riedel, C<sri@cpan.org>
 530 Matt S Trout, C<mst@shadowcatsystems.co.uk>
 531
 532 =head1 COPYRIGHT
 533
 534 This program is free software, you can redistribute it and/or modify it under
 535 the same terms as Perl itself.
 536
 537 =cut
 538
 539 1;