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->dispatch($c)
  88
  89 Delegate the dispatch to the action that matched the url, or return a
  90 message about unknown resource
  91
  92
  93 =cut
  94
  95 sub dispatch {
  96     my ( $self, $c ) = @_;
  97     if ( my $action = $c->action ) {
  98         $c->forward( join( '/', '', $action->namespace, '_DISPATCH' ) );
  99     }
 100
 101     else {
 102         my $path  = $c->req->path;
 103         my $error = $path
 104           ? qq/Unknown resource "$path"/
 105           : "No default action defined";
 106         $c->log->error($error) if $c->debug;
 107         $c->error($error);
 108     }
 109 }
 110
 111 # $self->_command2action( $c, $command [, \@arguments ] )
 112 # Search for an action, from the command and returns C<($action, $args)> on
 113 # success. Returns C<(0)> on error.
 114
 115 sub _command2action {
 116     my ( $self, $c, $command, @extra_params ) = @_;
 117
 118     unless ($command) {
 119         $c->log->debug('Nothing to go to') if $c->debug;
 120         return 0;
 121     }
 122
 123     my @args;
 124
 125     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
 126         @args = @{ pop @extra_params }
 127     } else {
 128         # this is a copy, it may take some abuse from
 129         # ->_invoke_as_path if the path had trailing parts
 130         @args = @{ $c->request->arguments };
 131     }
 132
 133     my $action;
 134
 135     # go to a string path ("/foo/bar/gorch")
 136     # or action object which stringifies to that
 137     $action = $self->_invoke_as_path( $c, "$command", \@args );
 138
 139     # go to a component ( "MyApp::*::Foo" or $c->component("...")
 140     # - a path or an object)
 141     unless ($action) {
 142         my $method = @extra_params ? $extra_params[0] : "process";
 143         $action = $self->_invoke_as_component( $c, $command, $method );
 144     }
 145
 146     return $action, \@args;
 147 }
 148
 149 =head2 $self->visit( $c, $command [, \@arguments ] )
 150
 151 Documented in L<Catalyst>
 152
 153 =cut
 154
 155 sub visit {
 156     my $self = shift;
 157     $self->_do_visit('visit', @_);
 158 }
 159
 160 sub _do_visit {
 161     my $self = shift;
 162     my $opname = shift;
 163     my ( $c, $command ) = @_;
 164     my ( $action, $args ) = $self->_command2action(@_);
 165     my $error = qq/Couldn't $opname("$command"): /;
 166
 167     if (!$action) {
 168         $error .= qq/Couldn't $opname to command "$command": /
 169                  .qq/Invalid action or component./;
 170     }
 171     elsif (!defined $action->namespace) {
 172         $error .= qq/Action has no namespace: cannot $opname() to a plain /
 173                  .qq/method or component, must be a :Action or some sort./
 174     }
 175     elsif (!$action->class->can('_DISPATCH')) {
 176         $error .= qq/Action cannot _DISPATCH. /
 177                  .qq/Did you try to $opname() a non-controller action?/;
 178     }
 179     else {
 180         $error = q();
 181     }
 182
 183     if($error) {
 184         $c->error($error);
 185         $c->log->debug($error) if $c->debug;
 186         return 0;
 187     }
 188
 189     $action = $self->expand_action($action);
 190
 191     local $c->request->{arguments} = $args;
 192     local $c->{namespace} = $action->{'namespace'};
 193     local $c->{action} = $action;
 194
 195     $self->dispatch($c);
 196 }
 197
 198 =head2 $self->go( $c, $command [, \@arguments ] )
 199
 200 Documented in L<Catalyst>
 201
 202 =cut
 203
 204 sub go {
 205     my $self = shift;
 206     $self->_do_visit('go', @_);
 207     die $Catalyst::GO;
 208 }
 209
 210 =head2 $self->forward( $c, $command [, \@arguments ] )
 211
 212 Documented in L<Catalyst>
 213
 214 =cut
 215
 216 sub forward {
 217     my $self = shift;
 218     $self->_do_forward(forward => @_);
 219 }
 220
 221 sub _do_forward {
 222     my $self = shift;
 223     my $opname = shift;
 224     my ( $c, $command ) = @_;
 225     my ( $action, $args ) = $self->_command2action(@_);
 226
 227     if (!$action) {
 228         my $error .= qq/Couldn't $opname to command "$command": /
 229                     .qq/Invalid action or component./;
 230         $c->error($error);
 231         $c->log->debug($error) if $c->debug;
 232         return 0;
 233     }
 234
 235     no warnings 'recursion';
 236
 237     my $orig_args = $c->request->arguments();
 238     $c->request->arguments($args);
 239     $action->dispatch( $c );
 240     $c->request->arguments($orig_args);
 241
 242     return $c->state;
 243 }
 244
 245 =head2 $self->detach( $c, $command [, \@arguments ] )
 246
 247 Documented in L<Catalyst>
 248
 249 =cut
 250
 251 sub detach {
 252     my ( $self, $c, $command, @args ) = @_;
 253     $self->_do_forward(detach => $c, $command, @args ) if $command;
 254     die $Catalyst::DETACH;
 255 }
 256
 257 sub _action_rel2abs {
 258     my ( $self, $c, $path ) = @_;
 259
 260     unless ( $path =~ m#^/# ) {
 261         my $namespace = $c->stack->[-1]->namespace;
 262         $path = "$namespace/$path";
 263     }
 264
 265     $path =~ s#^/##;
 266     return $path;
 267 }
 268
 269 sub _invoke_as_path {
 270     my ( $self, $c, $rel_path, $args ) = @_;
 271
 272     my $path = $self->_action_rel2abs( $c, $rel_path );
 273
 274     my ( $tail, @extra_args );
 275     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 276     {                           # allow $path to be empty
 277         if ( my $action = $c->get_action( $tail, $path ) ) {
 278             push @$args, @extra_args;
 279             return $action;
 280         }
 281         else {
 282             return
 283               unless $path
 284               ; # if a match on the global namespace failed then the whole lookup failed
 285         }
 286
 287         unshift @extra_args, $tail;
 288     }
 289 }
 290
 291 sub _find_component_class {
 292     my ( $self, $c, $component ) = @_;
 293
 294     return ref($component)
 295       || ref( $c->component($component) )
 296       || $c->component($component);
 297 }
 298
 299 sub _invoke_as_component {
 300     my ( $self, $c, $component, $method ) = @_;
 301
 302     my $class = $self->_find_component_class( $c, $component ) || return 0;
 303
 304     if ( my $code = $class->can($method) ) {
 305         return $self->_method_action_class->new(
 306             {
 307                 name      => $method,
 308                 code      => $code,
 309                 reverse   => "$class->$method",
 310                 class     => $class,
 311                 namespace => Catalyst::Utils::class2prefix(
 312                     $class, $c->config->{case_sensitive}
 313                 ),
 314             }
 315         );
 316     }
 317     else {
 318         my $error =
 319           qq/Couldn't forward to "$class". Does not implement "$method"/;
 320         $c->error($error);
 321         $c->log->debug($error)
 322           if $c->debug;
 323         return 0;
 324     }
 325 }
 326
 327 =head2 $self->prepare_action($c)
 328
 329 Find an dispatch type that matches $c->req->path, and set args from it.
 330
 331 =cut
 332
 333 sub prepare_action {
 334     my ( $self, $c ) = @_;
 335     my $req = $c->req;
 336     my $path = $req->path;
 337     my @path = split /\//, $req->path;
 338     $req->args( \my @args );
 339
 340     unshift( @path, '' );    # Root action
 341
 342   DESCEND: while (@path) {
 343         $path = join '/', @path;
 344         $path =~ s#^/##;
 345
 346         $path = '' if $path eq '/';    # Root action
 347
 348         # Check out dispatch types to see if any will handle the path at
 349         # this level
 350
 351         foreach my $type ( @{ $self->_dispatch_types } ) {
 352             last DESCEND if $type->match( $c, $path );
 353         }
 354
 355         # If not, move the last part path to args
 356         my $arg = pop(@path);
 357         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 358         unshift @args, $arg;
 359     }
 360
 361     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 362
 363     $c->log->debug( 'Path is "' . $req->match . '"' )
 364       if ( $c->debug && defined $req->match && length $req->match );
 365
 366     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 367       if ( $c->debug && @args );
 368 }
 369
 370 =head2 $self->get_action( $action, $namespace )
 371
 372 returns a named action from a given namespace.
 373
 374 =cut
 375
 376 sub get_action {
 377     my ( $self, $name, $namespace ) = @_;
 378     return unless $name;
 379
 380     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 381
 382     return $self->_action_hash->{"${namespace}/${name}"};
 383 }
 384
 385 =head2 $self->get_action_by_path( $path );
 386
 387 Returns the named action by its full path.
 388
 389 =cut
 390
 391 sub get_action_by_path {
 392     my ( $self, $path ) = @_;
 393     $path =~ s/^\///;
 394     $path = "/$path" unless $path =~ /\//;
 395     $self->_action_hash->{$path};
 396 }
 397
 398 =head2 $self->get_actions( $c, $action, $namespace )
 399
 400 =cut
 401
 402 sub get_actions {
 403     my ( $self, $c, $action, $namespace ) = @_;
 404     return [] unless $action;
 405
 406     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 407
 408     my @match = $self->get_containers($namespace);
 409
 410     return map { $_->get_action($action) } @match;
 411 }
 412
 413 =head2 $self->get_containers( $namespace )
 414
 415 Return all the action containers for a given namespace, inclusive
 416
 417 =cut
 418
 419 sub get_containers {
 420     my ( $self, $namespace ) = @_;
 421     $namespace ||= '';
 422     $namespace = '' if $namespace eq '/';
 423
 424     my @containers;
 425
 426     if ( length $namespace ) {
 427         do {
 428             push @containers, $self->_container_hash->{$namespace};
 429         } while ( $namespace =~ s#/[^/]+$## );
 430     }
 431
 432     return reverse grep { defined } @containers, $self->_container_hash->{''};
 433
 434     #return (split '/', $namespace); # isnt this more clear?
 435     my @parts = split '/', $namespace;
 436 }
 437
 438 =head2 $self->uri_for_action($action, \@captures)
 439
 440 Takes a Catalyst::Action object and action parameters and returns a URI
 441 part such that if $c->req->path were this URI part, this action would be
 442 dispatched to with $c->req->captures set to the supplied arrayref.
 443
 444 If the action object is not available for external dispatch or the dispatcher
 445 cannot determine an appropriate URI, this method will return undef.
 446
 447 =cut
 448
 449 sub uri_for_action {
 450     my ( $self, $action, $captures) = @_;
 451     $captures ||= [];
 452     foreach my $dispatch_type ( @{ $self->_dispatch_types } ) {
 453         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 454         return( $uri eq '' ? '/' : $uri )
 455             if defined($uri);
 456     }
 457     return undef;
 458 }
 459
 460 =head2 expand_action
 461
 462 expand an action into a full representation of the dispatch.
 463 mostly useful for chained, other actions will just return a
 464 single action.
 465
 466 =cut
 467
 468 sub expand_action {
 469     my ($self, $action) = @_;
 470
 471     foreach my $dispatch_type (@{ $self->_dispatch_types }) {
 472         my $expanded = $dispatch_type->expand_action($action);
 473         return $expanded if $expanded;
 474     }
 475
 476     return $action;
 477 }
 478
 479 =head2 $self->register( $c, $action )
 480
 481 Make sure all required dispatch types for this action are loaded, then
 482 pass the action to our dispatch types so they can register it if required.
 483 Also, set up the tree with the action containers.
 484
 485 =cut
 486
 487 sub register {
 488     my ( $self, $c, $action ) = @_;
 489
 490     my $registered = $self->_registered_dispatch_types;
 491
 492     #my $priv = 0; #seems to be unused
 493     foreach my $key ( keys %{ $action->attributes } ) {
 494         next if $key eq 'Private';
 495         my $class = "Catalyst::DispatchType::$key";
 496         unless ( $registered->{$class} ) {
 497             #some error checking rethrowing here wouldn't hurt.
 498             eval { Class::MOP::load_class($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
 558     my @classes =
 559       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 560     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 561
 562     foreach my $comp ( values %{ $c->components } ) {
 563         $comp->register_actions($c) if $comp->can('register_actions');
 564     }
 565
 566     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 567
 568     return unless $c->debug;
 569
 570     my $privates = Text::SimpleTable->new(
 571         [ 20, 'Private' ],
 572         [ 36, 'Class' ],
 573         [ 12, 'Method' ]
 574     );
 575
 576     my $has_private = 0;
 577     my $walker = sub {
 578         my ( $walker, $parent, $prefix ) = @_;
 579         $prefix .= $parent->getNodeValue || '';
 580         $prefix .= '/' unless $prefix =~ /\/$/;
 581         my $node = $parent->getNodeValue->actions;
 582
 583         for my $action ( keys %{$node} ) {
 584             my $action_obj = $node->{$action};
 585             next
 586               if ( ( $action =~ /^_.*/ )
 587                 && ( !$c->config->{show_internal_actions} ) );
 588             $privates->row( "$prefix$action", $action_obj->class, $action );
 589             $has_private = 1;
 590         }
 591
 592         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 593     };
 594
 595     $walker->( $walker, $self->_tree, '' );
 596     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 597       if $has_private;
 598
 599     # List all public actions
 600     $_->list($c) for @{ $self->_dispatch_types };
 601 }
 602
 603 sub _load_dispatch_types {
 604     my ( $self, @types ) = @_;
 605
 606     my @loaded;
 607
 608     # Preload action types
 609     for my $type (@types) {
 610         my $class =
 611           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 612
 613         eval { Class::MOP::load_class($class) };
 614         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 615           if $@;
 616         push @{ $self->_dispatch_types }, $class->new;
 617
 618         push @loaded, $class;
 619     }
 620
 621     return @loaded;
 622 }
 623
 624 no Moose;
 625 __PACKAGE__->meta->make_immutable;
 626
 627 =head2 meta
 628
 629 Provided by Moose
 630
 631 =head1 AUTHORS
 632
 633 Catalyst Contributors, see Catalyst.pm
 634
 635 =head1 COPYRIGHT
 636
 637 This program is free software, you can redistribute it and/or modify it under
 638 the same terms as Perl itself.
 639
 640 =cut
 641
 642 1;