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