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