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     my $orig_args = $c->request->arguments();
 175     $c->request->arguments(\@args);
 176     $action->dispatch( $c );
 177     $c->request->arguments($orig_args);
 178
 179     return $c->state;
 180 }
 181
 182 sub _action_rel2abs {
 183     my ( $self, $c, $path ) = @_;
 184
 185     unless ( $path =~ m#^/# ) {
 186         my $namespace = $c->stack->[-1]->namespace;
 187         $path = "$namespace/$path";
 188     }
 189
 190     $path =~ s#^/##;
 191     return $path;
 192 }
 193
 194 sub _invoke_as_path {
 195     my ( $self, $c, $rel_path, $args ) = @_;
 196
 197     my $path = $self->_action_rel2abs( $c, $rel_path );
 198
 199     my ( $tail, @extra_args );
 200     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 201     {                           # allow $path to be empty
 202         if ( my $action = $c->get_action( $tail, $path ) ) {
 203             push @$args, @extra_args;
 204             return $action;
 205         }
 206         else {
 207             return
 208               unless $path
 209               ; # if a match on the global namespace failed then the whole lookup failed
 210         }
 211
 212         unshift @extra_args, $tail;
 213     }
 214 }
 215
 216 sub _find_component_class {
 217     my ( $self, $c, $component ) = @_;
 218
 219     return ref($component)
 220       || ref( $c->component($component) )
 221       || $c->component($component);
 222 }
 223
 224 sub _invoke_as_component {
 225     my ( $self, $c, $component, $method ) = @_;
 226
 227     my $class = $self->_find_component_class( $c, $component ) || return 0;
 228
 229     if ( my $code = $class->can($method) ) {
 230         return $self->_method_action_class->new(
 231             {
 232                 name      => $method,
 233                 code      => $code,
 234                 reverse   => "$class->$method",
 235                 class     => $class,
 236                 namespace => Catalyst::Utils::class2prefix(
 237                     $class, $c->config->{case_sensitive}
 238                 ),
 239             }
 240         );
 241     }
 242     else {
 243         my $error =
 244           qq/Couldn't forward to "$class". Does not implement "$method"/;
 245         $c->error($error);
 246         $c->log->debug($error)
 247           if $c->debug;
 248         return 0;
 249     }
 250 }
 251
 252 =head2 $self->prepare_action($c)
 253
 254 Find an dispatch type that matches $c->req->path, and set args from it.
 255
 256 =cut
 257
 258 sub prepare_action {
 259     my ( $self, $c ) = @_;
 260     my $req = $c->req;
 261     my $path = $req->path;
 262     my @path = split /\//, $req->path;
 263     $req->args( \my @args );
 264
 265     unshift( @path, '' );    # Root action
 266
 267   DESCEND: while (@path) {
 268         $path = join '/', @path;
 269         $path =~ s#^/##;
 270
 271         $path = '' if $path eq '/';    # Root action
 272
 273         # Check out dispatch types to see if any will handle the path at
 274         # this level
 275
 276         foreach my $type ( @{ $self->_dispatch_types } ) {
 277             last DESCEND if $type->match( $c, $path );
 278         }
 279
 280         # If not, move the last part path to args
 281         my $arg = pop(@path);
 282         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 283         unshift @args, $arg;
 284     }
 285
 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
 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 no Moose;
 535 __PACKAGE__->meta->make_immutable;
 536
 537 =head2 meta
 538
 539 Provided by Moose
 540
 541 =head1 AUTHOR
 542
 543 Sebastian Riedel, C<sri@cpan.org>
 544 Matt S Trout, C<mst@shadowcatsystems.co.uk>
 545
 546 =head1 COPYRIGHT
 547
 548 This program is free software, you can redistribute it and/or modify it under
 549 the same terms as Perl itself.
 550
 551 =cut
 552
 553 1;