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
  15 # Stringify to class
  16 use overload '""' => sub { return ref shift }, fallback => 1;
  17
  18 __PACKAGE__->mk_accessors(
  19     qw/tree dispatch_types registered_dispatch_types
  20       method_action_class action_container_class
  21       preload_dispatch_types postload_dispatch_types
  22           action_hash
  23       /
  24 );
  25
  26 # Preload these action types
  27 our @PRELOAD = qw/Index Path Regex/;
  28
  29 # Postload these action types
  30 our @POSTLOAD = qw/Default/;
  31
  32 =head1 NAME
  33
  34 Catalyst::Dispatcher - The Catalyst Dispatcher
  35
  36 =head1 SYNOPSIS
  37
  38 See L<Catalyst>.
  39
  40 =head1 DESCRIPTION
  41
  42 This is the class that maps public urls to actions in your Catalyst
  43 application based on the attributes you set.
  44
  45 =head1 METHODS
  46
  47 =head2 new
  48
  49 Construct a new dispatcher.
  50
  51 =cut
  52
  53 sub new {
  54     my $self  = shift;
  55     my $class = ref($self) || $self;
  56
  57     my $obj = $class->SUPER::new(@_);
  58
  59     # set the default pre- and and postloads
  60     $obj->preload_dispatch_types( \@PRELOAD );
  61     $obj->postload_dispatch_types( \@POSTLOAD );
  62         $obj->action_hash({});
  63     return $obj;
  64 }
  65
  66 =head2 $self->preload_dispatch_types
  67
  68 An arrayref of pre-loaded dispatchtype classes
  69
  70 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  71 To use a custom class outside the regular C<Catalyst> namespace, prefix
  72 it with a C<+>, like so:
  73
  74     +My::Dispatch::Type
  75
  76 =head2 $self->postload_dispatch_types
  77
  78 An arrayref of post-loaded dispatchtype classes
  79
  80 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  81 To use a custom class outside the regular C<Catalyst> namespace, prefix
  82 it with a C<+>, like so:
  83
  84     +My::Dispatch::Type
  85
  86 =head2 $self->detach( $c, $command [, \@arguments ] )
  87
  88 Documented in L<Catalyst>
  89
  90 =cut
  91
  92 sub detach {
  93     my ( $self, $c, $command, @args ) = @_;
  94     $c->forward( $command, @args ) if $command;
  95     die $Catalyst::DETACH;
  96 }
  97
  98 =head2 $self->dispatch($c)
  99
 100 Delegate the dispatch to the action that matched the url, or return a
 101 message about unknown resource
 102
 103
 104 =cut
 105
 106 sub dispatch {
 107     my ( $self, $c ) = @_;
 108     if ( $c->action ) {
 109         $c->forward( join( '/', '', $c->action->namespace, '_DISPATCH' ) );
 110     }
 111
 112     else {
 113         my $path  = $c->req->path;
 114         my $error = $path
 115           ? qq/Unknown resource "$path"/
 116           : "No default action defined";
 117         $c->log->error($error) if $c->debug;
 118         $c->error($error);
 119     }
 120 }
 121
 122 =head2 $self->forward( $c, $command [, \@arguments ] )
 123
 124 Documented in L<Catalyst>
 125
 126 =cut
 127
 128 sub forward {
 129     my $self    = shift;
 130     my $c       = shift;
 131     my $command = shift;
 132
 133     unless ($command) {
 134         $c->log->debug('Nothing to forward to') if $c->debug;
 135         return 0;
 136     }
 137
 138     my $local_args = 0;
 139     my $arguments  = $c->req->args;
 140     if ( ref( $_[-1] ) eq 'ARRAY' ) {
 141         $arguments  = pop(@_);
 142         $local_args = 1;
 143     }
 144
 145     my $result;
 146
 147     unless ( ref $command ) {
 148         my $command_copy = $command;
 149
 150         unless ( $command_copy =~ s/^\/// ) {
 151             my $namespace = $c->stack->[-1]->namespace;
 152             $command_copy = "${namespace}/${command}";
 153         }
 154
 155         unless ( $command_copy =~ /\// ) {
 156             $result = $c->get_action( $command_copy, '/' );
 157         }
 158         else {
 159             my @extra_args;
 160           DESCEND: while ( $command_copy =~ s/^(.*)\/(\w+)$/$1/ ) {
 161                 my $tail = $2;
 162                 $result = $c->get_action( $tail, $1 );
 163                 if ($result) {
 164                     $local_args = 1;
 165                     $command    = $tail;
 166                     unshift( @{$arguments}, @extra_args );
 167                     last DESCEND;
 168                 }
 169                 unshift( @extra_args, $tail );
 170             }
 171         }
 172     }
 173
 174     unless ($result) {
 175
 176         my $class = ref($command)
 177           || ref( $c->component($command) )
 178           || $c->component($command);
 179         my $method = shift || 'process';
 180
 181         unless ($class) {
 182             my $error =
 183 qq/Couldn't forward to command "$command". Invalid action or component./;
 184             $c->error($error);
 185             $c->log->debug($error) if $c->debug;
 186             return 0;
 187         }
 188
 189         if ( my $code = $class->can($method) ) {
 190             my $action = $self->method_action_class->new(
 191                 {
 192                     name      => $method,
 193                     code      => $code,
 194                     reverse   => "$class->$method",
 195                     class     => $class,
 196                     namespace => Catalyst::Utils::class2prefix(
 197                         $class, $c->config->{case_sensitive}
 198                     ),
 199                 }
 200             );
 201             $result = $action;
 202         }
 203
 204         else {
 205             my $error =
 206               qq/Couldn't forward to "$class". Does not implement "$method"/;
 207             $c->error($error);
 208             $c->log->debug($error)
 209               if $c->debug;
 210             return 0;
 211         }
 212
 213     }
 214
 215     if ($local_args) {
 216         local $c->request->{arguments} = [ @{$arguments} ];
 217         $result->execute($c);
 218     }
 219     else { $result->execute($c) }
 220
 221     return $c->state;
 222 }
 223
 224 =head2 $self->prepare_action($c)
 225
 226 Find an dispatch type that matches $c->req->path, and set args from it.
 227
 228 =cut
 229
 230 sub prepare_action {
 231     my ( $self, $c ) = @_;
 232     my $path = $c->req->path;
 233     my @path = split /\//, $c->req->path;
 234     $c->req->args( \my @args );
 235
 236     unshift( @path, '' );    # Root action
 237
 238   DESCEND: while (@path) {
 239         $path = join '/', @path;
 240         $path =~ s#^/##;
 241
 242         $path = '' if $path eq '/';    # Root action
 243
 244         # Check out dispatch types to see if any will handle the path at
 245         # this level
 246
 247         foreach my $type ( @{ $self->dispatch_types } ) {
 248             last DESCEND if $type->match( $c, $path );
 249         }
 250
 251         # If not, move the last part path to args
 252         my $arg = pop(@path);
 253         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 254         unshift @args, $arg;
 255     }
 256
 257     $c->log->debug( 'Path is "' . $c->req->match . '"' )
 258       if ( $c->debug && $c->req->match );
 259
 260     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 261       if ( $c->debug && @args );
 262 }
 263
 264 =head2 $self->get_action( $action, $namespace )
 265
 266 returns a named action from a given namespace.
 267
 268 =cut
 269
 270 sub get_action {
 271     my ( $self, $name, $namespace ) = @_;
 272     return unless $name;
 273     $namespace ||= '';
 274     $namespace = '' if $namespace eq '/';
 275
 276         return $self->action_hash->{ "$namespace/$name" };
 277 }
 278
 279 =head2 $self->get_actions( $c, $action, $namespace )
 280
 281 =cut
 282
 283 sub get_actions {
 284     my ( $self, $c, $action, $namespace ) = @_;
 285     return [] unless $action;
 286     $namespace ||= '';
 287     $namespace = '' if $namespace eq '/';
 288
 289     my @match = $self->get_containers($namespace);
 290
 291     return map { $_->get_action($action) } @match;
 292 }
 293
 294 =head2 $self->get_containers( $namespace )
 295
 296 Return all the action containers for a given namespace, inclusive
 297
 298 =cut
 299
 300 sub get_containers {
 301     my ( $self, $namespace ) = @_;
 302
 303     # If the namespace is / just return the root ActionContainer
 304
 305     return ( $self->tree->getNodeValue )
 306       if ( !$namespace || ( $namespace eq '/' ) );
 307
 308     # Use a visitor to recurse down the tree finding the ActionContainers
 309     # for each namespace in the chain.
 310
 311     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 312     my @path = split( '/', $namespace );
 313     $visitor->setSearchPath(@path);
 314     $self->tree->accept($visitor);
 315
 316     my @match = $visitor->getResults;
 317     @match = ( $self->tree ) unless @match;
 318
 319     if ( !defined $visitor->getResult ) {
 320
 321         # If we don't manage to match, the visitor doesn't return the last
 322         # node is matched, so foo/bar/baz would only find the 'foo' node,
 323         # not the foo and foo/bar nodes as it should. This does another
 324         # single-level search to see if that's the case, and the 'last unless'
 325         # should catch any failures - or short-circuit this if this *is* a
 326         # bug in the visitor and gets fixed.
 327
 328         if ( my $extra = $path[ ( scalar @match ) - 1 ] ) {
 329             $visitor->setSearchPath($extra);
 330             $match[-1]->accept($visitor);
 331             push( @match, $visitor->getResult ) if defined $visitor->getResult;
 332         }
 333     }
 334
 335     return map { $_->getNodeValue } @match;
 336 }
 337
 338 =head2 $self->register( $c, $action )
 339
 340 Make sure all required dispatch types for this action are loaded, then
 341 pass the action to our dispatch types so they can register it if required.
 342 Also, set up the tree with the action containers.
 343
 344 =cut
 345
 346 sub register {
 347     my ( $self, $c, $action ) = @_;
 348
 349     my $registered = $self->registered_dispatch_types;
 350
 351     my $priv = 0;
 352     foreach my $key ( keys %{ $action->attributes } ) {
 353         $priv++ if $key eq 'Private';
 354         my $class = "Catalyst::DispatchType::$key";
 355         unless ( $registered->{$class} ) {
 356             eval "require $class";
 357             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 358             $registered->{$class} = 1;
 359         }
 360     }
 361
 362     # Pass the action to our dispatch types so they can register it if reqd.
 363     my $reg = 0;
 364     foreach my $type ( @{ $self->dispatch_types } ) {
 365         $reg++ if $type->register( $c, $action );
 366     }
 367
 368     return unless $reg + $priv;
 369
 370     my $namespace = $action->namespace;
 371         my $name = $action->name;
 372
 373         my $node = $self->find_or_create_namespace_node( $namespace );
 374
 375     # Set the method value
 376     $node->getNodeValue->actions->{ $name } = $action;
 377
 378         my $path = "$namespace/$name";
 379
 380         if ( exists $self->action_hash->{$path} and $self->action_hash->{$path} != $action ) {
 381                 warn "inconsistency: $path is already registered";
 382         }
 383
 384         $self->action_hash->{$path} = $action;
 385 }
 386
 387 sub find_or_create_namespace_node {
 388         my ( $self, $namespace ) = @_;
 389
 390     my $tree  ||= $self->tree;
 391
 392         return $tree unless $namespace;
 393
 394         my @namespace = split '/', $namespace;
 395         return $self->_find_or_create_namespace_node( $tree, @namespace );
 396 }
 397
 398 sub _find_or_create_namespace_node {
 399         my ( $self, $parent, $part, @namespace ) = @_;
 400
 401         return $parent unless $part;
 402
 403         my $child = ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 404
 405         unless ($child) {
 406                 # Create a new tree node and an ActionContainer to form
 407                 # its value.
 408
 409                 my $container =
 410                   Catalyst::ActionContainer->new(
 411                         { part => $part, actions => {} } );
 412
 413                 $parent->addChild( $child = Tree::Simple->new($container) );
 414         }
 415
 416         $self->_find_or_create_namespace_node( $child, @namespace );
 417 }
 418
 419 =head2 $self->setup_actions( $class, $context )
 420
 421
 422 =cut
 423
 424 sub setup_actions {
 425     my ( $self, $c ) = @_;
 426
 427     $self->dispatch_types( [] );
 428     $self->registered_dispatch_types( {} );
 429     $self->method_action_class('Catalyst::Action');
 430     $self->action_container_class('Catalyst::ActionContainer');
 431
 432     my @classes =
 433       $self->do_load_dispatch_types( @{ $self->preload_dispatch_types } );
 434     @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
 435
 436     # Create the root node of the tree
 437     my $container =
 438       Catalyst::ActionContainer->new( { part => '/', actions => {} } );
 439     $self->tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
 440
 441     foreach my $comp ( values %{ $c->components } ) {
 442         $comp->register_actions($c) if $comp->can('register_actions');
 443     }
 444
 445     $self->do_load_dispatch_types( @{ $self->postload_dispatch_types } );
 446
 447     return unless $c->debug;
 448
 449     my $privates = Text::SimpleTable->new(
 450         [ 20, 'Private' ],
 451         [ 38, 'Class' ],
 452         [ 12, 'Method' ]
 453     );
 454
 455     my $has_private = 0;
 456     my $walker = sub {
 457         my ( $walker, $parent, $prefix ) = @_;
 458         $prefix .= $parent->getNodeValue || '';
 459         $prefix .= '/' unless $prefix =~ /\/$/;
 460         my $node = $parent->getNodeValue->actions;
 461
 462         for my $action ( keys %{$node} ) {
 463             my $action_obj = $node->{$action};
 464             next
 465               if ( ( $action =~ /^_.*/ )
 466                 && ( !$c->config->{show_internal_actions} ) );
 467             $privates->row( "$prefix$action", $action_obj->class, $action );
 468             $has_private = 1;
 469         }
 470
 471         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 472     };
 473
 474     $walker->( $walker, $self->tree, '' );
 475     $c->log->debug( "Loaded Private actions:\n" . $privates->draw )
 476       if ($has_private);
 477
 478     # List all public actions
 479     $_->list($c) for @{ $self->dispatch_types };
 480 }
 481
 482 sub do_load_dispatch_types {
 483     my ( $self, @types ) = @_;
 484
 485     my @loaded;
 486
 487     # Preload action types
 488     for my $type (@types) {
 489         my $class =
 490           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 491         eval "require $class";
 492         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 493           if $@;
 494         push @{ $self->dispatch_types }, $class->new;
 495
 496         push @loaded, $class;
 497     }
 498
 499         return @loaded;
 500 }
 501
 502 =head1 AUTHOR
 503
 504 Sebastian Riedel, C<sri@cpan.org>
 505 Matt S Trout, C<mst@shadowcatsystems.co.uk>
 506
 507 =head1 COPYRIGHT
 508
 509 This program is free software, you can redistribute it and/or modify it under
 510 the same terms as Perl itself.
 511
 512 =cut
 513
 514 1;