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