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