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