lib/Catalyst/Dispatcher.pm

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