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