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