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     $path = "/$path" unless $path =~ /\//;
 304     $self->action_hash->{$path};
 305 }
 306
 307 =head2 $self->get_actions( $c, $action, $namespace )
 308
 309 =cut
 310
 311 sub get_actions {
 312     my ( $self, $c, $action, $namespace ) = @_;
 313     return [] unless $action;
 314
 315     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 316
 317     my @match = $self->get_containers($namespace);
 318
 319     return map { $_->get_action($action) } @match;
 320 }
 321
 322 =head2 $self->get_containers( $namespace )
 323
 324 Return all the action containers for a given namespace, inclusive
 325
 326 =cut
 327
 328 sub get_containers {
 329     my ( $self, $namespace ) = @_;
 330     $namespace ||= '';
 331     $namespace = '' if $namespace eq '/';
 332
 333     my @containers;
 334
 335     do {
 336         push @containers, $self->container_hash->{$namespace};
 337     } while ( $namespace =~ s#/[^/]+$## );
 338
 339     return reverse grep { defined } @containers, $self->container_hash->{''};
 340
 341     my @parts = split '/', $namespace;
 342 }
 343
 344 =head2 $self->register( $c, $action )
 345
 346 Make sure all required dispatch types for this action are loaded, then
 347 pass the action to our dispatch types so they can register it if required.
 348 Also, set up the tree with the action containers.
 349
 350 =cut
 351
 352 sub register {
 353     my ( $self, $c, $action ) = @_;
 354
 355     my $registered = $self->registered_dispatch_types;
 356
 357     my $priv = 0;
 358     foreach my $key ( keys %{ $action->attributes } ) {
 359         $priv++ if $key eq 'Private';
 360         my $class = "Catalyst::DispatchType::$key";
 361         unless ( $registered->{$class} ) {
 362             eval "require $class";
 363             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 364             $registered->{$class} = 1;
 365         }
 366     }
 367
 368     # Pass the action to our dispatch types so they can register it if reqd.
 369     my $reg = 0;
 370     foreach my $type ( @{ $self->dispatch_types } ) {
 371         $reg++ if $type->register( $c, $action );
 372     }
 373
 374     return unless $reg + $priv;
 375
 376     my $namespace = $action->namespace;
 377     my $name      = $action->name;
 378
 379     my $container = $self->find_or_create_action_container($namespace);
 380
 381     # Set the method value
 382     $container->add_action($action);
 383
 384     $self->action_hash->{"$namespace/$name"} = $action;
 385     $self->container_hash->{$namespace} = $container;
 386 }
 387
 388 sub find_or_create_action_container {
 389     my ( $self, $namespace ) = @_;
 390
 391     my $tree ||= $self->tree;
 392
 393     return $tree->getNodeValue unless $namespace;
 394
 395     my @namespace = split '/', $namespace;
 396     return $self->_find_or_create_namespace_node( $tree, @namespace )
 397       ->getNodeValue;
 398 }
 399
 400 sub _find_or_create_namespace_node {
 401     my ( $self, $parent, $part, @namespace ) = @_;
 402
 403     return $parent unless $part;
 404
 405     my $child =
 406       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 407
 408     unless ($child) {
 409         my $container = Catalyst::ActionContainer->new($part);
 410         $parent->addChild( $child = Tree::Simple->new($container) );
 411     }
 412
 413     $self->_find_or_create_namespace_node( $child, @namespace );
 414 }
 415
 416 =head2 $self->setup_actions( $class, $context )
 417
 418
 419 =cut
 420
 421 sub setup_actions {
 422     my ( $self, $c ) = @_;
 423
 424     $self->dispatch_types( [] );
 425     $self->registered_dispatch_types( {} );
 426     $self->method_action_class('Catalyst::Action');
 427     $self->action_container_class('Catalyst::ActionContainer');
 428
 429     my @classes =
 430       $self->do_load_dispatch_types( @{ $self->preload_dispatch_types } );
 431     @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
 432
 433     foreach my $comp ( values %{ $c->components } ) {
 434         $comp->register_actions($c) if $comp->can('register_actions');
 435     }
 436
 437     $self->do_load_dispatch_types( @{ $self->postload_dispatch_types } );
 438
 439     return unless $c->debug;
 440
 441     my $privates = Text::SimpleTable->new(
 442         [ 20, 'Private' ],
 443         [ 38, 'Class' ],
 444         [ 12, 'Method' ]
 445     );
 446
 447     my $has_private = 0;
 448     my $walker = sub {
 449         my ( $walker, $parent, $prefix ) = @_;
 450         $prefix .= $parent->getNodeValue || '';
 451         $prefix .= '/' unless $prefix =~ /\/$/;
 452         my $node = $parent->getNodeValue->actions;
 453
 454         for my $action ( keys %{$node} ) {
 455             my $action_obj = $node->{$action};
 456             next
 457               if ( ( $action =~ /^_.*/ )
 458                 && ( !$c->config->{show_internal_actions} ) );
 459             $privates->row( "$prefix$action", $action_obj->class, $action );
 460             $has_private = 1;
 461         }
 462
 463         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 464     };
 465
 466     $walker->( $walker, $self->tree, '' );
 467     $c->log->debug( "Loaded Private actions:\n" . $privates->draw )
 468       if ($has_private);
 469
 470     # List all public actions
 471     $_->list($c) for @{ $self->dispatch_types };
 472 }
 473
 474 sub do_load_dispatch_types {
 475     my ( $self, @types ) = @_;
 476
 477     my @loaded;
 478
 479     # Preload action types
 480     for my $type (@types) {
 481         my $class =
 482           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 483         eval "require $class";
 484         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 485           if $@;
 486         push @{ $self->dispatch_types }, $class->new;
 487
 488         push @loaded, $class;
 489     }
 490
 491     return @loaded;
 492 }
 493
 494 =head1 AUTHOR
 495
 496 Sebastian Riedel, C<sri@cpan.org>
 497 Matt S Trout, C<mst@shadowcatsystems.co.uk>
 498
 499 =head1 COPYRIGHT
 500
 501 This program is free software, you can redistribute it and/or modify it under
 502 the same terms as Perl itself.
 503
 504 =cut
 505
 506 1;