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