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