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         # Check out dispatch types to see if any will handle the path at
 376         # this level
 377
 378         foreach my $type ( @{ $self->_dispatch_types } ) {
 379             last DESCEND if $type->match( $c, $path );
 380         }
 381
 382         # If not, move the last part path to args
 383         my $arg = pop(@path);
 384         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 385         unshift @args, $arg;
 386     }
 387
 388     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 389
 390     $c->log->debug( 'Path is "' . $req->match . '"' )
 391       if ( $c->debug && defined $req->match && length $req->match );
 392
 393     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 394       if ( $c->debug && @args );
 395 }
 396
 397 =head2 $self->get_action( $action, $namespace )
 398
 399 returns a named action from a given namespace.
 400
 401 =cut
 402
 403 sub get_action {
 404     my ( $self, $name, $namespace ) = @_;
 405     return unless $name;
 406
 407     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 408
 409     return $self->_action_hash->{"${namespace}/${name}"};
 410 }
 411
 412 =head2 $self->get_action_by_path( $path );
 413
 414 Returns the named action by its full private path.
 415
 416 =cut
 417
 418 sub get_action_by_path {
 419     my ( $self, $path ) = @_;
 420     $path =~ s/^\///;
 421     $path = "/$path" unless $path =~ /\//;
 422     $self->_action_hash->{$path};
 423 }
 424
 425 =head2 $self->get_actions( $c, $action, $namespace )
 426
 427 =cut
 428
 429 sub get_actions {
 430     my ( $self, $c, $action, $namespace ) = @_;
 431     return [] unless $action;
 432
 433     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 434
 435     my @match = $self->get_containers($namespace);
 436
 437     return map { $_->get_action($action) } @match;
 438 }
 439
 440 =head2 $self->get_containers( $namespace )
 441
 442 Return all the action containers for a given namespace, inclusive
 443
 444 =cut
 445
 446 sub get_containers {
 447     my ( $self, $namespace ) = @_;
 448     $namespace ||= '';
 449     $namespace = '' if $namespace eq '/';
 450
 451     my @containers;
 452
 453     if ( length $namespace ) {
 454         do {
 455             push @containers, $self->_container_hash->{$namespace};
 456         } while ( $namespace =~ s#/[^/]+$## );
 457     }
 458
 459     return reverse grep { defined } @containers, $self->_container_hash->{''};
 460 }
 461
 462 =head2 $self->uri_for_action($action, \@captures)
 463
 464 Takes a Catalyst::Action object and action parameters and returns a URI
 465 part such that if $c->req->path were this URI part, this action would be
 466 dispatched to with $c->req->captures set to the supplied arrayref.
 467
 468 If the action object is not available for external dispatch or the dispatcher
 469 cannot determine an appropriate URI, this method will return undef.
 470
 471 =cut
 472
 473 sub uri_for_action {
 474     my ( $self, $action, $captures) = @_;
 475     $captures ||= [];
 476     foreach my $dispatch_type ( @{ $self->_dispatch_types } ) {
 477         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 478         return( $uri eq '' ? '/' : $uri )
 479             if defined($uri);
 480     }
 481     return undef;
 482 }
 483
 484 =head2 expand_action
 485
 486 expand an action into a full representation of the dispatch.
 487 mostly useful for chained, other actions will just return a
 488 single action.
 489
 490 =cut
 491
 492 sub expand_action {
 493     my ($self, $action) = @_;
 494
 495     foreach my $dispatch_type (@{ $self->_dispatch_types }) {
 496         my $expanded = $dispatch_type->expand_action($action);
 497         return $expanded if $expanded;
 498     }
 499
 500     return $action;
 501 }
 502
 503 =head2 $self->register( $c, $action )
 504
 505 Make sure all required dispatch types for this action are loaded, then
 506 pass the action to our dispatch types so they can register it if required.
 507 Also, set up the tree with the action containers.
 508
 509 =cut
 510
 511 sub register {
 512     my ( $self, $c, $action ) = @_;
 513
 514     my $registered = $self->_registered_dispatch_types;
 515
 516     #my $priv = 0; #seems to be unused
 517     foreach my $key ( keys %{ $action->attributes } ) {
 518         next if $key eq 'Private';
 519         my $class = "Catalyst::DispatchType::$key";
 520         unless ( $registered->{$class} ) {
 521             # FIXME - Some error checking and re-throwing needed here, as
 522             #         we eat exceptions loading dispatch types.
 523             eval { Class::MOP::load_class($class) };
 524             push( @{ $self->_dispatch_types }, $class->new ) unless $@;
 525             $registered->{$class} = 1;
 526         }
 527     }
 528
 529     my @dtypes = @{ $self->_dispatch_types };
 530     my @normal_dtypes;
 531     my @low_precedence_dtypes;
 532
 533     for my $type ( @dtypes ) {
 534         if ($type->_is_low_precedence) {
 535             push @low_precedence_dtypes, $type;
 536         } else {
 537             push @normal_dtypes, $type;
 538         }
 539     }
 540
 541     # Pass the action to our dispatch types so they can register it if reqd.
 542     my $was_registered = 0;
 543     foreach my $type ( @normal_dtypes ) {
 544         $was_registered = 1 if $type->register( $c, $action );
 545     }
 546
 547     if (not $was_registered) {
 548         foreach my $type ( @low_precedence_dtypes ) {
 549             $type->register( $c, $action );
 550         }
 551     }
 552
 553     my $namespace = $action->namespace;
 554     my $name      = $action->name;
 555
 556     my $container = $self->_find_or_create_action_container($namespace);
 557
 558     # Set the method value
 559     $container->add_action($action);
 560
 561     $self->_action_hash->{"$namespace/$name"} = $action;
 562     $self->_container_hash->{$namespace} = $container;
 563 }
 564
 565 sub _find_or_create_action_container {
 566     my ( $self, $namespace ) = @_;
 567
 568     my $tree ||= $self->_tree;
 569
 570     return $tree->getNodeValue unless $namespace;
 571
 572     my @namespace = split '/', $namespace;
 573     return $self->_find_or_create_namespace_node( $tree, @namespace )
 574       ->getNodeValue;
 575 }
 576
 577 sub _find_or_create_namespace_node {
 578     my ( $self, $parent, $part, @namespace ) = @_;
 579
 580     return $parent unless $part;
 581
 582     my $child =
 583       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 584
 585     unless ($child) {
 586         my $container = Catalyst::ActionContainer->new($part);
 587         $parent->addChild( $child = Tree::Simple->new($container) );
 588     }
 589
 590     $self->_find_or_create_namespace_node( $child, @namespace );
 591 }
 592
 593 =head2 $self->setup_actions( $class, $context )
 594
 595 Loads all of the preload dispatch types, registers their actions and then
 596 loads all of the postload dispatch types, and iterates over the tree of
 597 actions, displaying the debug information if appropriate.
 598
 599 =cut
 600
 601 sub setup_actions {
 602     my ( $self, $c ) = @_;
 603
 604     my @classes =
 605       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 606     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 607
 608     foreach my $comp ( values %{ $c->components } ) {
 609         $comp->register_actions($c) if $comp->can('register_actions');
 610     }
 611
 612     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 613
 614     return unless $c->debug;
 615     $self->_display_action_tables($c);
 616 }
 617
 618 sub _display_action_tables {
 619     my ($self, $c) = @_;
 620
 621     my $column_width = Catalyst::Utils::term_width() - 20 - 36 - 12;
 622     my $privates = Text::SimpleTable->new(
 623         [ 20, 'Private' ], [ 36, 'Class' ], [ $column_width, 'Method' ]
 624     );
 625
 626     my $has_private = 0;
 627     my $walker = sub {
 628         my ( $walker, $parent, $prefix ) = @_;
 629         $prefix .= $parent->getNodeValue || '';
 630         $prefix .= '/' unless $prefix =~ /\/$/;
 631         my $node = $parent->getNodeValue->actions;
 632
 633         for my $action ( keys %{$node} ) {
 634             my $action_obj = $node->{$action};
 635             next
 636               if ( ( $action =~ /^_.*/ )
 637                 && ( !$c->config->{show_internal_actions} ) );
 638             $privates->row( "$prefix$action", $action_obj->class, $action );
 639             $has_private = 1;
 640         }
 641
 642         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 643     };
 644
 645     $walker->( $walker, $self->_tree, '' );
 646     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 647       if $has_private;
 648
 649     # List all public actions
 650     $_->list($c) for @{ $self->_dispatch_types };
 651 }
 652
 653 sub _load_dispatch_types {
 654     my ( $self, @types ) = @_;
 655
 656     my @loaded;
 657
 658     # Preload action types
 659     for my $type (@types) {
 660         my $class =
 661           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 662
 663         eval { Class::MOP::load_class($class) };
 664         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 665           if $@;
 666         push @{ $self->_dispatch_types }, $class->new;
 667
 668         push @loaded, $class;
 669     }
 670
 671     return @loaded;
 672 }
 673
 674 =head2 $self->dispatch_type( $type )
 675
 676 Get the DispatchType object of the relevant type, i.e. passing C<$type> of
 677 C<Chained> would return a L<Catalyst::DispatchType::Chained> object (assuming
 678 of course it's being used.)
 679
 680 =cut
 681
 682 sub dispatch_type {
 683     my ($self, $name) = @_;
 684
 685     unless ($name =~ s/^\+//) {
 686         $name = "Catalyst::DispatchType::" . $name;
 687     }
 688
 689     for (@{ $self->_dispatch_types }) {
 690         return $_ if ref($_) eq $name;
 691     }
 692     return undef;
 693 }
 694
 695 use Moose;
 696
 697 # 5.70 backwards compatibility hacks.
 698
 699 # Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
 700 # need the methods here which *should* be private..
 701
 702 # However we can't really take them away until there is a sane API for
 703 # building actions and configuring / introspecting the dispatcher.
 704 # In 5.90, we should build that infrastructure, port the plugins which
 705 # use it, and then take the crap below away.
 706 # See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
 707
 708 # Alias _method_name to method_name, add a before modifier to warn..
 709 foreach my $public_method_name (qw/
 710         tree
 711         dispatch_types
 712         registered_dispatch_types
 713         method_action_class
 714         action_hash
 715         container_hash
 716     /) {
 717     my $private_method_name = '_' . $public_method_name;
 718     my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 719     $meta->add_method($public_method_name, $meta->get_method($private_method_name));
 720     {
 721         my %package_hash; # Only warn once per method, per package. These are infrequent enough that
 722                           # I haven't provided a way to disable them, patches welcome.
 723         $meta->add_before_method_modifier($public_method_name, sub {
 724             my $class = caller(2);
 725             chomp($class);
 726             $package_hash{$class}++ || do {
 727                 warn("Class $class is calling the deprecated method\n"
 728                     . "  Catalyst::Dispatcher::$public_method_name,\n"
 729                     . "  this will be removed in Catalyst 5.9X\n");
 730             };
 731         });
 732     }
 733 }
 734 # End 5.70 backwards compatibility hacks.
 735
 736 __PACKAGE__->meta->make_immutable;
 737
 738 =head2 meta
 739
 740 Provided by Moose
 741
 742 =head1 AUTHORS
 743
 744 Catalyst Contributors, see Catalyst.pm
 745
 746 =head1 COPYRIGHT
 747
 748 This library is free software. You can redistribute it and/or modify it under
 749 the same terms as Perl itself.
 750
 751 =cut
 752
 753 1;