X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=trunk%2Flib%2FCatalyst%2FDispatcher.pm;fp=trunk%2Flib%2FCatalyst%2FDispatcher.pm;h=0000000000000000000000000000000000000000;hb=f436bc1bece2bcc2a04138068e5c22e70d9d6d35;hp=d82dfe18f9552f1feea4aa28e68eb4c176379e59;hpb=e28a6876ad3e11890226e5bab6df4b0725e0981e;p=catagits%2FCatalyst-Runtime.git diff --git a/trunk/lib/Catalyst/Dispatcher.pm b/trunk/lib/Catalyst/Dispatcher.pm deleted file mode 100644 index d82dfe1..0000000 --- a/trunk/lib/Catalyst/Dispatcher.pm +++ /dev/null @@ -1,766 +0,0 @@ -package Catalyst::Dispatcher; - -use Moose; -use Class::MOP; -with 'MooseX::Emulate::Class::Accessor::Fast'; - -use Catalyst::Exception; -use Catalyst::Utils; -use Catalyst::Action; -use Catalyst::ActionContainer; -use Catalyst::DispatchType::Default; -use Catalyst::DispatchType::Index; -use Catalyst::Utils; -use Text::SimpleTable; -use Tree::Simple; -use Tree::Simple::Visitor::FindByPath; - -use namespace::clean -except => 'meta'; - -# Refactoring note: -# do these belong as package vars or should we build these via a builder method? -# See Catalyst-Plugin-Server for them being added to, which should be much less ugly. - -# Preload these action types -our @PRELOAD = qw/Index Path Regex/; - -# Postload these action types -our @POSTLOAD = qw/Default/; - -# Note - see back-compat methods at end of file. -has _tree => (is => 'rw', builder => '_build__tree'); -has dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1); -has _registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1); -has _method_action_class => (is => 'rw', default => 'Catalyst::Action'); -has _action_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} }); -has _container_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} }); - -my %dispatch_types = ( pre => \@PRELOAD, post => \@POSTLOAD ); -foreach my $type (keys %dispatch_types) { - has $type . "load_dispatch_types" => ( - is => 'rw', required => 1, lazy => 1, default => sub { $dispatch_types{$type} }, - traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute'], # List assignment is CAF style - ); -} - -=head1 NAME - -Catalyst::Dispatcher - The Catalyst Dispatcher - -=head1 SYNOPSIS - -See L. - -=head1 DESCRIPTION - -This is the class that maps public urls to actions in your Catalyst -application based on the attributes you set. - -=head1 METHODS - -=head2 new - -Construct a new dispatcher. - -=cut - -sub _build__tree { - my ($self) = @_; - - my $container = - Catalyst::ActionContainer->new( { part => '/', actions => {} } ); - - return Tree::Simple->new($container, Tree::Simple->ROOT); -} - -=head2 $self->preload_dispatch_types - -An arrayref of pre-loaded dispatchtype classes - -Entries are considered to be available as C -To use a custom class outside the regular C namespace, prefix -it with a C<+>, like so: - - +My::Dispatch::Type - -=head2 $self->postload_dispatch_types - -An arrayref of post-loaded dispatchtype classes - -Entries are considered to be available as C -To use a custom class outside the regular C namespace, prefix -it with a C<+>, like so: - - +My::Dispatch::Type - -=head2 $self->dispatch($c) - -Delegate the dispatch to the action that matched the url, or return a -message about unknown resource - -=cut - -sub dispatch { - my ( $self, $c ) = @_; - if ( my $action = $c->action ) { - $c->forward( join( '/', '', $action->namespace, '_DISPATCH' ) ); - } - else { - my $path = $c->req->path; - my $error = $path - ? qq/Unknown resource "$path"/ - : "No default action defined"; - $c->log->error($error) if $c->debug; - $c->error($error); - } -} - -# $self->_command2action( $c, $command [, \@arguments ] ) -# $self->_command2action( $c, $command [, \@captures, \@arguments ] ) -# Search for an action, from the command and returns C<($action, $args, $captures)> on -# success. Returns C<(0)> on error. - -sub _command2action { - my ( $self, $c, $command, @extra_params ) = @_; - - unless ($command) { - $c->log->debug('Nothing to go to') if $c->debug; - return 0; - } - - my (@args, @captures); - - if ( ref( $extra_params[-2] ) eq 'ARRAY' ) { - @captures = @{ splice @extra_params, -2, 1 }; - } - - if ( ref( $extra_params[-1] ) eq 'ARRAY' ) { - @args = @{ pop @extra_params } - } else { - # this is a copy, it may take some abuse from - # ->_invoke_as_path if the path had trailing parts - @args = @{ $c->request->arguments }; - } - - my $action; - - # go to a string path ("/foo/bar/gorch") - # or action object - if (blessed($command) && $command->isa('Catalyst::Action')) { - $action = $command; - } - else { - $action = $self->_invoke_as_path( $c, "$command", \@args ); - } - - # go to a component ( "MyApp::*::Foo" or $c->component("...") - # - a path or an object) - unless ($action) { - my $method = @extra_params ? $extra_params[0] : "process"; - $action = $self->_invoke_as_component( $c, $command, $method ); - } - - return $action, \@args, \@captures; -} - -=head2 $self->visit( $c, $command [, \@arguments ] ) - -Documented in L - -=cut - -sub visit { - my $self = shift; - $self->_do_visit('visit', @_); -} - -sub _do_visit { - my $self = shift; - my $opname = shift; - my ( $c, $command ) = @_; - my ( $action, $args, $captures ) = $self->_command2action(@_); - my $error = qq/Couldn't $opname("$command"): /; - - if (!$action) { - $error .= qq/Couldn't $opname to command "$command": / - .qq/Invalid action or component./; - } - elsif (!defined $action->namespace) { - $error .= qq/Action has no namespace: cannot $opname() to a plain / - .qq/method or component, must be an :Action of some sort./ - } - elsif (!$action->class->can('_DISPATCH')) { - $error .= qq/Action cannot _DISPATCH. / - .qq/Did you try to $opname() a non-controller action?/; - } - else { - $error = q(); - } - - if($error) { - $c->error($error); - $c->log->debug($error) if $c->debug; - return 0; - } - - $action = $self->expand_action($action); - - local $c->request->{arguments} = $args; - local $c->request->{captures} = $captures; - local $c->{namespace} = $action->{'namespace'}; - local $c->{action} = $action; - - $self->dispatch($c); -} - -=head2 $self->go( $c, $command [, \@arguments ] ) - -Documented in L - -=cut - -sub go { - my $self = shift; - $self->_do_visit('go', @_); - Catalyst::Exception::Go->throw; -} - -=head2 $self->forward( $c, $command [, \@arguments ] ) - -Documented in L - -=cut - -sub forward { - my $self = shift; - no warnings 'recursion'; - $self->_do_forward(forward => @_); -} - -sub _do_forward { - my $self = shift; - my $opname = shift; - my ( $c, $command ) = @_; - my ( $action, $args, $captures ) = $self->_command2action(@_); - - if (!$action) { - my $error .= qq/Couldn't $opname to command "$command": / - .qq/Invalid action or component./; - $c->error($error); - $c->log->debug($error) if $c->debug; - return 0; - } - - - local $c->request->{arguments} = $args; - no warnings 'recursion'; - $action->dispatch( $c ); - - return $c->state; -} - -=head2 $self->detach( $c, $command [, \@arguments ] ) - -Documented in L - -=cut - -sub detach { - my ( $self, $c, $command, @args ) = @_; - $self->_do_forward(detach => $c, $command, @args ) if $command; - Catalyst::Exception::Detach->throw; -} - -sub _action_rel2abs { - my ( $self, $c, $path ) = @_; - - unless ( $path =~ m#^/# ) { - my $namespace = $c->stack->[-1]->namespace; - $path = "$namespace/$path"; - } - - $path =~ s#^/##; - return $path; -} - -sub _invoke_as_path { - my ( $self, $c, $rel_path, $args ) = @_; - - my $path = $self->_action_rel2abs( $c, $rel_path ); - - my ( $tail, @extra_args ); - while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) ) - { # allow $path to be empty - if ( my $action = $c->get_action( $tail, $path ) ) { - push @$args, @extra_args; - return $action; - } - else { - return - unless $path - ; # if a match on the global namespace failed then the whole lookup failed - } - - unshift @extra_args, $tail; - } -} - -sub _find_component { - my ( $self, $c, $component ) = @_; - - # fugly, why doesn't ->component('MyApp') work? - return $c if ($component eq blessed($c)); - - return blessed($component) - ? $component - : $c->component($component); -} - -sub _invoke_as_component { - my ( $self, $c, $component_or_class, $method ) = @_; - - my $component = $self->_find_component($c, $component_or_class); - my $component_class = blessed $component || return 0; - - if (my $code = $component_class->can('action_for')) { - my $possible_action = $component->$code($method); - return $possible_action if $possible_action; - } - - if ( my $code = $component_class->can($method) ) { - return $self->_method_action_class->new( - { - name => $method, - code => $code, - reverse => "$component_class->$method", - class => $component_class, - namespace => Catalyst::Utils::class2prefix( - $component_class, ref($c)->config->{case_sensitive} - ), - } - ); - } - else { - my $error = - qq/Couldn't forward to "$component_class". Does not implement "$method"/; - $c->error($error); - $c->log->debug($error) - if $c->debug; - return 0; - } -} - -=head2 $self->prepare_action($c) - -Find an dispatch type that matches $c->req->path, and set args from it. - -=cut - -sub prepare_action { - my ( $self, $c ) = @_; - my $req = $c->req; - my $path = $req->path; - my @path = split /\//, $req->path; - $req->args( \my @args ); - - unshift( @path, '' ); # Root action - - DESCEND: while (@path) { - $path = join '/', @path; - $path =~ s#^/+##; - - # Check out dispatch types to see if any will handle the path at - # this level - - foreach my $type ( @{ $self->dispatch_types } ) { - last DESCEND if $type->match( $c, $path ); - } - - # If not, move the last part path to args - my $arg = pop(@path); - $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; - unshift @args, $arg; - } - - s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]}; - - $c->log->debug( 'Path is "' . $req->match . '"' ) - if ( $c->debug && defined $req->match && length $req->match ); - - $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' ) - if ( $c->debug && @args ); -} - -=head2 $self->get_action( $action, $namespace ) - -returns a named action from a given namespace. - -=cut - -sub get_action { - my ( $self, $name, $namespace ) = @_; - return unless $name; - - $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) ); - - return $self->_action_hash->{"${namespace}/${name}"}; -} - -=head2 $self->get_action_by_path( $path ); - -Returns the named action by its full private path. - -=cut - -sub get_action_by_path { - my ( $self, $path ) = @_; - $path =~ s/^\///; - $path = "/$path" unless $path =~ /\//; - $self->_action_hash->{$path}; -} - -=head2 $self->get_actions( $c, $action, $namespace ) - -=cut - -sub get_actions { - my ( $self, $c, $action, $namespace ) = @_; - return [] unless $action; - - $namespace = join( "/", grep { length } split '/', $namespace || "" ); - - my @match = $self->get_containers($namespace); - - return map { $_->get_action($action) } @match; -} - -=head2 $self->get_containers( $namespace ) - -Return all the action containers for a given namespace, inclusive - -=cut - -sub get_containers { - my ( $self, $namespace ) = @_; - $namespace ||= ''; - $namespace = '' if $namespace eq '/'; - - my @containers; - - if ( length $namespace ) { - do { - push @containers, $self->_container_hash->{$namespace}; - } while ( $namespace =~ s#/[^/]+$## ); - } - - return reverse grep { defined } @containers, $self->_container_hash->{''}; -} - -=head2 $self->uri_for_action($action, \@captures) - -Takes a Catalyst::Action object and action parameters and returns a URI -part such that if $c->req->path were this URI part, this action would be -dispatched to with $c->req->captures set to the supplied arrayref. - -If the action object is not available for external dispatch or the dispatcher -cannot determine an appropriate URI, this method will return undef. - -=cut - -sub uri_for_action { - my ( $self, $action, $captures) = @_; - $captures ||= []; - foreach my $dispatch_type ( @{ $self->dispatch_types } ) { - my $uri = $dispatch_type->uri_for_action( $action, $captures ); - return( $uri eq '' ? '/' : $uri ) - if defined($uri); - } - return undef; -} - -=head2 expand_action - -expand an action into a full representation of the dispatch. -mostly useful for chained, other actions will just return a -single action. - -=cut - -sub expand_action { - my ($self, $action) = @_; - - foreach my $dispatch_type (@{ $self->dispatch_types }) { - my $expanded = $dispatch_type->expand_action($action); - return $expanded if $expanded; - } - - return $action; -} - -=head2 $self->register( $c, $action ) - -Make sure all required dispatch types for this action are loaded, then -pass the action to our dispatch types so they can register it if required. -Also, set up the tree with the action containers. - -=cut - -sub register { - my ( $self, $c, $action ) = @_; - - my $registered = $self->_registered_dispatch_types; - - #my $priv = 0; #seems to be unused - foreach my $key ( keys %{ $action->attributes } ) { - next if $key eq 'Private'; - my $class = "Catalyst::DispatchType::$key"; - unless ( $registered->{$class} ) { - # FIXME - Some error checking and re-throwing needed here, as - # we eat exceptions loading dispatch types. - eval { Class::MOP::load_class($class) }; - push( @{ $self->dispatch_types }, $class->new ) unless $@; - $registered->{$class} = 1; - } - } - - my @dtypes = @{ $self->dispatch_types }; - my @normal_dtypes; - my @low_precedence_dtypes; - - for my $type ( @dtypes ) { - if ($type->_is_low_precedence) { - push @low_precedence_dtypes, $type; - } else { - push @normal_dtypes, $type; - } - } - - # Pass the action to our dispatch types so they can register it if reqd. - my $was_registered = 0; - foreach my $type ( @normal_dtypes ) { - $was_registered = 1 if $type->register( $c, $action ); - } - - if (not $was_registered) { - foreach my $type ( @low_precedence_dtypes ) { - $type->register( $c, $action ); - } - } - - my $namespace = $action->namespace; - my $name = $action->name; - - my $container = $self->_find_or_create_action_container($namespace); - - # Set the method value - $container->add_action($action); - - $self->_action_hash->{"$namespace/$name"} = $action; - $self->_container_hash->{$namespace} = $container; -} - -sub _find_or_create_action_container { - my ( $self, $namespace ) = @_; - - my $tree ||= $self->_tree; - - return $tree->getNodeValue unless $namespace; - - my @namespace = split '/', $namespace; - return $self->_find_or_create_namespace_node( $tree, @namespace ) - ->getNodeValue; -} - -sub _find_or_create_namespace_node { - my ( $self, $parent, $part, @namespace ) = @_; - - return $parent unless $part; - - my $child = - ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0]; - - unless ($child) { - my $container = Catalyst::ActionContainer->new($part); - $parent->addChild( $child = Tree::Simple->new($container) ); - } - - $self->_find_or_create_namespace_node( $child, @namespace ); -} - -=head2 $self->setup_actions( $class, $context ) - -Loads all of the preload dispatch types, registers their actions and then -loads all of the postload dispatch types, and iterates over the tree of -actions, displaying the debug information if appropriate. - -=cut - -sub setup_actions { - my ( $self, $c ) = @_; - - my @classes = - $self->_load_dispatch_types( @{ $self->preload_dispatch_types } ); - @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes; - - foreach my $comp ( values %{ $c->components } ) { - $comp->register_actions($c) if $comp->can('register_actions'); - } - - $self->_load_dispatch_types( @{ $self->postload_dispatch_types } ); - - return unless $c->debug; - $self->_display_action_tables($c); -} - -sub _display_action_tables { - my ($self, $c) = @_; - - my $avail_width = Catalyst::Utils::term_width() - 12; - my $col1_width = ($avail_width * .25) < 20 ? 20 : int($avail_width * .25); - my $col2_width = ($avail_width * .50) < 36 ? 36 : int($avail_width * .50); - my $col3_width = $avail_width - $col1_width - $col2_width; - my $privates = Text::SimpleTable->new( - [ $col1_width, 'Private' ], [ $col2_width, 'Class' ], [ $col3_width, 'Method' ] - ); - - my $has_private = 0; - my $walker = sub { - my ( $walker, $parent, $prefix ) = @_; - $prefix .= $parent->getNodeValue || ''; - $prefix .= '/' unless $prefix =~ /\/$/; - my $node = $parent->getNodeValue->actions; - - for my $action ( keys %{$node} ) { - my $action_obj = $node->{$action}; - next - if ( ( $action =~ /^_.*/ ) - && ( !$c->config->{show_internal_actions} ) ); - $privates->row( "$prefix$action", $action_obj->class, $action ); - $has_private = 1; - } - - $walker->( $walker, $_, $prefix ) for $parent->getAllChildren; - }; - - $walker->( $walker, $self->_tree, '' ); - $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" ) - if $has_private; - - # List all public actions - $_->list($c) for @{ $self->dispatch_types }; -} - -sub _load_dispatch_types { - my ( $self, @types ) = @_; - - my @loaded; - # Preload action types - for my $type (@types) { - # first param is undef because we cannot get the appclass - my $class = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $type); - - eval { Class::MOP::load_class($class) }; - Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ ) - if $@; - push @{ $self->dispatch_types }, $class->new; - - push @loaded, $class; - } - - return @loaded; -} - -=head2 $self->dispatch_type( $type ) - -Get the DispatchType object of the relevant type, i.e. passing C<$type> of -C would return a L object (assuming -of course it's being used.) - -=cut - -sub dispatch_type { - my ($self, $name) = @_; - - # first param is undef because we cannot get the appclass - $name = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $name); - - for (@{ $self->dispatch_types }) { - return $_ if ref($_) eq $name; - } - return undef; -} - -use Moose; - -# 5.70 backwards compatibility hacks. - -# Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL) -# need the methods here which *should* be private.. - -# You should be able to use get_actions or get_containers appropriately -# instead of relying on these methods which expose implementation details -# of the dispatcher.. -# -# IRC backlog included below, please come ask if this doesn't work for you. -# -# <@t0m> 5.80, the state of. There are things in the dispatcher which have -# been deprecated, that we yell at anyone for using, which there isn't -# a good alternative for yet.. -# <@mst> er, get_actions/get_containers provides that doesn't it? -# <@mst> DispatchTypes are loaded on demand anyway -# <@t0m> I'm thinking of things like _tree which is aliased to 'tree' with -# warnings otherwise shit breaks.. We're issuing warnings about the -# correct set of things which you shouldn't be calling.. -# <@mst> right -# <@mst> basically, I don't see there's a need for a replacement for anything -# <@mst> it was never a good idea to call ->tree -# <@mst> nothingmuch was the only one who did AFAIK -# <@mst> and he admitted it was a hack ;) - -# See also t/lib/TestApp/Plugin/AddDispatchTypes.pm - -# Alias _method_name to method_name, add a before modifier to warn.. -foreach my $public_method_name (qw/ - tree - registered_dispatch_types - method_action_class - action_hash - container_hash - /) { - my $private_method_name = '_' . $public_method_name; - my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time. - $meta->add_method($public_method_name, $meta->get_method($private_method_name)); - { - my %package_hash; # Only warn once per method, per package. These are infrequent enough that - # I haven't provided a way to disable them, patches welcome. - $meta->add_before_method_modifier($public_method_name, sub { - my $class = caller(2); - chomp($class); - $package_hash{$class}++ || do { - warn("Class $class is calling the deprecated method\n" - . " Catalyst::Dispatcher::$public_method_name,\n" - . " this will be removed in Catalyst 5.9X\n"); - }; - }); - } -} -# End 5.70 backwards compatibility hacks. - -__PACKAGE__->meta->make_immutable; - -=head2 meta - -Provided by Moose - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1;