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 use Class::Load qw(load_class try_load_class);
  18 use Encode 2.21 'decode_utf8';
  19
  20 use namespace::clean -except => 'meta';
  21
  22 # Refactoring note:
  23 # do these belong as package vars or should we build these via a builder method?
  24 # See Catalyst-Plugin-Server for them being added to, which should be much less ugly.
  25
  26 # Preload these action types
  27 our @PRELOAD = qw/Index Path/;
  28
  29 # Postload these action types
  30 our @POSTLOAD = qw/Default/;
  31
  32 # Note - see back-compat methods at end of file.
  33 has _tree => (is => 'rw', builder => '_build__tree');
  34 has dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1);
  35 has _registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1);
  36 has _method_action_class => (is => 'rw', default => 'Catalyst::Action');
  37 has _action_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
  38 has _container_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
  39
  40 my %dispatch_types = ( pre => \@PRELOAD, post => \@POSTLOAD );
  41 foreach my $type (keys %dispatch_types) {
  42     has $type . "load_dispatch_types" => (
  43         is => 'rw', required => 1, lazy => 1, default => sub { $dispatch_types{$type} },
  44         traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute'], # List assignment is CAF style
  45     );
  46 }
  47
  48 =head1 NAME
  49
  50 Catalyst::Dispatcher - The Catalyst Dispatcher
  51
  52 =head1 SYNOPSIS
  53
  54 See L<Catalyst>.
  55
  56 =head1 DESCRIPTION
  57
  58 This is the class that maps public urls to actions in your Catalyst
  59 application based on the attributes you set.
  60
  61 =head1 METHODS
  62
  63 =head2 new
  64
  65 Construct a new dispatcher.
  66
  67 =cut
  68
  69 sub _build__tree {
  70   my ($self) = @_;
  71
  72   my $container =
  73     Catalyst::ActionContainer->new( { part => '/', actions => {} } );
  74
  75   return Tree::Simple->new($container, Tree::Simple->ROOT);
  76 }
  77
  78 =head2 $self->preload_dispatch_types
  79
  80 An arrayref of pre-loaded dispatchtype classes
  81
  82 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  83 To use a custom class outside the regular C<Catalyst> namespace, prefix
  84 it with a C<+>, like so:
  85
  86     +My::Dispatch::Type
  87
  88 =head2 $self->postload_dispatch_types
  89
  90 An arrayref of post-loaded dispatchtype classes
  91
  92 Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
  93 To use a custom class outside the regular C<Catalyst> namespace, prefix
  94 it with a C<+>, like so:
  95
  96     +My::Dispatch::Type
  97
  98 =head2 $self->dispatch($c)
  99
 100 Delegate the dispatch to the action that matched the url, or return a
 101 message about unknown resource
 102
 103 =cut
 104
 105 sub dispatch {
 106     my ( $self, $c ) = @_;
 107     if ( my $action = $c->action ) {
 108         $c->forward( join( '/', '', $action->namespace, '_DISPATCH' ) );
 109     }
 110     else {
 111         my $path  = $c->req->path;
 112         $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 113         $path = decode_utf8($path);
 114
 115         my $error = $path
 116           ? qq/Unknown resource "$path"/
 117           : "No default action defined";
 118         $c->log->error($error) if $c->debug;
 119         $c->error($error);
 120     }
 121 }
 122
 123 # $self->_command2action( $c, $command [, \@arguments ] )
 124 # $self->_command2action( $c, $command [, \@captures, \@arguments ] )
 125 # Search for an action, from the command and returns C<($action, $args, $captures)> on
 126 # success. Returns C<(0)> on error.
 127
 128 sub _command2action {
 129     my ( $self, $c, $command, @extra_params ) = @_;
 130
 131     unless ($command) {
 132         $c->log->debug('Nothing to go to') if $c->debug;
 133         return 0;
 134     }
 135
 136     my (@args, @captures);
 137
 138     if ( ref( $extra_params[-2] ) eq 'ARRAY' ) {
 139         @captures = @{ splice @extra_params, -2, 1 };
 140     }
 141
 142     if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
 143         @args = @{ pop @extra_params }
 144     } else {
 145         # this is a copy, it may take some abuse from
 146         # ->_invoke_as_path if the path had trailing parts
 147         @args = @{ $c->request->arguments };
 148     }
 149
 150     my $action;
 151
 152     # go to a string path ("/foo/bar/gorch")
 153     # or action object
 154     if (blessed($command) && $command->isa('Catalyst::Action')) {
 155         $action = $command;
 156     }
 157     else {
 158         $action = $self->_invoke_as_path( $c, "$command", \@args );
 159     }
 160
 161     # go to a component ( "View::Foo" or $c->component("...")
 162     # - a path or an object)
 163     unless ($action) {
 164         my $method = @extra_params ? $extra_params[0] : "process";
 165         $action = $self->_invoke_as_component( $c, $command, $method );
 166     }
 167
 168     return $action, \@args, \@captures;
 169 }
 170
 171 =head2 $self->visit( $c, $command [, \@arguments ] )
 172
 173 Documented in L<Catalyst>
 174
 175 =cut
 176
 177 sub visit {
 178     my $self = shift;
 179     $self->_do_visit('visit', @_);
 180 }
 181
 182 sub _do_visit {
 183     my $self = shift;
 184     my $opname = shift;
 185     my ( $c, $command ) = @_;
 186     my ( $action, $args, $captures ) = $self->_command2action(@_);
 187     my $error = qq/Couldn't $opname("$command"): /;
 188
 189     if (!$action) {
 190         $error .= qq/Couldn't $opname to command "$command": /
 191                  .qq/Invalid action or component./;
 192     }
 193     elsif (!defined $action->namespace) {
 194         $error .= qq/Action has no namespace: cannot $opname() to a plain /
 195                  .qq/method or component, must be an :Action of some sort./
 196     }
 197     elsif (!$action->class->can('_DISPATCH')) {
 198         $error .= qq/Action cannot _DISPATCH. /
 199                  .qq/Did you try to $opname() a non-controller action?/;
 200     }
 201     else {
 202         $error = q();
 203     }
 204
 205     if($error) {
 206         $c->error($error);
 207         $c->log->debug($error) if $c->debug;
 208         return 0;
 209     }
 210
 211     $action = $self->expand_action($action);
 212
 213     local $c->request->{arguments} = $args;
 214     local $c->request->{captures}  = $captures;
 215     local $c->{namespace} = $action->{'namespace'};
 216     local $c->{action} = $action;
 217
 218     $self->dispatch($c);
 219 }
 220
 221 =head2 $self->go( $c, $command [, \@arguments ] )
 222
 223 Documented in L<Catalyst>
 224
 225 =cut
 226
 227 sub go {
 228     my $self = shift;
 229     $self->_do_visit('go', @_);
 230     Catalyst::Exception::Go->throw;
 231 }
 232
 233 =head2 $self->forward( $c, $command [, \@arguments ] )
 234
 235 Documented in L<Catalyst>
 236
 237 =cut
 238
 239 sub forward {
 240     my $self = shift;
 241     no warnings 'recursion';
 242     return $self->_do_forward(forward => @_);
 243 }
 244
 245 sub _do_forward {
 246     my $self = shift;
 247     my $opname = shift;
 248     my ( $c, $command ) = @_;
 249     my ( $action, $args, $captures ) = $self->_command2action(@_);
 250
 251     if (!$action) {
 252         my $error .= qq/Couldn't $opname to command "$command": /
 253                     .qq/Invalid action or component./;
 254         $c->error($error);
 255         $c->log->debug($error) if $c->debug;
 256         return 0;
 257     }
 258
 259
 260     local $c->request->{arguments} = $args;
 261     no warnings 'recursion';
 262     $action->dispatch( $c );
 263
 264     #If there is an error, all bets off regarding state.  Documentation
 265     #Specifies that when you forward, if there's an error you must expect
 266     #state to be 0.
 267     if( @{ $c->error }) {
 268       $c->state(0);
 269     }
 270     return $c->state;
 271 }
 272
 273 =head2 $self->detach( $c, $command [, \@arguments ] )
 274
 275 Documented in L<Catalyst>
 276
 277 =cut
 278
 279 sub detach {
 280     my ( $self, $c, $command, @args ) = @_;
 281     $self->_do_forward(detach => $c, $command, @args ) if $command;
 282     $c->state(0); # Needed in order to skip any auto functions
 283     Catalyst::Exception::Detach->throw;
 284 }
 285
 286 sub _action_rel2abs {
 287     my ( $self, $c, $path ) = @_;
 288
 289     unless ( $path =~ m#^/# ) {
 290         my $namespace = $c->stack->[-1]->namespace;
 291         $path = "$namespace/$path";
 292     }
 293
 294     $path =~ s#^/##;
 295     return $path;
 296 }
 297
 298 sub _invoke_as_path {
 299     my ( $self, $c, $rel_path, $args ) = @_;
 300
 301     my $path = $self->_action_rel2abs( $c, $rel_path );
 302
 303     my ( $tail, @extra_args );
 304     while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
 305     {                           # allow $path to be empty
 306         if ( my $action = $c->get_action( $tail, $path ) ) {
 307             push @$args, @extra_args;
 308             return $action;
 309         }
 310         else {
 311             return
 312               unless $path
 313               ; # if a match on the global namespace failed then the whole lookup failed
 314         }
 315
 316         unshift @extra_args, $tail;
 317     }
 318 }
 319
 320 sub _find_component {
 321     my ( $self, $c, $component ) = @_;
 322
 323     # fugly, why doesn't ->component('MyApp') work?
 324     return $c if ($component eq blessed($c));
 325
 326     return blessed($component)
 327         ? $component
 328         : $c->component($component);
 329 }
 330
 331 sub _invoke_as_component {
 332     my ( $self, $c, $component_or_class, $method ) = @_;
 333
 334     my $component = $self->_find_component($c, $component_or_class);
 335     my $component_class = blessed $component || return 0;
 336
 337     if (my $code = $component_class->can('action_for')) {
 338         my $possible_action = $component->$code($method);
 339         return $possible_action if $possible_action;
 340     }
 341
 342     if ( my $code = $component_class->can($method) ) {
 343         return $self->_method_action_class->new(
 344             {
 345                 name      => $method,
 346                 code      => $code,
 347                 reverse   => "$component_class->$method",
 348                 class     => $component_class,
 349                 namespace => Catalyst::Utils::class2prefix(
 350                     $component_class, ref($c)->config->{case_sensitive}
 351                 ),
 352             }
 353         );
 354     }
 355     else {
 356         my $error =
 357           qq/Couldn't forward to "$component_class". Does not implement "$method"/;
 358         $c->error($error);
 359         $c->log->debug($error)
 360           if $c->debug;
 361         return 0;
 362     }
 363 }
 364
 365 =head2 $self->prepare_action($c)
 366
 367 Find an dispatch type that matches $c->req->path, and set args from it.
 368
 369 =cut
 370
 371 sub prepare_action {
 372     my ( $self, $c ) = @_;
 373     my $req = $c->req;
 374     my $path = $req->path;
 375     my @path = split /\//, $req->path;
 376     $req->args( \my @args );
 377
 378     unshift( @path, '' );    # Root action
 379
 380   DESCEND: while (@path) {
 381         $path = join '/', @path;
 382         $path =~ s#^/+##;
 383
 384         # Check out dispatch types to see if any will handle the path at
 385         # this level
 386
 387         foreach my $type ( @{ $self->dispatch_types } ) {
 388             last DESCEND if $type->match( $c, $path );
 389         }
 390
 391         # If not, move the last part path to args
 392         my $arg = pop(@path);
 393         $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 394         unshift @args, $arg;
 395     }
 396
 397     s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
 398
 399     if($c->debug && defined $req->match && length $req->match) {
 400       my $match = $req->match;
 401       $match =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 402       $match = decode_utf8($match);
 403       $c->log->debug( 'Path is "' . $match . '"' )
 404     }
 405
 406     $c->log->debug( 'Arguments are "' . join( '/', map { decode_utf8 $_ } @args ) . '"' )
 407       if ( $c->debug && @args );
 408 }
 409
 410 =head2 $self->get_action( $action, $namespace )
 411
 412 returns a named action from a given namespace.
 413
 414 =cut
 415
 416 sub get_action {
 417     my ( $self, $name, $namespace ) = @_;
 418     return unless $name;
 419
 420     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 421
 422     return $self->get_action_by_path("${namespace}/${name}");
 423 }
 424
 425 =head2 $self->get_action_by_path( $path );
 426
 427 Returns the named action by its full private path.
 428
 429 =cut
 430
 431 sub get_action_by_path {
 432     my ( $self, $path ) = @_;
 433     $path =~ s/^\///;
 434     $path = "/$path" unless $path =~ /\//;
 435     $self->_action_hash->{$path};
 436 }
 437
 438 =head2 $self->get_actions( $c, $action, $namespace )
 439
 440 =cut
 441
 442 sub get_actions {
 443     my ( $self, $c, $action, $namespace ) = @_;
 444     return [] unless $action;
 445
 446     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 447
 448     my @match = $self->get_containers($namespace);
 449
 450     return map { $_->get_action($action) } @match;
 451 }
 452
 453 =head2 $self->get_containers( $namespace )
 454
 455 Return all the action containers for a given namespace, inclusive
 456
 457 =cut
 458
 459 sub get_containers {
 460     my ( $self, $namespace ) = @_;
 461     $namespace ||= '';
 462     $namespace = '' if $namespace eq '/';
 463
 464     my @containers;
 465
 466     if ( length $namespace ) {
 467         do {
 468             push @containers, $self->_container_hash->{$namespace};
 469         } while ( $namespace =~ s#/[^/]+$## );
 470     }
 471
 472     return reverse grep { defined } @containers, $self->_container_hash->{''};
 473 }
 474
 475 =head2 $self->uri_for_action($action, \@captures)
 476
 477 Takes a Catalyst::Action object and action parameters and returns a URI
 478 part such that if $c->req->path were this URI part, this action would be
 479 dispatched to with $c->req->captures set to the supplied arrayref.
 480
 481 If the action object is not available for external dispatch or the dispatcher
 482 cannot determine an appropriate URI, this method will return undef.
 483
 484 =cut
 485
 486 sub uri_for_action {
 487     my ( $self, $action, $captures) = @_;
 488     $captures ||= [];
 489     foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
 490         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 491         return( $uri eq '' ? '/' : $uri )
 492             if defined($uri);
 493     }
 494     return undef;
 495 }
 496
 497 =head2 expand_action
 498
 499 expand an action into a full representation of the dispatch.
 500 mostly useful for chained, other actions will just return a
 501 single action.
 502
 503 =cut
 504
 505 sub expand_action {
 506     my ($self, $action) = @_;
 507
 508     foreach my $dispatch_type (@{ $self->dispatch_types }) {
 509         my $expanded = $dispatch_type->expand_action($action);
 510         return $expanded if $expanded;
 511     }
 512
 513     return $action;
 514 }
 515
 516 =head2 $self->register( $c, $action )
 517
 518 Make sure all required dispatch types for this action are loaded, then
 519 pass the action to our dispatch types so they can register it if required.
 520 Also, set up the tree with the action containers.
 521
 522 =cut
 523
 524 sub register {
 525     my ( $self, $c, $action ) = @_;
 526
 527     my $registered = $self->_registered_dispatch_types;
 528
 529     foreach my $key ( keys %{ $action->attributes } ) {
 530         next if $key eq 'Private';
 531         my $class = "Catalyst::DispatchType::$key";
 532         unless ( $registered->{$class} ) {
 533             # FIXME - Some error checking and re-throwing needed here, as
 534             #         we eat exceptions loading dispatch types.
 535             # see also try_load_class
 536             eval { load_class($class) };
 537             my $load_failed = $@;
 538             $self->_check_deprecated_dispatch_type( $key, $load_failed );
 539             push( @{ $self->dispatch_types }, $class->new ) unless $load_failed;
 540             $registered->{$class} = 1;
 541         }
 542     }
 543
 544     my @dtypes = @{ $self->dispatch_types };
 545     my @normal_dtypes;
 546     my @low_precedence_dtypes;
 547
 548     for my $type ( @dtypes ) {
 549         if ($type->_is_low_precedence) {
 550             push @low_precedence_dtypes, $type;
 551         } else {
 552             push @normal_dtypes, $type;
 553         }
 554     }
 555
 556     # Pass the action to our dispatch types so they can register it if reqd.
 557     my $was_registered = 0;
 558     foreach my $type ( @normal_dtypes ) {
 559         $was_registered = 1 if $type->register( $c, $action );
 560     }
 561
 562     if (not $was_registered) {
 563         foreach my $type ( @low_precedence_dtypes ) {
 564             $type->register( $c, $action );
 565         }
 566     }
 567
 568     my $namespace = $action->namespace;
 569     my $name      = $action->name;
 570
 571     my $container = $self->_find_or_create_action_container($namespace);
 572
 573     # Set the method value
 574     $container->add_action($action);
 575
 576     $self->_action_hash->{"$namespace/$name"} = $action;
 577     $self->_container_hash->{$namespace} = $container;
 578 }
 579
 580 sub _find_or_create_action_container {
 581     my ( $self, $namespace ) = @_;
 582
 583     my $tree ||= $self->_tree;
 584
 585     return $tree->getNodeValue unless $namespace;
 586
 587     my @namespace = split '/', $namespace;
 588     return $self->_find_or_create_namespace_node( $tree, @namespace )
 589       ->getNodeValue;
 590 }
 591
 592 sub _find_or_create_namespace_node {
 593     my ( $self, $parent, $part, @namespace ) = @_;
 594
 595     return $parent unless $part;
 596
 597     my $child =
 598       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 599
 600     unless ($child) {
 601         my $container = Catalyst::ActionContainer->new($part);
 602         $parent->addChild( $child = Tree::Simple->new($container) );
 603     }
 604
 605     $self->_find_or_create_namespace_node( $child, @namespace );
 606 }
 607
 608 =head2 $self->setup_actions( $class, $context )
 609
 610 Loads all of the pre-load dispatch types, registers their actions and then
 611 loads all of the post-load dispatch types, and iterates over the tree of
 612 actions, displaying the debug information if appropriate.
 613
 614 =cut
 615
 616 sub setup_actions {
 617     my ( $self, $c ) = @_;
 618
 619     my @classes =
 620       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 621     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 622
 623     foreach my $comp ( map @{$_}{sort keys %$_}, $c->components ) {
 624         $comp = $comp->() if ref($comp) eq 'CODE';
 625         $comp->register_actions($c) if $comp->can('register_actions');
 626     }
 627
 628     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 629
 630     return unless $c->debug;
 631     $self->_display_action_tables($c);
 632 }
 633
 634 sub _display_action_tables {
 635     my ($self, $c) = @_;
 636
 637     my $avail_width = Catalyst::Utils::term_width() - 12;
 638     my $col1_width = ($avail_width * .25) < 20 ? 20 : int($avail_width * .25);
 639     my $col2_width = ($avail_width * .50) < 36 ? 36 : int($avail_width * .50);
 640     my $col3_width =  $avail_width - $col1_width - $col2_width;
 641     my $privates = Text::SimpleTable->new(
 642         [ $col1_width, 'Private' ], [ $col2_width, 'Class' ], [ $col3_width, 'Method' ]
 643     );
 644
 645     my $has_private = 0;
 646     my $walker = sub {
 647         my ( $walker, $parent, $prefix ) = @_;
 648         $prefix .= $parent->getNodeValue || '';
 649         $prefix .= '/' unless $prefix =~ /\/$/;
 650         my $node = $parent->getNodeValue->actions;
 651
 652         for my $action ( keys %{$node} ) {
 653             my $action_obj = $node->{$action};
 654             next
 655               if ( ( $action =~ /^_.*/ )
 656                 && ( !$c->config->{show_internal_actions} ) );
 657             $privates->row( "$prefix$action", $action_obj->class, $action );
 658             $has_private = 1;
 659         }
 660
 661         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 662     };
 663
 664     $walker->( $walker, $self->_tree, '' );
 665     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 666       if $has_private;
 667
 668     # List all public actions
 669     $_->list($c) for @{ $self->dispatch_types };
 670 }
 671
 672 sub _load_dispatch_types {
 673     my ( $self, @types ) = @_;
 674
 675     my @loaded;
 676     # Preload action types
 677     for my $type (@types) {
 678         # first param is undef because we cannot get the appclass
 679         my $class = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $type);
 680
 681         my ($success, $error) = try_load_class($class);
 682         Catalyst::Exception->throw( message => $error ) if not $success;
 683         push @{ $self->dispatch_types }, $class->new;
 684
 685         push @loaded, $class;
 686     }
 687
 688     return @loaded;
 689 }
 690
 691 =head2 $self->dispatch_type( $type )
 692
 693 Get the DispatchType object of the relevant type, i.e. passing C<$type> of
 694 C<Chained> would return a L<Catalyst::DispatchType::Chained> object (assuming
 695 of course it's being used.)
 696
 697 =cut
 698
 699 sub dispatch_type {
 700     my ($self, $name) = @_;
 701
 702     # first param is undef because we cannot get the appclass
 703     $name = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $name);
 704
 705     for (@{ $self->dispatch_types }) {
 706         return $_ if ref($_) eq $name;
 707     }
 708     return undef;
 709 }
 710
 711 sub _check_deprecated_dispatch_type {
 712     my ($self, $key, $load_failed) = @_;
 713
 714     return unless $key =~ /^(Local)?Regexp?/;
 715
 716     # TODO: Should these throw an exception rather than just warning?
 717     if ($load_failed) {
 718         warn(   "Attempt to use deprecated $key dispatch type.\n"
 719               . "  Use Chained methods or install the standalone\n"
 720               . "  Catalyst::DispatchType::Regex if necessary.\n" );
 721     } elsif ( !defined $Catalyst::DispatchType::Regex::VERSION
 722         || $Catalyst::DispatchType::Regex::VERSION le '5.90020' ) {
 723         # We loaded the old core version of the Regex module this will break
 724         warn(   "The $key DispatchType has been removed from Catalyst core.\n"
 725               . "  An old version of the core Catalyst::DispatchType::Regex\n"
 726               . "  has been loaded and will likely fail. Please remove\n"
 727               . "   $INC{'Catalyst/DispatchType/Regex.pm'}\n"
 728               . "  and use Chained methods or install the standalone\n"
 729               . "  Catalyst::DispatchType::Regex if necessary.\n" );
 730     }
 731 }
 732
 733 use Moose;
 734
 735 # 5.70 backwards compatibility hacks.
 736
 737 # Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
 738 # need the methods here which *should* be private..
 739
 740 # You should be able to use get_actions or get_containers appropriately
 741 # instead of relying on these methods which expose implementation details
 742 # of the dispatcher..
 743 #
 744 # IRC backlog included below, please come ask if this doesn't work for you.
 745 #
 746 # <@t0m> 5.80, the state of. There are things in the dispatcher which have
 747 #        been deprecated, that we yell at anyone for using, which there isn't
 748 #        a good alternative for yet..
 749 # <@mst> er, get_actions/get_containers provides that doesn't it?
 750 # <@mst> DispatchTypes are loaded on demand anyway
 751 # <@t0m> I'm thinking of things like _tree which is aliased to 'tree' with
 752 #        warnings otherwise shit breaks.. We're issuing warnings about the
 753 #        correct set of things which you shouldn't be calling..
 754 # <@mst> right
 755 # <@mst> basically, I don't see there's a need for a replacement for anything
 756 # <@mst> it was never a good idea to call ->tree
 757 # <@mst> nothingmuch was the only one who did AFAIK
 758 # <@mst> and he admitted it was a hack ;)
 759
 760 # See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
 761
 762 # Alias _method_name to method_name, add a before modifier to warn..
 763 foreach my $public_method_name (qw/
 764         tree
 765         registered_dispatch_types
 766         method_action_class
 767         action_hash
 768         container_hash
 769     /) {
 770     my $private_method_name = '_' . $public_method_name;
 771     my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 772     $meta->add_method($public_method_name, $meta->get_method($private_method_name));
 773     {
 774         my %package_hash; # Only warn once per method, per package. These are infrequent enough that
 775                           # I haven't provided a way to disable them, patches welcome.
 776         $meta->add_before_method_modifier($public_method_name, sub {
 777             my $class = caller(2);
 778             chomp($class);
 779             $package_hash{$class}++ || do {
 780                 warn("Class $class is calling the deprecated method\n"
 781                     . "  Catalyst::Dispatcher::$public_method_name,\n"
 782                     . "  this will be removed in Catalyst 5.9\n");
 783             };
 784         });
 785     }
 786 }
 787 # End 5.70 backwards compatibility hacks.
 788
 789 __PACKAGE__->meta->make_immutable;
 790
 791 =head2 meta
 792
 793 Provided by Moose
 794
 795 =head1 AUTHORS
 796
 797 Catalyst Contributors, see Catalyst.pm
 798
 799 =head1 COPYRIGHT
 800
 801 This library is free software. You can redistribute it and/or modify it under
 802 the same terms as Perl itself.
 803
 804 =cut
 805
 806 1;