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