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