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