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 Catalyst::Utils;
  14 use Text::SimpleTable;
  15 use Tree::Simple;
  16 use Tree::Simple::Visitor::FindByPath;
  17 use Class::Load qw(load_class try_load_class);
  18 use Encode 2.21 'decode_utf8';
  19
  20 use namespace::clean -except => 'meta';
  21
  22 # Refactoring note:
  23 # do these belong as package vars or should we build these via a builder method?
  24 # See Catalyst-Plugin-Server for them being added to, which should be much less ugly.
  25
  26 # Preload these action types
  27 our @PRELOAD = qw/Index Path/;
  28
  29 # Postload these action types
  30 our @POSTLOAD = qw/Default/;
  31
  32 # Note - see back-compat methods at end of file.
  33 has _tree => (is => 'rw', builder => '_build__tree');
  34 has dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1);
  35 has _registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1);
  36 has _method_action_class => (is => 'rw', default => 'Catalyst::Action');
  37 has _action_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
  38 has _container_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
  39
  40 my %dispatch_types = ( pre => \@PRELOAD, post => \@POSTLOAD );
  41 foreach my $type (keys %dispatch_types) {
  42     has $type . "load_dispatch_types" => (
  43         is => 'rw', required => 1, lazy => 1, default => sub { $dispatch_types{$type} },
  44         traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute'], # List assignment is CAF style
  45     );
  46 }
  47
  48 =head1 NAME
  49
  50 Catalyst::Dispatcher - The Catalyst Dispatcher
  51
  52 =head1 SYNOPSIS
  53
  54 See L<Catalyst>.
  55
  56 =head1 DESCRIPTION
  57
  58 This is the class that maps public urls to actions in your Catalyst
  59 application based on the attributes you set.
  60
  61 =head1 METHODS
  62
  63 =head2 new
  64
  65 Construct a new dispatcher.
  66
  67 =cut
  68
  69 sub _build__tree {
  70   my ($self) = @_;
  71
  72   my $container =
  73     Catalyst::ActionContainer->new( { part => '/', actions => {} } );
  74
  75   return Tree::Simple->new($container, Tree::Simple->ROOT);
  76 }
  77
  78 =head2 $self->preload_dispatch_types
  79
  80 An arrayref of pre-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->postload_dispatch_types
  89
  90 An arrayref of post-loaded dispatchtype classes
  91
  92 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  93 To use a custom class outside the regular C<Catalyst> namespace, prefix
  94 it with a C<+>, like so:
  95
  96     +My::Dispatch::Type
  97
  98 =head2 $self->dispatch($c)
  99
 100 Delegate the dispatch to the action that matched the url, or return a
 101 message about unknown resource
 102
 103 =cut
 104
 105 sub dispatch {
 106     my ( $self, $c ) = @_;
 107     if ( my $action = $c->action ) {
 108         $c->forward( join( '/', '', $action->namespace, '_DISPATCH' ) );
 109     }
 110     else {
 111         my $path  = $c->req->path;
 112         $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 113         $path = decode_utf8($path);
 114
 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 # $self->_command2action( $c, $command [, \@captures, \@arguments ] )
 125 # Search for an action, from the command and returns C<($action, $args, $captures)> on
 126 # success. Returns C<(0)> on error.
 127
 128 sub _command2action {
 129     my ( $self, $c, $command, @extra_params ) = @_;
 130
 131     unless ($command) {
 132         $c->log->debug('Nothing to go to') if $c->debug;
 133         return 0;
 134     }
 135
 136     my (@args, @captures);
 137
 138     if ( ref( $extra_params[-2] ) eq 'ARRAY' ) {
 139         @captures = @{ splice @extra_params, -2, 1 };
 140     }
 141
 142     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
 143         @args = @{ pop @extra_params }
 144     } else {
 145         # this is a copy, it may take some abuse from
 146         # ->_invoke_as_path if the path had trailing parts
 147         @args = @{ $c->request->arguments };
 148     }
 149
 150     my $action;
 151
 152     # go to a string path ("/foo/bar/gorch")
 153     # or action object
 154     if (blessed($command) && $command->isa('Catalyst::Action')) {
 155         $action = $command;
 156     }
 157     else {
 158         $action = $self->_invoke_as_path( $c, "$command", \@args );
 159     }
 160
 161     # go to a component ( "View::Foo" or $c->component("...")
 162     # - a path or an object)
 163     unless ($action) {
 164         my $method = @extra_params ? $extra_params[0] : "process";
 165         $action = $self->_invoke_as_component( $c, $command, $method );
 166     }
 167
 168     return $action, \@args, \@captures;
 169 }
 170
 171 =head2 $self->visit( $c, $command [, \@arguments ] )
 172
 173 Documented in L<Catalyst>
 174
 175 =cut
 176
 177 sub visit {
 178     my $self = shift;
 179     $self->_do_visit('visit', @_);
 180 }
 181
 182 sub _do_visit {
 183     my $self = shift;
 184     my $opname = shift;
 185     my ( $c, $command ) = @_;
 186     my ( $action, $args, $captures ) = $self->_command2action(@_);
 187     my $error = qq/Couldn't $opname("$command"): /;
 188
 189     if (!$action) {
 190         $error .= qq/Couldn't $opname to command "$command": /
 191                  .qq/Invalid action or component./;
 192     }
 193     elsif (!defined $action->namespace) {
 194         $error .= qq/Action has no namespace: cannot $opname() to a plain /
 195                  .qq/method or component, must be an :Action of some sort./
 196     }
 197     elsif (!$action->class->can('_DISPATCH')) {
 198         $error .= qq/Action cannot _DISPATCH. /
 199                  .qq/Did you try to $opname() a non-controller action?/;
 200     }
 201     else {
 202         $error = q();
 203     }
 204
 205     if($error) {
 206         $c->error($error);
 207         $c->log->debug($error) if $c->debug;
 208         return 0;
 209     }
 210
 211     $action = $self->expand_action($action);
 212
 213     local $c->request->{arguments} = $args;
 214     local $c->request->{captures}  = $captures;
 215     local $c->{namespace} = $action->{'namespace'};
 216     local $c->{action} = $action;
 217
 218     $self->dispatch($c);
 219 }
 220
 221 =head2 $self->go( $c, $command [, \@arguments ] )
 222
 223 Documented in L<Catalyst>
 224
 225 =cut
 226
 227 sub go {
 228     my $self = shift;
 229     $self->_do_visit('go', @_);
 230     Catalyst::Exception::Go->throw;
 231 }
 232
 233 =head2 $self->forward( $c, $command [, \@arguments ] )
 234
 235 Documented in L<Catalyst>
 236
 237 =cut
 238
 239 sub forward {
 240     my $self = shift;
 241     no warnings 'recursion';
 242     $self->_do_forward(forward => @_);
 243 }
 244
 245 sub _do_forward {
 246     my $self = shift;
 247     my $opname = shift;
 248     my ( $c, $command ) = @_;
 249     my ( $action, $args, $captures ) = $self->_command2action(@_);
 250
 251     if (!$action) {
 252         my $error .= qq/Couldn't $opname to command "$command": /
 253                     .qq/Invalid action or component./;
 254         $c->error($error);
 255         $c->log->debug($error) if $c->debug;
 256         return 0;
 257     }
 258
 259
 260     local $c->request->{arguments} = $args;
 261     no warnings 'recursion';
 262     $action->dispatch( $c );
 263
 264     return $c->state;
 265 }
 266
 267 =head2 $self->detach( $c, $command [, \@arguments ] )
 268
 269 Documented in L<Catalyst>
 270
 271 =cut
 272
 273 sub detach {
 274     my ( $self, $c, $command, @args ) = @_;
 275     $self->_do_forward(detach => $c, $command, @args ) if $command;
 276     $c->state(0); # Needed in order to skip any auto functions
 277     Catalyst::Exception::Detach->throw;
 278 }
 279
 280 sub _action_rel2abs {
 281     my ( $self, $c, $path ) = @_;
 282
 283     unless ( $path =~ m#^/# ) {
 284         my $namespace = $c->stack->[-1]->namespace;
 285         $path = "$namespace/$path";
 286     }
 287
 288     $path =~ s#^/##;
 289     return $path;
 290 }
 291
 292 sub _invoke_as_path {
 293     my ( $self, $c, $rel_path, $args ) = @_;
 294
 295     my $path = $self->_action_rel2abs( $c, $rel_path );
 296
 297     my ( $tail, @extra_args );
 298     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 299     {                           # allow $path to be empty
 300         if ( my $action = $c->get_action( $tail, $path ) ) {
 301             push @$args, @extra_args;
 302             return $action;
 303         }
 304         else {
 305             return
 306               unless $path
 307               ; # if a match on the global namespace failed then the whole lookup failed
 308         }
 309
 310         unshift @extra_args, $tail;
 311     }
 312 }
 313
 314 sub _find_component {
 315     my ( $self, $c, $component ) = @_;
 316
 317     # fugly, why doesn't ->component('MyApp') work?
 318     return $c if ($component eq blessed($c));
 319
 320     return blessed($component)
 321         ? $component
 322         : $c->component($component);
 323 }
 324
 325 sub _invoke_as_component {
 326     my ( $self, $c, $component_or_class, $method ) = @_;
 327
 328     my $component = $self->_find_component($c, $component_or_class);
 329     my $component_class = blessed $component || return 0;
 330
 331     if (my $code = $component_class->can('action_for')) {
 332         my $possible_action = $component->$code($method);
 333         return $possible_action if $possible_action;
 334     }
 335
 336     if ( my $code = $component_class->can($method) ) {
 337         return $self->_method_action_class->new(
 338             {
 339                 name      => $method,
 340                 code      => $code,
 341                 reverse   => "$component_class->$method",
 342                 class     => $component_class,
 343                 namespace => Catalyst::Utils::class2prefix(
 344                     $component_class, ref($c)->config->{case_sensitive}
 345                 ),
 346             }
 347         );
 348     }
 349     else {
 350         my $error =
 351           qq/Couldn't forward to "$component_class". Does not implement "$method"/;
 352         $c->error($error);
 353         $c->log->debug($error)
 354           if $c->debug;
 355         return 0;
 356     }
 357 }
 358
 359 =head2 $self->prepare_action($c)
 360
 361 Find an dispatch type that matches $c->req->path, and set args from it.
 362
 363 =cut
 364
 365 sub prepare_action {
 366     my ( $self, $c ) = @_;
 367     my $req = $c->req;
 368     my $path = $req->path;
 369     my @path = split /\//, $req->path;
 370     $req->args( \my @args );
 371
 372     unshift( @path, '' );    # Root action
 373
 374   DESCEND: while (@path) {
 375         $path = join '/', @path;
 376         $path =~ s#^/+##;
 377
 378         # Check out dispatch types to see if any will handle the path at
 379         # this level
 380
 381         foreach my $type ( @{ $self->dispatch_types } ) {
 382             last DESCEND if $type->match( $c, $path );
 383         }
 384
 385         # If not, move the last part path to args
 386         my $arg = pop(@path);
 387         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 388         unshift @args, $arg;
 389     }
 390
 391     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 392
 393     if($c->debug && defined $req->match && length $req->match) {
 394       my $match = $req->match;
 395       $match =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 396       $match = decode_utf8($match);
 397       $c->log->debug( 'Path is "' . $match . '"' )
 398     }
 399
 400     $c->log->debug( 'Arguments are "' . join( '/', map { decode_utf8 $_ } @args ) . '"' )
 401       if ( $c->debug && @args );
 402 }
 403
 404 =head2 $self->get_action( $action, $namespace )
 405
 406 returns a named action from a given namespace.
 407
 408 =cut
 409
 410 sub get_action {
 411     my ( $self, $name, $namespace ) = @_;
 412     return unless $name;
 413
 414     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 415
 416     return $self->_action_hash->{"${namespace}/${name}"};
 417 }
 418
 419 =head2 $self->get_action_by_path( $path );
 420
 421 Returns the named action by its full private path.
 422
 423 =cut
 424
 425 sub get_action_by_path {
 426     my ( $self, $path ) = @_;
 427     $path =~ s/^\///;
 428     $path = "/$path" unless $path =~ /\//;
 429     $self->_action_hash->{$path};
 430 }
 431
 432 =head2 $self->get_actions( $c, $action, $namespace )
 433
 434 =cut
 435
 436 sub get_actions {
 437     my ( $self, $c, $action, $namespace ) = @_;
 438     return [] unless $action;
 439
 440     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 441
 442     my @match = $self->get_containers($namespace);
 443
 444     return map { $_->get_action($action) } @match;
 445 }
 446
 447 =head2 $self->get_containers( $namespace )
 448
 449 Return all the action containers for a given namespace, inclusive
 450
 451 =cut
 452
 453 sub get_containers {
 454     my ( $self, $namespace ) = @_;
 455     $namespace ||= '';
 456     $namespace = '' if $namespace eq '/';
 457
 458     my @containers;
 459
 460     if ( length $namespace ) {
 461         do {
 462             push @containers, $self->_container_hash->{$namespace};
 463         } while ( $namespace =~ s#/[^/]+$## );
 464     }
 465
 466     return reverse grep { defined } @containers, $self->_container_hash->{''};
 467 }
 468
 469 =head2 $self->uri_for_action($action, \@captures)
 470
 471 Takes a Catalyst::Action object and action parameters and returns a URI
 472 part such that if $c->req->path were this URI part, this action would be
 473 dispatched to with $c->req->captures set to the supplied arrayref.
 474
 475 If the action object is not available for external dispatch or the dispatcher
 476 cannot determine an appropriate URI, this method will return undef.
 477
 478 =cut
 479
 480 sub uri_for_action {
 481     my ( $self, $action, $captures) = @_;
 482     $captures ||= [];
 483     foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
 484         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 485         return( $uri eq '' ? '/' : $uri )
 486             if defined($uri);
 487     }
 488     return undef;
 489 }
 490
 491 =head2 expand_action
 492
 493 expand an action into a full representation of the dispatch.
 494 mostly useful for chained, other actions will just return a
 495 single action.
 496
 497 =cut
 498
 499 sub expand_action {
 500     my ($self, $action) = @_;
 501
 502     foreach my $dispatch_type (@{ $self->dispatch_types }) {
 503         my $expanded = $dispatch_type->expand_action($action);
 504         return $expanded if $expanded;
 505     }
 506
 507     return $action;
 508 }
 509
 510 =head2 $self->register( $c, $action )
 511
 512 Make sure all required dispatch types for this action are loaded, then
 513 pass the action to our dispatch types so they can register it if required.
 514 Also, set up the tree with the action containers.
 515
 516 =cut
 517
 518 sub register {
 519     my ( $self, $c, $action ) = @_;
 520
 521     my $registered = $self->_registered_dispatch_types;
 522
 523     foreach my $key ( keys %{ $action->attributes } ) {
 524         next if $key eq 'Private';
 525         my $class = "Catalyst::DispatchType::$key";
 526         unless ( $registered->{$class} ) {
 527             # FIXME - Some error checking and re-throwing needed here, as
 528             #         we eat exceptions loading dispatch types.
 529             # see also try_load_class
 530             eval { load_class($class) };
 531             my $load_failed = $@;
 532             $self->_check_deprecated_dispatch_type( $key, $load_failed );
 533             push( @{ $self->dispatch_types }, $class->new ) unless $load_failed;
 534             $registered->{$class} = 1;
 535         }
 536     }
 537
 538     my @dtypes = @{ $self->dispatch_types };
 539     my @normal_dtypes;
 540     my @low_precedence_dtypes;
 541
 542     for my $type ( @dtypes ) {
 543         if ($type->_is_low_precedence) {
 544             push @low_precedence_dtypes, $type;
 545         } else {
 546             push @normal_dtypes, $type;
 547         }
 548     }
 549
 550     # Pass the action to our dispatch types so they can register it if reqd.
 551     my $was_registered = 0;
 552     foreach my $type ( @normal_dtypes ) {
 553         $was_registered = 1 if $type->register( $c, $action );
 554     }
 555
 556     if (not $was_registered) {
 557         foreach my $type ( @low_precedence_dtypes ) {
 558             $type->register( $c, $action );
 559         }
 560     }
 561
 562     my $namespace = $action->namespace;
 563     my $name      = $action->name;
 564
 565     my $container = $self->_find_or_create_action_container($namespace);
 566
 567     # Set the method value
 568     $container->add_action($action);
 569
 570     $self->_action_hash->{"$namespace/$name"} = $action;
 571     $self->_container_hash->{$namespace} = $container;
 572 }
 573
 574 sub _find_or_create_action_container {
 575     my ( $self, $namespace ) = @_;
 576
 577     my $tree ||= $self->_tree;
 578
 579     return $tree->getNodeValue unless $namespace;
 580
 581     my @namespace = split '/', $namespace;
 582     return $self->_find_or_create_namespace_node( $tree, @namespace )
 583       ->getNodeValue;
 584 }
 585
 586 sub _find_or_create_namespace_node {
 587     my ( $self, $parent, $part, @namespace ) = @_;
 588
 589     return $parent unless $part;
 590
 591     my $child =
 592       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 593
 594     unless ($child) {
 595         my $container = Catalyst::ActionContainer->new($part);
 596         $parent->addChild( $child = Tree::Simple->new($container) );
 597     }
 598
 599     $self->_find_or_create_namespace_node( $child, @namespace );
 600 }
 601
 602 =head2 $self->setup_actions( $class, $context )
 603
 604 Loads all of the pre-load dispatch types, registers their actions and then
 605 loads all of the post-load dispatch types, and iterates over the tree of
 606 actions, displaying the debug information if appropriate.
 607
 608 =cut
 609
 610 sub setup_actions {
 611     my ( $self, $c ) = @_;
 612
 613     my @classes =
 614       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 615     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 616
 617     foreach my $comp ( values %{ $c->components } ) {
 618         $comp = $comp->() if ref($comp) eq 'CODE';
 619         $comp->register_actions($c) if $comp->can('register_actions');
 620     }
 621
 622     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 623
 624     return unless $c->debug;
 625     $self->_display_action_tables($c);
 626 }
 627
 628 sub _display_action_tables {
 629     my ($self, $c) = @_;
 630
 631     my $avail_width = Catalyst::Utils::term_width() - 12;
 632     my $col1_width = ($avail_width * .25) < 20 ? 20 : int($avail_width * .25);
 633     my $col2_width = ($avail_width * .50) < 36 ? 36 : int($avail_width * .50);
 634     my $col3_width =  $avail_width - $col1_width - $col2_width;
 635     my $privates = Text::SimpleTable->new(
 636         [ $col1_width, 'Private' ], [ $col2_width, 'Class' ], [ $col3_width, 'Method' ]
 637     );
 638
 639     my $has_private = 0;
 640     my $walker = sub {
 641         my ( $walker, $parent, $prefix ) = @_;
 642         $prefix .= $parent->getNodeValue || '';
 643         $prefix .= '/' unless $prefix =~ /\/$/;
 644         my $node = $parent->getNodeValue->actions;
 645
 646         for my $action ( keys %{$node} ) {
 647             my $action_obj = $node->{$action};
 648             next
 649               if ( ( $action =~ /^_.*/ )
 650                 && ( !$c->config->{show_internal_actions} ) );
 651             $privates->row( "$prefix$action", $action_obj->class, $action );
 652             $has_private = 1;
 653         }
 654
 655         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 656     };
 657
 658     $walker->( $walker, $self->_tree, '' );
 659     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 660       if $has_private;
 661
 662     # List all public actions
 663     $_->list($c) for @{ $self->dispatch_types };
 664 }
 665
 666 sub _load_dispatch_types {
 667     my ( $self, @types ) = @_;
 668
 669     my @loaded;
 670     # Preload action types
 671     for my $type (@types) {
 672         # first param is undef because we cannot get the appclass
 673         my $class = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $type);
 674
 675         my ($success, $error) = try_load_class($class);
 676         Catalyst::Exception->throw( message => $error ) if not $success;
 677         push @{ $self->dispatch_types }, $class->new;
 678
 679         push @loaded, $class;
 680     }
 681
 682     return @loaded;
 683 }
 684
 685 =head2 $self->dispatch_type( $type )
 686
 687 Get the DispatchType object of the relevant type, i.e. passing C<$type> of
 688 C<Chained> would return a L<Catalyst::DispatchType::Chained> object (assuming
 689 of course it's being used.)
 690
 691 =cut
 692
 693 sub dispatch_type {
 694     my ($self, $name) = @_;
 695
 696     # first param is undef because we cannot get the appclass
 697     $name = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $name);
 698
 699     for (@{ $self->dispatch_types }) {
 700         return $_ if ref($_) eq $name;
 701     }
 702     return undef;
 703 }
 704
 705 sub _check_deprecated_dispatch_type {
 706     my ($self, $key, $load_failed) = @_;
 707
 708     return unless $key =~ /^(Local)?Regexp?/;
 709
 710     # TODO: Should these throw an exception rather than just warning?
 711     if ($load_failed) {
 712         warn(   "Attempt to use deprecated $key dispatch type.\n"
 713               . "  Use Chained methods or install the standalone\n"
 714               . "  Catalyst::DispatchType::Regex if necessary.\n" );
 715     } elsif ( !defined $Catalyst::DispatchType::Regex::VERSION
 716         || $Catalyst::DispatchType::Regex::VERSION le '5.90020' ) {
 717         # We loaded the old core version of the Regex module this will break
 718         warn(   "The $key DispatchType has been removed from Catalyst core.\n"
 719               . "  An old version of the core Catalyst::DispatchType::Regex\n"
 720               . "  has been loaded and will likely fail. Please remove\n"
 721               . "   $INC{'Catalyst/DispatchType/Regex.pm'}\n"
 722               . "  and use Chained methods or install the standalone\n"
 723               . "  Catalyst::DispatchType::Regex if necessary.\n" );
 724     }
 725 }
 726
 727 use Moose;
 728
 729 # 5.70 backwards compatibility hacks.
 730
 731 # Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
 732 # need the methods here which *should* be private..
 733
 734 # You should be able to use get_actions or get_containers appropriately
 735 # instead of relying on these methods which expose implementation details
 736 # of the dispatcher..
 737 #
 738 # IRC backlog included below, please come ask if this doesn't work for you.
 739 #
 740 # <@t0m> 5.80, the state of. There are things in the dispatcher which have
 741 #        been deprecated, that we yell at anyone for using, which there isn't
 742 #        a good alternative for yet..
 743 # <@mst> er, get_actions/get_containers provides that doesn't it?
 744 # <@mst> DispatchTypes are loaded on demand anyway
 745 # <@t0m> I'm thinking of things like _tree which is aliased to 'tree' with
 746 #        warnings otherwise shit breaks.. We're issuing warnings about the
 747 #        correct set of things which you shouldn't be calling..
 748 # <@mst> right
 749 # <@mst> basically, I don't see there's a need for a replacement for anything
 750 # <@mst> it was never a good idea to call ->tree
 751 # <@mst> nothingmuch was the only one who did AFAIK
 752 # <@mst> and he admitted it was a hack ;)
 753
 754 # See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
 755
 756 # Alias _method_name to method_name, add a before modifier to warn..
 757 foreach my $public_method_name (qw/
 758         tree
 759         registered_dispatch_types
 760         method_action_class
 761         action_hash
 762         container_hash
 763     /) {
 764     my $private_method_name = '_' . $public_method_name;
 765     my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 766     $meta->add_method($public_method_name, $meta->get_method($private_method_name));
 767     {
 768         my %package_hash; # Only warn once per method, per package. These are infrequent enough that
 769                           # I haven't provided a way to disable them, patches welcome.
 770         $meta->add_before_method_modifier($public_method_name, sub {
 771             my $class = caller(2);
 772             chomp($class);
 773             $package_hash{$class}++ || do {
 774                 warn("Class $class is calling the deprecated method\n"
 775                     . "  Catalyst::Dispatcher::$public_method_name,\n"
 776                     . "  this will be removed in Catalyst 5.9\n");
 777             };
 778         });
 779     }
 780 }
 781 # End 5.70 backwards compatibility hacks.
 782
 783 __PACKAGE__->meta->make_immutable;
 784
 785 =head2 meta
 786
 787 Provided by Moose
 788
 789 =head1 AUTHORS
 790
 791 Catalyst Contributors, see Catalyst.pm
 792
 793 =head1 COPYRIGHT
 794
 795 This library is free software. You can redistribute it and/or modify it under
 796 the same terms as Perl itself.
 797
 798 =cut
 799
 800 1;