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 =head2 $self->forward( $c, $command [, \@arguments ] )
 124
 125 Documented in L<Catalyst>
 126
 127 =cut
 128
 129 sub forward {
 130     my ( $self, $c, $command, @extra_params ) = @_;
 131
 132     unless ($command) {
 133         $c->log->debug('Nothing to forward to') if $c->debug;
 134         return 0;
 135     }
 136
 137     my @args;
 138
 139     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
 140         @args = @{ pop @extra_params }
 141     } else {
 142         # this is a copy, it may take some abuse from ->_invoke_as_path if the path had trailing parts
 143         @args = @{ $c->request->arguments };
 144     }
 145
 146     my $action;
 147
 148     # forward to a string path ("/foo/bar/gorch") or action object which stringifies to that
 149     $action = $self->_invoke_as_path( $c, "$command", \@args );
 150
 151     # forward to a component ( "MyApp::*::Foo" or $c->component("...") - a path or an object)
 152     unless ($action) {
 153         my $method = @extra_params ? $extra_params[0] : "process";
 154         $action = $self->_invoke_as_component( $c, $command, $method );
 155     }
 156
 157
 158     unless ($action) {
 159         my $error =
 160             qq/Couldn't forward to command "$command": /
 161           . qq/Invalid action or component./;
 162         $c->error($error);
 163         $c->log->debug($error) if $c->debug;
 164         return 0;
 165     }
 166
 167     #push @$args, @_;
 168
 169     no warnings 'recursion';
 170
 171     my $orig_args = $c->request->arguments();
 172     $c->request->arguments(\@args);
 173     $action->dispatch( $c );
 174     $c->request->arguments($orig_args);
 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     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 284
 285     $c->log->debug( 'Path is "' . $req->match . '"' )
 286       if ( $c->debug && $req->match );
 287
 288     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 289       if ( $c->debug && @args );
 290 }
 291
 292 =head2 $self->get_action( $action, $namespace )
 293
 294 returns a named action from a given namespace.
 295
 296 =cut
 297
 298 sub get_action {
 299     my ( $self, $name, $namespace ) = @_;
 300     return unless $name;
 301
 302     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 303
 304     return $self->_action_hash->{"${namespace}/${name}"};
 305 }
 306
 307 =head2 $self->get_action_by_path( $path );
 308
 309 Returns the named action by its full path.
 310
 311 =cut
 312
 313 sub get_action_by_path {
 314     my ( $self, $path ) = @_;
 315     $path =~ s/^\///;
 316     $path = "/$path" unless $path =~ /\//;
 317     $self->_action_hash->{$path};
 318 }
 319
 320 =head2 $self->get_actions( $c, $action, $namespace )
 321
 322 =cut
 323
 324 sub get_actions {
 325     my ( $self, $c, $action, $namespace ) = @_;
 326     return [] unless $action;
 327
 328     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 329
 330     my @match = $self->get_containers($namespace);
 331
 332     return map { $_->get_action($action) } @match;
 333 }
 334
 335 =head2 $self->get_containers( $namespace )
 336
 337 Return all the action containers for a given namespace, inclusive
 338
 339 =cut
 340
 341 sub get_containers {
 342     my ( $self, $namespace ) = @_;
 343     $namespace ||= '';
 344     $namespace = '' if $namespace eq '/';
 345
 346     my @containers;
 347
 348     if ( length $namespace ) {
 349         do {
 350             push @containers, $self->_container_hash->{$namespace};
 351         } while ( $namespace =~ s#/[^/]+$## );
 352     }
 353
 354     return reverse grep { defined } @containers, $self->_container_hash->{''};
 355
 356     #return (split '/', $namespace); # isnt this more clear?
 357     my @parts = split '/', $namespace;
 358 }
 359
 360 =head2 $self->uri_for_action($action, \@captures)
 361
 362 Takes a Catalyst::Action object and action parameters and returns a URI
 363 part such that if $c->req->path were this URI part, this action would be
 364 dispatched to with $c->req->captures set to the supplied arrayref.
 365
 366 If the action object is not available for external dispatch or the dispatcher
 367 cannot determine an appropriate URI, this method will return undef.
 368
 369 =cut
 370
 371 sub uri_for_action {
 372     my ( $self, $action, $captures) = @_;
 373     $captures ||= [];
 374     foreach my $dispatch_type ( @{ $self->_dispatch_types } ) {
 375         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 376         return( $uri eq '' ? '/' : $uri )
 377             if defined($uri);
 378     }
 379     return undef;
 380 }
 381
 382 =head2 $self->register( $c, $action )
 383
 384 Make sure all required dispatch types for this action are loaded, then
 385 pass the action to our dispatch types so they can register it if required.
 386 Also, set up the tree with the action containers.
 387
 388 =cut
 389
 390 sub register {
 391     my ( $self, $c, $action ) = @_;
 392
 393     my $registered = $self->_registered_dispatch_types;
 394
 395     #my $priv = 0; #seems to be unused
 396     foreach my $key ( keys %{ $action->attributes } ) {
 397         next if $key eq 'Private';
 398         my $class = "Catalyst::DispatchType::$key";
 399         unless ( $registered->{$class} ) {
 400             #some error checking rethrowing here wouldn't hurt.
 401             eval { Class::MOP::load_class($class) };
 402             push( @{ $self->_dispatch_types }, $class->new ) unless $@;
 403             $registered->{$class} = 1;
 404         }
 405     }
 406
 407     # Pass the action to our dispatch types so they can register it if reqd.
 408     foreach my $type ( @{ $self->_dispatch_types } ) {
 409         $type->register( $c, $action );
 410     }
 411
 412     my $namespace = $action->namespace;
 413     my $name      = $action->name;
 414
 415     my $container = $self->_find_or_create_action_container($namespace);
 416
 417     # Set the method value
 418     $container->add_action($action);
 419
 420     $self->_action_hash->{"$namespace/$name"} = $action;
 421     $self->_container_hash->{$namespace} = $container;
 422 }
 423
 424 sub _find_or_create_action_container {
 425     my ( $self, $namespace ) = @_;
 426
 427     my $tree ||= $self->_tree;
 428
 429     return $tree->getNodeValue unless $namespace;
 430
 431     my @namespace = split '/', $namespace;
 432     return $self->_find_or_create_namespace_node( $tree, @namespace )
 433       ->getNodeValue;
 434 }
 435
 436 sub _find_or_create_namespace_node {
 437     my ( $self, $parent, $part, @namespace ) = @_;
 438
 439     return $parent unless $part;
 440
 441     my $child =
 442       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 443
 444     unless ($child) {
 445         my $container = Catalyst::ActionContainer->new($part);
 446         $parent->addChild( $child = Tree::Simple->new($container) );
 447     }
 448
 449     $self->_find_or_create_namespace_node( $child, @namespace );
 450 }
 451
 452 =head2 $self->setup_actions( $class, $context )
 453
 454
 455 =cut
 456
 457 sub setup_actions {
 458     my ( $self, $c ) = @_;
 459
 460
 461     my @classes =
 462       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 463     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 464
 465     foreach my $comp ( values %{ $c->components } ) {
 466         $comp->register_actions($c) if $comp->can('register_actions');
 467     }
 468
 469     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 470
 471     return unless $c->debug;
 472
 473     my $privates = Text::SimpleTable->new(
 474         [ 20, 'Private' ],
 475         [ 36, 'Class' ],
 476         [ 12, 'Method' ]
 477     );
 478
 479     my $has_private = 0;
 480     my $walker = sub {
 481         my ( $walker, $parent, $prefix ) = @_;
 482         $prefix .= $parent->getNodeValue || '';
 483         $prefix .= '/' unless $prefix =~ /\/$/;
 484         my $node = $parent->getNodeValue->actions;
 485
 486         for my $action ( keys %{$node} ) {
 487             my $action_obj = $node->{$action};
 488             next
 489               if ( ( $action =~ /^_.*/ )
 490                 && ( !$c->config->{show_internal_actions} ) );
 491             $privates->row( "$prefix$action", $action_obj->class, $action );
 492             $has_private = 1;
 493         }
 494
 495         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 496     };
 497
 498     $walker->( $walker, $self->_tree, '' );
 499     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 500       if $has_private;
 501
 502     # List all public actions
 503     $_->list($c) for @{ $self->_dispatch_types };
 504 }
 505
 506 sub _load_dispatch_types {
 507     my ( $self, @types ) = @_;
 508
 509     my @loaded;
 510
 511     # Preload action types
 512     for my $type (@types) {
 513         my $class =
 514           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 515
 516         eval { Class::MOP::load_class($class) };
 517         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 518           if $@;
 519         push @{ $self->_dispatch_types }, $class->new;
 520
 521         push @loaded, $class;
 522     }
 523
 524     return @loaded;
 525 }
 526
 527 no Moose;
 528 __PACKAGE__->meta->make_immutable;
 529
 530 =head2 meta
 531
 532 Provided by Moose
 533
 534 =head1 AUTHOR
 535
 536 Sebastian Riedel, C<sri@cpan.org>
 537 Matt S Trout, C<mst@shadowcatsystems.co.uk>
 538
 539 =head1 COPYRIGHT
 540
 541 This program is free software, you can redistribute it and/or modify it under
 542 the same terms as Perl itself.
 543
 544 =cut
 545
 546 1;