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