lib/Catalyst/Dispatcher.pm

   1 package Catalyst::Dispatcher;
   2
   3 use Moose;
   4 use Class::MOP;
   5
   6 use Catalyst::Exception;
   7 use Catalyst::Utils;
   8 use Catalyst::Action;
   9 use Catalyst::ActionContainer;
  10 use Catalyst::DispatchType::Default;
  11 use Catalyst::DispatchType::Index;
  12 use Text::SimpleTable;
  13 use Tree::Simple;
  14 use Tree::Simple::Visitor::FindByPath;
  15 use Scalar::Util ();
  16
  17 #do these belong as package vars or should we build these via a builder method?
  18 # Preload these action types
  19 our @PRELOAD = qw/Index Path Regex/;
  20
  21 # Postload these action types
  22 our @POSTLOAD = qw/Default/;
  23
  24 has _tree => (is => 'rw');
  25 has _dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1);
  26 has _registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1);
  27 has _method_action_class => (is => 'rw', default => 'Catalyst::Action');
  28 has _action_container_class => (is => 'rw', default => 'Catalyst::ActionContainer');
  29
  30 has preload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@PRELOAD] });
  31 has postload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@POSTLOAD] });
  32 has _action_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
  33 has _container_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
  34
  35 no Moose;
  36
  37 =head1 NAME
  38
  39 Catalyst::Dispatcher - The Catalyst Dispatcher
  40
  41 =head1 SYNOPSIS
  42
  43 See L<Catalyst>.
  44
  45 =head1 DESCRIPTION
  46
  47 This is the class that maps public urls to actions in your Catalyst
  48 application based on the attributes you set.
  49
  50 =head1 METHODS
  51
  52 =head2 new
  53
  54 Construct a new dispatcher.
  55
  56 =cut
  57
  58 sub BUILD {
  59   my ($self, $params) = @_;
  60
  61   my $container =
  62     Catalyst::ActionContainer->new( { part => '/', actions => {} } );
  63
  64   $self->_tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
  65 }
  66
  67 =head2 $self->preload_dispatch_types
  68
  69 An arrayref of pre-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->postload_dispatch_types
  78
  79 An arrayref of post-loaded dispatchtype classes
  80
  81 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  82 To use a custom class outside the regular C<Catalyst> namespace, prefix
  83 it with a C<+>, like so:
  84
  85     +My::Dispatch::Type
  86
  87 =head2 $self->detach( $c, $command [, \@arguments ] )
  88
  89 Documented in L<Catalyst>
  90
  91 =cut
  92
  93 sub detach {
  94     my ( $self, $c, $command, @args ) = @_;
  95     $c->forward( $command, @args ) if $command;
  96     die $Catalyst::DETACH;
  97 }
  98
  99 =head2 $self->dispatch($c)
 100
 101 Delegate the dispatch to the action that matched the url, or return a
 102 message about unknown resource
 103
 104
 105 =cut
 106
 107 sub dispatch {
 108     my ( $self, $c ) = @_;
 109     if ( my $action = $c->action ) {
 110         $c->forward( join( '/', '', $action->namespace, '_DISPATCH' ) );
 111     }
 112
 113     else {
 114         my $path  = $c->req->path;
 115         my $error = $path
 116           ? qq/Unknown resource "$path"/
 117           : "No default action defined";
 118         $c->log->error($error) if $c->debug;
 119         $c->error($error);
 120     }
 121 }
 122
 123 # $self->_command2action( $c, $command [, \@arguments ] )
 124 # Search for an action, from the command and returns C<($action, $args)> on
 125 # success. Returns C<(0)> on error.
 126
 127 sub _command2action {
 128     my ( $self, $c, $command, @extra_params ) = @_;
 129
 130     unless ($command) {
 131         $c->log->debug('Nothing to go to') if $c->debug;
 132         return 0;
 133     }
 134
 135     my @args;
 136
 137     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
 138         @args = @{ pop @extra_params }
 139     } else {
 140         # this is a copy, it may take some abuse from
 141         # ->_invoke_as_path if the path had trailing parts
 142         @args = @{ $c->request->arguments };
 143     }
 144
 145     my $action;
 146
 147     # go to a string path ("/foo/bar/gorch")
 148     # or action object which stringifies to that
 149     $action = $self->_invoke_as_path( $c, "$command", \@args );
 150
 151     # go to a component ( "MyApp::*::Foo" or $c->component("...")
 152     # - a path or an object)
 153     unless ($action) {
 154         my $method = @extra_params ? $extra_params[0] : "process";
 155         $action = $self->_invoke_as_component( $c, $command, $method );
 156     }
 157
 158     return $action, \@args;
 159 }
 160
 161 =head2 $self->go( $c, $command [, \@arguments ] )
 162
 163 Documented in L<Catalyst>
 164
 165 =cut
 166
 167 sub go {
 168     my $self = shift;
 169     my ( $c, $command ) = @_;
 170     my ( $action, $args ) = $self->_command2action(@_);
 171
 172     unless ($action && defined $action->namespace) {
 173         my $error =
 174             qq/Couldn't go to command "$command": /
 175           . qq/Invalid action or component./;
 176         $c->error($error);
 177         $c->log->debug($error) if $c->debug;
 178         return 0;
 179     }
 180
 181     $action = $self->expand_action($action);
 182
 183     local $c->request->{arguments} = $args;
 184     $c->namespace($action->namespace);
 185     $c->action($action);
 186     $self->dispatch($c);
 187
 188     die $Catalyst::GO;
 189 }
 190
 191 =head2 $self->forward( $c, $command [, \@arguments ] )
 192
 193 Documented in L<Catalyst>
 194
 195 =cut
 196
 197 sub forward {
 198     my $self = shift;
 199     my ( $c, $command ) = @_;
 200     my ( $action, $args ) = $self->_command2action(@_);
 201
 202     unless ($action) {
 203         my $error =
 204             qq/Couldn't forward to command "$command": /
 205           . qq/Invalid action or component./;
 206         $c->error($error);
 207         $c->log->debug($error) if $c->debug;
 208         return 0;
 209     }
 210
 211     #push @$args, @_;
 212
 213     no warnings 'recursion';
 214
 215     my $orig_args = $c->request->arguments();
 216     $c->request->arguments($args);
 217     $action->dispatch( $c );
 218     $c->request->arguments($orig_args);
 219
 220     return $c->state;
 221 }
 222
 223 sub _action_rel2abs {
 224     my ( $self, $c, $path ) = @_;
 225
 226     unless ( $path =~ m#^/# ) {
 227         my $namespace = $c->stack->[-1]->namespace;
 228         $path = "$namespace/$path";
 229     }
 230
 231     $path =~ s#^/##;
 232     return $path;
 233 }
 234
 235 sub _invoke_as_path {
 236     my ( $self, $c, $rel_path, $args ) = @_;
 237
 238     my $path = $self->_action_rel2abs( $c, $rel_path );
 239
 240     my ( $tail, @extra_args );
 241     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 242     {                           # allow $path to be empty
 243         if ( my $action = $c->get_action( $tail, $path ) ) {
 244             push @$args, @extra_args;
 245             return $action;
 246         }
 247         else {
 248             return
 249               unless $path
 250               ; # if a match on the global namespace failed then the whole lookup failed
 251         }
 252
 253         unshift @extra_args, $tail;
 254     }
 255 }
 256
 257 sub _find_component_class {
 258     my ( $self, $c, $component ) = @_;
 259
 260     return ref($component)
 261       || ref( $c->component($component) )
 262       || $c->component($component);
 263 }
 264
 265 sub _invoke_as_component {
 266     my ( $self, $c, $component, $method ) = @_;
 267
 268     my $class = $self->_find_component_class( $c, $component ) || return 0;
 269
 270     if ( my $code = $class->can($method) ) {
 271         return $self->_method_action_class->new(
 272             {
 273                 name      => $method,
 274                 code      => $code,
 275                 reverse   => "$class->$method",
 276                 class     => $class,
 277                 namespace => Catalyst::Utils::class2prefix(
 278                     $class, $c->config->{case_sensitive}
 279                 ),
 280             }
 281         );
 282     }
 283     else {
 284         my $error =
 285           qq/Couldn't forward to "$class". Does not implement "$method"/;
 286         $c->error($error);
 287         $c->log->debug($error)
 288           if $c->debug;
 289         return 0;
 290     }
 291 }
 292
 293 =head2 $self->prepare_action($c)
 294
 295 Find an dispatch type that matches $c->req->path, and set args from it.
 296
 297 =cut
 298
 299 sub prepare_action {
 300     my ( $self, $c ) = @_;
 301     my $req = $c->req;
 302     my $path = $req->path;
 303     my @path = split /\//, $req->path;
 304     $req->args( \my @args );
 305
 306     unshift( @path, '' );    # Root action
 307
 308   DESCEND: while (@path) {
 309         $path = join '/', @path;
 310         $path =~ s#^/##;
 311
 312         $path = '' if $path eq '/';    # Root action
 313
 314         # Check out dispatch types to see if any will handle the path at
 315         # this level
 316
 317         foreach my $type ( @{ $self->_dispatch_types } ) {
 318             last DESCEND if $type->match( $c, $path );
 319         }
 320
 321         # If not, move the last part path to args
 322         my $arg = pop(@path);
 323         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 324         unshift @args, $arg;
 325     }
 326
 327     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 328
 329     $c->log->debug( 'Path is "' . $req->match . '"' )
 330       if ( $c->debug && length $req->match );
 331
 332     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 333       if ( $c->debug && @args );
 334 }
 335
 336 =head2 $self->get_action( $action, $namespace )
 337
 338 returns a named action from a given namespace.
 339
 340 =cut
 341
 342 sub get_action {
 343     my ( $self, $name, $namespace ) = @_;
 344     return unless $name;
 345
 346     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 347
 348     return $self->_action_hash->{"${namespace}/${name}"};
 349 }
 350
 351 =head2 $self->get_action_by_path( $path );
 352
 353 Returns the named action by its full path.
 354
 355 =cut
 356
 357 sub get_action_by_path {
 358     my ( $self, $path ) = @_;
 359     $path =~ s/^\///;
 360     $path = "/$path" unless $path =~ /\//;
 361     $self->_action_hash->{$path};
 362 }
 363
 364 =head2 $self->get_actions( $c, $action, $namespace )
 365
 366 =cut
 367
 368 sub get_actions {
 369     my ( $self, $c, $action, $namespace ) = @_;
 370     return [] unless $action;
 371
 372     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 373
 374     my @match = $self->get_containers($namespace);
 375
 376     return map { $_->get_action($action) } @match;
 377 }
 378
 379 =head2 $self->get_containers( $namespace )
 380
 381 Return all the action containers for a given namespace, inclusive
 382
 383 =cut
 384
 385 sub get_containers {
 386     my ( $self, $namespace ) = @_;
 387     $namespace ||= '';
 388     $namespace = '' if $namespace eq '/';
 389
 390     my @containers;
 391
 392     if ( length $namespace ) {
 393         do {
 394             push @containers, $self->_container_hash->{$namespace};
 395         } while ( $namespace =~ s#/[^/]+$## );
 396     }
 397
 398     return reverse grep { defined } @containers, $self->_container_hash->{''};
 399
 400     #return (split '/', $namespace); # isnt this more clear?
 401     my @parts = split '/', $namespace;
 402 }
 403
 404 =head2 $self->uri_for_action($action, \@captures)
 405
 406 Takes a Catalyst::Action object and action parameters and returns a URI
 407 part such that if $c->req->path were this URI part, this action would be
 408 dispatched to with $c->req->captures set to the supplied arrayref.
 409
 410 If the action object is not available for external dispatch or the dispatcher
 411 cannot determine an appropriate URI, this method will return undef.
 412
 413 =cut
 414
 415 sub uri_for_action {
 416     my ( $self, $action, $captures) = @_;
 417     $captures ||= [];
 418     foreach my $dispatch_type ( @{ $self->_dispatch_types } ) {
 419         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 420         return( $uri eq '' ? '/' : $uri )
 421             if defined($uri);
 422     }
 423     return undef;
 424 }
 425
 426 sub expand_action {
 427     my ($self, $action) = @_;
 428
 429     foreach my $dispatch_type (@{ $self->_dispatch_types }) {
 430         my $expanded = $dispatch_type->expand_action($action);
 431         return $expanded if $expanded;
 432     }
 433
 434     return $action;
 435 }
 436
 437 =head2 $self->register( $c, $action )
 438
 439 Make sure all required dispatch types for this action are loaded, then
 440 pass the action to our dispatch types so they can register it if required.
 441 Also, set up the tree with the action containers.
 442
 443 =cut
 444
 445 sub register {
 446     my ( $self, $c, $action ) = @_;
 447
 448     my $registered = $self->_registered_dispatch_types;
 449
 450     #my $priv = 0; #seems to be unused
 451     foreach my $key ( keys %{ $action->attributes } ) {
 452         next if $key eq 'Private';
 453         my $class = "Catalyst::DispatchType::$key";
 454         unless ( $registered->{$class} ) {
 455             #some error checking rethrowing here wouldn't hurt.
 456             eval { Class::MOP::load_class($class) };
 457             push( @{ $self->_dispatch_types }, $class->new ) unless $@;
 458             $registered->{$class} = 1;
 459         }
 460     }
 461
 462     # Pass the action to our dispatch types so they can register it if reqd.
 463     foreach my $type ( @{ $self->_dispatch_types } ) {
 464         $type->register( $c, $action );
 465     }
 466
 467     my $namespace = $action->namespace;
 468     my $name      = $action->name;
 469
 470     my $container = $self->_find_or_create_action_container($namespace);
 471
 472     # Set the method value
 473     $container->add_action($action);
 474
 475     $self->_action_hash->{"$namespace/$name"} = $action;
 476     $self->_container_hash->{$namespace} = $container;
 477 }
 478
 479 sub _find_or_create_action_container {
 480     my ( $self, $namespace ) = @_;
 481
 482     my $tree ||= $self->_tree;
 483
 484     return $tree->getNodeValue unless $namespace;
 485
 486     my @namespace = split '/', $namespace;
 487     return $self->_find_or_create_namespace_node( $tree, @namespace )
 488       ->getNodeValue;
 489 }
 490
 491 sub _find_or_create_namespace_node {
 492     my ( $self, $parent, $part, @namespace ) = @_;
 493
 494     return $parent unless $part;
 495
 496     my $child =
 497       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 498
 499     unless ($child) {
 500         my $container = Catalyst::ActionContainer->new($part);
 501         $parent->addChild( $child = Tree::Simple->new($container) );
 502     }
 503
 504     $self->_find_or_create_namespace_node( $child, @namespace );
 505 }
 506
 507 =head2 $self->setup_actions( $class, $context )
 508
 509
 510 =cut
 511
 512 sub setup_actions {
 513     my ( $self, $c ) = @_;
 514
 515
 516     my @classes =
 517       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 518     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 519
 520     foreach my $comp ( values %{ $c->components } ) {
 521         $comp->register_actions($c) if $comp->can('register_actions');
 522     }
 523
 524     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 525
 526     return unless $c->debug;
 527
 528     my $privates = Text::SimpleTable->new(
 529         [ 20, 'Private' ],
 530         [ 36, 'Class' ],
 531         [ 12, 'Method' ]
 532     );
 533
 534     my $has_private = 0;
 535     my $walker = sub {
 536         my ( $walker, $parent, $prefix ) = @_;
 537         $prefix .= $parent->getNodeValue || '';
 538         $prefix .= '/' unless $prefix =~ /\/$/;
 539         my $node = $parent->getNodeValue->actions;
 540
 541         for my $action ( keys %{$node} ) {
 542             my $action_obj = $node->{$action};
 543             next
 544               if ( ( $action =~ /^_.*/ )
 545                 && ( !$c->config->{show_internal_actions} ) );
 546             $privates->row( "$prefix$action", $action_obj->class, $action );
 547             $has_private = 1;
 548         }
 549
 550         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 551     };
 552
 553     $walker->( $walker, $self->_tree, '' );
 554     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 555       if $has_private;
 556
 557     # List all public actions
 558     $_->list($c) for @{ $self->_dispatch_types };
 559 }
 560
 561 sub _load_dispatch_types {
 562     my ( $self, @types ) = @_;
 563
 564     my @loaded;
 565
 566     # Preload action types
 567     for my $type (@types) {
 568         my $class =
 569           ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
 570
 571         eval { Class::MOP::load_class($class) };
 572         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 573           if $@;
 574         push @{ $self->_dispatch_types }, $class->new;
 575
 576         push @loaded, $class;
 577     }
 578
 579     return @loaded;
 580 }
 581
 582 no Moose;
 583 __PACKAGE__->meta->make_immutable;
 584
 585 =head2 meta
 586
 587 Provided by Moose
 588
 589 =head1 AUTHORS
 590
 591 Catalyst Contributors, see Catalyst.pm
 592
 593 =head1 COPYRIGHT
 594
 595 This program is free software, you can redistribute it and/or modify it under
 596 the same terms as Perl itself.
 597
 598 =cut
 599
 600 1;