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
 136 sub forward {
 137         my ( $self, $c, $command ) = splice( @_, 0, 3 );
 138
 139     unless ($command) {
 140         $c->log->debug('Nothing to forward to') if $c->debug;
 141         return 0;
 142     }
 143
 144         my $args = [ @{ $c->request->arguments } ];
 145
 146         @$args = @{ pop @_ } if ( ref( $_[-1] ) eq 'ARRAY' );
 147
 148     my $action = $self->_invoke_as_path( $c, $command, $args )
 149                       || $self->_invoke_as_component( $c, $command, shift );
 150
 151         unless ( $action ) {
 152                 my $error = qq/Couldn't forward to command "$command": / . qq/Invalid action or component./;
 153                 $c->error($error);
 154                 $c->log->debug($error) if $c->debug;
 155                 return 0;
 156         }
 157
 158         #push @$args, @_;
 159
 160         local $c->request->{arguments} = $args;
 161         $action->execute($c);
 162
 163     return $c->state;
 164 }
 165
 166 sub _action_rel2abs {
 167         my ( $self, $c, $path ) = @_;
 168
 169         unless ( $path =~ m#^/# ) {
 170                 my $namespace = $c->stack->[-1]->namespace;
 171                 $path = "$namespace/$path";
 172         }
 173
 174         $path =~ s#^/##;
 175         return $path;
 176 }
 177
 178 sub _invoke_as_path {
 179         my ( $self, $c, $rel_path, $args ) = @_;
 180
 181         return if ref $rel_path; # it must be a string
 182
 183         my $path = $self->_action_rel2abs( $c, $rel_path );
 184
 185         my ($tail, @extra_args);
 186         while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) ) { # allow $path to be empty
 187                 if ( my $action = $c->get_action( $tail, $path ) ) {
 188                         push @$args, @extra_args;
 189                         return $action;
 190                 } else {
 191                         return unless $path; # if a match on the global namespace failed then the whole lookup failed
 192                 }
 193
 194                 unshift @extra_args, $tail;
 195         }
 196 }
 197
 198 sub _find_component_class {
 199         my ( $self, $c, $component ) = @_;
 200
 201         return ref($component)
 202         || ref( $c->component($component) )
 203         || $c->component($component)
 204 }
 205
 206 sub _invoke_as_component {
 207         my ( $self, $c, $component, $method ) = @_;
 208
 209         my $class = $self->_find_component_class( $c, $component ) || return 0;
 210         $method ||= "process";
 211
 212         if ( my $code = $class->can($method) ) {
 213                 return $self->method_action_class->new(
 214                         {
 215                                 name      => $method,
 216                                 code      => $code,
 217                                 reverse   => "$class->$method",
 218                                 class     => $class,
 219                                 namespace => Catalyst::Utils::class2prefix(
 220                                         $class, $c->config->{case_sensitive}
 221                                 ),
 222                         }
 223                 );
 224         } else {
 225                 my $error =
 226                   qq/Couldn't forward to "$class". Does not implement "$method"/;
 227                 $c->error($error);
 228                 $c->log->debug($error)
 229                   if $c->debug;
 230                 return 0;
 231         }
 232 }
 233
 234 =head2 $self->prepare_action($c)
 235
 236 Find an dispatch type that matches $c->req->path, and set args from it.
 237
 238 =cut
 239
 240 sub prepare_action {
 241     my ( $self, $c ) = @_;
 242     my $path = $c->req->path;
 243     my @path = split /\//, $c->req->path;
 244     $c->req->args( \my @args );
 245
 246     unshift( @path, '' );    # Root action
 247
 248   DESCEND: while (@path) {
 249         $path = join '/', @path;
 250         $path =~ s#^/##;
 251
 252         $path = '' if $path eq '/';    # Root action
 253
 254         # Check out dispatch types to see if any will handle the path at
 255         # this level
 256
 257         foreach my $type ( @{ $self->dispatch_types } ) {
 258             last DESCEND if $type->match( $c, $path );
 259         }
 260
 261         # If not, move the last part path to args
 262         my $arg = pop(@path);
 263         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 264         unshift @args, $arg;
 265     }
 266
 267     $c->log->debug( 'Path is "' . $c->req->match . '"' )
 268       if ( $c->debug && $c->req->match );
 269
 270     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 271       if ( $c->debug && @args );
 272 }
 273
 274 =head2 $self->get_action( $action, $namespace )
 275
 276 returns a named action from a given namespace.
 277
 278 =cut
 279
 280 sub get_action {
 281     my ( $self, $name, $namespace ) = @_;
 282     return unless $name;
 283     $namespace ||= '';
 284     $namespace = '' if $namespace eq '/';
 285
 286     return $self->action_hash->{"$namespace/$name"};
 287 }
 288
 289 =head2 $self->get_actions( $c, $action, $namespace )
 290
 291 =cut
 292
 293 sub get_actions {
 294     my ( $self, $c, $action, $namespace ) = @_;
 295     return [] unless $action;
 296     $namespace ||= '';
 297     $namespace = '' if $namespace eq '/';
 298
 299     my @match = $self->get_containers($namespace);
 300
 301     return map { $_->get_action($action) } @match;
 302 }
 303
 304 =head2 $self->get_containers( $namespace )
 305
 306 Return all the action containers for a given namespace, inclusive
 307
 308 =cut
 309
 310 sub get_containers {
 311     my ( $self, $namespace ) = @_;
 312     $namespace ||= '';
 313     $namespace = '' if $namespace eq '/';
 314
 315     my @containers;
 316
 317     do {
 318         push @containers, $self->container_hash->{$namespace};
 319     } while ( $namespace =~ s#/[^/]+$## );
 320
 321     return reverse grep { defined } @containers, $self->container_hash->{''};
 322
 323     my @parts = split '/', $namespace;
 324 }
 325
 326 =head2 $self->register( $c, $action )
 327
 328 Make sure all required dispatch types for this action are loaded, then
 329 pass the action to our dispatch types so they can register it if required.
 330 Also, set up the tree with the action containers.
 331
 332 =cut
 333
 334 sub register {
 335     my ( $self, $c, $action ) = @_;
 336
 337     my $registered = $self->registered_dispatch_types;
 338
 339     my $priv = 0;
 340     foreach my $key ( keys %{ $action->attributes } ) {
 341         $priv++ if $key eq 'Private';
 342         my $class = "Catalyst::DispatchType::$key";
 343         unless ( $registered->{$class} ) {
 344             eval "require $class";
 345             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 346             $registered->{$class} = 1;
 347         }
 348     }
 349
 350     # Pass the action to our dispatch types so they can register it if reqd.
 351     my $reg = 0;
 352     foreach my $type ( @{ $self->dispatch_types } ) {
 353         $reg++ if $type->register( $c, $action );
 354     }
 355
 356     return unless $reg + $priv;
 357
 358     my $namespace = $action->namespace;
 359     my $name      = $action->name;
 360
 361     my $container = $self->find_or_create_action_container($namespace);
 362
 363     # Set the method value
 364     $container->add_action($action);
 365
 366     $self->action_hash->{"$namespace/$name"} = $action;
 367     $self->container_hash->{$namespace} = $container;
 368 }
 369
 370 sub find_or_create_action_container {
 371     my ( $self, $namespace ) = @_;
 372
 373     my $tree ||= $self->tree;
 374
 375     return $tree->getNodeValue unless $namespace;
 376
 377     my @namespace = split '/', $namespace;
 378     return $self->_find_or_create_namespace_node( $tree, @namespace )
 379       ->getNodeValue;
 380 }
 381
 382 sub _find_or_create_namespace_node {
 383     my ( $self, $parent, $part, @namespace ) = @_;
 384
 385     return $parent unless $part;
 386
 387     my $child =
 388       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 389
 390     unless ($child) {
 391         my $container = Catalyst::ActionContainer->new($part);
 392         $parent->addChild( $child = Tree::Simple->new($container) );
 393     }
 394
 395     $self->_find_or_create_namespace_node( $child, @namespace );
 396 }
 397
 398 =head2 $self->setup_actions( $class, $context )
 399
 400
 401 =cut
 402
 403 sub setup_actions {
 404     my ( $self, $c ) = @_;
 405
 406     $self->dispatch_types( [] );
 407     $self->registered_dispatch_types( {} );
 408     $self->method_action_class('Catalyst::Action');
 409     $self->action_container_class('Catalyst::ActionContainer');
 410
 411     my @classes =
 412       $self->do_load_dispatch_types( @{ $self->preload_dispatch_types } );
 413     @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
 414
 415     foreach my $comp ( values %{ $c->components } ) {
 416         $comp->register_actions($c) if $comp->can('register_actions');
 417     }
 418
 419     $self->do_load_dispatch_types( @{ $self->postload_dispatch_types } );
 420
 421     return unless $c->debug;
 422
 423     my $privates = Text::SimpleTable->new(
 424         [ 20, 'Private' ],
 425         [ 38, 'Class' ],
 426         [ 12, 'Method' ]
 427     );
 428
 429     my $has_private = 0;
 430     my $walker = sub {
 431         my ( $walker, $parent, $prefix ) = @_;
 432         $prefix .= $parent->getNodeValue || '';
 433         $prefix .= '/' unless $prefix =~ /\/$/;
 434         my $node = $parent->getNodeValue->actions;
 435
 436         for my $action ( keys %{$node} ) {
 437             my $action_obj = $node->{$action};
 438             next
 439               if ( ( $action =~ /^_.*/ )
 440                 && ( !$c->config->{show_internal_actions} ) );
 441             $privates->row( "$prefix$action", $action_obj->class, $action );
 442             $has_private = 1;
 443         }
 444
 445         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 446     };
 447
 448     $walker->( $walker, $self->tree, '' );
 449     $c->log->debug( "Loaded Private actions:\n" . $privates->draw )
 450       if ($has_private);
 451
 452     # List all public actions
 453     $_->list($c) for @{ $self->dispatch_types };
 454 }
 455
 456 sub do_load_dispatch_types {
 457     my ( $self, @types ) = @_;
 458
 459     my @loaded;
 460
 461     # Preload action types
 462     for my $type (@types) {
 463         my $class =
 464           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 465         eval "require $class";
 466         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 467           if $@;
 468         push @{ $self->dispatch_types }, $class->new;
 469
 470         push @loaded, $class;
 471     }
 472
 473     return @loaded;
 474 }
 475
 476 =head1 AUTHOR
 477
 478 Sebastian Riedel, C<sri@cpan.org>
 479 Matt S Trout, C<mst@shadowcatsystems.co.uk>
 480
 481 =head1 COPYRIGHT
 482
 483 This program is free software, you can redistribute it and/or modify it under
 484 the same terms as Perl itself.
 485
 486 =cut
 487
 488 1;