lib/Catalyst/Dispatcher.pm

   1 package Catalyst::Dispatcher;
   2
   3 use Moose;
   4 use Class::MOP;
   5 with 'MooseX::Emulate::Class::Accessor::Fast';
   6
   7 use Catalyst::Exception;
   8 use Catalyst::Utils;
   9 use Catalyst::Action;
  10 use Catalyst::ActionContainer;
  11 use Catalyst::DispatchType::Default;
  12 use Catalyst::DispatchType::Index;
  13 use Catalyst::Utils;
  14 use Text::SimpleTable;
  15 use Tree::Simple;
  16 use Tree::Simple::Visitor::FindByPath;
  17 use Scalar::Util ();
  18
  19 # Refactoring note:
  20 # do these belong as package vars or should we build these via a builder method?
  21 # See Catalyst-Plugin-Server for them being added to, which should be much less ugly.
  22
  23 # Preload these action types
  24 our @PRELOAD = qw/Index Path Regex/;
  25
  26 # Postload these action types
  27 our @POSTLOAD = qw/Default/;
  28
  29 # Note - see back-compat methods at end of file.
  30 has _tree => (is => 'rw');
  31 has _dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1);
  32 has _registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1);
  33 has _method_action_class => (is => 'rw', default => 'Catalyst::Action');
  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 has preload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@PRELOAD] });
  38 has postload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@POSTLOAD] });
  39
  40 # Wrap accessors so you can assign a list and it will capture a list ref.
  41 around qw/preload_dispatch_types postload_dispatch_types/ => sub {
  42     my $orig = shift;
  43     my $self = shift;
  44     return $self->$orig([@_]) if (scalar @_ && ref $_[0] ne 'ARRAY');
  45     return $self->$orig(@_);
  46 };
  47
  48 no Moose;
  49
  50 =head1 NAME
  51
  52 Catalyst::Dispatcher - The Catalyst Dispatcher
  53
  54 =head1 SYNOPSIS
  55
  56 See L<Catalyst>.
  57
  58 =head1 DESCRIPTION
  59
  60 This is the class that maps public urls to actions in your Catalyst
  61 application based on the attributes you set.
  62
  63 =head1 METHODS
  64
  65 =head2 new
  66
  67 Construct a new dispatcher.
  68
  69 =cut
  70
  71 sub BUILD {
  72   my ($self, $params) = @_;
  73
  74   my $container =
  75     Catalyst::ActionContainer->new( { part => '/', actions => {} } );
  76
  77   $self->_tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
  78 }
  79
  80 =head2 $self->preload_dispatch_types
  81
  82 An arrayref of pre-loaded dispatchtype classes
  83
  84 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  85 To use a custom class outside the regular C<Catalyst> namespace, prefix
  86 it with a C<+>, like so:
  87
  88     +My::Dispatch::Type
  89
  90 =head2 $self->postload_dispatch_types
  91
  92 An arrayref of post-loaded dispatchtype classes
  93
  94 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  95 To use a custom class outside the regular C<Catalyst> namespace, prefix
  96 it with a C<+>, like so:
  97
  98     +My::Dispatch::Type
  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 ( my $action = $c->action ) {
 111         $c->forward( join( '/', '', $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 # $self->_command2action( $c, $command [, \@arguments ] )
 125 # Search for an action, from the command and returns C<($action, $args)> on
 126 # success. Returns C<(0)> on error.
 127
 128 sub _command2action {
 129     my ( $self, $c, $command, @extra_params ) = @_;
 130
 131     unless ($command) {
 132         $c->log->debug('Nothing to go to') if $c->debug;
 133         return 0;
 134     }
 135
 136     my @args;
 137
 138     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
 139         @args = @{ pop @extra_params }
 140     } else {
 141         # this is a copy, it may take some abuse from
 142         # ->_invoke_as_path if the path had trailing parts
 143         @args = @{ $c->request->arguments };
 144     }
 145
 146     my $action;
 147
 148     # go to a string path ("/foo/bar/gorch")
 149     # or action object
 150     if (blessed($command) && $command->isa('Catalyst::Action')) {
 151         $action = $command;
 152     }
 153     else {
 154         $action = $self->_invoke_as_path( $c, "$command", \@args );
 155     }
 156
 157     # go to a component ( "MyApp::*::Foo" or $c->component("...")
 158     # - 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     return $action, \@args;
 165 }
 166
 167 =head2 $self->visit( $c, $command [, \@arguments ] )
 168
 169 Documented in L<Catalyst>
 170
 171 =cut
 172
 173 sub visit {
 174     my $self = shift;
 175     $self->_do_visit('visit', @_);
 176 }
 177
 178 sub _do_visit {
 179     my $self = shift;
 180     my $opname = shift;
 181     my ( $c, $command ) = @_;
 182     my ( $action, $args ) = $self->_command2action(@_);
 183     my $error = qq/Couldn't $opname("$command"): /;
 184
 185     if (!$action) {
 186         $error .= qq/Couldn't $opname to command "$command": /
 187                  .qq/Invalid action or component./;
 188     }
 189     elsif (!defined $action->namespace) {
 190         $error .= qq/Action has no namespace: cannot $opname() to a plain /
 191                  .qq/method or component, must be a :Action or some sort./
 192     }
 193     elsif (!$action->class->can('_DISPATCH')) {
 194         $error .= qq/Action cannot _DISPATCH. /
 195                  .qq/Did you try to $opname() a non-controller action?/;
 196     }
 197     else {
 198         $error = q();
 199     }
 200
 201     if($error) {
 202         $c->error($error);
 203         $c->log->debug($error) if $c->debug;
 204         return 0;
 205     }
 206
 207     $action = $self->expand_action($action);
 208
 209     local $c->request->{arguments} = $args;
 210     local $c->{namespace} = $action->{'namespace'};
 211     local $c->{action} = $action;
 212
 213     $self->dispatch($c);
 214 }
 215
 216 =head2 $self->go( $c, $command [, \@arguments ] )
 217
 218 Documented in L<Catalyst>
 219
 220 =cut
 221
 222 sub go {
 223     my $self = shift;
 224     $self->_do_visit('go', @_);
 225     die $Catalyst::GO;
 226 }
 227
 228 =head2 $self->forward( $c, $command [, \@arguments ] )
 229
 230 Documented in L<Catalyst>
 231
 232 =cut
 233
 234 sub forward {
 235     my $self = shift;
 236     $self->_do_forward(forward => @_);
 237 }
 238
 239 sub _do_forward {
 240     my $self = shift;
 241     my $opname = shift;
 242     my ( $c, $command ) = @_;
 243     my ( $action, $args ) = $self->_command2action(@_);
 244
 245     if (!$action) {
 246         my $error .= qq/Couldn't $opname to command "$command": /
 247                     .qq/Invalid action or component./;
 248         $c->error($error);
 249         $c->log->debug($error) if $c->debug;
 250         return 0;
 251     }
 252
 253     no warnings 'recursion';
 254
 255     local $c->request->{arguments} = $args;
 256     $action->dispatch( $c );
 257
 258     return $c->state;
 259 }
 260
 261 =head2 $self->detach( $c, $command [, \@arguments ] )
 262
 263 Documented in L<Catalyst>
 264
 265 =cut
 266
 267 sub detach {
 268     my ( $self, $c, $command, @args ) = @_;
 269     $self->_do_forward(detach => $c, $command, @args ) if $command;
 270     die $Catalyst::DETACH;
 271 }
 272
 273 sub _action_rel2abs {
 274     my ( $self, $c, $path ) = @_;
 275
 276     unless ( $path =~ m#^/# ) {
 277         my $namespace = $c->stack->[-1]->namespace;
 278         $path = "$namespace/$path";
 279     }
 280
 281     $path =~ s#^/##;
 282     return $path;
 283 }
 284
 285 sub _invoke_as_path {
 286     my ( $self, $c, $rel_path, $args ) = @_;
 287
 288     my $path = $self->_action_rel2abs( $c, $rel_path );
 289
 290     my ( $tail, @extra_args );
 291     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 292     {                           # allow $path to be empty
 293         if ( my $action = $c->get_action( $tail, $path ) ) {
 294             push @$args, @extra_args;
 295             return $action;
 296         }
 297         else {
 298             return
 299               unless $path
 300               ; # if a match on the global namespace failed then the whole lookup failed
 301         }
 302
 303         unshift @extra_args, $tail;
 304     }
 305 }
 306
 307 sub _find_component_class {
 308     my ( $self, $c, $component ) = @_;
 309
 310     return ref($component)
 311       || ref( $c->component($component) )
 312       || $c->component($component);
 313 }
 314
 315 sub _invoke_as_component {
 316     my ( $self, $c, $component, $method ) = @_;
 317
 318     my $class = $self->_find_component_class( $c, $component ) || return 0;
 319
 320     if ( my $code = $class->can($method) ) {
 321         return $self->_method_action_class->new(
 322             {
 323                 name      => $method,
 324                 code      => $code,
 325                 reverse   => "$class->$method",
 326                 class     => $class,
 327                 namespace => Catalyst::Utils::class2prefix(
 328                     $class, $c->config->{case_sensitive}
 329                 ),
 330             }
 331         );
 332     }
 333     else {
 334         my $error =
 335           qq/Couldn't forward to "$class". Does not implement "$method"/;
 336         $c->error($error);
 337         $c->log->debug($error)
 338           if $c->debug;
 339         return 0;
 340     }
 341 }
 342
 343 =head2 $self->prepare_action($c)
 344
 345 Find an dispatch type that matches $c->req->path, and set args from it.
 346
 347 =cut
 348
 349 sub prepare_action {
 350     my ( $self, $c ) = @_;
 351     my $req = $c->req;
 352     my $path = $req->path;
 353     my @path = split /\//, $req->path;
 354     $req->args( \my @args );
 355
 356     unshift( @path, '' );    # Root action
 357
 358   DESCEND: while (@path) {
 359         $path = join '/', @path;
 360         $path =~ s#^/##;
 361
 362         $path = '' if $path eq '/';    # Root action
 363
 364         # Check out dispatch types to see if any will handle the path at
 365         # this level
 366
 367         foreach my $type ( @{ $self->_dispatch_types } ) {
 368             last DESCEND if $type->match( $c, $path );
 369         }
 370
 371         # If not, move the last part path to args
 372         my $arg = pop(@path);
 373         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 374         unshift @args, $arg;
 375     }
 376
 377     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 378
 379     $c->log->debug( 'Path is "' . $req->match . '"' )
 380       if ( $c->debug && defined $req->match && length $req->match );
 381
 382     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 383       if ( $c->debug && @args );
 384 }
 385
 386 =head2 $self->get_action( $action, $namespace )
 387
 388 returns a named action from a given namespace.
 389
 390 =cut
 391
 392 sub get_action {
 393     my ( $self, $name, $namespace ) = @_;
 394     return unless $name;
 395
 396     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 397
 398     return $self->_action_hash->{"${namespace}/${name}"};
 399 }
 400
 401 =head2 $self->get_action_by_path( $path );
 402
 403 Returns the named action by its full path.
 404
 405 =cut
 406
 407 sub get_action_by_path {
 408     my ( $self, $path ) = @_;
 409     $path =~ s/^\///;
 410     $path = "/$path" unless $path =~ /\//;
 411     $self->_action_hash->{$path};
 412 }
 413
 414 =head2 $self->get_actions( $c, $action, $namespace )
 415
 416 =cut
 417
 418 sub get_actions {
 419     my ( $self, $c, $action, $namespace ) = @_;
 420     return [] unless $action;
 421
 422     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 423
 424     my @match = $self->get_containers($namespace);
 425
 426     return map { $_->get_action($action) } @match;
 427 }
 428
 429 =head2 $self->get_containers( $namespace )
 430
 431 Return all the action containers for a given namespace, inclusive
 432
 433 =cut
 434
 435 sub get_containers {
 436     my ( $self, $namespace ) = @_;
 437     $namespace ||= '';
 438     $namespace = '' if $namespace eq '/';
 439
 440     my @containers;
 441
 442     if ( length $namespace ) {
 443         do {
 444             push @containers, $self->_container_hash->{$namespace};
 445         } while ( $namespace =~ s#/[^/]+$## );
 446     }
 447
 448     return reverse grep { defined } @containers, $self->_container_hash->{''};
 449
 450     #return (split '/', $namespace); # isnt this more clear?
 451     my @parts = split '/', $namespace;
 452 }
 453
 454 =head2 $self->uri_for_action($action, \@captures)
 455
 456 Takes a Catalyst::Action object and action parameters and returns a URI
 457 part such that if $c->req->path were this URI part, this action would be
 458 dispatched to with $c->req->captures set to the supplied arrayref.
 459
 460 If the action object is not available for external dispatch or the dispatcher
 461 cannot determine an appropriate URI, this method will return undef.
 462
 463 =cut
 464
 465 sub uri_for_action {
 466     my ( $self, $action, $captures) = @_;
 467     $captures ||= [];
 468     foreach my $dispatch_type ( @{ $self->_dispatch_types } ) {
 469         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 470         return( $uri eq '' ? '/' : $uri )
 471             if defined($uri);
 472     }
 473     return undef;
 474 }
 475
 476 =head2 expand_action
 477
 478 expand an action into a full representation of the dispatch.
 479 mostly useful for chained, other actions will just return a
 480 single action.
 481
 482 =cut
 483
 484 sub expand_action {
 485     my ($self, $action) = @_;
 486
 487     foreach my $dispatch_type (@{ $self->_dispatch_types }) {
 488         my $expanded = $dispatch_type->expand_action($action);
 489         return $expanded if $expanded;
 490     }
 491
 492     return $action;
 493 }
 494
 495 =head2 $self->register( $c, $action )
 496
 497 Make sure all required dispatch types for this action are loaded, then
 498 pass the action to our dispatch types so they can register it if required.
 499 Also, set up the tree with the action containers.
 500
 501 =cut
 502
 503 sub register {
 504     my ( $self, $c, $action ) = @_;
 505
 506     my $registered = $self->_registered_dispatch_types;
 507
 508     #my $priv = 0; #seems to be unused
 509     foreach my $key ( keys %{ $action->attributes } ) {
 510         next if $key eq 'Private';
 511         my $class = "Catalyst::DispatchType::$key";
 512         unless ( $registered->{$class} ) {
 513             # FIXME - Some error checking and re-throwing needed here, as
 514             #         we eat exceptions loading dispatch types.
 515             eval { Class::MOP::load_class($class) };
 516             push( @{ $self->_dispatch_types }, $class->new ) unless $@;
 517             $registered->{$class} = 1;
 518         }
 519     }
 520
 521     # Pass the action to our dispatch types so they can register it if reqd.
 522     foreach my $type ( @{ $self->_dispatch_types } ) {
 523         $type->register( $c, $action );
 524     }
 525
 526     my $namespace = $action->namespace;
 527     my $name      = $action->name;
 528
 529     my $container = $self->_find_or_create_action_container($namespace);
 530
 531     # Set the method value
 532     $container->add_action($action);
 533
 534     $self->_action_hash->{"$namespace/$name"} = $action;
 535     $self->_container_hash->{$namespace} = $container;
 536 }
 537
 538 sub _find_or_create_action_container {
 539     my ( $self, $namespace ) = @_;
 540
 541     my $tree ||= $self->_tree;
 542
 543     return $tree->getNodeValue unless $namespace;
 544
 545     my @namespace = split '/', $namespace;
 546     return $self->_find_or_create_namespace_node( $tree, @namespace )
 547       ->getNodeValue;
 548 }
 549
 550 sub _find_or_create_namespace_node {
 551     my ( $self, $parent, $part, @namespace ) = @_;
 552
 553     return $parent unless $part;
 554
 555     my $child =
 556       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 557
 558     unless ($child) {
 559         my $container = Catalyst::ActionContainer->new($part);
 560         $parent->addChild( $child = Tree::Simple->new($container) );
 561     }
 562
 563     $self->_find_or_create_namespace_node( $child, @namespace );
 564 }
 565
 566 =head2 $self->setup_actions( $class, $context )
 567
 568
 569 =cut
 570
 571 sub setup_actions {
 572     my ( $self, $c ) = @_;
 573
 574
 575     my @classes =
 576       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 577     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 578
 579     foreach my $comp ( values %{ $c->components } ) {
 580         $comp->register_actions($c) if $comp->can('register_actions');
 581     }
 582
 583     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 584
 585     return unless $c->debug;
 586
 587     my $column_width = Catalyst::Utils::term_width() - 20 - 36 - 12;
 588     my $privates = Text::SimpleTable->new(
 589         [ 20, 'Private' ], [ 36, 'Class' ], [ $column_width, 'Method' ]
 590     );
 591
 592     my $has_private = 0;
 593     my $walker = sub {
 594         my ( $walker, $parent, $prefix ) = @_;
 595         $prefix .= $parent->getNodeValue || '';
 596         $prefix .= '/' unless $prefix =~ /\/$/;
 597         my $node = $parent->getNodeValue->actions;
 598
 599         for my $action ( keys %{$node} ) {
 600             my $action_obj = $node->{$action};
 601             next
 602               if ( ( $action =~ /^_.*/ )
 603                 && ( !$c->config->{show_internal_actions} ) );
 604             $privates->row( "$prefix$action", $action_obj->class, $action );
 605             $has_private = 1;
 606         }
 607
 608         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 609     };
 610
 611     $walker->( $walker, $self->_tree, '' );
 612     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 613       if $has_private;
 614
 615     # List all public actions
 616     $_->list($c) for @{ $self->_dispatch_types };
 617 }
 618
 619 sub _load_dispatch_types {
 620     my ( $self, @types ) = @_;
 621
 622     my @loaded;
 623
 624     # Preload action types
 625     for my $type (@types) {
 626         my $class =
 627           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 628
 629         eval { Class::MOP::load_class($class) };
 630         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 631           if $@;
 632         push @{ $self->_dispatch_types }, $class->new;
 633
 634         push @loaded, $class;
 635     }
 636
 637     return @loaded;
 638 }
 639
 640 use Moose;
 641
 642 # 5.70 backwards compatibility hacks.
 643
 644 # Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
 645 # need the methods here which *should* be private..
 646
 647 # However we can't really take them away until there is a sane API for
 648 # building actions and configuring / introspecting the dispatcher.
 649 # In 5.90, we should build that infrastructure, port the plugins which
 650 # use it, and then take the crap below away.
 651 # See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
 652
 653 # Alias _method_name to method_name, add a before modifier to warn..
 654 foreach my $public_method_name (qw/
 655         tree
 656         dispatch_types
 657         registered_dispatch_types
 658         method_action_class
 659         action_hash
 660         container_hash
 661     /) {
 662     my $private_method_name = '_' . $public_method_name;
 663     my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 664     $meta->add_method($public_method_name, $meta->get_method($private_method_name));
 665     {
 666         my %package_hash; # Only warn once per method, per package. These are infrequent enough that
 667                           # I haven't provided a way to disable them, patches welcome.
 668         $meta->add_before_method_modifier($public_method_name, sub {
 669             my $class = blessed(shift);
 670             $package_hash{$class}++ || do {
 671                 warn("Class $class is calling the deprecated method Catalyst::Dispatcher::$public_method_name,\n"
 672                     . "this will be removed in Catalyst 5.9X");
 673             };
 674         });
 675     }
 676 }
 677 # End 5.70 backwards compatibility hacks.
 678
 679 no Moose;
 680 __PACKAGE__->meta->make_immutable;
 681
 682 =head2 meta
 683
 684 Provided by Moose
 685
 686 =head1 AUTHORS
 687
 688 Catalyst Contributors, see Catalyst.pm
 689
 690 =head1 COPYRIGHT
 691
 692 This program is free software, you can redistribute it and/or modify it under
 693 the same terms as Perl itself.
 694
 695 =cut
 696
 697 1;