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