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     /
  23 );
  24
  25 # Preload these action types
  26 our @PRELOAD = qw/Index Path Regex/;
  27
  28 # Postload these action types
  29 our @POSTLOAD = qw/Default/;
  30
  31 =head1 NAME
  32
  33 Catalyst::Dispatcher - The Catalyst Dispatcher
  34
  35 =head1 SYNOPSIS
  36
  37 See L<Catalyst>.
  38
  39 =head1 DESCRIPTION
  40
  41 =head1 METHODS
  42
  43 =cut
  44
  45 sub new {
  46     my $self = shift;
  47     my $class = ref($self) || $self;
  48
  49     my $obj = $class->SUPER::new( @_ );
  50
  51     # set the default pre- and and postloads
  52     $obj->preload_dispatch_types(  \@PRELOAD );
  53     $obj->postload_dispatch_types( \@POSTLOAD );
  54     return $obj;
  55 }
  56
  57 =head2 $self->preload_dispatch_types
  58
  59 An arrayref of pre-loaded dispatchtype classes
  60
  61 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  62 To use a custom class outside the regular C<Catalyst> namespace, prefix
  63 it with a C<+>, like so:
  64
  65     +My::Dispatch::Type
  66
  67 =head2 $self->postload_dispatch_types
  68
  69 An arrayref of post-loaded dispatchtype classes
  70
  71 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  72 To use a custom class outside the regular C<Catalyst> namespace, prefix
  73 it with a C<+>, like so:
  74
  75     +My::Dispatch::Type
  76
  77 =head2 $self->detach( $c, $command [, \@arguments ] )
  78
  79 =cut
  80
  81 sub detach {
  82     my ( $self, $c, $command, @args ) = @_;
  83     $c->forward( $command, @args ) if $command;
  84     die $Catalyst::DETACH;
  85 }
  86
  87 =head2 $self->dispatch($c)
  88
  89 =cut
  90
  91 sub dispatch {
  92     my ( $self, $c ) = @_;
  93     if ( $c->action ) {
  94         $c->forward( join( '/', '', $c->action->namespace, '_DISPATCH' ) );
  95     }
  96
  97     else {
  98         my $path  = $c->req->path;
  99         my $error = $path
 100           ? qq/Unknown resource "$path"/
 101           : "No default action defined";
 102         $c->log->error($error) if $c->debug;
 103         $c->error($error);
 104     }
 105 }
 106
 107 =head2 $self->forward( $c, $command [, \@arguments ] )
 108
 109 =cut
 110
 111 sub forward {
 112     my $self    = shift;
 113     my $c       = shift;
 114     my $command = shift;
 115
 116     unless ($command) {
 117         $c->log->debug('Nothing to forward to') if $c->debug;
 118         return 0;
 119     }
 120
 121     my $local_args = 0;
 122     my $arguments  = $c->req->args;
 123     if ( ref( $_[-1] ) eq 'ARRAY' ) {
 124         $arguments  = pop(@_);
 125         $local_args = 1;
 126     }
 127
 128     my $result;
 129
 130     unless ( ref $command ) {
 131         my $command_copy = $command;
 132
 133         unless ( $command_copy =~ s/^\/// ) {
 134             my $namespace = $c->stack->[-1]->namespace;
 135             $command_copy = "${namespace}/${command}";
 136         }
 137
 138         unless ( $command_copy =~ /\// ) {
 139             $result = $c->get_action( $command_copy, '/' );
 140         }
 141         else {
 142             my @extra_args;
 143           DESCEND: while ( $command_copy =~ s/^(.*)\/(\w+)$/$1/ ) {
 144                 my $tail = $2;
 145                 $result = $c->get_action( $tail, $1 );
 146                 if ($result) {
 147                     $local_args = 1;
 148                     $command    = $tail;
 149                     unshift( @{$arguments}, @extra_args );
 150                     last DESCEND;
 151                 }
 152                 unshift( @extra_args, $tail );
 153             }
 154         }
 155     }
 156
 157     unless ($result) {
 158
 159         my $class = ref($command)
 160           || ref( $c->component($command) )
 161           || $c->component($command);
 162         my $method = shift || 'process';
 163
 164         unless ($class) {
 165             my $error =
 166 qq/Couldn't forward to command "$command". Invalid action or component./;
 167             $c->error($error);
 168             $c->log->debug($error) if $c->debug;
 169             return 0;
 170         }
 171
 172         if ( my $code = $class->can($method) ) {
 173             my $action = $self->method_action_class->new(
 174                 {
 175                     name      => $method,
 176                     code      => $code,
 177                     reverse   => "$class->$method",
 178                     class     => $class,
 179                     namespace => Catalyst::Utils::class2prefix(
 180                         $class, $c->config->{case_sensitive}
 181                     ),
 182                 }
 183             );
 184             $result = $action;
 185         }
 186
 187         else {
 188             my $error =
 189               qq/Couldn't forward to "$class". Does not implement "$method"/;
 190             $c->error($error);
 191             $c->log->debug($error)
 192               if $c->debug;
 193             return 0;
 194         }
 195
 196     }
 197
 198     if ($local_args) {
 199         local $c->request->{arguments} = [ @{$arguments} ];
 200         $result->execute($c);
 201     }
 202     else { $result->execute($c) }
 203
 204     return $c->state;
 205 }
 206
 207 =head2 $self->prepare_action($c)
 208
 209 =cut
 210
 211 sub prepare_action {
 212     my ( $self, $c ) = @_;
 213     my $path = $c->req->path;
 214     my @path = split /\//, $c->req->path;
 215     $c->req->args( \my @args );
 216
 217     unshift( @path, '' );    # Root action
 218
 219   DESCEND: while (@path) {
 220         $path = join '/', @path;
 221         $path =~ s#^/##;
 222
 223         $path = '' if $path eq '/';    # Root action
 224
 225         # Check out dispatch types to see if any will handle the path at
 226         # this level
 227
 228         foreach my $type ( @{ $self->dispatch_types } ) {
 229             last DESCEND if $type->match( $c, $path );
 230         }
 231
 232         # If not, move the last part path to args
 233         my $arg = pop(@path);
 234         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 235         unshift @args, $arg;
 236     }
 237
 238     $c->log->debug( 'Path is "' . $c->req->match . '"' )
 239       if ( $c->debug && $c->req->match );
 240
 241     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 242       if ( $c->debug && @args );
 243 }
 244
 245 =head2 $self->get_action( $action, $namespace )
 246
 247 =cut
 248
 249 sub get_action {
 250     my ( $self, $name, $namespace ) = @_;
 251     return unless $name;
 252     $namespace ||= '';
 253     $namespace = '' if $namespace eq '/';
 254
 255     my @match = $self->get_containers($namespace);
 256
 257     return unless @match;
 258
 259     if ( my $action = $match[-1]->get_action($name) ) {
 260         return $action if $action->namespace eq $namespace;
 261     }
 262 }
 263
 264 =head2 $self->get_actions( $c, $action, $namespace )
 265
 266 =cut
 267
 268 sub get_actions {
 269     my ( $self, $c, $action, $namespace ) = @_;
 270     return [] unless $action;
 271     $namespace ||= '';
 272     $namespace = '' if $namespace eq '/';
 273
 274     my @match = $self->get_containers($namespace);
 275
 276     return map { $_->get_action($action) } @match;
 277 }
 278
 279 =head2 $self->get_containers( $namespace )
 280
 281 =cut
 282
 283 sub get_containers {
 284     my ( $self, $namespace ) = @_;
 285
 286     # If the namespace is / just return the root ActionContainer
 287
 288     return ( $self->tree->getNodeValue )
 289       if ( !$namespace || ( $namespace eq '/' ) );
 290
 291     # Use a visitor to recurse down the tree finding the ActionContainers
 292     # for each namespace in the chain.
 293
 294     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 295     my @path = split( '/', $namespace );
 296     $visitor->setSearchPath(@path);
 297     $self->tree->accept($visitor);
 298
 299     my @match = $visitor->getResults;
 300     @match = ( $self->tree ) unless @match;
 301
 302     if ( !defined $visitor->getResult ) {
 303
 304         # If we don't manage to match, the visitor doesn't return the last
 305         # node is matched, so foo/bar/baz would only find the 'foo' node,
 306         # not the foo and foo/bar nodes as it should. This does another
 307         # single-level search to see if that's the case, and the 'last unless'
 308         # should catch any failures - or short-circuit this if this *is* a
 309         # bug in the visitor and gets fixed.
 310
 311         if ( my $extra = $path[ ( scalar @match ) - 1 ] ) {
 312             $visitor->setSearchPath($extra);
 313             $match[-1]->accept($visitor);
 314             push( @match, $visitor->getResult ) if defined $visitor->getResult;
 315         }
 316     }
 317
 318     return map { $_->getNodeValue } @match;
 319 }
 320
 321 =head2 $self->register( $c, $action )
 322
 323 =cut
 324
 325 sub register {
 326     my ( $self, $c, $action ) = @_;
 327
 328     my $registered = $self->registered_dispatch_types;
 329
 330     my $priv = 0;
 331     foreach my $key ( keys %{ $action->attributes } ) {
 332         $priv++ if $key eq 'Private';
 333         my $class = "Catalyst::DispatchType::$key";
 334         unless ( $registered->{$class} ) {
 335             eval "require $class";
 336             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 337             $registered->{$class} = 1;
 338         }
 339     }
 340
 341     # Pass the action to our dispatch types so they can register it if reqd.
 342     my $reg = 0;
 343     foreach my $type ( @{ $self->dispatch_types } ) {
 344         $reg++ if $type->register( $c, $action );
 345     }
 346
 347     return unless $reg + $priv;
 348
 349     my $namespace = $action->namespace;
 350     my $parent    = $self->tree;
 351     my $visitor   = Tree::Simple::Visitor::FindByPath->new;
 352
 353     if ($namespace) {
 354         for my $part ( split '/', $namespace ) {
 355             $visitor->setSearchPath($part);
 356             $parent->accept($visitor);
 357             my $child = $visitor->getResult;
 358
 359             unless ($child) {
 360
 361                 # Create a new tree node and an ActionContainer to form
 362                 # its value.
 363
 364                 my $container =
 365                   Catalyst::ActionContainer->new(
 366                     { part => $part, actions => {} } );
 367                 $child = $parent->addChild( Tree::Simple->new($container) );
 368                 $visitor->setSearchPath($part);
 369                 $parent->accept($visitor);
 370                 $child = $visitor->getResult;
 371             }
 372
 373             $parent = $child;
 374         }
 375     }
 376
 377     # Set the method value
 378     $parent->getNodeValue->actions->{ $action->name } = $action;
 379 }
 380
 381 =head2 $self->setup_actions( $class, $component )
 382
 383 =cut
 384
 385 sub setup_actions {
 386     my ( $self, $c ) = @_;
 387
 388     $self->dispatch_types( [] );
 389     $self->registered_dispatch_types( {} );
 390     $self->method_action_class('Catalyst::Action');
 391     $self->action_container_class('Catalyst::ActionContainer');
 392
 393     # Preload action types
 394     for my $type ( @{$self->preload_dispatch_types} ) {
 395         my $class = ($type =~ /^\+(.*)$/) ? $1 : "Catalyst::DispatchType::${type}";
 396         eval "require $class";
 397         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 398           if $@;
 399         push @{ $self->dispatch_types }, $class->new;
 400         $self->registered_dispatch_types->{$class} = 1;
 401     }
 402
 403     # We use a tree
 404     my $container =
 405       Catalyst::ActionContainer->new( { part => '/', actions => {} } );
 406     $self->tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
 407
 408     foreach my $comp ( values %{ $c->components } ) {
 409         $comp->register_actions($c) if $comp->can('register_actions');
 410     }
 411
 412     # Postload action types
 413     for my $type ( @{$self->postload_dispatch_types} ) {
 414         my $class = ($type =~ /^\+(.*)$/) ? $1 : "Catalyst::DispatchType::${type}";
 415         eval "require $class";
 416         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 417           if $@;
 418         push @{ $self->dispatch_types }, $class->new;
 419     }
 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 =head1 AUTHOR
 457
 458 Sebastian Riedel, C<sri@cpan.org>
 459 Matt S Trout, C<mst@shadowcatsystems.co.uk>
 460
 461 =head1 COPYRIGHT
 462
 463 This program is free software, you can redistribute it and/or modify it under
 464 the same terms as Perl itself.
 465
 466 =cut
 467
 468 1;