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     Catalyst::Exception::Detach->throw;
 277 }
 278
 279 sub _action_rel2abs {
 280     my ( $self, $c, $path ) = @_;
 281
 282     unless ( $path =~ m#^/# ) {
 283         my $namespace = $c->stack->[-1]->namespace;
 284         $path = "$namespace/$path";
 285     }
 286
 287     $path =~ s#^/##;
 288     return $path;
 289 }
 290
 291 sub _invoke_as_path {
 292     my ( $self, $c, $rel_path, $args ) = @_;
 293
 294     my $path = $self->_action_rel2abs( $c, $rel_path );
 295
 296     my ( $tail, @extra_args );
 297     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 298     {                           # allow $path to be empty
 299         if ( my $action = $c->get_action( $tail, $path ) ) {
 300             push @$args, @extra_args;
 301             return $action;
 302         }
 303         else {
 304             return
 305               unless $path
 306               ; # if a match on the global namespace failed then the whole lookup failed
 307         }
 308
 309         unshift @extra_args, $tail;
 310     }
 311 }
 312
 313 sub _find_component {
 314     my ( $self, $c, $component ) = @_;
 315
 316     # fugly, why doesn't ->component('MyApp') work?
 317     return $c if ($component eq blessed($c));
 318
 319     return blessed($component)
 320         ? $component
 321         : $c->component($component);
 322 }
 323
 324 sub _invoke_as_component {
 325     my ( $self, $c, $component_or_class, $method ) = @_;
 326
 327     my $component = $self->_find_component($c, $component_or_class);
 328     my $component_class = blessed $component || return 0;
 329
 330     if (my $code = $component_class->can('action_for')) {
 331         my $possible_action = $component->$code($method);
 332         return $possible_action if $possible_action;
 333     }
 334
 335     if ( my $code = $component_class->can($method) ) {
 336         return $self->_method_action_class->new(
 337             {
 338                 name      => $method,
 339                 code      => $code,
 340                 reverse   => "$component_class->$method",
 341                 class     => $component_class,
 342                 namespace => Catalyst::Utils::class2prefix(
 343                     $component_class, ref($c)->config->{case_sensitive}
 344                 ),
 345             }
 346         );
 347     }
 348     else {
 349         my $error =
 350           qq/Couldn't forward to "$component_class". Does not implement "$method"/;
 351         $c->error($error);
 352         $c->log->debug($error)
 353           if $c->debug;
 354         return 0;
 355     }
 356 }
 357
 358 =head2 $self->prepare_action($c)
 359
 360 Find an dispatch type that matches $c->req->path, and set args from it.
 361
 362 =cut
 363
 364 sub prepare_action {
 365     my ( $self, $c ) = @_;
 366     my $req = $c->req;
 367     my $path = $req->path;
 368     my @path = split /\//, $req->path;
 369     $req->args( \my @args );
 370
 371     unshift( @path, '' );    # Root action
 372
 373   DESCEND: while (@path) {
 374         $path = join '/', @path;
 375         $path =~ s#^/+##;
 376
 377         # Check out dispatch types to see if any will handle the path at
 378         # this level
 379
 380         foreach my $type ( @{ $self->dispatch_types } ) {
 381             last DESCEND if $type->match( $c, $path );
 382         }
 383
 384         # If not, move the last part path to args
 385         my $arg = pop(@path);
 386         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 387         unshift @args, $arg;
 388     }
 389
 390     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 391
 392     if($c->debug && defined $req->match && length $req->match) {
 393       my $match = $req->match;
 394       $match =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 395       $match = decode_utf8($match);
 396       $c->log->debug( 'Path is "' . $match . '"' )
 397     }
 398
 399     $c->log->debug( 'Arguments are "' . join( '/', map { decode_utf8 $_ } @args ) . '"' )
 400       if ( $c->debug && @args );
 401 }
 402
 403 =head2 $self->get_action( $action, $namespace )
 404
 405 returns a named action from a given namespace.
 406
 407 =cut
 408
 409 sub get_action {
 410     my ( $self, $name, $namespace ) = @_;
 411     return unless $name;
 412
 413     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 414
 415     return $self->_action_hash->{"${namespace}/${name}"};
 416 }
 417
 418 =head2 $self->get_action_by_path( $path );
 419
 420 Returns the named action by its full private path.
 421
 422 =cut
 423
 424 sub get_action_by_path {
 425     my ( $self, $path ) = @_;
 426     $path =~ s/^\///;
 427     $path = "/$path" unless $path =~ /\//;
 428     $self->_action_hash->{$path};
 429 }
 430
 431 =head2 $self->get_actions( $c, $action, $namespace )
 432
 433 =cut
 434
 435 sub get_actions {
 436     my ( $self, $c, $action, $namespace ) = @_;
 437     return [] unless $action;
 438
 439     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 440
 441     my @match = $self->get_containers($namespace);
 442
 443     return map { $_->get_action($action) } @match;
 444 }
 445
 446 =head2 $self->get_containers( $namespace )
 447
 448 Return all the action containers for a given namespace, inclusive
 449
 450 =cut
 451
 452 sub get_containers {
 453     my ( $self, $namespace ) = @_;
 454     $namespace ||= '';
 455     $namespace = '' if $namespace eq '/';
 456
 457     my @containers;
 458
 459     if ( length $namespace ) {
 460         do {
 461             push @containers, $self->_container_hash->{$namespace};
 462         } while ( $namespace =~ s#/[^/]+$## );
 463     }
 464
 465     return reverse grep { defined } @containers, $self->_container_hash->{''};
 466 }
 467
 468 =head2 $self->uri_for_action($action, \@captures)
 469
 470 Takes a Catalyst::Action object and action parameters and returns a URI
 471 part such that if $c->req->path were this URI part, this action would be
 472 dispatched to with $c->req->captures set to the supplied arrayref.
 473
 474 If the action object is not available for external dispatch or the dispatcher
 475 cannot determine an appropriate URI, this method will return undef.
 476
 477 =cut
 478
 479 sub uri_for_action {
 480     my ( $self, $action, $captures) = @_;
 481     $captures ||= [];
 482     foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
 483         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 484         return( $uri eq '' ? '/' : $uri )
 485             if defined($uri);
 486     }
 487     return undef;
 488 }
 489
 490 =head2 expand_action
 491
 492 expand an action into a full representation of the dispatch.
 493 mostly useful for chained, other actions will just return a
 494 single action.
 495
 496 =cut
 497
 498 sub expand_action {
 499     my ($self, $action) = @_;
 500
 501     foreach my $dispatch_type (@{ $self->dispatch_types }) {
 502         my $expanded = $dispatch_type->expand_action($action);
 503         return $expanded if $expanded;
 504     }
 505
 506     return $action;
 507 }
 508
 509 =head2 $self->register( $c, $action )
 510
 511 Make sure all required dispatch types for this action are loaded, then
 512 pass the action to our dispatch types so they can register it if required.
 513 Also, set up the tree with the action containers.
 514
 515 =cut
 516
 517 sub register {
 518     my ( $self, $c, $action ) = @_;
 519
 520     my $registered = $self->_registered_dispatch_types;
 521
 522     foreach my $key ( keys %{ $action->attributes } ) {
 523         next if $key eq 'Private';
 524         my $class = "Catalyst::DispatchType::$key";
 525         unless ( $registered->{$class} ) {
 526             # FIXME - Some error checking and re-throwing needed here, as
 527             #         we eat exceptions loading dispatch types.
 528             # see also try_load_class
 529             eval { load_class($class) };
 530             my $load_failed = $@;
 531             $self->_check_deprecated_dispatch_type( $key, $load_failed );
 532             push( @{ $self->dispatch_types }, $class->new ) unless $load_failed;
 533             $registered->{$class} = 1;
 534         }
 535     }
 536
 537     my @dtypes = @{ $self->dispatch_types };
 538     my @normal_dtypes;
 539     my @low_precedence_dtypes;
 540
 541     for my $type ( @dtypes ) {
 542         if ($type->_is_low_precedence) {
 543             push @low_precedence_dtypes, $type;
 544         } else {
 545             push @normal_dtypes, $type;
 546         }
 547     }
 548
 549     # Pass the action to our dispatch types so they can register it if reqd.
 550     my $was_registered = 0;
 551     foreach my $type ( @normal_dtypes ) {
 552         $was_registered = 1 if $type->register( $c, $action );
 553     }
 554
 555     if (not $was_registered) {
 556         foreach my $type ( @low_precedence_dtypes ) {
 557             $type->register( $c, $action );
 558         }
 559     }
 560
 561     my $namespace = $action->namespace;
 562     my $name      = $action->name;
 563
 564     my $container = $self->_find_or_create_action_container($namespace);
 565
 566     # Set the method value
 567     $container->add_action($action);
 568
 569     $self->_action_hash->{"$namespace/$name"} = $action;
 570     $self->_container_hash->{$namespace} = $container;
 571 }
 572
 573 sub _find_or_create_action_container {
 574     my ( $self, $namespace ) = @_;
 575
 576     my $tree ||= $self->_tree;
 577
 578     return $tree->getNodeValue unless $namespace;
 579
 580     my @namespace = split '/', $namespace;
 581     return $self->_find_or_create_namespace_node( $tree, @namespace )
 582       ->getNodeValue;
 583 }
 584
 585 sub _find_or_create_namespace_node {
 586     my ( $self, $parent, $part, @namespace ) = @_;
 587
 588     return $parent unless $part;
 589
 590     my $child =
 591       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 592
 593     unless ($child) {
 594         my $container = Catalyst::ActionContainer->new($part);
 595         $parent->addChild( $child = Tree::Simple->new($container) );
 596     }
 597
 598     $self->_find_or_create_namespace_node( $child, @namespace );
 599 }
 600
 601 =head2 $self->setup_actions( $class, $context )
 602
 603 Loads all of the pre-load dispatch types, registers their actions and then
 604 loads all of the post-load dispatch types, and iterates over the tree of
 605 actions, displaying the debug information if appropriate.
 606
 607 =cut
 608
 609 sub setup_actions {
 610     my ( $self, $c ) = @_;
 611
 612     my @classes =
 613       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 614     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 615
 616     foreach my $comp ( values %{ $c->components } ) {
 617         $comp->register_actions($c) if $comp->can('register_actions');
 618     }
 619
 620     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 621
 622     return unless $c->debug;
 623     $self->_display_action_tables($c);
 624 }
 625
 626 sub _display_action_tables {
 627     my ($self, $c) = @_;
 628
 629     my $avail_width = Catalyst::Utils::term_width() - 12;
 630     my $col1_width = ($avail_width * .25) < 20 ? 20 : int($avail_width * .25);
 631     my $col2_width = ($avail_width * .50) < 36 ? 36 : int($avail_width * .50);
 632     my $col3_width =  $avail_width - $col1_width - $col2_width;
 633     my $privates = Text::SimpleTable->new(
 634         [ $col1_width, 'Private' ], [ $col2_width, 'Class' ], [ $col3_width, 'Method' ]
 635     );
 636
 637     my $has_private = 0;
 638     my $walker = sub {
 639         my ( $walker, $parent, $prefix ) = @_;
 640         $prefix .= $parent->getNodeValue || '';
 641         $prefix .= '/' unless $prefix =~ /\/$/;
 642         my $node = $parent->getNodeValue->actions;
 643
 644         for my $action ( keys %{$node} ) {
 645             my $action_obj = $node->{$action};
 646             next
 647               if ( ( $action =~ /^_.*/ )
 648                 && ( !$c->config->{show_internal_actions} ) );
 649             $privates->row( "$prefix$action", $action_obj->class, $action );
 650             $has_private = 1;
 651         }
 652
 653         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 654     };
 655
 656     $walker->( $walker, $self->_tree, '' );
 657     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 658       if $has_private;
 659
 660     # List all public actions
 661     $_->list($c) for @{ $self->dispatch_types };
 662 }
 663
 664 sub _load_dispatch_types {
 665     my ( $self, @types ) = @_;
 666
 667     my @loaded;
 668     # Preload action types
 669     for my $type (@types) {
 670         # first param is undef because we cannot get the appclass
 671         my $class = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $type);
 672
 673         my ($success, $error) = try_load_class($class);
 674         Catalyst::Exception->throw( message => $error ) if not $success;
 675         push @{ $self->dispatch_types }, $class->new;
 676
 677         push @loaded, $class;
 678     }
 679
 680     return @loaded;
 681 }
 682
 683 =head2 $self->dispatch_type( $type )
 684
 685 Get the DispatchType object of the relevant type, i.e. passing C<$type> of
 686 C<Chained> would return a L<Catalyst::DispatchType::Chained> object (assuming
 687 of course it's being used.)
 688
 689 =cut
 690
 691 sub dispatch_type {
 692     my ($self, $name) = @_;
 693
 694     # first param is undef because we cannot get the appclass
 695     $name = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $name);
 696
 697     for (@{ $self->dispatch_types }) {
 698         return $_ if ref($_) eq $name;
 699     }
 700     return undef;
 701 }
 702
 703 sub _check_deprecated_dispatch_type {
 704     my ($self, $key, $load_failed) = @_;
 705
 706     return unless $key =~ /^(Local)?Regexp?/;
 707
 708     # TODO: Should these throw an exception rather than just warning?
 709     if ($load_failed) {
 710         warn(   "Attempt to use deprecated $key dispatch type.\n"
 711               . "  Use Chained methods or install the standalone\n"
 712               . "  Catalyst::DispatchType::Regex if necessary.\n" );
 713     } elsif ( !defined $Catalyst::DispatchType::Regex::VERSION
 714         || $Catalyst::DispatchType::Regex::VERSION le '5.90020' ) {
 715         # We loaded the old core version of the Regex module this will break
 716         warn(   "The $key DispatchType has been removed from Catalyst core.\n"
 717               . "  An old version of the core Catalyst::DispatchType::Regex\n"
 718               . "  has been loaded and will likely fail. Please remove\n"
 719               . "   $INC{'Catalyst/DispatchType/Regex.pm'}\n"
 720               . "  and use Chained methods or install the standalone\n"
 721               . "  Catalyst::DispatchType::Regex if necessary.\n" );
 722     }
 723 }
 724
 725 use Moose;
 726
 727 # 5.70 backwards compatibility hacks.
 728
 729 # Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
 730 # need the methods here which *should* be private..
 731
 732 # You should be able to use get_actions or get_containers appropriately
 733 # instead of relying on these methods which expose implementation details
 734 # of the dispatcher..
 735 #
 736 # IRC backlog included below, please come ask if this doesn't work for you.
 737 #
 738 # <@t0m> 5.80, the state of. There are things in the dispatcher which have
 739 #        been deprecated, that we yell at anyone for using, which there isn't
 740 #        a good alternative for yet..
 741 # <@mst> er, get_actions/get_containers provides that doesn't it?
 742 # <@mst> DispatchTypes are loaded on demand anyway
 743 # <@t0m> I'm thinking of things like _tree which is aliased to 'tree' with
 744 #        warnings otherwise shit breaks.. We're issuing warnings about the
 745 #        correct set of things which you shouldn't be calling..
 746 # <@mst> right
 747 # <@mst> basically, I don't see there's a need for a replacement for anything
 748 # <@mst> it was never a good idea to call ->tree
 749 # <@mst> nothingmuch was the only one who did AFAIK
 750 # <@mst> and he admitted it was a hack ;)
 751
 752 # See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
 753
 754 # Alias _method_name to method_name, add a before modifier to warn..
 755 foreach my $public_method_name (qw/
 756         tree
 757         registered_dispatch_types
 758         method_action_class
 759         action_hash
 760         container_hash
 761     /) {
 762     my $private_method_name = '_' . $public_method_name;
 763     my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 764     $meta->add_method($public_method_name, $meta->get_method($private_method_name));
 765     {
 766         my %package_hash; # Only warn once per method, per package. These are infrequent enough that
 767                           # I haven't provided a way to disable them, patches welcome.
 768         $meta->add_before_method_modifier($public_method_name, sub {
 769             my $class = caller(2);
 770             chomp($class);
 771             $package_hash{$class}++ || do {
 772                 warn("Class $class is calling the deprecated method\n"
 773                     . "  Catalyst::Dispatcher::$public_method_name,\n"
 774                     . "  this will be removed in Catalyst 5.9\n");
 775             };
 776         });
 777     }
 778 }
 779 # End 5.70 backwards compatibility hacks.
 780
 781 __PACKAGE__->meta->make_immutable;
 782
 783 =head2 meta
 784
 785 Provided by Moose
 786
 787 =head1 AUTHORS
 788
 789 Catalyst Contributors, see Catalyst.pm
 790
 791 =head1 COPYRIGHT
 792
 793 This library is free software. You can redistribute it and/or modify it under
 794 the same terms as Perl itself.
 795
 796 =cut
 797
 798 1;