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_class {
 311     my ( $self, $c, $component ) = @_;
 312
 313     return ref($component)
 314       || ref( $c->component($component) )
 315       || $c->component($component);
 316 }
 317
 318 sub _invoke_as_component {
 319     my ( $self, $c, $component, $method ) = @_;
 320
 321     my $class = $self->_find_component_class( $c, $component ) || return 0;
 322
 323     if (my $code = $component_instance->can('action_for')) {
 324         my $possible_action = $component_instance->$code($method);
 325         return $possible_action if $possible_action;
 326     }
 327
 328     if ( my $code = $class->can($method) ) {
 329         return $self->_method_action_class->new(
 330             {
 331                 name      => $method,
 332                 code      => $code,
 333                 reverse   => "$class->$method",
 334                 class     => $class,
 335                 namespace => Catalyst::Utils::class2prefix(
 336                     $class, $c->config->{case_sensitive}
 337                 ),
 338             }
 339         );
 340     }
 341     else {
 342         my $error =
 343           qq/Couldn't forward to "$class". Does not implement "$method"/;
 344         $c->error($error);
 345         $c->log->debug($error)
 346           if $c->debug;
 347         return 0;
 348     }
 349 }
 350
 351 =head2 $self->prepare_action($c)
 352
 353 Find an dispatch type that matches $c->req->path, and set args from it.
 354
 355 =cut
 356
 357 sub prepare_action {
 358     my ( $self, $c ) = @_;
 359     my $req = $c->req;
 360     my $path = $req->path;
 361     my @path = split /\//, $req->path;
 362     $req->args( \my @args );
 363
 364     unshift( @path, '' );    # Root action
 365
 366   DESCEND: while (@path) {
 367         $path = join '/', @path;
 368         $path =~ s#^/##;
 369
 370         $path = '' if $path eq '/';    # Root action
 371
 372         # Check out dispatch types to see if any will handle the path at
 373         # this level
 374
 375         foreach my $type ( @{ $self->_dispatch_types } ) {
 376             last DESCEND if $type->match( $c, $path );
 377         }
 378
 379         # If not, move the last part path to args
 380         my $arg = pop(@path);
 381         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 382         unshift @args, $arg;
 383     }
 384
 385     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 386
 387     $c->log->debug( 'Path is "' . $req->match . '"' )
 388       if ( $c->debug && defined $req->match && length $req->match );
 389
 390     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 391       if ( $c->debug && @args );
 392 }
 393
 394 =head2 $self->get_action( $action, $namespace )
 395
 396 returns a named action from a given namespace.
 397
 398 =cut
 399
 400 sub get_action {
 401     my ( $self, $name, $namespace ) = @_;
 402     return unless $name;
 403
 404     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 405
 406     return $self->_action_hash->{"${namespace}/${name}"};
 407 }
 408
 409 =head2 $self->get_action_by_path( $path );
 410
 411 Returns the named action by its full path.
 412
 413 =cut
 414
 415 sub get_action_by_path {
 416     my ( $self, $path ) = @_;
 417     $path =~ s/^\///;
 418     $path = "/$path" unless $path =~ /\//;
 419     $self->_action_hash->{$path};
 420 }
 421
 422 =head2 $self->get_actions( $c, $action, $namespace )
 423
 424 =cut
 425
 426 sub get_actions {
 427     my ( $self, $c, $action, $namespace ) = @_;
 428     return [] unless $action;
 429
 430     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 431
 432     my @match = $self->get_containers($namespace);
 433
 434     return map { $_->get_action($action) } @match;
 435 }
 436
 437 =head2 $self->get_containers( $namespace )
 438
 439 Return all the action containers for a given namespace, inclusive
 440
 441 =cut
 442
 443 sub get_containers {
 444     my ( $self, $namespace ) = @_;
 445     $namespace ||= '';
 446     $namespace = '' if $namespace eq '/';
 447
 448     my @containers;
 449
 450     if ( length $namespace ) {
 451         do {
 452             push @containers, $self->_container_hash->{$namespace};
 453         } while ( $namespace =~ s#/[^/]+$## );
 454     }
 455
 456     return reverse grep { defined } @containers, $self->_container_hash->{''};
 457
 458     #return (split '/', $namespace); # isnt this more clear?
 459     my @parts = split '/', $namespace;
 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     # Pass the action to our dispatch types so they can register it if reqd.
 530     foreach my $type ( @{ $self->_dispatch_types } ) {
 531         $type->register( $c, $action );
 532     }
 533
 534     my $namespace = $action->namespace;
 535     my $name      = $action->name;
 536
 537     my $container = $self->_find_or_create_action_container($namespace);
 538
 539     # Set the method value
 540     $container->add_action($action);
 541
 542     $self->_action_hash->{"$namespace/$name"} = $action;
 543     $self->_container_hash->{$namespace} = $container;
 544 }
 545
 546 sub _find_or_create_action_container {
 547     my ( $self, $namespace ) = @_;
 548
 549     my $tree ||= $self->_tree;
 550
 551     return $tree->getNodeValue unless $namespace;
 552
 553     my @namespace = split '/', $namespace;
 554     return $self->_find_or_create_namespace_node( $tree, @namespace )
 555       ->getNodeValue;
 556 }
 557
 558 sub _find_or_create_namespace_node {
 559     my ( $self, $parent, $part, @namespace ) = @_;
 560
 561     return $parent unless $part;
 562
 563     my $child =
 564       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 565
 566     unless ($child) {
 567         my $container = Catalyst::ActionContainer->new($part);
 568         $parent->addChild( $child = Tree::Simple->new($container) );
 569     }
 570
 571     $self->_find_or_create_namespace_node( $child, @namespace );
 572 }
 573
 574 =head2 $self->setup_actions( $class, $context )
 575
 576 Loads all of the preload dispatch types, registers their actions and then
 577 loads all of the postload dispatch types, and iterates over the tree of
 578 actions, displaying the debug information if appropriate.
 579
 580 =cut
 581
 582 sub setup_actions {
 583     my ( $self, $c ) = @_;
 584
 585     my @classes =
 586       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 587     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 588
 589     foreach my $comp ( values %{ $c->components } ) {
 590         $comp->register_actions($c) if $comp->can('register_actions');
 591     }
 592
 593     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 594
 595     return unless $c->debug;
 596     $self->_display_action_tables($c);
 597 }
 598
 599 sub _display_action_tables {
 600     my ($self, $c) = @_;
 601
 602     my $column_width = Catalyst::Utils::term_width() - 20 - 36 - 12;
 603     my $privates = Text::SimpleTable->new(
 604         [ 20, 'Private' ], [ 36, 'Class' ], [ $column_width, 'Method' ]
 605     );
 606
 607     my $has_private = 0;
 608     my $walker = sub {
 609         my ( $walker, $parent, $prefix ) = @_;
 610         $prefix .= $parent->getNodeValue || '';
 611         $prefix .= '/' unless $prefix =~ /\/$/;
 612         my $node = $parent->getNodeValue->actions;
 613
 614         for my $action ( keys %{$node} ) {
 615             my $action_obj = $node->{$action};
 616             next
 617               if ( ( $action =~ /^_.*/ )
 618                 && ( !$c->config->{show_internal_actions} ) );
 619             $privates->row( "$prefix$action", $action_obj->class, $action );
 620             $has_private = 1;
 621         }
 622
 623         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 624     };
 625
 626     $walker->( $walker, $self->_tree, '' );
 627     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 628       if $has_private;
 629
 630     # List all public actions
 631     $_->list($c) for @{ $self->_dispatch_types };
 632 }
 633
 634 sub _load_dispatch_types {
 635     my ( $self, @types ) = @_;
 636
 637     my @loaded;
 638
 639     # Preload action types
 640     for my $type (@types) {
 641         my $class =
 642           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 643
 644         eval { Class::MOP::load_class($class) };
 645         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 646           if $@;
 647         push @{ $self->_dispatch_types }, $class->new;
 648
 649         push @loaded, $class;
 650     }
 651
 652     return @loaded;
 653 }
 654
 655 # Dont document this until someone else is happy with beaviour. Ash 2009/03/16
 656 sub dispatch_type {
 657     my ($self, $name) = @_;
 658
 659     unless ($name =~ s/^\+//) {
 660         $name = "Catalyst::DispatchType::" . $name;
 661     }
 662
 663     for (@{ $self->_dispatch_types }) {
 664         return $_ if ref($_) eq $name;
 665     }
 666     return undef;
 667 }
 668
 669 use Moose;
 670
 671 # 5.70 backwards compatibility hacks.
 672
 673 # Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
 674 # need the methods here which *should* be private..
 675
 676 # However we can't really take them away until there is a sane API for
 677 # building actions and configuring / introspecting the dispatcher.
 678 # In 5.90, we should build that infrastructure, port the plugins which
 679 # use it, and then take the crap below away.
 680 # See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
 681
 682 # Alias _method_name to method_name, add a before modifier to warn..
 683 foreach my $public_method_name (qw/
 684         tree
 685         dispatch_types
 686         registered_dispatch_types
 687         method_action_class
 688         action_hash
 689         container_hash
 690     /) {
 691     my $private_method_name = '_' . $public_method_name;
 692     my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 693     $meta->add_method($public_method_name, $meta->get_method($private_method_name));
 694     {
 695         my %package_hash; # Only warn once per method, per package. These are infrequent enough that
 696                           # I haven't provided a way to disable them, patches welcome.
 697         $meta->add_before_method_modifier($public_method_name, sub {
 698             my $class = blessed(shift);
 699             $package_hash{$class}++ || do {
 700                 warn("Class $class is calling the deprecated method Catalyst::Dispatcher::$public_method_name,\n"
 701                     . "this will be removed in Catalyst 5.9X");
 702             };
 703         });
 704     }
 705 }
 706 # End 5.70 backwards compatibility hacks.
 707
 708 no Moose;
 709 __PACKAGE__->meta->make_immutable;
 710
 711 =head2 meta
 712
 713 Provided by Moose
 714
 715 =head1 AUTHORS
 716
 717 Catalyst Contributors, see Catalyst.pm
 718
 719 =head1 COPYRIGHT
 720
 721 This program is free software, you can redistribute it and/or modify it under
 722 the same terms as Perl itself.
 723
 724 =cut
 725
 726 1;