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_name, $namespace )
 411
 412 returns a named action from a given namespace.  C<$action_name>
 413 may be a relative path on that C<$namespace> such as
 414
 415     $self->get_action('../bar', 'foo/baz');
 416
 417 In which case we look for the action at 'foo/bar'.
 418
 419 =cut
 420
 421 sub get_action {
 422     my ( $self, $name, $namespace ) = @_;
 423     return unless $name;
 424
 425     $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
 426
 427     return $self->get_action_by_path("${namespace}/${name}");
 428 }
 429
 430 =head2 $self->get_action_by_path( $path );
 431
 432 Returns the named action by its full private path.
 433
 434 This method performs some normalization on C<$path> so that if
 435 it includes '..' it will do the right thing (for example if
 436 C<$path> is '/foo/../bar' that is normalized to '/bar'.
 437
 438 =cut
 439
 440 sub get_action_by_path {
 441     my ( $self, $path ) = @_;
 442     $path =~s/[^\/]+\/\.\.\/// while $path=~m/[^\/]+\/\.\.\//;
 443     $path =~ s/^\///;
 444     $path = "/$path" unless $path =~ /\//;
 445     $self->_action_hash->{$path};
 446 }
 447
 448 =head2 $self->get_actions( $c, $action, $namespace )
 449
 450 =cut
 451
 452 sub get_actions {
 453     my ( $self, $c, $action, $namespace ) = @_;
 454     return [] unless $action;
 455
 456     $namespace = join( "/", grep { length } split '/', $namespace || "" );
 457
 458     my @match = $self->get_containers($namespace);
 459
 460     return map { $_->get_action($action) } @match;
 461 }
 462
 463 =head2 $self->get_containers( $namespace )
 464
 465 Return all the action containers for a given namespace, inclusive
 466
 467 =cut
 468
 469 sub get_containers {
 470     my ( $self, $namespace ) = @_;
 471     $namespace ||= '';
 472     $namespace = '' if $namespace eq '/';
 473
 474     my @containers;
 475
 476     if ( length $namespace ) {
 477         do {
 478             push @containers, $self->_container_hash->{$namespace};
 479         } while ( $namespace =~ s#/[^/]+$## );
 480     }
 481
 482     return reverse grep { defined } @containers, $self->_container_hash->{''};
 483 }
 484
 485 =head2 $self->uri_for_action($action, \@captures)
 486
 487 Takes a Catalyst::Action object and action parameters and returns a URI
 488 part such that if $c->req->path were this URI part, this action would be
 489 dispatched to with $c->req->captures set to the supplied arrayref.
 490
 491 If the action object is not available for external dispatch or the dispatcher
 492 cannot determine an appropriate URI, this method will return undef.
 493
 494 =cut
 495
 496 sub uri_for_action {
 497     my ( $self, $action, $captures) = @_;
 498     $captures ||= [];
 499     foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
 500         my $uri = $dispatch_type->uri_for_action( $action, $captures );
 501         return( $uri eq '' ? '/' : $uri )
 502             if defined($uri);
 503     }
 504     return undef;
 505 }
 506
 507 =head2 expand_action
 508
 509 expand an action into a full representation of the dispatch.
 510 mostly useful for chained, other actions will just return a
 511 single action.
 512
 513 =cut
 514
 515 sub expand_action {
 516     my ($self, $action) = @_;
 517
 518     foreach my $dispatch_type (@{ $self->dispatch_types }) {
 519         my $expanded = $dispatch_type->expand_action($action);
 520         return $expanded if $expanded;
 521     }
 522
 523     return $action;
 524 }
 525
 526 =head2 $self->register( $c, $action )
 527
 528 Make sure all required dispatch types for this action are loaded, then
 529 pass the action to our dispatch types so they can register it if required.
 530 Also, set up the tree with the action containers.
 531
 532 =cut
 533
 534 sub register {
 535     my ( $self, $c, $action ) = @_;
 536
 537     my $registered = $self->_registered_dispatch_types;
 538
 539     foreach my $key ( keys %{ $action->attributes } ) {
 540         next if $key eq 'Private';
 541         my $class = "Catalyst::DispatchType::$key";
 542         unless ( $registered->{$class} ) {
 543             # FIXME - Some error checking and re-throwing needed here, as
 544             #         we eat exceptions loading dispatch types.
 545             # see also try_load_class
 546             eval { load_class($class) };
 547             my $load_failed = $@;
 548             $self->_check_deprecated_dispatch_type( $key, $load_failed );
 549             push( @{ $self->dispatch_types }, $class->new ) unless $load_failed;
 550             $registered->{$class} = 1;
 551         }
 552     }
 553
 554     my @dtypes = @{ $self->dispatch_types };
 555     my @normal_dtypes;
 556     my @low_precedence_dtypes;
 557
 558     for my $type ( @dtypes ) {
 559         if ($type->_is_low_precedence) {
 560             push @low_precedence_dtypes, $type;
 561         } else {
 562             push @normal_dtypes, $type;
 563         }
 564     }
 565
 566     # Pass the action to our dispatch types so they can register it if reqd.
 567     my $was_registered = 0;
 568     foreach my $type ( @normal_dtypes ) {
 569         $was_registered = 1 if $type->register( $c, $action );
 570     }
 571
 572     if (not $was_registered) {
 573         foreach my $type ( @low_precedence_dtypes ) {
 574             $type->register( $c, $action );
 575         }
 576     }
 577
 578     my $namespace = $action->namespace;
 579     my $name      = $action->name;
 580
 581     my $container = $self->_find_or_create_action_container($namespace);
 582
 583     # Set the method value
 584     $container->add_action($action);
 585
 586     $self->_action_hash->{"$namespace/$name"} = $action;
 587     $self->_container_hash->{$namespace} = $container;
 588 }
 589
 590 sub _find_or_create_action_container {
 591     my ( $self, $namespace ) = @_;
 592
 593     my $tree ||= $self->_tree;
 594
 595     return $tree->getNodeValue unless $namespace;
 596
 597     my @namespace = split '/', $namespace;
 598     return $self->_find_or_create_namespace_node( $tree, @namespace )
 599       ->getNodeValue;
 600 }
 601
 602 sub _find_or_create_namespace_node {
 603     my ( $self, $parent, $part, @namespace ) = @_;
 604
 605     return $parent unless $part;
 606
 607     my $child =
 608       ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
 609
 610     unless ($child) {
 611         my $container = Catalyst::ActionContainer->new($part);
 612         $parent->addChild( $child = Tree::Simple->new($container) );
 613     }
 614
 615     $self->_find_or_create_namespace_node( $child, @namespace );
 616 }
 617
 618 =head2 $self->setup_actions( $class, $context )
 619
 620 Loads all of the pre-load dispatch types, registers their actions and then
 621 loads all of the post-load dispatch types, and iterates over the tree of
 622 actions, displaying the debug information if appropriate.
 623
 624 =cut
 625
 626 sub setup_actions {
 627     my ( $self, $c ) = @_;
 628
 629     my @classes =
 630       $self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
 631     @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
 632
 633     foreach my $comp ( map @{$_}{sort keys %$_}, $c->components ) {
 634         $comp = $comp->() if ref($comp) eq 'CODE';
 635         $comp->register_actions($c) if $comp->can('register_actions');
 636     }
 637
 638     $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
 639
 640     return unless $c->debug;
 641     $self->_display_action_tables($c);
 642 }
 643
 644 sub _display_action_tables {
 645     my ($self, $c) = @_;
 646
 647     my $avail_width = Catalyst::Utils::term_width() - 12;
 648     my $col1_width = ($avail_width * .25) < 20 ? 20 : int($avail_width * .25);
 649     my $col2_width = ($avail_width * .50) < 36 ? 36 : int($avail_width * .50);
 650     my $col3_width =  $avail_width - $col1_width - $col2_width;
 651     my $privates = Text::SimpleTable->new(
 652         [ $col1_width, 'Private' ], [ $col2_width, 'Class' ], [ $col3_width, 'Method' ]
 653     );
 654
 655     my $has_private = 0;
 656     my $walker = sub {
 657         my ( $walker, $parent, $prefix ) = @_;
 658         $prefix .= $parent->getNodeValue || '';
 659         $prefix .= '/' unless $prefix =~ /\/$/;
 660         my $node = $parent->getNodeValue->actions;
 661
 662         for my $action ( keys %{$node} ) {
 663             my $action_obj = $node->{$action};
 664             next
 665               if ( ( $action =~ /^_.*/ )
 666                 && ( !$c->config->{show_internal_actions} ) );
 667             $privates->row( "$prefix$action", $action_obj->class, $action );
 668             $has_private = 1;
 669         }
 670
 671         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 672     };
 673
 674     $walker->( $walker, $self->_tree, '' );
 675     $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
 676       if $has_private;
 677
 678     # List all public actions
 679     $_->list($c) for @{ $self->dispatch_types };
 680 }
 681
 682 sub _load_dispatch_types {
 683     my ( $self, @types ) = @_;
 684
 685     my @loaded;
 686     # Preload action types
 687     for my $type (@types) {
 688         # first param is undef because we cannot get the appclass
 689         my $class = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $type);
 690
 691         my ($success, $error) = try_load_class($class);
 692         Catalyst::Exception->throw( message => $error ) if not $success;
 693         push @{ $self->dispatch_types }, $class->new;
 694
 695         push @loaded, $class;
 696     }
 697
 698     return @loaded;
 699 }
 700
 701 =head2 $self->dispatch_type( $type )
 702
 703 Get the DispatchType object of the relevant type, i.e. passing C<$type> of
 704 C<Chained> would return a L<Catalyst::DispatchType::Chained> object (assuming
 705 of course it's being used.)
 706
 707 =cut
 708
 709 sub dispatch_type {
 710     my ($self, $name) = @_;
 711
 712     # first param is undef because we cannot get the appclass
 713     $name = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $name);
 714
 715     for (@{ $self->dispatch_types }) {
 716         return $_ if ref($_) eq $name;
 717     }
 718     return undef;
 719 }
 720
 721 sub _check_deprecated_dispatch_type {
 722     my ($self, $key, $load_failed) = @_;
 723
 724     return unless $key =~ /^(Local)?Regexp?/;
 725
 726     # TODO: Should these throw an exception rather than just warning?
 727     if ($load_failed) {
 728         warn(   "Attempt to use deprecated $key dispatch type.\n"
 729               . "  Use Chained methods or install the standalone\n"
 730               . "  Catalyst::DispatchType::Regex if necessary.\n" );
 731     } elsif ( !defined $Catalyst::DispatchType::Regex::VERSION
 732         || $Catalyst::DispatchType::Regex::VERSION le '5.90020' ) {
 733         # We loaded the old core version of the Regex module this will break
 734         warn(   "The $key DispatchType has been removed from Catalyst core.\n"
 735               . "  An old version of the core Catalyst::DispatchType::Regex\n"
 736               . "  has been loaded and will likely fail. Please remove\n"
 737               . "   $INC{'Catalyst/DispatchType/Regex.pm'}\n"
 738               . "  and use Chained methods or install the standalone\n"
 739               . "  Catalyst::DispatchType::Regex if necessary.\n" );
 740     }
 741 }
 742
 743 use Moose;
 744
 745 # 5.70 backwards compatibility hacks.
 746
 747 # Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
 748 # need the methods here which *should* be private..
 749
 750 # You should be able to use get_actions or get_containers appropriately
 751 # instead of relying on these methods which expose implementation details
 752 # of the dispatcher..
 753 #
 754 # IRC backlog included below, please come ask if this doesn't work for you.
 755 #
 756 # <@t0m> 5.80, the state of. There are things in the dispatcher which have
 757 #        been deprecated, that we yell at anyone for using, which there isn't
 758 #        a good alternative for yet..
 759 # <@mst> er, get_actions/get_containers provides that doesn't it?
 760 # <@mst> DispatchTypes are loaded on demand anyway
 761 # <@t0m> I'm thinking of things like _tree which is aliased to 'tree' with
 762 #        warnings otherwise shit breaks.. We're issuing warnings about the
 763 #        correct set of things which you shouldn't be calling..
 764 # <@mst> right
 765 # <@mst> basically, I don't see there's a need for a replacement for anything
 766 # <@mst> it was never a good idea to call ->tree
 767 # <@mst> nothingmuch was the only one who did AFAIK
 768 # <@mst> and he admitted it was a hack ;)
 769
 770 # See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
 771
 772 # Alias _method_name to method_name, add a before modifier to warn..
 773 foreach my $public_method_name (qw/
 774         tree
 775         registered_dispatch_types
 776         method_action_class
 777         action_hash
 778         container_hash
 779     /) {
 780     my $private_method_name = '_' . $public_method_name;
 781     my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 782     $meta->add_method($public_method_name, $meta->get_method($private_method_name));
 783     {
 784         my %package_hash; # Only warn once per method, per package. These are infrequent enough that
 785                           # I haven't provided a way to disable them, patches welcome.
 786         $meta->add_before_method_modifier($public_method_name, sub {
 787             my $class = caller(2);
 788             chomp($class);
 789             $package_hash{$class}++ || do {
 790                 warn("Class $class is calling the deprecated method\n"
 791                     . "  Catalyst::Dispatcher::$public_method_name,\n"
 792                     . "  this will be removed in Catalyst 5.9\n");
 793             };
 794         });
 795     }
 796 }
 797 # End 5.70 backwards compatibility hacks.
 798
 799 __PACKAGE__->meta->make_immutable;
 800
 801 =head2 meta
 802
 803 Provided by Moose
 804
 805 =head1 AUTHORS
 806
 807 Catalyst Contributors, see Catalyst.pm
 808
 809 =head1 COPYRIGHT
 810
 811 This library is free software. You can redistribute it and/or modify it under
 812 the same terms as Perl itself.
 813
 814 =cut
 815
 816 1;