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 Text::SimpleTable;
  14 use Tree::Simple;
  15 use Tree::Simple::Visitor::FindByPath;
  16 use Scalar::Util ();
  17
  18 #do these belong as package vars or should we build these via a builder method?
  19 # Preload these action types
  20 our @PRELOAD = qw/Index Path Regex/;
  21
  22 # Postload these action types
  23 our @POSTLOAD = qw/Default/;
  24
  25 has _tree => (is => 'rw');
  26 has _dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1);
  27 has _registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1);
  28 has _method_action_class => (is => 'rw', default => 'Catalyst::Action');
  29 has _action_container_class => (is => 'rw', default => 'Catalyst::ActionContainer');
  30
  31 has preload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@PRELOAD] });
  32 has postload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@POSTLOAD] });
  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 # Wrap accessors so you can assign a list and it will capture a list ref.
  37 around qw/preload_dispatch_types postload_dispatch_types/ => sub {
  38     my $orig = shift;
  39     my $self = shift;
  40     return $self->$orig([@_]) if (scalar @_ && ref $_[0] ne 'ARRAY');
  41     return $self->$orig(@_);
  42 };
  43
  44 no Moose;
  45
  46 =head1 NAME
  47
  48 Catalyst::Dispatcher - The Catalyst Dispatcher
  49
  50 =head1 SYNOPSIS
  51
  52 See L<Catalyst>.
  53
  54 =head1 DESCRIPTION
  55
  56 This is the class that maps public urls to actions in your Catalyst
  57 application based on the attributes you set.
  58
  59 =head1 METHODS
  60
  61 =head2 new
  62
  63 Construct a new dispatcher.
  64
  65 =cut
  66
  67 sub BUILD {
  68   my ($self, $params) = @_;
  69
  70   my $container =
  71     Catalyst::ActionContainer->new( { part => '/', actions => {} } );
  72
  73   $self->_tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
  74 }
  75
  76 =head2 $self->preload_dispatch_types
  77
  78 An arrayref of pre-loaded dispatchtype classes
  79
  80 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  81 To use a custom class outside the regular C<Catalyst> namespace, prefix
  82 it with a C<+>, like so:
  83
  84     +My::Dispatch::Type
  85
  86 =head2 $self->postload_dispatch_types
  87
  88 An arrayref of post-loaded dispatchtype classes
  89
  90 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  91 To use a custom class outside the regular C<Catalyst> namespace, prefix
  92 it with a C<+>, like so:
  93
  94     +My::Dispatch::Type
  95
  96 =head2 $self->dispatch($c)
  97
  98 Delegate the dispatch to the action that matched the url, or return a
  99 message about unknown resource
 100
 101
 102 =cut
 103
 104 sub dispatch {
 105     my ( $self, $c ) = @_;
 106     if ( my $action = $c->action ) {
 107         $c->forward( join( '/', '', $action->namespace, '_DISPATCH' ) );
 108     }
 109
 110     else {
 111         my $path  = $c->req->path;
 112         my $error = $path
 113           ? qq/Unknown resource "$path"/
 114           : "No default action defined";
 115         $c->log->error($error) if $c->debug;
 116         $c->error($error);
 117     }
 118 }
 119
 120 # $self->_command2action( $c, $command [, \@arguments ] )
 121 # Search for an action, from the command and returns C<($action, $args)> on
 122 # success. Returns C<(0)> on error.
 123
 124 sub _command2action {
 125     my ( $self, $c, $command, @extra_params ) = @_;
 126
 127     unless ($command) {
 128         $c->log->debug('Nothing to go to') if $c->debug;
 129         return 0;
 130     }
 131
 132     my @args;
 133
 134     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
 135         @args = @{ pop @extra_params }
 136     } else {
 137         # this is a copy, it may take some abuse from
 138         # ->_invoke_as_path if the path had trailing parts
 139         @args = @{ $c->request->arguments };
 140     }
 141
 142     my $action;
 143
 144     # go to a string path ("/foo/bar/gorch")
 145     # or action object
 146     if (Scalar::Util::blessed($command) && $command->isa('Catalyst::Action')) {
 147         $action = $command;
 148     }
 149     else {
 150         $action = $self->_invoke_as_path( $c, "$command", \@args );
 151     }
 152
 153     # go to a component ( "MyApp::*::Foo" or $c->component("...")
 154     # - a path or an object)
 155     unless ($action) {
 156         my $method = @extra_params ? $extra_params[0] : "process";
 157         $action = $self->_invoke_as_component( $c, $command, $method );
 158     }
 159
 160     return $action, \@args;
 161 }
 162
 163 =head2 $self->visit( $c, $command [, \@arguments ] )
 164
 165 Documented in L<Catalyst>
 166
 167 =cut
 168
 169 sub visit {
 170     my $self = shift;
 171     $self->_do_visit('visit', @_);
 172 }
 173
 174 sub _do_visit {
 175     my $self = shift;
 176     my $opname = shift;
 177     my ( $c, $command ) = @_;
 178     my ( $action, $args ) = $self->_command2action(@_);
 179     my $error = qq/Couldn't $opname("$command"): /;
 180
 181     if (!$action) {
 182         $error .= qq/Couldn't $opname to command "$command": /
 183                  .qq/Invalid action or component./;
 184     }
 185     elsif (!defined $action->namespace) {
 186         $error .= qq/Action has no namespace: cannot $opname() to a plain /
 187                  .qq/method or component, must be a :Action or some sort./
 188     }
 189     elsif (!$action->class->can('_DISPATCH')) {
 190         $error .= qq/Action cannot _DISPATCH. /
 191                  .qq/Did you try to $opname() a non-controller action?/;
 192     }
 193     else {
 194         $error = q();
 195     }
 196
 197     if($error) {
 198         $c->error($error);
 199         $c->log->debug($error) if $c->debug;
 200         return 0;
 201     }
 202
 203     $action = $self->expand_action($action);
 204
 205     local $c->request->{arguments} = $args;
 206     local $c->{namespace} = $action->{'namespace'};
 207     local $c->{action} = $action;
 208
 209     $self->dispatch($c);
 210 }
 211
 212 =head2 $self->go( $c, $command [, \@arguments ] )
 213
 214 Documented in L<Catalyst>
 215
 216 =cut
 217
 218 sub go {
 219     my $self = shift;
 220     $self->_do_visit('go', @_);
 221     die $Catalyst::GO;
 222 }
 223
 224 =head2 $self->forward( $c, $command [, \@arguments ] )
 225
 226 Documented in L<Catalyst>
 227
 228 =cut
 229
 230 sub forward {
 231     my $self = shift;
 232     $self->_do_forward(forward => @_);
 233 }
 234
 235 sub _do_forward {
 236     my $self = shift;
 237     my $opname = shift;
 238     my ( $c, $command ) = @_;
 239     my ( $action, $args ) = $self->_command2action(@_);
 240
 241     if (!$action) {
 242         my $error .= qq/Couldn't $opname to command "$command": /
 243                     .qq/Invalid action or component./;
 244         $c->error($error);
 245         $c->log->debug($error) if $c->debug;
 246         return 0;
 247     }
 248
 249     no warnings 'recursion';
 250
 251     my $orig_args = $c->request->arguments();
 252     $c->request->arguments($args);
 253     $action->dispatch( $c );
 254     $c->request->arguments($orig_args);
 255
 256     return $c->state;
 257 }
 258
 259 =head2 $self->detach( $c, $command [, \@arguments ] )
 260
 261 Documented in L<Catalyst>
 262
 263 =cut
 264
 265 sub detach {
 266     my ( $self, $c, $command, @args ) = @_;
 267     $self->_do_forward(detach => $c, $command, @args ) if $command;
 268     die $Catalyst::DETACH;
 269 }
 270
 271 sub _action_rel2abs {
 272     my ( $self, $c, $path ) = @_;
 273
 274     unless ( $path =~ m#^/# ) {
 275         my $namespace = $c->stack->[-1]->namespace;
 276         $path = "$namespace/$path";
 277     }
 278
 279     $path =~ s#^/##;
 280     return $path;
 281 }
 282
 283 sub _invoke_as_path {
 284     my ( $self, $c, $rel_path, $args ) = @_;
 285
 286     my $path = $self->_action_rel2abs( $c, $rel_path );
 287
 288     my ( $tail, @extra_args );
 289     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 290     {                           # allow $path to be empty
 291         if ( my $action = $c->get_action( $tail, $path ) ) {
 292             push @$args, @extra_args;
 293             return $action;
 294         }
 295         else {
 296             return
 297               unless $path
 298               ; # if a match on the global namespace failed then the whole lookup failed
 299         }
 300
 301         unshift @extra_args, $tail;
 302     }
 303 }
 304
 305 sub _find_component_class {
 306     my ( $self, $c, $component ) = @_;
 307
 308     return ref($component)
 309       || ref( $c->component($component) )
 310       || $c->component($component);
 311 }
 312
 313 sub _invoke_as_component {
 314     my ( $self, $c, $component, $method ) = @_;
 315
 316     my $class = $self->_find_component_class( $c, $component ) || return 0;
 317
 318     if ( my $code = $class->can($method) ) {
 319         return $self->_method_action_class->new(
 320             {
 321                 name      => $method,
 322                 code      => $code,
 323                 reverse   => "$class->$method",
 324                 class     => $class,
 325                 namespace => Catalyst::Utils::class2prefix(
 326                     $class, $c->config->{case_sensitive}
 327                 ),
 328             }
 329         );
 330     }
 331     else {
 332         my $error =
 333           qq/Couldn't forward to "$class". Does not implement "$method"/;
 334         $c->error($error);
 335         $c->log->debug($error)
 336           if $c->debug;
 337         return 0;
 338     }
 339 }
 340
 341 =head2 $self->prepare_action($c)
 342
 343 Find an dispatch type that matches $c->req->path, and set args from it.
 344
 345 =cut
 346
 347 sub prepare_action {
 348     my ( $self, $c ) = @_;
 349     my $req = $c->req;
 350     my $path = $req->path;
 351     my @path = split /\//, $req->path;
 352     $req->args( \my @args );
 353
 354     unshift( @path, '' );    # Root action
 355
 356   DESCEND: while (@path) {
 357         $path = join '/', @path;
 358         $path =~ s#^/##;
 359
 360         $path = '' if $path eq '/';    # Root action
 361
 362         # Check out dispatch types to see if any will handle the path at
 363         # this level
 364
 365         foreach my $type ( @{ $self->_dispatch_types } ) {
 366             last DESCEND if $type->match( $c, $path );
 367         }
 368
 369         # If not, move the last part path to args
 370         my $arg = pop(@path);
 371         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 372         unshift @args, $arg;
 373     }
 374
 375     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 376
 377     $c->log->debug( 'Path is "' . $req->match . '"' )
 378       if ( $c->debug && defined $req->match && length $req->match );
 379
 380     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 381       if ( $c->debug && @args );
 382 }
 383
 384 =head2 $self->get_action( $action, $namespace )
 385
 386 returns a named action from a given namespace.
 387
 388 =cut
 389
 390 sub get_action {
 391     my ( $self, $name, $namespace ) = @_;
 392     return unless $name;
 393
 394     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 395
 396     return $self->_action_hash->{"${namespace}/${name}"};
 397 }
 398
 399 =head2 $self->get_action_by_path( $path );
 400
 401 Returns the named action by its full path.
 402
 403 =cut
 404
 405 sub get_action_by_path {
 406     my ( $self, $path ) = @_;
 407     $path =~ s/^\///;
 408     $path = "/$path" unless $path =~ /\//;
 409     $self->_action_hash->{$path};
 410 }
 411
 412 =head2 $self->get_actions( $c, $action, $namespace )
 413
 414 =cut
 415
 416 sub get_actions {
 417     my ( $self, $c, $action, $namespace ) = @_;
 418     return [] unless $action;
 419
 420     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 421
 422     my @match = $self->get_containers($namespace);
 423
 424     return map { $_->get_action($action) } @match;
 425 }
 426
 427 =head2 $self->get_containers( $namespace )
 428
 429 Return all the action containers for a given namespace, inclusive
 430
 431 =cut
 432
 433 sub get_containers {
 434     my ( $self, $namespace ) = @_;
 435     $namespace ||= '';
 436     $namespace = '' if $namespace eq '/';
 437
 438     my @containers;
 439
 440     if ( length $namespace ) {
 441         do {
 442             push @containers, $self->_container_hash->{$namespace};
 443         } while ( $namespace =~ s#/[^/]+$## );
 444     }
 445
 446     return reverse grep { defined } @containers, $self->_container_hash->{''};
 447
 448     #return (split '/', $namespace); # isnt this more clear?
 449     my @parts = split '/', $namespace;
 450 }
 451
 452 =head2 $self->uri_for_action($action, \@captures)
 453
 454 Takes a Catalyst::Action object and action parameters and returns a URI
 455 part such that if $c->req->path were this URI part, this action would be
 456 dispatched to with $c->req->captures set to the supplied arrayref.
 457
 458 If the action object is not available for external dispatch or the dispatcher
 459 cannot determine an appropriate URI, this method will return undef.
 460
 461 =cut
 462
 463 sub uri_for_action {
 464     my ( $self, $action, $captures) = @_;
 465     $captures ||= [];
 466     foreach my $dispatch_type ( @{ $self->_dispatch_types } ) {
 467         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 468         return( $uri eq '' ? '/' : $uri )
 469             if defined($uri);
 470     }
 471     return undef;
 472 }
 473
 474 =head2 expand_action
 475
 476 expand an action into a full representation of the dispatch.
 477 mostly useful for chained, other actions will just return a
 478 single action.
 479
 480 =cut
 481
 482 sub expand_action {
 483     my ($self, $action) = @_;
 484
 485     foreach my $dispatch_type (@{ $self->_dispatch_types }) {
 486         my $expanded = $dispatch_type->expand_action($action);
 487         return $expanded if $expanded;
 488     }
 489
 490     return $action;
 491 }
 492
 493 =head2 $self->register( $c, $action )
 494
 495 Make sure all required dispatch types for this action are loaded, then
 496 pass the action to our dispatch types so they can register it if required.
 497 Also, set up the tree with the action containers.
 498
 499 =cut
 500
 501 sub register {
 502     my ( $self, $c, $action ) = @_;
 503
 504     my $registered = $self->_registered_dispatch_types;
 505
 506     #my $priv = 0; #seems to be unused
 507     foreach my $key ( keys %{ $action->attributes } ) {
 508         next if $key eq 'Private';
 509         my $class = "Catalyst::DispatchType::$key";
 510         unless ( $registered->{$class} ) {
 511             #some error checking rethrowing here wouldn't hurt.
 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
 566 =cut
 567
 568 sub setup_actions {
 569     my ( $self, $c ) = @_;
 570
 571
 572     my @classes =
 573       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 574     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 575
 576     foreach my $comp ( values %{ $c->components } ) {
 577         $comp->register_actions($c) if $comp->can('register_actions');
 578     }
 579
 580     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 581
 582     return unless $c->debug;
 583
 584     my $privates = Text::SimpleTable->new(
 585         [ 20, 'Private' ],
 586         [ 36, 'Class' ],
 587         [ 12, '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 no Moose;
 639 __PACKAGE__->meta->make_immutable;
 640
 641 =head2 meta
 642
 643 Provided by Moose
 644
 645 =head1 AUTHORS
 646
 647 Catalyst Contributors, see Catalyst.pm
 648
 649 =head1 COPYRIGHT
 650
 651 This program is free software, you can redistribute it and/or modify it under
 652 the same terms as Perl itself.
 653
 654 =cut
 655
 656 1;