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