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     unless ($command) {
 126         $c->log->debug('Nothing to go to') if $c->debug;
 127         return 0;
 128     }
 129
 130     my (@args, @captures);
 131
 132     if ( ref( $extra_params[-2] ) eq 'ARRAY' ) {
 133         @captures = @{ splice @extra_params, -2, 1 };
 134     }
 135
 136     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
 137         @args = @{ pop @extra_params }
 138     } else {
 139         # this is a copy, it may take some abuse from
 140         # ->_invoke_as_path if the path had trailing parts
 141         @args = @{ $c->request->arguments };
 142     }
 143
 144     my $action;
 145     # go to a string path ("/foo/bar/gorch")
 146     # or action object
 147     if (blessed($command) && $command->isa('Catalyst::Action')) {
 148         $action = $command;
 149     }
 150     else {
 151         $action = $self->_invoke_as_path( $c, "$command", \@args );
 152     }
 153     # go to a component ( "MyApp::*::Foo" or $c->component("...")
 154     # - a path or an object)
 155     unless ($action) {
 156         my $method = @extra_params ? $extra_params[0] : "process";
 157         $action = $self->_invoke_as_component( $c, $command, $method );
 158     }
 159
 160     return $action, \@args, \@captures;
 161 }
 162
 163 =head2 $self->visit( $c, $command [, \@arguments ] )
 164
 165 Documented in L<Catalyst>
 166
 167 =cut
 168
 169 sub visit {
 170     my $self = shift;
 171     $self->_do_visit('visit', @_);
 172 }
 173
 174 sub _do_visit {
 175     my $self = shift;
 176     my $opname = shift;
 177     my ( $c, $command ) = @_;
 178     my ( $action, $args, $captures ) = $self->_command2action(@_);
 179     my $error = qq/Couldn't $opname("$command"): /;
 180
 181     if (!$action) {
 182         $error .= qq/Couldn't $opname to command "$command": /
 183                  .qq/Invalid action or component./;
 184     }
 185     elsif (!defined $action->namespace) {
 186         $error .= qq/Action has no namespace: cannot $opname() to a plain /
 187                  .qq/method or component, must be an :Action of some sort./
 188     }
 189     elsif (!$action->class->can('_DISPATCH')) {
 190         $error .= qq/Action cannot _DISPATCH. /
 191                  .qq/Did you try to $opname() a non-controller action?/;
 192     }
 193     else {
 194         $error = q();
 195     }
 196
 197     if($error) {
 198         $c->error($error);
 199         $c->log->debug($error) if $c->debug;
 200         return 0;
 201     }
 202
 203     $action = $self->expand_action($action);
 204
 205     local $c->request->{arguments} = $args;
 206     local $c->request->{captures}  = $captures;
 207     local $c->{namespace} = $action->{'namespace'};
 208     local $c->{action} = $action;
 209     $self->dispatch($c);
 210 }
 211
 212 =head2 $self->go( $c, $command [, \@arguments ] )
 213
 214 Documented in L<Catalyst>
 215
 216 =cut
 217
 218 sub go {
 219     my $self = shift;
 220     $self->_do_visit('go', @_);
 221     Catalyst::Exception::Go->throw;
 222 }
 223
 224 =head2 $self->forward( $c, $command [, \@arguments ] )
 225
 226 Documented in L<Catalyst>
 227
 228 =cut
 229
 230 sub forward {
 231     my $self = shift;
 232     no warnings 'recursion';
 233     $self->_do_forward(forward => @_);
 234 }
 235
 236 sub _do_forward {
 237     my $self = shift;
 238     my $opname = shift;
 239     my ( $c, $command ) = @_;
 240     my ( $action, $args, $captures ) = $self->_command2action(@_);
 241
 242     if (!$action) {
 243         my $error .= qq/Couldn't $opname to command "$command": /
 244                     .qq/Invalid action or component./;
 245         $c->error($error);
 246         $c->log->debug($error) if $c->debug;
 247         return 0;
 248     }
 249
 250
 251     local $c->request->{arguments} = $args;
 252     no warnings 'recursion';
 253     $action->dispatch( $c );
 254
 255     return $c->state;
 256 }
 257
 258 =head2 $self->detach( $c, $command [, \@arguments ] )
 259
 260 Documented in L<Catalyst>
 261
 262 =cut
 263
 264 sub detach {
 265     my ( $self, $c, $command, @args ) = @_;
 266     $self->_do_forward(detach => $c, $command, @args ) if $command;
 267     Catalyst::Exception::Detach->throw;
 268 }
 269
 270 sub _action_rel2abs {
 271     my ( $self, $c, $path ) = @_;
 272
 273     unless ( $path =~ m#^/# ) {
 274         my $namespace = $c->stack->[-1]->namespace;
 275         $path = "$namespace/$path";
 276     }
 277
 278     $path =~ s#^/##;
 279     return $path;
 280 }
 281
 282 sub _invoke_as_path {
 283     my ( $self, $c, $rel_path, $args ) = @_;
 284     my $path = $self->_action_rel2abs( $c, $rel_path );
 285     my ( $tail, @extra_args );
 286     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 287     {                           # allow $path to be empty
 288         if ( my $action = $c->get_action( $tail, $path ) ) {
 289             push @$args, @extra_args;
 290             return $action;
 291         }
 292         else {
 293             return
 294               unless $path
 295               ; # if a match on the global namespace failed then the whole lookup failed
 296         }
 297
 298         unshift @extra_args, $tail;
 299     }
 300 }
 301
 302 sub _find_component {
 303     my ( $self, $c, $component ) = @_;
 304
 305     return blessed($component)
 306         ? $component
 307         : $c->component($component);
 308 }
 309
 310 sub _invoke_as_component {
 311     my ( $self, $c, $component_or_class, $method ) = @_;
 312     if( $component_or_class eq blessed($c->application) ){
 313         my $possible_action = $c->application->action_for($method);
 314         return $possible_action if $possible_action;
 315         if( my $code = $c->application->can($method) ){
 316             return $self->_method_action_class->new(
 317                 {
 318                     name      => $method,
 319                     code      => $code,
 320                     reverse   => "$component_or_class->$method",
 321                     class     => $component_or_class,
 322                     namespace => Catalyst::Utils::class2prefix(
 323                         $component_or_class,
 324                     ),
 325                 }
 326             );
 327         }
 328     }
 329     my $component = $self->_find_component($c, $component_or_class);
 330     my $component_class = blessed $component || return 0;
 331     if (my $code = $component_class->can('action_for')) {
 332         my $possible_action = $component->$code($method);
 333         return $possible_action if $possible_action;
 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,
 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     $c->log->debug( 'Path is "' . $req->match . '"' )
 393       if ( $c->debug && defined $req->match && length $req->match );
 394
 395     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 396       if ( $c->debug && @args );
 397 }
 398
 399 =head2 $self->get_action( $action, $namespace )
 400
 401 returns a named action from a given namespace.
 402
 403 =cut
 404
 405 sub get_action {
 406     my ( $self, $name, $namespace ) = @_;
 407     return unless $name;
 408
 409     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 410
 411     return $self->_action_hash->{"${namespace}/${name}"};
 412 }
 413
 414 =head2 $self->get_action_by_path( $path );
 415
 416 Returns the named action by its full private path.
 417
 418 =cut
 419
 420 sub get_action_by_path {
 421     my ( $self, $path ) = @_;
 422     $path =~ s/^\///;
 423     $path = "/$path" unless $path =~ /\//;
 424     $self->_action_hash->{$path};
 425 }
 426
 427 =head2 $self->get_actions( $c, $action, $namespace )
 428
 429 =cut
 430
 431 sub get_actions {
 432     my ( $self, $c, $action, $namespace ) = @_;
 433     return [] unless $action;
 434
 435     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 436
 437     my @match = $self->get_containers($namespace);
 438
 439     return map { $_->get_action($action) } @match;
 440 }
 441
 442 =head2 $self->get_containers( $namespace )
 443
 444 Return all the action containers for a given namespace, inclusive
 445
 446 =cut
 447
 448 sub get_containers {
 449     my ( $self, $namespace ) = @_;
 450     $namespace ||= '';
 451     $namespace = '' if $namespace eq '/';
 452
 453     my @containers;
 454
 455     if ( length $namespace ) {
 456         do {
 457             push @containers, $self->_container_hash->{$namespace};
 458         } while ( $namespace =~ s#/[^/]+$## );
 459     }
 460
 461     return reverse grep { defined } @containers, $self->_container_hash->{''};
 462 }
 463
 464 =head2 $self->uri_for_action($action, \@captures)
 465
 466 Takes a Catalyst::Action object and action parameters and returns a URI
 467 part such that if $c->req->path were this URI part, this action would be
 468 dispatched to with $c->req->captures set to the supplied arrayref.
 469
 470 If the action object is not available for external dispatch or the dispatcher
 471 cannot determine an appropriate URI, this method will return undef.
 472
 473 =cut
 474
 475 sub uri_for_action {
 476     my ( $self, $action, $captures) = @_;
 477     $captures ||= [];
 478     foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
 479         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 480         return( $uri eq '' ? '/' : $uri )
 481             if defined($uri);
 482     }
 483     return undef;
 484 }
 485
 486 =head2 expand_action
 487
 488 expand an action into a full representation of the dispatch.
 489 mostly useful for chained, other actions will just return a
 490 single action.
 491
 492 =cut
 493
 494 sub expand_action {
 495     my ($self, $action) = @_;
 496
 497     foreach my $dispatch_type (@{ $self->dispatch_types }) {
 498         my $expanded = $dispatch_type->expand_action($action);
 499         return $expanded if $expanded;
 500     }
 501
 502     return $action;
 503 }
 504
 505 =head2 $self->register( $c, $action )
 506
 507 Make sure all required dispatch types for this action are loaded, then
 508 pass the action to our dispatch types so they can register it if required.
 509 Also, set up the tree with the action containers.
 510
 511 =cut
 512
 513 sub register {
 514     my ( $self, $c, $action ) = @_;
 515
 516     my $registered = $self->_registered_dispatch_types;
 517
 518     #my $priv = 0; #seems to be unused
 519     foreach my $key ( keys %{ $action->attributes } ) {
 520         next if $key eq 'Private';
 521         my $class = "Catalyst::DispatchType::$key";
 522         unless ( $registered->{$class} ) {
 523             # FIXME - Some error checking and re-throwing needed here, as
 524             #         we eat exceptions loading dispatch types.
 525             eval { Class::MOP::load_class($class) };
 526             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 527             $registered->{$class} = 1;
 528         }
 529     }
 530
 531     my @dtypes = @{ $self->dispatch_types };
 532     my @normal_dtypes;
 533     my @low_precedence_dtypes;
 534
 535     for my $type ( @dtypes ) {
 536         if ($type->_is_low_precedence) {
 537             push @low_precedence_dtypes, $type;
 538         } else {
 539             push @normal_dtypes, $type;
 540         }
 541     }
 542
 543     # Pass the action to our dispatch types so they can register it if reqd.
 544     my $was_registered = 0;
 545     foreach my $type ( @normal_dtypes ) {
 546         $was_registered = 1 if $type->register( $c, $action );
 547     }
 548
 549     if (not $was_registered) {
 550         foreach my $type ( @low_precedence_dtypes ) {
 551             $type->register( $c, $action );
 552         }
 553     }
 554
 555     my $namespace = $action->namespace;
 556     my $name      = $action->name;
 557
 558     my $container = $self->_find_or_create_action_container($namespace);
 559
 560     # Set the method value
 561     $container->add_action($action);
 562
 563     $self->_action_hash->{"$namespace/$name"} = $action;
 564     $self->_container_hash->{$namespace} = $container;
 565 }
 566
 567 sub _find_or_create_action_container {
 568     my ( $self, $namespace ) = @_;
 569
 570     my $tree ||= $self->_tree;
 571
 572     return $tree->getNodeValue unless $namespace;
 573
 574     my @namespace = split '/', $namespace;
 575     return $self->_find_or_create_namespace_node( $tree, @namespace )
 576       ->getNodeValue;
 577 }
 578
 579 sub _find_or_create_namespace_node {
 580     my ( $self, $parent, $part, @namespace ) = @_;
 581
 582     return $parent unless $part;
 583
 584     my $child =
 585       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 586
 587     unless ($child) {
 588         my $container = Catalyst::ActionContainer->new($part);
 589         $parent->addChild( $child = Tree::Simple->new($container) );
 590     }
 591
 592     $self->_find_or_create_namespace_node( $child, @namespace );
 593 }
 594
 595 =head2 $self->setup_actions( $class, $context )
 596
 597 Loads all of the preload dispatch types, registers their actions and then
 598 loads all of the postload dispatch types, and iterates over the tree of
 599 actions, displaying the debug information if appropriate.
 600
 601 =cut
 602
 603 sub setup_actions {
 604     my ( $self, $c ) = @_;
 605
 606     my @classes =
 607       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 608     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 609
 610     foreach my $comp ( values %{ $c->components } ) {
 611         $comp->register_actions($c) if $comp->can('register_actions');
 612     }
 613
 614     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 615
 616     return unless $c->debug;
 617     $self->_display_action_tables($c);
 618 }
 619
 620 sub _display_action_tables {
 621     my ($self, $c) = @_;
 622
 623     my $avail_width = Catalyst::Utils::term_width() - 12;
 624     my $col1_width = ($avail_width * .25) < 20 ? 20 : int($avail_width * .25);
 625     my $col2_width = ($avail_width * .50) < 36 ? 36 : int($avail_width * .50);
 626     my $col3_width =  $avail_width - $col1_width - $col2_width;
 627     my $privates = Text::SimpleTable->new(
 628         [ $col1_width, 'Private' ], [ $col2_width, 'Class' ], [ $col3_width, 'Method' ]
 629     );
 630
 631     my $has_private = 0;
 632     my $walker = sub {
 633         my ( $walker, $parent, $prefix ) = @_;
 634         $prefix .= $parent->getNodeValue || '';
 635         $prefix .= '/' unless $prefix =~ /\/$/;
 636         my $node = $parent->getNodeValue->actions;
 637
 638         for my $action ( keys %{$node} ) {
 639             my $action_obj = $node->{$action};
 640             next
 641               if ( ( $action =~ /^_.*/ )
 642                 && ( !$c->config->{show_internal_actions} ) );
 643             $privates->row( "$prefix$action", $action_obj->class, $action );
 644             $has_private = 1;
 645         }
 646
 647         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 648     };
 649
 650     $walker->( $walker, $self->_tree, '' );
 651     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 652       if $has_private;
 653
 654     # List all public actions
 655     $_->list($c) for @{ $self->dispatch_types };
 656 }
 657
 658 sub _load_dispatch_types {
 659     my ( $self, @types ) = @_;
 660
 661     my @loaded;
 662     # Preload action types
 663     for my $type (@types) {
 664         # first param is undef because we cannot get the appclass
 665         my $class = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $type);
 666
 667         eval { Class::MOP::load_class($class) };
 668         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 669           if $@;
 670         push @{ $self->dispatch_types }, $class->new;
 671
 672         push @loaded, $class;
 673     }
 674
 675     return @loaded;
 676 }
 677
 678 =head2 $self->dispatch_type( $type )
 679
 680 Get the DispatchType object of the relevant type, i.e. passing C<$type> of
 681 C<Chained> would return a L<Catalyst::DispatchType::Chained> object (assuming
 682 of course it's being used.)
 683
 684 =cut
 685
 686 sub dispatch_type {
 687     my ($self, $name) = @_;
 688
 689     # first param is undef because we cannot get the appclass
 690     $name = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $name);
 691
 692     for (@{ $self->dispatch_types }) {
 693         return $_ if ref($_) eq $name;
 694     }
 695     return undef;
 696 }
 697
 698 use Moose;
 699
 700 # 5.70 backwards compatibility hacks.
 701
 702 # Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
 703 # need the methods here which *should* be private..
 704
 705 # You should be able to use get_actions or get_containers appropriately
 706 # instead of relying on these methods which expose implementation details
 707 # of the dispatcher..
 708 #
 709 # IRC backlog included below, please come ask if this doesn't work for you.
 710 #
 711 # <@t0m> 5.80, the state of. There are things in the dispatcher which have
 712 #        been deprecated, that we yell at anyone for using, which there isn't
 713 #        a good alternative for yet..
 714 # <@mst> er, get_actions/get_containers provides that doesn't it?
 715 # <@mst> DispatchTypes are loaded on demand anyway
 716 # <@t0m> I'm thinking of things like _tree which is aliased to 'tree' with
 717 #        warnings otherwise shit breaks.. We're issuing warnings about the
 718 #        correct set of things which you shouldn't be calling..
 719 # <@mst> right
 720 # <@mst> basically, I don't see there's a need for a replacement for anything
 721 # <@mst> it was never a good idea to call ->tree
 722 # <@mst> nothingmuch was the only one who did AFAIK
 723 # <@mst> and he admitted it was a hack ;)
 724
 725 # See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
 726
 727 # Alias _method_name to method_name, add a before modifier to warn..
 728 foreach my $public_method_name (qw/
 729         tree
 730         registered_dispatch_types
 731         method_action_class
 732         action_hash
 733         container_hash
 734     /) {
 735     my $private_method_name = '_' . $public_method_name;
 736     my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 737     $meta->add_method($public_method_name, $meta->get_method($private_method_name));
 738     {
 739         my %package_hash; # Only warn once per method, per package. These are infrequent enough that
 740                           # I haven't provided a way to disable them, patches welcome.
 741         $meta->add_before_method_modifier($public_method_name, sub {
 742             my $class = caller(2);
 743             chomp($class);
 744             $package_hash{$class}++ || do {
 745                 warn("Class $class is calling the deprecated method\n"
 746                     . "  Catalyst::Dispatcher::$public_method_name,\n"
 747                     . "  this will be removed in Catalyst 5.9X\n");
 748             };
 749         });
 750     }
 751 }
 752 # End 5.70 backwards compatibility hacks.
 753
 754 __PACKAGE__->meta->make_immutable;
 755
 756 =head2 meta
 757
 758 Provided by Moose
 759
 760 =head1 AUTHORS
 761
 762 Catalyst Contributors, see Catalyst.pm
 763
 764 =head1 COPYRIGHT
 765
 766 This library is free software. You can redistribute it and/or modify it under
 767 the same terms as Perl itself.
 768
 769 =cut
 770
 771 1;