lib/Catalyst/Dispatcher.pm

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