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     #moose todo: reaching inside another object is bad
 174     local $c->request->{arguments} = \@args;
 175     $action->dispatch( $c );
 176
 177     return $c->state;
 178 }
 179
 180 sub _action_rel2abs {
 181     my ( $self, $c, $path ) = @_;
 182
 183     unless ( $path =~ m#^/# ) {
 184         my $namespace = $c->stack->[-1]->namespace;
 185         $path = "$namespace/$path";
 186     }
 187
 188     $path =~ s#^/##;
 189     return $path;
 190 }
 191
 192 sub _invoke_as_path {
 193     my ( $self, $c, $rel_path, $args ) = @_;
 194
 195     my $path = $self->_action_rel2abs( $c, $rel_path );
 196
 197     my ( $tail, @extra_args );
 198     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 199     {                           # allow $path to be empty
 200         if ( my $action = $c->get_action( $tail, $path ) ) {
 201             push @$args, @extra_args;
 202             return $action;
 203         }
 204         else {
 205             return
 206               unless $path
 207               ; # if a match on the global namespace failed then the whole lookup failed
 208         }
 209
 210         unshift @extra_args, $tail;
 211     }
 212 }
 213
 214 sub _find_component_class {
 215     my ( $self, $c, $component ) = @_;
 216
 217     return ref($component)
 218       || ref( $c->component($component) )
 219       || $c->component($component);
 220 }
 221
 222 sub _invoke_as_component {
 223     my ( $self, $c, $component, $method ) = @_;
 224
 225     my $class = $self->_find_component_class( $c, $component ) || return 0;
 226
 227     if ( my $code = $class->can($method) ) {
 228         return $self->_method_action_class->new(
 229             {
 230                 name      => $method,
 231                 code      => $code,
 232                 reverse   => "$class->$method",
 233                 class     => $class,
 234                 namespace => Catalyst::Utils::class2prefix(
 235                     $class, $c->config->{case_sensitive}
 236                 ),
 237             }
 238         );
 239     }
 240     else {
 241         my $error =
 242           qq/Couldn't forward to "$class". Does not implement "$method"/;
 243         $c->error($error);
 244         $c->log->debug($error)
 245           if $c->debug;
 246         return 0;
 247     }
 248 }
 249
 250 =head2 $self->prepare_action($c)
 251
 252 Find an dispatch type that matches $c->req->path, and set args from it.
 253
 254 =cut
 255
 256 sub prepare_action {
 257     my ( $self, $c ) = @_;
 258     my $req = $c->req;
 259     my $path = $req->path;
 260     my @path = split /\//, $req->path;
 261     $req->args( \my @args );
 262
 263     unshift( @path, '' );    # Root action
 264
 265   DESCEND: while (@path) {
 266         $path = join '/', @path;
 267         $path =~ s#^/##;
 268
 269         $path = '' if $path eq '/';    # Root action
 270
 271         # Check out dispatch types to see if any will handle the path at
 272         # this level
 273
 274         foreach my $type ( @{ $self->_dispatch_types } ) {
 275             last DESCEND if $type->match( $c, $path );
 276         }
 277
 278         # If not, move the last part path to args
 279         my $arg = pop(@path);
 280         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 281         unshift @args, $arg;
 282     }
 283
 284     #Moose todo: This seems illegible, even if efficient.
 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     $self->_dispatch_types( [] );
 463     $self->_registered_dispatch_types( {} );
 464     $self->_method_action_class('Catalyst::Action');
 465     $self->_action_container_class('Catalyst::ActionContainer');
 466
 467     my @classes =
 468       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 469     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 470
 471     foreach my $comp ( values %{ $c->components } ) {
 472         $comp->register_actions($c) if $comp->can('register_actions');
 473     }
 474
 475     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 476
 477     return unless $c->debug;
 478
 479     my $privates = Text::SimpleTable->new(
 480         [ 20, 'Private' ],
 481         [ 36, 'Class' ],
 482         [ 12, 'Method' ]
 483     );
 484
 485     my $has_private = 0;
 486     my $walker = sub {
 487         my ( $walker, $parent, $prefix ) = @_;
 488         $prefix .= $parent->getNodeValue || '';
 489         $prefix .= '/' unless $prefix =~ /\/$/;
 490         my $node = $parent->getNodeValue->actions;
 491
 492         for my $action ( keys %{$node} ) {
 493             my $action_obj = $node->{$action};
 494             next
 495               if ( ( $action =~ /^_.*/ )
 496                 && ( !$c->config->{show_internal_actions} ) );
 497             $privates->row( "$prefix$action", $action_obj->class, $action );
 498             $has_private = 1;
 499         }
 500
 501         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 502     };
 503
 504     $walker->( $walker, $self->_tree, '' );
 505     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 506       if $has_private;
 507
 508     # List all public actions
 509     $_->list($c) for @{ $self->_dispatch_types };
 510 }
 511
 512 sub _load_dispatch_types {
 513     my ( $self, @types ) = @_;
 514
 515     my @loaded;
 516
 517     # Preload action types
 518     for my $type (@types) {
 519         my $class =
 520           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 521         #eval "require $class";
 522         eval { Class::MOP::load_class($class) };
 523         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 524           if $@;
 525         push @{ $self->_dispatch_types }, $class->new;
 526
 527         push @loaded, $class;
 528     }
 529
 530     return @loaded;
 531 }
 532
 533 __PACKAGE__->meta->make_immutable;
 534
 535 =head2 meta
 536
 537 Provided by Moose
 538
 539 =head1 AUTHOR
 540
 541 Sebastian Riedel, C<sri@cpan.org>
 542 Matt S Trout, C<mst@shadowcatsystems.co.uk>
 543
 544 =head1 COPYRIGHT
 545
 546 This program is free software, you can redistribute it and/or modify it under
 547 the same terms as Perl itself.
 548
 549 =cut
 550
 551 1;