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
  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 (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     local $c->request->{arguments} = $args;
 255     $action->dispatch( $c );
 256
 257     return $c->state;
 258 }
 259
 260 =head2 $self->detach( $c, $command [, \@arguments ] )
 261
 262 Documented in L<Catalyst>
 263
 264 =cut
 265
 266 sub detach {
 267     my ( $self, $c, $command, @args ) = @_;
 268     $self->_do_forward(detach => $c, $command, @args ) if $command;
 269     die $Catalyst::DETACH;
 270 }
 271
 272 sub _action_rel2abs {
 273     my ( $self, $c, $path ) = @_;
 274
 275     unless ( $path =~ m#^/# ) {
 276         my $namespace = $c->stack->[-1]->namespace;
 277         $path = "$namespace/$path";
 278     }
 279
 280     $path =~ s#^/##;
 281     return $path;
 282 }
 283
 284 sub _invoke_as_path {
 285     my ( $self, $c, $rel_path, $args ) = @_;
 286
 287     my $path = $self->_action_rel2abs( $c, $rel_path );
 288
 289     my ( $tail, @extra_args );
 290     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 291     {                           # allow $path to be empty
 292         if ( my $action = $c->get_action( $tail, $path ) ) {
 293             push @$args, @extra_args;
 294             return $action;
 295         }
 296         else {
 297             return
 298               unless $path
 299               ; # if a match on the global namespace failed then the whole lookup failed
 300         }
 301
 302         unshift @extra_args, $tail;
 303     }
 304 }
 305
 306 sub _find_component_class {
 307     my ( $self, $c, $component ) = @_;
 308
 309     return ref($component)
 310       || ref( $c->component($component) )
 311       || $c->component($component);
 312 }
 313
 314 sub _invoke_as_component {
 315     my ( $self, $c, $component, $method ) = @_;
 316
 317     my $class = $self->_find_component_class( $c, $component ) || return 0;
 318
 319     if ( my $code = $class->can($method) ) {
 320         return $self->_method_action_class->new(
 321             {
 322                 name      => $method,
 323                 code      => $code,
 324                 reverse   => "$class->$method",
 325                 class     => $class,
 326                 namespace => Catalyst::Utils::class2prefix(
 327                     $class, $c->config->{case_sensitive}
 328                 ),
 329             }
 330         );
 331     }
 332     else {
 333         my $error =
 334           qq/Couldn't forward to "$class". Does not implement "$method"/;
 335         $c->error($error);
 336         $c->log->debug($error)
 337           if $c->debug;
 338         return 0;
 339     }
 340 }
 341
 342 =head2 $self->prepare_action($c)
 343
 344 Find an dispatch type that matches $c->req->path, and set args from it.
 345
 346 =cut
 347
 348 sub prepare_action {
 349     my ( $self, $c ) = @_;
 350     my $req = $c->req;
 351     my $path = $req->path;
 352     my @path = split /\//, $req->path;
 353     $req->args( \my @args );
 354
 355     unshift( @path, '' );    # Root action
 356
 357   DESCEND: while (@path) {
 358         $path = join '/', @path;
 359         $path =~ s#^/##;
 360
 361         $path = '' if $path eq '/';    # Root action
 362
 363         # Check out dispatch types to see if any will handle the path at
 364         # this level
 365
 366         foreach my $type ( @{ $self->_dispatch_types } ) {
 367             last DESCEND if $type->match( $c, $path );
 368         }
 369
 370         # If not, move the last part path to args
 371         my $arg = pop(@path);
 372         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 373         unshift @args, $arg;
 374     }
 375
 376     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 377
 378     $c->log->debug( 'Path is "' . $req->match . '"' )
 379       if ( $c->debug && defined $req->match && length $req->match );
 380
 381     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 382       if ( $c->debug && @args );
 383 }
 384
 385 =head2 $self->get_action( $action, $namespace )
 386
 387 returns a named action from a given namespace.
 388
 389 =cut
 390
 391 sub get_action {
 392     my ( $self, $name, $namespace ) = @_;
 393     return unless $name;
 394
 395     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 396
 397     return $self->_action_hash->{"${namespace}/${name}"};
 398 }
 399
 400 =head2 $self->get_action_by_path( $path );
 401
 402 Returns the named action by its full path.
 403
 404 =cut
 405
 406 sub get_action_by_path {
 407     my ( $self, $path ) = @_;
 408     $path =~ s/^\///;
 409     $path = "/$path" unless $path =~ /\//;
 410     $self->_action_hash->{$path};
 411 }
 412
 413 =head2 $self->get_actions( $c, $action, $namespace )
 414
 415 =cut
 416
 417 sub get_actions {
 418     my ( $self, $c, $action, $namespace ) = @_;
 419     return [] unless $action;
 420
 421     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 422
 423     my @match = $self->get_containers($namespace);
 424
 425     return map { $_->get_action($action) } @match;
 426 }
 427
 428 =head2 $self->get_containers( $namespace )
 429
 430 Return all the action containers for a given namespace, inclusive
 431
 432 =cut
 433
 434 sub get_containers {
 435     my ( $self, $namespace ) = @_;
 436     $namespace ||= '';
 437     $namespace = '' if $namespace eq '/';
 438
 439     my @containers;
 440
 441     if ( length $namespace ) {
 442         do {
 443             push @containers, $self->_container_hash->{$namespace};
 444         } while ( $namespace =~ s#/[^/]+$## );
 445     }
 446
 447     return reverse grep { defined } @containers, $self->_container_hash->{''};
 448
 449     #return (split '/', $namespace); # isnt this more clear?
 450     my @parts = split '/', $namespace;
 451 }
 452
 453 =head2 $self->uri_for_action($action, \@captures)
 454
 455 Takes a Catalyst::Action object and action parameters and returns a URI
 456 part such that if $c->req->path were this URI part, this action would be
 457 dispatched to with $c->req->captures set to the supplied arrayref.
 458
 459 If the action object is not available for external dispatch or the dispatcher
 460 cannot determine an appropriate URI, this method will return undef.
 461
 462 =cut
 463
 464 sub uri_for_action {
 465     my ( $self, $action, $captures) = @_;
 466     $captures ||= [];
 467     foreach my $dispatch_type ( @{ $self->_dispatch_types } ) {
 468         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 469         return( $uri eq '' ? '/' : $uri )
 470             if defined($uri);
 471     }
 472     return undef;
 473 }
 474
 475 =head2 expand_action
 476
 477 expand an action into a full representation of the dispatch.
 478 mostly useful for chained, other actions will just return a
 479 single action.
 480
 481 =cut
 482
 483 sub expand_action {
 484     my ($self, $action) = @_;
 485
 486     foreach my $dispatch_type (@{ $self->_dispatch_types }) {
 487         my $expanded = $dispatch_type->expand_action($action);
 488         return $expanded if $expanded;
 489     }
 490
 491     return $action;
 492 }
 493
 494 =head2 $self->register( $c, $action )
 495
 496 Make sure all required dispatch types for this action are loaded, then
 497 pass the action to our dispatch types so they can register it if required.
 498 Also, set up the tree with the action containers.
 499
 500 =cut
 501
 502 sub register {
 503     my ( $self, $c, $action ) = @_;
 504
 505     my $registered = $self->_registered_dispatch_types;
 506
 507     #my $priv = 0; #seems to be unused
 508     foreach my $key ( keys %{ $action->attributes } ) {
 509         next if $key eq 'Private';
 510         my $class = "Catalyst::DispatchType::$key";
 511         unless ( $registered->{$class} ) {
 512             # FIXME - Some error checking and re-throwing needed here, as
 513             #         we eat exceptions loading dispatch types.
 514             eval { Class::MOP::load_class($class) };
 515             push( @{ $self->_dispatch_types }, $class->new ) unless $@;
 516             $registered->{$class} = 1;
 517         }
 518     }
 519
 520     # Pass the action to our dispatch types so they can register it if reqd.
 521     foreach my $type ( @{ $self->_dispatch_types } ) {
 522         $type->register( $c, $action );
 523     }
 524
 525     my $namespace = $action->namespace;
 526     my $name      = $action->name;
 527
 528     my $container = $self->_find_or_create_action_container($namespace);
 529
 530     # Set the method value
 531     $container->add_action($action);
 532
 533     $self->_action_hash->{"$namespace/$name"} = $action;
 534     $self->_container_hash->{$namespace} = $container;
 535 }
 536
 537 sub _find_or_create_action_container {
 538     my ( $self, $namespace ) = @_;
 539
 540     my $tree ||= $self->_tree;
 541
 542     return $tree->getNodeValue unless $namespace;
 543
 544     my @namespace = split '/', $namespace;
 545     return $self->_find_or_create_namespace_node( $tree, @namespace )
 546       ->getNodeValue;
 547 }
 548
 549 sub _find_or_create_namespace_node {
 550     my ( $self, $parent, $part, @namespace ) = @_;
 551
 552     return $parent unless $part;
 553
 554     my $child =
 555       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 556
 557     unless ($child) {
 558         my $container = Catalyst::ActionContainer->new($part);
 559         $parent->addChild( $child = Tree::Simple->new($container) );
 560     }
 561
 562     $self->_find_or_create_namespace_node( $child, @namespace );
 563 }
 564
 565 =head2 $self->setup_actions( $class, $context )
 566
 567
 568 =cut
 569
 570 sub setup_actions {
 571     my ( $self, $c ) = @_;
 572
 573
 574     my @classes =
 575       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 576     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 577
 578     foreach my $comp ( values %{ $c->components } ) {
 579         $comp->register_actions($c) if $comp->can('register_actions');
 580     }
 581
 582     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 583
 584     return unless $c->debug;
 585
 586     my $column_width = Catalyst::Utils::term_width() - 20 - 36 - 12;
 587     my $privates = Text::SimpleTable->new(
 588         [ 20, 'Private' ], [ 36, 'Class' ], [ $column_width, 'Method' ]
 589     );
 590
 591     my $has_private = 0;
 592     my $walker = sub {
 593         my ( $walker, $parent, $prefix ) = @_;
 594         $prefix .= $parent->getNodeValue || '';
 595         $prefix .= '/' unless $prefix =~ /\/$/;
 596         my $node = $parent->getNodeValue->actions;
 597
 598         for my $action ( keys %{$node} ) {
 599             my $action_obj = $node->{$action};
 600             next
 601               if ( ( $action =~ /^_.*/ )
 602                 && ( !$c->config->{show_internal_actions} ) );
 603             $privates->row( "$prefix$action", $action_obj->class, $action );
 604             $has_private = 1;
 605         }
 606
 607         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 608     };
 609
 610     $walker->( $walker, $self->_tree, '' );
 611     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 612       if $has_private;
 613
 614     # List all public actions
 615     $_->list($c) for @{ $self->_dispatch_types };
 616 }
 617
 618 sub _load_dispatch_types {
 619     my ( $self, @types ) = @_;
 620
 621     my @loaded;
 622
 623     # Preload action types
 624     for my $type (@types) {
 625         my $class =
 626           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 627
 628         eval { Class::MOP::load_class($class) };
 629         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 630           if $@;
 631         push @{ $self->_dispatch_types }, $class->new;
 632
 633         push @loaded, $class;
 634     }
 635
 636     return @loaded;
 637 }
 638
 639 use Moose;
 640
 641 # 5.70 backwards compatibility hacks.
 642
 643 # Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
 644 # need the methods here which *should* be private..
 645
 646 # However we can't really take them away until there is a sane API for
 647 # building actions and configuring / introspecting the dispatcher.
 648 # In 5.90, we should build that infrastructure, port the plugins which
 649 # use it, and then take the crap below away.
 650 # See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
 651
 652 # Alias _method_name to method_name, add a before modifier to warn..
 653 foreach my $public_method_name (qw/
 654         tree
 655         dispatch_types
 656         registered_dispatch_types
 657         method_action_class
 658         action_hash
 659         container_hash
 660     /) {
 661     my $private_method_name = '_' . $public_method_name;
 662     my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 663     $meta->add_method($public_method_name, $meta->get_method($private_method_name));
 664     {
 665         my %package_hash; # Only warn once per method, per package. These are infrequent enough that
 666                           # I haven't provided a way to disable them, patches welcome.
 667         $meta->add_before_method_modifier($public_method_name, sub {
 668             my $class = blessed(shift);
 669             $package_hash{$class}++ || do {
 670                 warn("Class $class is calling the deprecated method Catalyst::Dispatcher::$public_method_name,\n"
 671                     . "this will be removed in Catalyst 5.9X");
 672             };
 673         });
 674     }
 675 }
 676 # End 5.70 backwards compatibility hacks.
 677
 678 no Moose;
 679 __PACKAGE__->meta->make_immutable;
 680
 681 =head2 meta
 682
 683 Provided by Moose
 684
 685 =head1 AUTHORS
 686
 687 Catalyst Contributors, see Catalyst.pm
 688
 689 =head1 COPYRIGHT
 690
 691 This program is free software, you can redistribute it and/or modify it under
 692 the same terms as Perl itself.
 693
 694 =cut
 695
 696 1;