lib/Catalyst/Dispatcher.pm

   1 package Catalyst::Dispatcher;
   2
   3 use strict;
   4 use base 'Class::Accessor::Fast';
   5 use Catalyst::Exception;
   6 use Catalyst::Utils;
   7 use Catalyst::Action;
   8 use Catalyst::ActionContainer;
   9 use Catalyst::DispatchType::Default;
  10 use Catalyst::DispatchType::Index;
  11 use Text::SimpleTable;
  12 use Tree::Simple;
  13 use Tree::Simple::Visitor::FindByPath;
  14 use Scalar::Util ();
  15
  16 # Stringify to class
  17 use overload '""' => sub { return ref shift }, fallback => 1;
  18
  19 __PACKAGE__->mk_accessors(
  20     qw/tree dispatch_types registered_dispatch_types
  21       method_action_class action_container_class
  22       preload_dispatch_types postload_dispatch_types
  23       action_hash container_hash
  24       /
  25 );
  26
  27 # Preload these action types
  28 our @PRELOAD = qw/Index Path Regex/;
  29
  30 # Postload these action types
  31 our @POSTLOAD = qw/Default/;
  32
  33 =head1 NAME
  34
  35 Catalyst::Dispatcher - The Catalyst Dispatcher
  36
  37 =head1 SYNOPSIS
  38
  39 See L<Catalyst>.
  40
  41 =head1 DESCRIPTION
  42
  43 This is the class that maps public urls to actions in your Catalyst
  44 application based on the attributes you set.
  45
  46 =head1 METHODS
  47
  48 =head2 new
  49
  50 Construct a new dispatcher.
  51
  52 =cut
  53
  54 sub new {
  55     my $self  = shift;
  56     my $class = ref($self) || $self;
  57
  58     my $obj = $class->SUPER::new(@_);
  59
  60     # set the default pre- and and postloads
  61     $obj->preload_dispatch_types( \@PRELOAD );
  62     $obj->postload_dispatch_types( \@POSTLOAD );
  63     $obj->action_hash(    {} );
  64     $obj->container_hash( {} );
  65
  66     # Create the root node of the tree
  67     my $container =
  68       Catalyst::ActionContainer->new( { part => '/', actions => {} } );
  69     $obj->tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
  70
  71     return $obj;
  72 }
  73
  74 =head2 $self->preload_dispatch_types
  75
  76 An arrayref of pre-loaded dispatchtype classes
  77
  78 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  79 To use a custom class outside the regular C<Catalyst> namespace, prefix
  80 it with a C<+>, like so:
  81
  82     +My::Dispatch::Type
  83
  84 =head2 $self->postload_dispatch_types
  85
  86 An arrayref of post-loaded dispatchtype classes
  87
  88 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  89 To use a custom class outside the regular C<Catalyst> namespace, prefix
  90 it with a C<+>, like so:
  91
  92     +My::Dispatch::Type
  93
  94 =head2 $self->detach( $c, $command [, \@arguments ] )
  95
  96 Documented in L<Catalyst>
  97
  98 =cut
  99
 100 sub detach {
 101     my ( $self, $c, $command, @args ) = @_;
 102     $c->forward( $command, @args ) if $command;
 103     die $Catalyst::DETACH;
 104 }
 105
 106 =head2 $self->dispatch($c)
 107
 108 Delegate the dispatch to the action that matched the url, or return a
 109 message about unknown resource
 110
 111
 112 =cut
 113
 114 sub dispatch {
 115     my ( $self, $c ) = @_;
 116     if ( $c->action ) {
 117         $c->forward( join( '/', '', $c->action->namespace, '_DISPATCH' ) );
 118     }
 119
 120     else {
 121         my $path  = $c->req->path;
 122         my $error = $path
 123           ? qq/Unknown resource "$path"/
 124           : "No default action defined";
 125         $c->log->error($error) if $c->debug;
 126         $c->error($error);
 127     }
 128 }
 129
 130 # $self->_command2action( $c, $command [, \@arguments ] )
 131 # Search for an action, from the command and returns C<($action, $args)> on
 132 # success. Returns C<(0)> on error.
 133
 134 sub _command2action {
 135     my ( $self, $c, $command, @extra_params ) = @_;
 136
 137     unless ($command) {
 138         $c->log->debug('Nothing to go to') if $c->debug;
 139         return 0;
 140     }
 141
 142     my @args;
 143
 144     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
 145         @args = @{ pop @extra_params }
 146     } else {
 147         # this is a copy, it may take some abuse from
 148         # ->_invoke_as_path if the path had trailing parts
 149         @args = @{ $c->request->arguments };
 150     }
 151
 152     my $action;
 153
 154     if (Scalar::Util::blessed($command) && $command->isa('Catalyst::Action')) {
 155         $action = $command;
 156     }
 157     else {
 158         # go to a string path ("/foo/bar/gorch")
 159         # or action object which stringifies to that
 160         $action = $self->_invoke_as_path( $c, "$command", \@args );
 161     }
 162
 163     # go to a component ( "MyApp::*::Foo" or $c->component("...")
 164     # - a path or an object)
 165     unless ($action) {
 166         my $method = @extra_params ? $extra_params[0] : "process";
 167         $action = $self->_invoke_as_component( $c, $command, $method );
 168     }
 169
 170     return $action, \@args;
 171 }
 172
 173 =head2 $self->visit( $c, $command [, \@arguments ] )
 174
 175 Documented in L<Catalyst>
 176
 177 =cut
 178
 179 sub visit {
 180     my $self = shift;
 181     $self->_do_visit('visit', @_);
 182 }
 183
 184 sub _do_visit {
 185     my $self = shift;
 186     my $opname = shift;
 187     my ( $c, $command ) = @_;
 188     my ( $action, $args ) = $self->_command2action(@_);
 189     my $error = qq/Couldn't $opname("$command"): /;
 190
 191     if (!$action) {
 192         $error .= qq/Couldn't $opname to command "$command": /
 193                  .qq/Invalid action or component./;
 194     }
 195     elsif (!defined $action->namespace) {
 196         $error .= qq/Action has no namespace: cannot $opname() to a plain /
 197                  .qq/method or component, must be a :Action or some sort./
 198     }
 199     elsif (!$action->class->can('_DISPATCH')) {
 200         $error .= qq/Action cannot _DISPATCH. /
 201                  .qq/Did you try to $opname() a non-controller action?/;
 202     }
 203     else {
 204         $error = q();
 205     }
 206
 207     if($error) {
 208         $c->error($error);
 209         $c->log->debug($error) if $c->debug;
 210         return 0;
 211     }
 212
 213     $action = $self->expand_action($action);
 214
 215     local $c->request->{arguments} = $args;
 216     local $c->{namespace} = $action->{'namespace'};
 217     local $c->{action} = $action;
 218
 219     $self->dispatch($c);
 220 }
 221
 222 =head2 $self->go( $c, $command [, \@arguments ] )
 223
 224 Documented in L<Catalyst>
 225
 226 =cut
 227
 228 sub go {
 229     my $self = shift;
 230     $self->_do_visit('go', @_);
 231     die $Catalyst::GO;
 232 }
 233
 234 =head2 $self->forward( $c, $command [, \@arguments ] )
 235
 236 Documented in L<Catalyst>
 237
 238 =cut
 239
 240 sub forward {
 241     my $self = shift;
 242     my ( $c, $command ) = @_;
 243     my ( $action, $args ) = $self->_command2action(@_);
 244
 245     unless ($action) {
 246         my $error =
 247             qq/Couldn't forward to command "$command": /
 248           . qq/Invalid action or component./;
 249         $c->error($error);
 250         $c->log->debug($error) if $c->debug;
 251         return 0;
 252     }
 253
 254     local $c->request->{arguments} = $args;
 255     $action->dispatch( $c );
 256
 257     return $c->state;
 258 }
 259
 260 sub _action_rel2abs {
 261     my ( $self, $c, $path ) = @_;
 262
 263     unless ( $path =~ m#^/# ) {
 264         my $namespace = $c->stack->[-1]->namespace;
 265         $path = "$namespace/$path";
 266     }
 267
 268     $path =~ s#^/##;
 269     return $path;
 270 }
 271
 272 sub _invoke_as_path {
 273     my ( $self, $c, $rel_path, $args ) = @_;
 274
 275     my $path = $self->_action_rel2abs( $c, $rel_path );
 276
 277     my ( $tail, @extra_args );
 278     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 279     {                           # allow $path to be empty
 280         if ( my $action = $c->get_action( $tail, $path ) ) {
 281             push @$args, @extra_args;
 282             return $action;
 283         }
 284         else {
 285             return
 286               unless $path
 287               ; # if a match on the global namespace failed then the whole lookup failed
 288         }
 289
 290         unshift @extra_args, $tail;
 291     }
 292 }
 293
 294 sub _find_component_class {
 295     my ( $self, $c, $component ) = @_;
 296
 297     return ref($component)
 298       || ref( $c->component($component) )
 299       || $c->component($component);
 300 }
 301
 302 sub _invoke_as_component {
 303     my ( $self, $c, $component, $method ) = @_;
 304
 305     my $class = $self->_find_component_class( $c, $component ) || return 0;
 306
 307     if ( my $code = $class->can($method) ) {
 308         return $self->method_action_class->new(
 309             {
 310                 name      => $method,
 311                 code      => $code,
 312                 reverse   => "$class->$method",
 313                 class     => $class,
 314                 namespace => Catalyst::Utils::class2prefix(
 315                     $class, $c->config->{case_sensitive}
 316                 ),
 317             }
 318         );
 319     }
 320     else {
 321         my $error =
 322           qq/Couldn't forward to "$class". Does not implement "$method"/;
 323         $c->error($error);
 324         $c->log->debug($error)
 325           if $c->debug;
 326         return 0;
 327     }
 328 }
 329
 330 =head2 $self->prepare_action($c)
 331
 332 Find an dispatch type that matches $c->req->path, and set args from it.
 333
 334 =cut
 335
 336 sub prepare_action {
 337     my ( $self, $c ) = @_;
 338     my $path = $c->req->path;
 339     my @path = split /\//, $c->req->path;
 340     $c->req->args( \my @args );
 341
 342     unshift( @path, '' );    # Root action
 343
 344   DESCEND: while (@path) {
 345         $path = join '/', @path;
 346         $path =~ s#^/##;
 347
 348         $path = '' if $path eq '/';    # Root action
 349
 350         # Check out dispatch types to see if any will handle the path at
 351         # this level
 352
 353         foreach my $type ( @{ $self->dispatch_types } ) {
 354             last DESCEND if $type->match( $c, $path );
 355         }
 356
 357         # If not, move the last part path to args
 358         my $arg = pop(@path);
 359         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 360         unshift @args, $arg;
 361     }
 362
 363     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$c->req->captures||[]};
 364
 365     $c->log->debug( 'Path is "' . $c->req->match . '"' )
 366       if ( $c->debug && length $c->req->match );
 367
 368     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 369       if ( $c->debug && @args );
 370 }
 371
 372 =head2 $self->get_action( $action, $namespace )
 373
 374 returns a named action from a given namespace.
 375
 376 =cut
 377
 378 sub get_action {
 379     my ( $self, $name, $namespace ) = @_;
 380     return unless $name;
 381
 382     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 383
 384     return $self->action_hash->{"$namespace/$name"};
 385 }
 386
 387 =head2 $self->get_action_by_path( $path );
 388
 389 Returns the named action by its full path.
 390
 391 =cut
 392
 393 sub get_action_by_path {
 394     my ( $self, $path ) = @_;
 395     $path =~ s/^\///;
 396     $path = "/$path" unless $path =~ /\//;
 397     $self->action_hash->{$path};
 398 }
 399
 400 =head2 $self->get_actions( $c, $action, $namespace )
 401
 402 =cut
 403
 404 sub get_actions {
 405     my ( $self, $c, $action, $namespace ) = @_;
 406     return [] unless $action;
 407
 408     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 409
 410     my @match = $self->get_containers($namespace);
 411
 412     return map { $_->get_action($action) } @match;
 413 }
 414
 415 =head2 $self->get_containers( $namespace )
 416
 417 Return all the action containers for a given namespace, inclusive
 418
 419 =cut
 420
 421 sub get_containers {
 422     my ( $self, $namespace ) = @_;
 423     $namespace ||= '';
 424     $namespace = '' if $namespace eq '/';
 425
 426     my @containers;
 427
 428     if ( length $namespace ) {
 429         do {
 430             push @containers, $self->container_hash->{$namespace};
 431         } while ( $namespace =~ s#/[^/]+$## );
 432     }
 433
 434     return reverse grep { defined } @containers, $self->container_hash->{''};
 435
 436     my @parts = split '/', $namespace;
 437 }
 438
 439 =head2 $self->uri_for_action($action, \@captures)
 440
 441 Takes a Catalyst::Action object and action parameters and returns a URI
 442 part such that if $c->req->path were this URI part, this action would be
 443 dispatched to with $c->req->captures set to the supplied arrayref.
 444
 445 If the action object is not available for external dispatch or the dispatcher
 446 cannot determine an appropriate URI, this method will return undef.
 447
 448 =cut
 449
 450 sub uri_for_action {
 451     my ( $self, $action, $captures) = @_;
 452     $captures ||= [];
 453     foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
 454         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 455         return( $uri eq '' ? '/' : $uri )
 456             if defined($uri);
 457     }
 458     return undef;
 459 }
 460
 461 =head2 expand_action
 462
 463 expand an action into a full representation of the dispatch.
 464 mostly useful for chained, other actions will just return a
 465 single action.
 466
 467 =cut
 468
 469 sub expand_action {
 470     my ($self, $action) = @_;
 471
 472     foreach my $dispatch_type (@{ $self->dispatch_types }) {
 473         my $expanded = $dispatch_type->expand_action($action);
 474         return $expanded if $expanded;
 475     }
 476
 477     return $action;
 478 }
 479
 480 =head2 $self->register( $c, $action )
 481
 482 Make sure all required dispatch types for this action are loaded, then
 483 pass the action to our dispatch types so they can register it if required.
 484 Also, set up the tree with the action containers.
 485
 486 =cut
 487
 488 sub register {
 489     my ( $self, $c, $action ) = @_;
 490
 491     my $registered = $self->registered_dispatch_types;
 492
 493     my $priv = 0;
 494     foreach my $key ( keys %{ $action->attributes } ) {
 495         next if $key eq 'Private';
 496         my $class = "Catalyst::DispatchType::$key";
 497         unless ( $registered->{$class} ) {
 498             eval "require $class";
 499             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 500             $registered->{$class} = 1;
 501         }
 502     }
 503
 504     # Pass the action to our dispatch types so they can register it if reqd.
 505     foreach my $type ( @{ $self->dispatch_types } ) {
 506         $type->register( $c, $action );
 507     }
 508
 509     my $namespace = $action->namespace;
 510     my $name      = $action->name;
 511
 512     my $container = $self->_find_or_create_action_container($namespace);
 513
 514     # Set the method value
 515     $container->add_action($action);
 516
 517     $self->action_hash->{"$namespace/$name"} = $action;
 518     $self->container_hash->{$namespace} = $container;
 519 }
 520
 521 sub _find_or_create_action_container {
 522     my ( $self, $namespace ) = @_;
 523
 524     my $tree ||= $self->tree;
 525
 526     return $tree->getNodeValue unless $namespace;
 527
 528     my @namespace = split '/', $namespace;
 529     return $self->_find_or_create_namespace_node( $tree, @namespace )
 530       ->getNodeValue;
 531 }
 532
 533 sub _find_or_create_namespace_node {
 534     my ( $self, $parent, $part, @namespace ) = @_;
 535
 536     return $parent unless $part;
 537
 538     my $child =
 539       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 540
 541     unless ($child) {
 542         my $container = Catalyst::ActionContainer->new($part);
 543         $parent->addChild( $child = Tree::Simple->new($container) );
 544     }
 545
 546     $self->_find_or_create_namespace_node( $child, @namespace );
 547 }
 548
 549 =head2 $self->setup_actions( $class, $context )
 550
 551
 552 =cut
 553
 554 sub setup_actions {
 555     my ( $self, $c ) = @_;
 556
 557     $self->dispatch_types( [] );
 558     $self->registered_dispatch_types( {} );
 559     $self->method_action_class('Catalyst::Action');
 560     $self->action_container_class('Catalyst::ActionContainer');
 561
 562     my @classes =
 563       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 564     @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
 565
 566     foreach my $comp ( values %{ $c->components } ) {
 567         $comp->register_actions($c) if $comp->can('register_actions');
 568     }
 569
 570     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 571
 572     return unless $c->debug;
 573
 574     my $privates = Text::SimpleTable->new(
 575         [ 20, 'Private' ],
 576         [ 36, 'Class' ],
 577         [ 12, 'Method' ]
 578     );
 579
 580     my $has_private = 0;
 581     my $walker = sub {
 582         my ( $walker, $parent, $prefix ) = @_;
 583         $prefix .= $parent->getNodeValue || '';
 584         $prefix .= '/' unless $prefix =~ /\/$/;
 585         my $node = $parent->getNodeValue->actions;
 586
 587         for my $action ( keys %{$node} ) {
 588             my $action_obj = $node->{$action};
 589             next
 590               if ( ( $action =~ /^_.*/ )
 591                 && ( !$c->config->{show_internal_actions} ) );
 592             $privates->row( "$prefix$action", $action_obj->class, $action );
 593             $has_private = 1;
 594         }
 595
 596         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 597     };
 598
 599     $walker->( $walker, $self->tree, '' );
 600     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 601       if $has_private;
 602
 603     # List all public actions
 604     $_->list($c) for @{ $self->dispatch_types };
 605 }
 606
 607 sub _load_dispatch_types {
 608     my ( $self, @types ) = @_;
 609
 610     my @loaded;
 611
 612     # Preload action types
 613     for my $type (@types) {
 614         my $class =
 615           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 616         eval "require $class";
 617         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 618           if $@;
 619         push @{ $self->dispatch_types }, $class->new;
 620
 621         push @loaded, $class;
 622     }
 623
 624     return @loaded;
 625 }
 626
 627 =head1 AUTHORS
 628
 629 Catalyst Contributors, see Catalyst.pm
 630
 631 =head1 COPYRIGHT
 632
 633 This program is free software, you can redistribute it and/or modify it under
 634 the same terms as Perl itself.
 635
 636 =cut
 637
 638 1;