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