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