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