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