lib/Catalyst/Dispatcher.pm

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