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