lib/Catalyst/Dispatcher.pm

   1 package Catalyst::Dispatcher;
   2
   3 use MRO::Compat;
   4 use mro 'c3';
   5 use Moose;
   6 use Class::MOP;
   7
   8 use Catalyst::Exception;
   9 use Catalyst::Utils;
  10 use Catalyst::Action;
  11 use Catalyst::ActionContainer;
  12 use Catalyst::DispatchType::Default;
  13 use Catalyst::DispatchType::Index;
  14 use Text::SimpleTable;
  15 use Tree::Simple;
  16 use Tree::Simple::Visitor::FindByPath;
  17 use Scalar::Util ();
  18
  19 #do these belong as package vars or should we build these via a builder method?
  20 # Preload these action types
  21 our @PRELOAD = qw/Index Path Regex/;
  22
  23 # Postload these action types
  24 our @POSTLOAD = qw/Default/;
  25
  26 has _tree => (is => 'rw');
  27 has _dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1);
  28 has _registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1);
  29 has _method_action_class => (is => 'rw', default => 'Catalyst::Action');
  30 has _action_container_class => (is => 'rw', default => 'Catalyst::ActionContainer');
  31
  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     my $orig_args = $c->request->arguments();
 174     $c->request->arguments(\@args);
 175     $action->dispatch( $c );
 176     $c->request->arguments($orig_args);
 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     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 286
 287     $c->log->debug( 'Path is "' . $req->match . '"' )
 288       if ( $c->debug && $req->match );
 289
 290     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 291       if ( $c->debug && @args );
 292 }
 293
 294 =head2 $self->get_action( $action, $namespace )
 295
 296 returns a named action from a given namespace.
 297
 298 =cut
 299
 300 sub get_action {
 301     my ( $self, $name, $namespace ) = @_;
 302     return unless $name;
 303
 304     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 305
 306     return $self->_action_hash->{"${namespace}/${name}"};
 307 }
 308
 309 =head2 $self->get_action_by_path( $path );
 310
 311 Returns the named action by its full path.
 312
 313 =cut
 314
 315 sub get_action_by_path {
 316     my ( $self, $path ) = @_;
 317     $path =~ s/^\///;
 318     $path = "/$path" unless $path =~ /\//;
 319     $self->_action_hash->{$path};
 320 }
 321
 322 =head2 $self->get_actions( $c, $action, $namespace )
 323
 324 =cut
 325
 326 sub get_actions {
 327     my ( $self, $c, $action, $namespace ) = @_;
 328     return [] unless $action;
 329
 330     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 331
 332     my @match = $self->get_containers($namespace);
 333
 334     return map { $_->get_action($action) } @match;
 335 }
 336
 337 =head2 $self->get_containers( $namespace )
 338
 339 Return all the action containers for a given namespace, inclusive
 340
 341 =cut
 342
 343 sub get_containers {
 344     my ( $self, $namespace ) = @_;
 345     $namespace ||= '';
 346     $namespace = '' if $namespace eq '/';
 347
 348     my @containers;
 349
 350     if ( length $namespace ) {
 351         do {
 352             push @containers, $self->_container_hash->{$namespace};
 353         } while ( $namespace =~ s#/[^/]+$## );
 354     }
 355
 356     return reverse grep { defined } @containers, $self->_container_hash->{''};
 357
 358     #return (split '/', $namespace); # isnt this more clear?
 359     my @parts = split '/', $namespace;
 360 }
 361
 362 =head2 $self->uri_for_action($action, \@captures)
 363
 364 Takes a Catalyst::Action object and action parameters and returns a URI
 365 part such that if $c->req->path were this URI part, this action would be
 366 dispatched to with $c->req->captures set to the supplied arrayref.
 367
 368 If the action object is not available for external dispatch or the dispatcher
 369 cannot determine an appropriate URI, this method will return undef.
 370
 371 =cut
 372
 373 sub uri_for_action {
 374     my ( $self, $action, $captures) = @_;
 375     $captures ||= [];
 376     foreach my $dispatch_type ( @{ $self->_dispatch_types } ) {
 377         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 378         return( $uri eq '' ? '/' : $uri )
 379             if defined($uri);
 380     }
 381     return undef;
 382 }
 383
 384 =head2 $self->register( $c, $action )
 385
 386 Make sure all required dispatch types for this action are loaded, then
 387 pass the action to our dispatch types so they can register it if required.
 388 Also, set up the tree with the action containers.
 389
 390 =cut
 391
 392 sub register {
 393     my ( $self, $c, $action ) = @_;
 394
 395     my $registered = $self->_registered_dispatch_types;
 396
 397     #my $priv = 0; #seems to be unused
 398     foreach my $key ( keys %{ $action->attributes } ) {
 399         next if $key eq 'Private';
 400         my $class = "Catalyst::DispatchType::$key";
 401         unless ( $registered->{$class} ) {
 402             #some error checking rethrowing here wouldn't hurt.
 403             eval { Class::MOP::load_class($class) };
 404             push( @{ $self->_dispatch_types }, $class->new ) unless $@;
 405             $registered->{$class} = 1;
 406         }
 407     }
 408
 409     # Pass the action to our dispatch types so they can register it if reqd.
 410     foreach my $type ( @{ $self->_dispatch_types } ) {
 411         $type->register( $c, $action );
 412     }
 413
 414     my $namespace = $action->namespace;
 415     my $name      = $action->name;
 416
 417     my $container = $self->_find_or_create_action_container($namespace);
 418
 419     # Set the method value
 420     $container->add_action($action);
 421
 422     $self->_action_hash->{"$namespace/$name"} = $action;
 423     $self->_container_hash->{$namespace} = $container;
 424 }
 425
 426 sub _find_or_create_action_container {
 427     my ( $self, $namespace ) = @_;
 428
 429     my $tree ||= $self->_tree;
 430
 431     return $tree->getNodeValue unless $namespace;
 432
 433     my @namespace = split '/', $namespace;
 434     return $self->_find_or_create_namespace_node( $tree, @namespace )
 435       ->getNodeValue;
 436 }
 437
 438 sub _find_or_create_namespace_node {
 439     my ( $self, $parent, $part, @namespace ) = @_;
 440
 441     return $parent unless $part;
 442
 443     my $child =
 444       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 445
 446     unless ($child) {
 447         my $container = Catalyst::ActionContainer->new($part);
 448         $parent->addChild( $child = Tree::Simple->new($container) );
 449     }
 450
 451     $self->_find_or_create_namespace_node( $child, @namespace );
 452 }
 453
 454 =head2 $self->setup_actions( $class, $context )
 455
 456
 457 =cut
 458
 459 sub setup_actions {
 460     my ( $self, $c ) = @_;
 461
 462
 463     my @classes =
 464       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 465     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 466
 467     foreach my $comp ( values %{ $c->components } ) {
 468         $comp->register_actions($c) if $comp->can('register_actions');
 469     }
 470
 471     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 472
 473     return unless $c->debug;
 474
 475     my $privates = Text::SimpleTable->new(
 476         [ 20, 'Private' ],
 477         [ 36, 'Class' ],
 478         [ 12, 'Method' ]
 479     );
 480
 481     my $has_private = 0;
 482     my $walker = sub {
 483         my ( $walker, $parent, $prefix ) = @_;
 484         $prefix .= $parent->getNodeValue || '';
 485         $prefix .= '/' unless $prefix =~ /\/$/;
 486         my $node = $parent->getNodeValue->actions;
 487
 488         for my $action ( keys %{$node} ) {
 489             my $action_obj = $node->{$action};
 490             next
 491               if ( ( $action =~ /^_.*/ )
 492                 && ( !$c->config->{show_internal_actions} ) );
 493             $privates->row( "$prefix$action", $action_obj->class, $action );
 494             $has_private = 1;
 495         }
 496
 497         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 498     };
 499
 500     $walker->( $walker, $self->_tree, '' );
 501     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 502       if $has_private;
 503
 504     # List all public actions
 505     $_->list($c) for @{ $self->_dispatch_types };
 506 }
 507
 508 sub _load_dispatch_types {
 509     my ( $self, @types ) = @_;
 510
 511     my @loaded;
 512
 513     # Preload action types
 514     for my $type (@types) {
 515         my $class =
 516           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 517
 518         eval { Class::MOP::load_class($class) };
 519         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 520           if $@;
 521         push @{ $self->_dispatch_types }, $class->new;
 522
 523         push @loaded, $class;
 524     }
 525
 526     return @loaded;
 527 }
 528
 529 no Moose;
 530 __PACKAGE__->meta->make_immutable;
 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;