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 { Class::MOP::load_class($class) };
 399             push( @{ $self->_dispatch_types }, $class->new ) unless $@;
 400             $registered->{$class} = 1;
 401         }
 402     }
 403
 404     # Pass the action to our dispatch types so they can register it if reqd.
 405     foreach my $type ( @{ $self->_dispatch_types } ) {
 406         $type->register( $c, $action );
 407     }
 408
 409     my $namespace = $action->namespace;
 410     my $name      = $action->name;
 411
 412     my $container = $self->_find_or_create_action_container($namespace);
 413
 414     # Set the method value
 415     $container->add_action($action);
 416
 417     $self->_action_hash->{"$namespace/$name"} = $action;
 418     $self->_container_hash->{$namespace} = $container;
 419 }
 420
 421 sub _find_or_create_action_container {
 422     my ( $self, $namespace ) = @_;
 423
 424     my $tree ||= $self->_tree;
 425
 426     return $tree->getNodeValue unless $namespace;
 427
 428     my @namespace = split '/', $namespace;
 429     return $self->_find_or_create_namespace_node( $tree, @namespace )
 430       ->getNodeValue;
 431 }
 432
 433 sub _find_or_create_namespace_node {
 434     my ( $self, $parent, $part, @namespace ) = @_;
 435
 436     return $parent unless $part;
 437
 438     my $child =
 439       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 440
 441     unless ($child) {
 442         my $container = Catalyst::ActionContainer->new($part);
 443         $parent->addChild( $child = Tree::Simple->new($container) );
 444     }
 445
 446     $self->_find_or_create_namespace_node( $child, @namespace );
 447 }
 448
 449 =head2 $self->setup_actions( $class, $context )
 450
 451
 452 =cut
 453
 454 sub setup_actions {
 455     my ( $self, $c ) = @_;
 456
 457     $self->_dispatch_types( [] );
 458     $self->_registered_dispatch_types( {} );
 459     $self->_method_action_class('Catalyst::Action');
 460     $self->_action_container_class('Catalyst::ActionContainer');
 461
 462     my @classes =
 463       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 464     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 465
 466     foreach my $comp ( values %{ $c->components } ) {
 467         $comp->register_actions($c) if $comp->can('register_actions');
 468     }
 469
 470     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 471
 472     return unless $c->debug;
 473
 474     my $privates = Text::SimpleTable->new(
 475         [ 20, 'Private' ],
 476         [ 36, 'Class' ],
 477         [ 12, 'Method' ]
 478     );
 479
 480     my $has_private = 0;
 481     my $walker = sub {
 482         my ( $walker, $parent, $prefix ) = @_;
 483         $prefix .= $parent->getNodeValue || '';
 484         $prefix .= '/' unless $prefix =~ /\/$/;
 485         my $node = $parent->getNodeValue->actions;
 486
 487         for my $action ( keys %{$node} ) {
 488             my $action_obj = $node->{$action};
 489             next
 490               if ( ( $action =~ /^_.*/ )
 491                 && ( !$c->config->{show_internal_actions} ) );
 492             $privates->row( "$prefix$action", $action_obj->class, $action );
 493             $has_private = 1;
 494         }
 495
 496         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 497     };
 498
 499     $walker->( $walker, $self->_tree, '' );
 500     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 501       if $has_private;
 502
 503     # List all public actions
 504     $_->list($c) for @{ $self->_dispatch_types };
 505 }
 506
 507 sub _load_dispatch_types {
 508     my ( $self, @types ) = @_;
 509
 510     my @loaded;
 511
 512     # Preload action types
 513     for my $type (@types) {
 514         my $class =
 515           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 516         eval { Class::MOP::load_class($class) };
 517         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 518           if $@;
 519         push @{ $self->_dispatch_types }, $class->new;
 520
 521         push @loaded, $class;
 522     }
 523
 524     return @loaded;
 525 }
 526
 527 =head2 meta
 528
 529 Provided by Moose
 530
 531 =head1 AUTHOR
 532
 533 Sebastian Riedel, C<sri@cpan.org>
 534 Matt S Trout, C<mst@shadowcatsystems.co.uk>
 535
 536 =head1 COPYRIGHT
 537
 538 This program is free software, you can redistribute it and/or modify it under
 539 the same terms as Perl itself.
 540
 541 =cut
 542
 543 1;