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