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     }
 326     my $component = $self->_find_component($c, $component_or_class);
 327     my $component_class = blessed $component || return 0;
 328
 329     if (my $code = $component_class->can('action_for')) {
 330         my $possible_action = $component->$code($method);
 331         return $possible_action if $possible_action;
 332     }
 333
 334     if ( my $code = $component_class->can($method) ) {
 335         return $self->_method_action_class->new(
 336             {
 337                 name      => $method,
 338                 code      => $code,
 339                 reverse   => "$component_class->$method",
 340                 class     => $component_class,
 341                 namespace => Catalyst::Utils::class2prefix( $component_class ),
 342             }
 343         );
 344     }
 345     else {
 346         my $error =
 347           qq/Couldn't forward to "$component_class". Does not implement "$method"/;
 348         $c->error($error);
 349         $c->log->debug($error)
 350           if $c->debug;
 351         return 0;
 352     }
 353 }
 354
 355 =head2 $self->prepare_action($c)
 356
 357 Find an dispatch type that matches $c->req->path, and set args from it.
 358
 359 =cut
 360
 361 sub prepare_action {
 362     my ( $self, $c ) = @_;
 363     my $req = $c->req;
 364     my $path = $req->path;
 365     my @path = split /\//, $req->path;
 366     $req->args( \my @args );
 367
 368     unshift( @path, '' );    # Root action
 369
 370   DESCEND: while (@path) {
 371         $path = join '/', @path;
 372         $path =~ s#^/+##;
 373
 374         # Check out dispatch types to see if any will handle the path at
 375         # this level
 376
 377         foreach my $type ( @{ $self->dispatch_types } ) {
 378             last DESCEND if $type->match( $c, $path );
 379         }
 380
 381         # If not, move the last part path to args
 382         my $arg = pop(@path);
 383         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 384         unshift @args, $arg;
 385     }
 386
 387     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 388
 389     $c->log->debug( 'Path is "' . $req->match . '"' )
 390       if ( $c->debug && defined $req->match && length $req->match );
 391
 392     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 393       if ( $c->debug && @args );
 394 }
 395
 396 =head2 $self->get_action( $action, $namespace )
 397
 398 returns a named action from a given namespace.
 399
 400 =cut
 401
 402 sub get_action {
 403     my ( $self, $name, $namespace ) = @_;
 404     return unless $name;
 405
 406     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 407
 408     return $self->_action_hash->{"${namespace}/${name}"};
 409 }
 410
 411 =head2 $self->get_action_by_path( $path );
 412
 413 Returns the named action by its full private path.
 414
 415 =cut
 416
 417 sub get_action_by_path {
 418     my ( $self, $path ) = @_;
 419     $path =~ s/^\///;
 420     $path = "/$path" unless $path =~ /\//;
 421     $self->_action_hash->{$path};
 422 }
 423
 424 =head2 $self->get_actions( $c, $action, $namespace )
 425
 426 =cut
 427
 428 sub get_actions {
 429     my ( $self, $c, $action, $namespace ) = @_;
 430     return [] unless $action;
 431
 432     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 433
 434     my @match = $self->get_containers($namespace);
 435
 436     return map { $_->get_action($action) } @match;
 437 }
 438
 439 =head2 $self->get_containers( $namespace )
 440
 441 Return all the action containers for a given namespace, inclusive
 442
 443 =cut
 444
 445 sub get_containers {
 446     my ( $self, $namespace ) = @_;
 447     $namespace ||= '';
 448     $namespace = '' if $namespace eq '/';
 449
 450     my @containers;
 451
 452     if ( length $namespace ) {
 453         do {
 454             push @containers, $self->_container_hash->{$namespace};
 455         } while ( $namespace =~ s#/[^/]+$## );
 456     }
 457
 458     return reverse grep { defined } @containers, $self->_container_hash->{''};
 459 }
 460
 461 =head2 $self->uri_for_action($action, \@captures)
 462
 463 Takes a Catalyst::Action object and action parameters and returns a URI
 464 part such that if $c->req->path were this URI part, this action would be
 465 dispatched to with $c->req->captures set to the supplied arrayref.
 466
 467 If the action object is not available for external dispatch or the dispatcher
 468 cannot determine an appropriate URI, this method will return undef.
 469
 470 =cut
 471
 472 sub uri_for_action {
 473     my ( $self, $action, $captures) = @_;
 474     $captures ||= [];
 475     foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
 476         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 477         return( $uri eq '' ? '/' : $uri )
 478             if defined($uri);
 479     }
 480     return undef;
 481 }
 482
 483 =head2 expand_action
 484
 485 expand an action into a full representation of the dispatch.
 486 mostly useful for chained, other actions will just return a
 487 single action.
 488
 489 =cut
 490
 491 sub expand_action {
 492     my ($self, $action) = @_;
 493
 494     foreach my $dispatch_type (@{ $self->dispatch_types }) {
 495         my $expanded = $dispatch_type->expand_action($action);
 496         return $expanded if $expanded;
 497     }
 498
 499     return $action;
 500 }
 501
 502 =head2 $self->register( $c, $action )
 503
 504 Make sure all required dispatch types for this action are loaded, then
 505 pass the action to our dispatch types so they can register it if required.
 506 Also, set up the tree with the action containers.
 507
 508 =cut
 509
 510 sub register {
 511     my ( $self, $c, $action ) = @_;
 512
 513     my $registered = $self->_registered_dispatch_types;
 514
 515     #my $priv = 0; #seems to be unused
 516     foreach my $key ( keys %{ $action->attributes } ) {
 517         next if $key eq 'Private';
 518         my $class = "Catalyst::DispatchType::$key";
 519         unless ( $registered->{$class} ) {
 520             # FIXME - Some error checking and re-throwing needed here, as
 521             #         we eat exceptions loading dispatch types.
 522             eval { Class::MOP::load_class($class) };
 523             push( @{ $self->dispatch_types }, $class->new ) unless $@;
 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 preload dispatch types, registers their actions and then
 595 loads all of the postload 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->debug;
 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->log->debug( "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         eval { Class::MOP::load_class($class) };
 665         Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
 666           if $@;
 667         push @{ $self->dispatch_types }, $class->new;
 668
 669         push @loaded, $class;
 670     }
 671
 672     return @loaded;
 673 }
 674
 675 =head2 $self->dispatch_type( $type )
 676
 677 Get the DispatchType object of the relevant type, i.e. passing C<$type> of
 678 C<Chained> would return a L<Catalyst::DispatchType::Chained> object (assuming
 679 of course it's being used.)
 680
 681 =cut
 682
 683 sub dispatch_type {
 684     my ($self, $name) = @_;
 685
 686     # first param is undef because we cannot get the appclass
 687     $name = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $name);
 688
 689     for (@{ $self->dispatch_types }) {
 690         return $_ if ref($_) eq $name;
 691     }
 692     return undef;
 693 }
 694
 695 use Moose;
 696
 697 # 5.70 backwards compatibility hacks.
 698
 699 # Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
 700 # need the methods here which *should* be private..
 701
 702 # You should be able to use get_actions or get_containers appropriately
 703 # instead of relying on these methods which expose implementation details
 704 # of the dispatcher..
 705 #
 706 # IRC backlog included below, please come ask if this doesn't work for you.
 707 #
 708 # <@t0m> 5.80, the state of. There are things in the dispatcher which have
 709 #        been deprecated, that we yell at anyone for using, which there isn't
 710 #        a good alternative for yet..
 711 # <@mst> er, get_actions/get_containers provides that doesn't it?
 712 # <@mst> DispatchTypes are loaded on demand anyway
 713 # <@t0m> I'm thinking of things like _tree which is aliased to 'tree' with
 714 #        warnings otherwise shit breaks.. We're issuing warnings about the
 715 #        correct set of things which you shouldn't be calling..
 716 # <@mst> right
 717 # <@mst> basically, I don't see there's a need for a replacement for anything
 718 # <@mst> it was never a good idea to call ->tree
 719 # <@mst> nothingmuch was the only one who did AFAIK
 720 # <@mst> and he admitted it was a hack ;)
 721
 722 # See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
 723
 724 # Alias _method_name to method_name, add a before modifier to warn..
 725 foreach my $public_method_name (qw/
 726         tree
 727         registered_dispatch_types
 728         method_action_class
 729         action_hash
 730         container_hash
 731     /) {
 732     my $private_method_name = '_' . $public_method_name;
 733     my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 734     $meta->add_method($public_method_name, $meta->get_method($private_method_name));
 735     {
 736         my %package_hash; # Only warn once per method, per package. These are infrequent enough that
 737                           # I haven't provided a way to disable them, patches welcome.
 738         $meta->add_before_method_modifier($public_method_name, sub {
 739             my $class = caller(2);
 740             chomp($class);
 741             $package_hash{$class}++ || do {
 742                 warn("Class $class is calling the deprecated method\n"
 743                     . "  Catalyst::Dispatcher::$public_method_name,\n"
 744                     . "  this will be removed in Catalyst 5.9X\n");
 745             };
 746         });
 747     }
 748 }
 749 # End 5.70 backwards compatibility hacks.
 750
 751 __PACKAGE__->meta->make_immutable;
 752
 753 =head2 meta
 754
 755 Provided by Moose
 756
 757 =head1 AUTHORS
 758
 759 Catalyst Contributors, see Catalyst.pm
 760
 761 =head1 COPYRIGHT
 762
 763 This library is free software. You can redistribute it and/or modify it under
 764 the same terms as Perl itself.
 765
 766 =cut
 767
 768 1;