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 ();
  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 # Search for an action, from the command and returns C<($action, $args)> on
 133 # success. Returns C<(0)> on error.
 134
 135 sub _command2action {
 136     my ( $self, $c, $command, @extra_params ) = @_;
 137
 138     unless ($command) {
 139         $c->log->debug('Nothing to go to') if $c->debug;
 140         return 0;
 141     }
 142
 143     my @args;
 144
 145     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
 146         @args = @{ pop @extra_params }
 147     } else {
 148         # this is a copy, it may take some abuse from
 149         # ->_invoke_as_path if the path had trailing parts
 150         @args = @{ $c->request->arguments };
 151     }
 152
 153     my $action;
 154
 155     if (Scalar::Util::blessed($command) && $command->isa('Catalyst::Action')) {
 156         $action = $command;
 157     }
 158     else {
 159         # go to a string path ("/foo/bar/gorch")
 160         # or action object which stringifies to that
 161         $action = $self->_invoke_as_path( $c, "$command", \@args );
 162     }
 163
 164     # go to a component ( "MyApp::*::Foo" or $c->component("...")
 165     # - a path or an object)
 166     unless ($action) {
 167         my $method = @extra_params ? $extra_params[0] : "process";
 168         $action = $self->_invoke_as_component( $c, $command, $method );
 169     }
 170
 171     return $action, \@args;
 172 }
 173
 174 =head2 $self->visit( $c, $command [, \@arguments ] )
 175
 176 Documented in L<Catalyst>
 177
 178 =cut
 179
 180 sub visit {
 181     my $self = shift;
 182     $self->_do_visit('visit', @_);
 183 }
 184
 185 sub _do_visit {
 186     my $self = shift;
 187     my $opname = shift;
 188     my ( $c, $command ) = @_;
 189     my ( $action, $args ) = $self->_command2action(@_);
 190     my $error = qq/Couldn't $opname("$command"): /;
 191
 192     if (!$action) {
 193         $error .= qq/Couldn't $opname to command "$command": /
 194                  .qq/Invalid action or component./;
 195     }
 196     elsif (!defined $action->namespace) {
 197         $error .= qq/Action has no namespace: cannot $opname() to a plain /
 198                  .qq/method or component, must be a :Action or some sort./
 199     }
 200     elsif (!$action->class->can('_DISPATCH')) {
 201         $error .= qq/Action cannot _DISPATCH. /
 202                  .qq/Did you try to $opname() a non-controller action?/;
 203     }
 204     else {
 205         $error = q();
 206     }
 207
 208     if($error) {
 209         $c->error($error);
 210         $c->log->debug($error) if $c->debug;
 211         return 0;
 212     }
 213
 214     $action = $self->expand_action($action);
 215
 216     local $c->request->{arguments} = $args;
 217     local $c->{namespace} = $action->{'namespace'};
 218     local $c->{action} = $action;
 219
 220     $self->dispatch($c);
 221 }
 222
 223 =head2 $self->go( $c, $command [, \@arguments ] )
 224
 225 Documented in L<Catalyst>
 226
 227 =cut
 228
 229 sub go {
 230     my $self = shift;
 231     $self->_do_visit('go', @_);
 232     die $Catalyst::GO;
 233 }
 234
 235 =head2 $self->forward( $c, $command [, \@arguments ] )
 236
 237 Documented in L<Catalyst>
 238
 239 =cut
 240
 241 sub forward {
 242     my $self = shift;
 243     my ( $c, $command ) = @_;
 244     my ( $action, $args ) = $self->_command2action(@_);
 245
 246     unless ($action) {
 247         my $error =
 248             qq/Couldn't forward to command "$command": /
 249           . qq/Invalid action or component./;
 250         $c->error($error);
 251         $c->log->debug($error) if $c->debug;
 252         return 0;
 253     }
 254
 255     local $c->request->{arguments} = $args;
 256     $action->dispatch( $c );
 257
 258     return $c->state;
 259 }
 260
 261 sub _action_rel2abs {
 262     my ( $self, $c, $path ) = @_;
 263
 264     unless ( $path =~ m#^/# ) {
 265         my $namespace = $c->stack->[-1]->namespace;
 266         $path = "$namespace/$path";
 267     }
 268
 269     $path =~ s#^/##;
 270     return $path;
 271 }
 272
 273 sub _invoke_as_path {
 274     my ( $self, $c, $rel_path, $args ) = @_;
 275
 276     my $path = $self->_action_rel2abs( $c, $rel_path );
 277
 278     my ( $tail, @extra_args );
 279     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 280     {                           # allow $path to be empty
 281         if ( my $action = $c->get_action( $tail, $path ) ) {
 282             push @$args, @extra_args;
 283             return $action;
 284         }
 285         else {
 286             return
 287               unless $path
 288               ; # if a match on the global namespace failed then the whole lookup failed
 289         }
 290
 291         unshift @extra_args, $tail;
 292     }
 293 }
 294
 295 sub _find_component_class {
 296     my ( $self, $c, $component ) = @_;
 297
 298     return ref($component)
 299       || ref( $c->component($component) )
 300       || $c->component($component);
 301 }
 302
 303 sub _invoke_as_component {
 304     my ( $self, $c, $component, $method ) = @_;
 305
 306     my $class = $self->_find_component_class( $c, $component ) || return 0;
 307
 308     if ( my $code = $class->can($method) ) {
 309         return $self->method_action_class->new(
 310             {
 311                 name      => $method,
 312                 code      => $code,
 313                 reverse   => "$class->$method",
 314                 class     => $class,
 315                 namespace => Catalyst::Utils::class2prefix(
 316                     $class, $c->config->{case_sensitive}
 317                 ),
 318             }
 319         );
 320     }
 321     else {
 322         my $error =
 323           qq/Couldn't forward to "$class". Does not implement "$method"/;
 324         $c->error($error);
 325         $c->log->debug($error)
 326           if $c->debug;
 327         return 0;
 328     }
 329 }
 330
 331 =head2 $self->prepare_action($c)
 332
 333 Find an dispatch type that matches $c->req->path, and set args from it.
 334
 335 =cut
 336
 337 sub prepare_action {
 338     my ( $self, $c ) = @_;
 339     my $path = $c->req->path;
 340     my @path = split /\//, $c->req->path;
 341     $c->req->args( \my @args );
 342
 343     unshift( @path, '' );    # Root action
 344
 345   DESCEND: while (@path) {
 346         $path = join '/', @path;
 347         $path =~ s#^/##;
 348
 349         $path = '' if $path eq '/';    # Root action
 350
 351         # Check out dispatch types to see if any will handle the path at
 352         # this level
 353
 354         foreach my $type ( @{ $self->dispatch_types } ) {
 355             last DESCEND if $type->match( $c, $path );
 356         }
 357
 358         # If not, move the last part path to args
 359         my $arg = pop(@path);
 360         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 361         unshift @args, $arg;
 362     }
 363
 364     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$c->req->captures||[]};
 365
 366     $c->log->debug( 'Path is "' . $c->req->match . '"' )
 367       if ( $c->debug && length $c->req->match );
 368
 369     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 370       if ( $c->debug && @args );
 371 }
 372
 373 =head2 $self->get_action( $action, $namespace )
 374
 375 returns a named action from a given namespace.
 376
 377 =cut
 378
 379 sub get_action {
 380     my ( $self, $name, $namespace ) = @_;
 381     return unless $name;
 382
 383     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 384
 385     return $self->action_hash->{"$namespace/$name"};
 386 }
 387
 388 =head2 $self->get_action_by_path( $path );
 389
 390 Returns the named action by its full path.
 391
 392 =cut
 393
 394 sub get_action_by_path {
 395     my ( $self, $path ) = @_;
 396     $path =~ s/^\///;
 397     $path = "/$path" unless $path =~ /\//;
 398     $self->action_hash->{$path};
 399 }
 400
 401 =head2 $self->get_actions( $c, $action, $namespace )
 402
 403 =cut
 404
 405 sub get_actions {
 406     my ( $self, $c, $action, $namespace ) = @_;
 407     return [] unless $action;
 408
 409     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 410
 411     my @match = $self->get_containers($namespace);
 412
 413     return map { $_->get_action($action) } @match;
 414 }
 415
 416 =head2 $self->get_containers( $namespace )
 417
 418 Return all the action containers for a given namespace, inclusive
 419
 420 =cut
 421
 422 sub get_containers {
 423     my ( $self, $namespace ) = @_;
 424     $namespace ||= '';
 425     $namespace = '' if $namespace eq '/';
 426
 427     my @containers;
 428
 429     if ( length $namespace ) {
 430         do {
 431             push @containers, $self->container_hash->{$namespace};
 432         } while ( $namespace =~ s#/[^/]+$## );
 433     }
 434
 435     return reverse grep { defined } @containers, $self->container_hash->{''};
 436
 437     my @parts = split '/', $namespace;
 438 }
 439
 440 =head2 $self->uri_for_action($action, \@captures)
 441
 442 Takes a Catalyst::Action object and action parameters and returns a URI
 443 part such that if $c->req->path were this URI part, this action would be
 444 dispatched to with $c->req->captures set to the supplied arrayref.
 445
 446 If the action object is not available for external dispatch or the dispatcher
 447 cannot determine an appropriate URI, this method will return undef.
 448
 449 =cut
 450
 451 sub uri_for_action {
 452     my ( $self, $action, $captures) = @_;
 453     $captures ||= [];
 454     foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
 455         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 456         return( $uri eq '' ? '/' : $uri )
 457             if defined($uri);
 458     }
 459     return undef;
 460 }
 461
 462 =head2 expand_action
 463
 464 expand an action into a full representation of the dispatch.
 465 mostly useful for chained, other actions will just return a
 466 single action.
 467
 468 =cut
 469
 470 sub expand_action {
 471     my ($self, $action) = @_;
 472
 473     foreach my $dispatch_type (@{ $self->dispatch_types }) {
 474         my $expanded = $dispatch_type->expand_action($action);
 475         return $expanded if $expanded;
 476     }
 477
 478     return $action;
 479 }
 480
 481 =head2 $self->register( $c, $action )
 482
 483 Make sure all required dispatch types for this action are loaded, then
 484 pass the action to our dispatch types so they can register it if required.
 485 Also, set up the tree with the action containers.
 486
 487 =cut
 488
 489 sub register {
 490     my ( $self, $c, $action ) = @_;
 491
 492     my $registered = $self->registered_dispatch_types;
 493
 494     my $priv = 0;
 495     foreach my $key ( keys %{ $action->attributes } ) {
 496         next if $key eq 'Private';
 497         my $class = "Catalyst::DispatchType::$key";
 498         unless ( $registered->{$class} ) {
 499             eval "require $class";
 500             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 501             $registered->{$class} = 1;
 502         }
 503     }
 504
 505     # Pass the action to our dispatch types so they can register it if reqd.
 506     foreach my $type ( @{ $self->dispatch_types } ) {
 507         $type->register( $c, $action );
 508     }
 509
 510     my $namespace = $action->namespace;
 511     my $name      = $action->name;
 512
 513     my $container = $self->_find_or_create_action_container($namespace);
 514
 515     # Set the method value
 516     $container->add_action($action);
 517
 518     $self->action_hash->{"$namespace/$name"} = $action;
 519     $self->container_hash->{$namespace} = $container;
 520 }
 521
 522 sub _find_or_create_action_container {
 523     my ( $self, $namespace ) = @_;
 524
 525     my $tree ||= $self->tree;
 526
 527     return $tree->getNodeValue unless $namespace;
 528
 529     my @namespace = split '/', $namespace;
 530     return $self->_find_or_create_namespace_node( $tree, @namespace )
 531       ->getNodeValue;
 532 }
 533
 534 sub _find_or_create_namespace_node {
 535     my ( $self, $parent, $part, @namespace ) = @_;
 536
 537     return $parent unless $part;
 538
 539     my $child =
 540       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 541
 542     unless ($child) {
 543         my $container = Catalyst::ActionContainer->new($part);
 544         $parent->addChild( $child = Tree::Simple->new($container) );
 545     }
 546
 547     $self->_find_or_create_namespace_node( $child, @namespace );
 548 }
 549
 550 =head2 $self->setup_actions( $class, $context )
 551
 552
 553 =cut
 554
 555 sub setup_actions {
 556     my ( $self, $c ) = @_;
 557
 558     $self->dispatch_types( [] );
 559     $self->registered_dispatch_types( {} );
 560     $self->method_action_class('Catalyst::Action');
 561     $self->action_container_class('Catalyst::ActionContainer');
 562
 563     my @classes =
 564       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 565     @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
 566
 567     foreach my $comp ( values %{ $c->components } ) {
 568         $comp->register_actions($c) if $comp->can('register_actions');
 569     }
 570
 571     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 572
 573     return unless $c->debug;
 574
 575     my $column_width = Catalyst::Utils::term_width() - 20 - 36 - 12;
 576     my $privates = Text::SimpleTable->new(
 577         [ 20, 'Private' ], [ 36, 'Class' ], [ $column_width, '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;