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->trace(1, $error);
 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->trace(1,'Nothing to go to');
 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->trace(1,$error);
 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->trace(1,$error);
 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->trace(1,$error);
 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->trace(1, 'Path is "' . $req->match . '"' )
 388       if (defined $req->match && length $req->match );
 389
 390     $c->trace(1, 'Arguments are "' . join( '/', @args ) . '"' )
 391       if @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->register( $c, $action )
 501
 502 Make sure all required dispatch types for this action are loaded, then
 503 pass the action to our dispatch types so they can register it if required.
 504 Also, set up the tree with the action containers.
 505
 506 =cut
 507
 508 sub register {
 509     my ( $self, $c, $action ) = @_;
 510
 511     my $registered = $self->_registered_dispatch_types;
 512
 513     foreach my $key ( keys %{ $action->attributes } ) {
 514         next if $key eq 'Private';
 515         my $class = "Catalyst::DispatchType::$key";
 516         unless ( $registered->{$class} ) {
 517             # FIXME - Some error checking and re-throwing needed here, as
 518             #         we eat exceptions loading dispatch types.
 519             # see also try_load_class
 520             eval { load_class($class) };
 521             my $load_failed = $@;
 522             $self->_check_deprecated_dispatch_type( $key, $load_failed );
 523             push( @{ $self->dispatch_types }, $class->new ) unless $load_failed;
 524             $registered->{$class} = 1;
 525         }
 526     }
 527
 528     my @dtypes = @{ $self->dispatch_types };
 529     my @normal_dtypes;
 530     my @low_precedence_dtypes;
 531
 532     for my $type ( @dtypes ) {
 533         if ($type->_is_low_precedence) {
 534             push @low_precedence_dtypes, $type;
 535         } else {
 536             push @normal_dtypes, $type;
 537         }
 538     }
 539
 540     # Pass the action to our dispatch types so they can register it if reqd.
 541     my $was_registered = 0;
 542     foreach my $type ( @normal_dtypes ) {
 543         $was_registered = 1 if $type->register( $c, $action );
 544     }
 545
 546     if (not $was_registered) {
 547         foreach my $type ( @low_precedence_dtypes ) {
 548             $type->register( $c, $action );
 549         }
 550     }
 551
 552     my $namespace = $action->namespace;
 553     my $name      = $action->name;
 554
 555     my $container = $self->_find_or_create_action_container($namespace);
 556
 557     # Set the method value
 558     $container->add_action($action);
 559
 560     $self->_action_hash->{"$namespace/$name"} = $action;
 561     $self->_container_hash->{$namespace} = $container;
 562 }
 563
 564 sub _find_or_create_action_container {
 565     my ( $self, $namespace ) = @_;
 566
 567     my $tree ||= $self->_tree;
 568
 569     return $tree->getNodeValue unless $namespace;
 570
 571     my @namespace = split '/', $namespace;
 572     return $self->_find_or_create_namespace_node( $tree, @namespace )
 573       ->getNodeValue;
 574 }
 575
 576 sub _find_or_create_namespace_node {
 577     my ( $self, $parent, $part, @namespace ) = @_;
 578
 579     return $parent unless $part;
 580
 581     my $child =
 582       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 583
 584     unless ($child) {
 585         my $container = Catalyst::ActionContainer->new($part);
 586         $parent->addChild( $child = Tree::Simple->new($container) );
 587     }
 588
 589     $self->_find_or_create_namespace_node( $child, @namespace );
 590 }
 591
 592 =head2 $self->setup_actions( $class, $context )
 593
 594 Loads all of the pre-load dispatch types, registers their actions and then
 595 loads all of the post-load dispatch types, and iterates over the tree of
 596 actions, displaying the debug information if appropriate.
 597
 598 =cut
 599
 600 sub setup_actions {
 601     my ( $self, $c ) = @_;
 602
 603     my @classes =
 604       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 605     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 606
 607     foreach my $comp ( values %{ $c->components } ) {
 608         $comp->register_actions($c) if $comp->can('register_actions');
 609     }
 610
 611     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 612
 613     return unless $c->trace_level;
 614     $self->_display_action_tables($c);
 615 }
 616
 617 sub _display_action_tables {
 618     my ($self, $c) = @_;
 619
 620     my $avail_width = Catalyst::Utils::term_width() - 12;
 621     my $col1_width = ($avail_width * .25) < 20 ? 20 : int($avail_width * .25);
 622     my $col2_width = ($avail_width * .50) < 36 ? 36 : int($avail_width * .50);
 623     my $col3_width =  $avail_width - $col1_width - $col2_width;
 624     my $privates = Text::SimpleTable->new(
 625         [ $col1_width, 'Private' ], [ $col2_width, 'Class' ], [ $col3_width, 'Method' ]
 626     );
 627
 628     my $has_private = 0;
 629     my $walker = sub {
 630         my ( $walker, $parent, $prefix ) = @_;
 631         $prefix .= $parent->getNodeValue || '';
 632         $prefix .= '/' unless $prefix =~ /\/$/;
 633         my $node = $parent->getNodeValue->actions;
 634
 635         for my $action ( keys %{$node} ) {
 636             my $action_obj = $node->{$action};
 637             next
 638               if ( ( $action =~ /^_.*/ )
 639                 && ( !$c->config->{show_internal_actions} ) );
 640             $privates->row( "$prefix$action", $action_obj->class, $action );
 641             $has_private = 1;
 642         }
 643
 644         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 645     };
 646
 647     $walker->( $walker, $self->_tree, '' );
 648     $c->trace(1, "Loaded Private actions:\n" . $privates->draw . "\n" )
 649       if $has_private;
 650
 651     # List all public actions
 652     $_->list($c) for @{ $self->dispatch_types };
 653 }
 654
 655 sub _load_dispatch_types {
 656     my ( $self, @types ) = @_;
 657
 658     my @loaded;
 659     # Preload action types
 660     for my $type (@types) {
 661         # first param is undef because we cannot get the appclass
 662         my $class = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $type);
 663
 664         my ($success, $error) = try_load_class($class);
 665         Catalyst::Exception->throw( message => $error ) if not $success;
 666         push @{ $self->dispatch_types }, $class->new;
 667
 668         push @loaded, $class;
 669     }
 670
 671     return @loaded;
 672 }
 673
 674 =head2 $self->dispatch_type( $type )
 675
 676 Get the DispatchType object of the relevant type, i.e. passing C<$type> of
 677 C<Chained> would return a L<Catalyst::DispatchType::Chained> object (assuming
 678 of course it's being used.)
 679
 680 =cut
 681
 682 sub dispatch_type {
 683     my ($self, $name) = @_;
 684
 685     # first param is undef because we cannot get the appclass
 686     $name = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $name);
 687
 688     for (@{ $self->dispatch_types }) {
 689         return $_ if ref($_) eq $name;
 690     }
 691     return undef;
 692 }
 693
 694 sub _check_deprecated_dispatch_type {
 695     my ($self, $key, $load_failed) = @_;
 696
 697     return unless $key =~ /^(Local)?Regexp?/;
 698
 699     # TODO: Should these throw an exception rather than just warning?
 700     if ($load_failed) {
 701         warn(   "Attempt to use deprecated $key dispatch type.\n"
 702               . "  Use Chained methods or install the standalone\n"
 703               . "  Catalyst::DispatchType::Regex if necessary.\n" );
 704     } elsif ( !defined $Catalyst::DispatchType::Regex::VERSION
 705         || $Catalyst::DispatchType::Regex::VERSION le '5.90020' ) {
 706         # We loaded the old core version of the Regex module this will break
 707         warn(   "The $key DispatchType has been removed from Catalyst core.\n"
 708               . "  An old version of the core Catalyst::DispatchType::Regex\n"
 709               . "  has been loaded and will likely fail. Please remove\n"
 710               . "   $INC{'Catalyst/DispatchType/Regex.pm'}\n"
 711               . "  and use Chained methods or install the standalone\n"
 712               . "  Catalyst::DispatchType::Regex if necessary.\n" );
 713     }
 714 }
 715
 716 use Moose;
 717
 718 # 5.70 backwards compatibility hacks.
 719
 720 # Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
 721 # need the methods here which *should* be private..
 722
 723 # You should be able to use get_actions or get_containers appropriately
 724 # instead of relying on these methods which expose implementation details
 725 # of the dispatcher..
 726 #
 727 # IRC backlog included below, please come ask if this doesn't work for you.
 728 #
 729 # <@t0m> 5.80, the state of. There are things in the dispatcher which have
 730 #        been deprecated, that we yell at anyone for using, which there isn't
 731 #        a good alternative for yet..
 732 # <@mst> er, get_actions/get_containers provides that doesn't it?
 733 # <@mst> DispatchTypes are loaded on demand anyway
 734 # <@t0m> I'm thinking of things like _tree which is aliased to 'tree' with
 735 #        warnings otherwise shit breaks.. We're issuing warnings about the
 736 #        correct set of things which you shouldn't be calling..
 737 # <@mst> right
 738 # <@mst> basically, I don't see there's a need for a replacement for anything
 739 # <@mst> it was never a good idea to call ->tree
 740 # <@mst> nothingmuch was the only one who did AFAIK
 741 # <@mst> and he admitted it was a hack ;)
 742
 743 # See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
 744
 745 # Alias _method_name to method_name, add a before modifier to warn..
 746 foreach my $public_method_name (qw/
 747         tree
 748         registered_dispatch_types
 749         method_action_class
 750         action_hash
 751         container_hash
 752     /) {
 753     my $private_method_name = '_' . $public_method_name;
 754     my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 755     $meta->add_method($public_method_name, $meta->get_method($private_method_name));
 756     {
 757         my %package_hash; # Only warn once per method, per package. These are infrequent enough that
 758                           # I haven't provided a way to disable them, patches welcome.
 759         $meta->add_before_method_modifier($public_method_name, sub {
 760             my $class = caller(2);
 761             chomp($class);
 762             $package_hash{$class}++ || do {
 763                 warn("Class $class is calling the deprecated method\n"
 764                     . "  Catalyst::Dispatcher::$public_method_name,\n"
 765                     . "  this will be removed in Catalyst 5.9\n");
 766             };
 767         });
 768     }
 769 }
 770 # End 5.70 backwards compatibility hacks.
 771
 772 __PACKAGE__->meta->make_immutable;
 773
 774 =head2 meta
 775
 776 Provided by Moose
 777
 778 =head1 AUTHORS
 779
 780 Catalyst Contributors, see Catalyst.pm
 781
 782 =head1 COPYRIGHT
 783
 784 This library is free software. You can redistribute it and/or modify it under
 785 the same terms as Perl itself.
 786
 787 =cut
 788
 789 1;