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