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