lib/Catalyst/Dispatcher.pm

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