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 container_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     $obj->container_hash( {} );
  64
  65     # Create the root node of the tree
  66     my $container =
  67       Catalyst::ActionContainer->new( { part => '/', actions => {} } );
  68     $obj->tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
  69
  70     return $obj;
  71 }
  72
  73 =head2 $self->preload_dispatch_types
  74
  75 An arrayref of pre-loaded dispatchtype classes
  76
  77 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  78 To use a custom class outside the regular C<Catalyst> namespace, prefix
  79 it with a C<+>, like so:
  80
  81     +My::Dispatch::Type
  82
  83 =head2 $self->postload_dispatch_types
  84
  85 An arrayref of post-loaded dispatchtype classes
  86
  87 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  88 To use a custom class outside the regular C<Catalyst> namespace, prefix
  89 it with a C<+>, like so:
  90
  91     +My::Dispatch::Type
  92
  93 =head2 $self->detach( $c, $command [, \@arguments ] )
  94
  95 Documented in L<Catalyst>
  96
  97 =cut
  98
  99 sub detach {
 100     my ( $self, $c, $command, @args ) = @_;
 101     $c->forward( $command, @args ) if $command;
 102     die $Catalyst::DETACH;
 103 }
 104
 105 =head2 $self->dispatch($c)
 106
 107 Delegate the dispatch to the action that matched the url, or return a
 108 message about unknown resource
 109
 110
 111 =cut
 112
 113 sub dispatch {
 114     my ( $self, $c ) = @_;
 115     if ( $c->action ) {
 116         $c->forward( join( '/', '', $c->action->namespace, '_DISPATCH' ) );
 117     }
 118
 119     else {
 120         my $path  = $c->req->path;
 121         my $error = $path
 122           ? qq/Unknown resource "$path"/
 123           : "No default action defined";
 124         $c->log->error($error) if $c->debug;
 125         $c->error($error);
 126     }
 127 }
 128
 129 =head2 $self->forward( $c, $command [, \@arguments ] )
 130
 131 Documented in L<Catalyst>
 132
 133 =cut
 134
 135 sub forward {
 136     my ( $self, $c, $command ) = splice( @_, 0, 3 );
 137
 138     unless ($command) {
 139         $c->log->debug('Nothing to forward to') if $c->debug;
 140         return 0;
 141     }
 142
 143     my $args = [ @{ $c->request->arguments } ];
 144
 145     @$args = @{ pop @_ } if ( ref( $_[-1] ) eq 'ARRAY' );
 146
 147     my $action = $self->_invoke_as_path( $c, $command, $args )
 148       || $self->_invoke_as_component( $c, $command, shift );
 149
 150     unless ($action) {
 151         my $error =
 152             qq/Couldn't forward to command "$command": /
 153           . qq/Invalid action or component./;
 154         $c->error($error);
 155         $c->log->debug($error) if $c->debug;
 156         return 0;
 157     }
 158
 159     #push @$args, @_;
 160
 161     local $c->request->{arguments} = $args;
 162     $action->execute($c);
 163
 164     return $c->state;
 165 }
 166
 167 sub _action_rel2abs {
 168     my ( $self, $c, $path ) = @_;
 169
 170     unless ( $path =~ m#^/# ) {
 171         my $namespace = $c->stack->[-1]->namespace;
 172         $path = "$namespace/$path";
 173     }
 174
 175     $path =~ s#^/##;
 176     return $path;
 177 }
 178
 179 sub _invoke_as_path {
 180     my ( $self, $c, $rel_path, $args ) = @_;
 181
 182     return if ref $rel_path;    # it must be a string
 183
 184     my $path = $self->_action_rel2abs( $c, $rel_path );
 185
 186     my ( $tail, @extra_args );
 187     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 188     {                           # allow $path to be empty
 189         if ( my $action = $c->get_action( $tail, $path ) ) {
 190             push @$args, @extra_args;
 191             return $action;
 192         }
 193         else {
 194             return
 195               unless $path
 196               ; # if a match on the global namespace failed then the whole lookup failed
 197         }
 198
 199         unshift @extra_args, $tail;
 200     }
 201 }
 202
 203 sub _find_component_class {
 204     my ( $self, $c, $component ) = @_;
 205
 206     return ref($component)
 207       || ref( $c->component($component) )
 208       || $c->component($component);
 209 }
 210
 211 sub _invoke_as_component {
 212     my ( $self, $c, $component, $method ) = @_;
 213
 214     my $class = $self->_find_component_class( $c, $component ) || return 0;
 215     $method ||= "process";
 216
 217     if ( my $code = $class->can($method) ) {
 218         return $self->method_action_class->new(
 219             {
 220                 name      => $method,
 221                 code      => $code,
 222                 reverse   => "$class->$method",
 223                 class     => $class,
 224                 namespace => Catalyst::Utils::class2prefix(
 225                     $class, $c->config->{case_sensitive}
 226                 ),
 227             }
 228         );
 229     }
 230     else {
 231         my $error =
 232           qq/Couldn't forward to "$class". Does not implement "$method"/;
 233         $c->error($error);
 234         $c->log->debug($error)
 235           if $c->debug;
 236         return 0;
 237     }
 238 }
 239
 240 =head2 $self->prepare_action($c)
 241
 242 Find an dispatch type that matches $c->req->path, and set args from it.
 243
 244 =cut
 245
 246 sub prepare_action {
 247     my ( $self, $c ) = @_;
 248     my $path = $c->req->path;
 249     my @path = split /\//, $c->req->path;
 250     $c->req->args( \my @args );
 251
 252     unshift( @path, '' );    # Root action
 253
 254   DESCEND: while (@path) {
 255         $path = join '/', @path;
 256         $path =~ s#^/##;
 257
 258         $path = '' if $path eq '/';    # Root action
 259
 260         # Check out dispatch types to see if any will handle the path at
 261         # this level
 262
 263         foreach my $type ( @{ $self->dispatch_types } ) {
 264             last DESCEND if $type->match( $c, $path );
 265         }
 266
 267         # If not, move the last part path to args
 268         my $arg = pop(@path);
 269         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 270         unshift @args, $arg;
 271     }
 272
 273     $c->log->debug( 'Path is "' . $c->req->match . '"' )
 274       if ( $c->debug && $c->req->match );
 275
 276     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 277       if ( $c->debug && @args );
 278 }
 279
 280 =head2 $self->get_action( $action, $namespace )
 281
 282 returns a named action from a given namespace.
 283
 284 =cut
 285
 286 sub get_action {
 287     my ( $self, $name, $namespace ) = @_;
 288     return unless $name;
 289
 290     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 291
 292     return $self->action_hash->{"$namespace/$name"};
 293 }
 294
 295 =head2 $self->get_action_by_path( $path );
 296
 297 Returns the named action by its full path.
 298
 299 =cut
 300
 301 sub get_action_by_path {
 302     my ( $self, $path ) = @_;
 303     $path = "/$path" unless $path =~ /\//;
 304     $self->action_hash->{$path};
 305 }
 306
 307 =head2 $self->get_actions( $c, $action, $namespace )
 308
 309 =cut
 310
 311 sub get_actions {
 312     my ( $self, $c, $action, $namespace ) = @_;
 313     return [] unless $action;
 314
 315     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 316
 317     my @match = $self->get_containers($namespace);
 318
 319     return map { $_->get_action($action) } @match;
 320 }
 321
 322 =head2 $self->get_containers( $namespace )
 323
 324 Return all the action containers for a given namespace, inclusive
 325
 326 =cut
 327
 328 sub get_containers {
 329     my ( $self, $namespace ) = @_;
 330     $namespace ||= '';
 331     $namespace = '' if $namespace eq '/';
 332
 333     my @containers;
 334
 335     if ( length $namespace ) {
 336         do {
 337             push @containers, $self->container_hash->{$namespace};
 338         } while ( $namespace =~ s#/[^/]+$## );
 339     }
 340
 341     return reverse grep { defined } @containers, $self->container_hash->{''};
 342
 343     my @parts = split '/', $namespace;
 344 }
 345
 346 =head2 $self->register( $c, $action )
 347
 348 Make sure all required dispatch types for this action are loaded, then
 349 pass the action to our dispatch types so they can register it if required.
 350 Also, set up the tree with the action containers.
 351
 352 =cut
 353
 354 sub register {
 355     my ( $self, $c, $action ) = @_;
 356
 357     my $registered = $self->registered_dispatch_types;
 358
 359     my $priv = 0;
 360     foreach my $key ( keys %{ $action->attributes } ) {
 361         $priv++ if $key eq 'Private';
 362         my $class = "Catalyst::DispatchType::$key";
 363         unless ( $registered->{$class} ) {
 364             eval "require $class";
 365             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 366             $registered->{$class} = 1;
 367         }
 368     }
 369
 370     # Pass the action to our dispatch types so they can register it if reqd.
 371     my $reg = 0;
 372     foreach my $type ( @{ $self->dispatch_types } ) {
 373         $reg++ if $type->register( $c, $action );
 374     }
 375
 376     return unless $reg + $priv;
 377
 378     my $namespace = $action->namespace;
 379     my $name      = $action->name;
 380
 381     my $container = $self->find_or_create_action_container($namespace);
 382
 383     # Set the method value
 384     $container->add_action($action);
 385
 386     $self->action_hash->{"$namespace/$name"} = $action;
 387     $self->container_hash->{$namespace} = $container;
 388 }
 389
 390 sub find_or_create_action_container {
 391     my ( $self, $namespace ) = @_;
 392
 393     my $tree ||= $self->tree;
 394
 395     return $tree->getNodeValue unless $namespace;
 396
 397     my @namespace = split '/', $namespace;
 398     return $self->_find_or_create_namespace_node( $tree, @namespace )
 399       ->getNodeValue;
 400 }
 401
 402 sub _find_or_create_namespace_node {
 403     my ( $self, $parent, $part, @namespace ) = @_;
 404
 405     return $parent unless $part;
 406
 407     my $child =
 408       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 409
 410     unless ($child) {
 411         my $container = Catalyst::ActionContainer->new($part);
 412         $parent->addChild( $child = Tree::Simple->new($container) );
 413     }
 414
 415     $self->_find_or_create_namespace_node( $child, @namespace );
 416 }
 417
 418 =head2 $self->setup_actions( $class, $context )
 419
 420
 421 =cut
 422
 423 sub setup_actions {
 424     my ( $self, $c ) = @_;
 425
 426     $self->dispatch_types( [] );
 427     $self->registered_dispatch_types( {} );
 428     $self->method_action_class('Catalyst::Action');
 429     $self->action_container_class('Catalyst::ActionContainer');
 430
 431     my @classes =
 432       $self->do_load_dispatch_types( @{ $self->preload_dispatch_types } );
 433     @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
 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         [ 36, '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;