lib/Catalyst/Dispatcher.pm

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