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