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