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     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$c->req->captures||[]};
 286
 287     $c->log->debug( 'Path is "' . $c->req->match . '"' )
 288       if ( $c->debug && length $c->req->match );
 289
 290     $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     my ( $self, $name, $namespace ) = @_;
 302     return unless $name;
 303
 304     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 305
 306     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     my ( $self, $path ) = @_;
 317     $path =~ s/^\///;
 318     $path = "/$path" unless $path =~ /\//;
 319     $self->action_hash->{$path};
 320 }
 321
 322 =head2 $self->get_actions( $c, $action, $namespace )
 323
 324 =cut
 325
 326 sub get_actions {
 327     my ( $self, $c, $action, $namespace ) = @_;
 328     return [] unless $action;
 329
 330     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 331
 332     my @match = $self->get_containers($namespace);
 333
 334     return map { $_->get_action($action) } @match;
 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     my ( $self, $namespace ) = @_;
 345     $namespace ||= '';
 346     $namespace = '' if $namespace eq '/';
 347
 348     my @containers;
 349
 350     if ( length $namespace ) {
 351         do {
 352             push @containers, $self->container_hash->{$namespace};
 353         } while ( $namespace =~ s#/[^/]+$## );
 354     }
 355
 356     return reverse grep { defined } @containers, $self->container_hash->{''};
 357
 358     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     my ( $self, $action, $captures) = @_;
 374     $captures ||= [];
 375     foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
 376         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 377         return( $uri eq '' ? '/' : $uri )
 378             if defined($uri);
 379     }
 380     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     my ( $self, $c, $action ) = @_;
 393
 394     my $registered = $self->registered_dispatch_types;
 395
 396     my $priv = 0;
 397     foreach my $key ( keys %{ $action->attributes } ) {
 398         next if $key eq 'Private';
 399         my $class = "Catalyst::DispatchType::$key";
 400         unless ( $registered->{$class} ) {
 401             eval "require $class";
 402             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 403             $registered->{$class} = 1;
 404         }
 405     }
 406
 407     # Pass the action to our dispatch types so they can register it if reqd.
 408     foreach my $type ( @{ $self->dispatch_types } ) {
 409         $type->register( $c, $action );
 410     }
 411
 412     my $namespace = $action->namespace;
 413     my $name      = $action->name;
 414
 415     my $container = $self->_find_or_create_action_container($namespace);
 416
 417     # Set the method value
 418     $container->add_action($action);
 419
 420     $self->action_hash->{"$namespace/$name"} = $action;
 421     $self->container_hash->{$namespace} = $container;
 422 }
 423
 424 sub _find_or_create_action_container {
 425     my ( $self, $namespace ) = @_;
 426
 427     my $tree ||= $self->tree;
 428
 429     return $tree->getNodeValue unless $namespace;
 430
 431     my @namespace = split '/', $namespace;
 432     return $self->_find_or_create_namespace_node( $tree, @namespace )
 433       ->getNodeValue;
 434 }
 435
 436 sub _find_or_create_namespace_node {
 437     my ( $self, $parent, $part, @namespace ) = @_;
 438
 439     return $parent unless $part;
 440
 441     my $child =
 442       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 443
 444     unless ($child) {
 445         my $container = Catalyst::ActionContainer->new($part);
 446         $parent->addChild( $child = Tree::Simple->new($container) );
 447     }
 448
 449     $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     my ( $self, $c ) = @_;
 459
 460     $self->dispatch_types( [] );
 461     $self->registered_dispatch_types( {} );
 462     $self->method_action_class('Catalyst::Action');
 463     $self->action_container_class('Catalyst::ActionContainer');
 464
 465     my @classes =
 466       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 467     @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
 468
 469     foreach my $comp ( values %{ $c->components } ) {
 470         $comp->register_actions($c) if $comp->can('register_actions');
 471     }
 472
 473     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 474
 475     return unless $c->debug;
 476
 477     my $privates = Text::SimpleTable->new(
 478         [ 20, 'Private' ],
 479         [ 36, 'Class' ],
 480         [ 12, 'Method' ]
 481     );
 482
 483     my $has_private = 0;
 484     my $walker = sub {
 485         my ( $walker, $parent, $prefix ) = @_;
 486         $prefix .= $parent->getNodeValue || '';
 487         $prefix .= '/' unless $prefix =~ /\/$/;
 488         my $node = $parent->getNodeValue->actions;
 489
 490         for my $action ( keys %{$node} ) {
 491             my $action_obj = $node->{$action};
 492             next
 493               if ( ( $action =~ /^_.*/ )
 494                 && ( !$c->config->{show_internal_actions} ) );
 495             $privates->row( "$prefix$action", $action_obj->class, $action );
 496             $has_private = 1;
 497         }
 498
 499         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 500     };
 501
 502     $walker->( $walker, $self->tree, '' );
 503     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 504       if $has_private;
 505
 506     # List all public actions
 507     $_->list($c) for @{ $self->dispatch_types };
 508 }
 509
 510 sub _load_dispatch_types {
 511     my ( $self, @types ) = @_;
 512
 513     my @loaded;
 514
 515     # Preload action types
 516     for my $type (@types) {
 517         my $class =
 518           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 519         eval "require $class";
 520         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 521           if $@;
 522         push @{ $self->dispatch_types }, $class->new;
 523
 524         push @loaded, $class;
 525     }
 526
 527     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;