X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst%2FDispatchType%2FChained.pm;h=3cd15f025659103d28ef92a8386a87fc517128b2;hp=bc12721f5f6ecbba4828c6d667d3b833e216cade;hb=5dd46e24eedec447bdfbc4061ed683b5a17a7b0c;hpb=3c0186f29e8864c86aca75f03f8d8ac1afd5507d diff --git a/lib/Catalyst/DispatchType/Chained.pm b/lib/Catalyst/DispatchType/Chained.pm index bc12721..3cd15f0 100644 --- a/lib/Catalyst/DispatchType/Chained.pm +++ b/lib/Catalyst/DispatchType/Chained.pm @@ -1,33 +1,38 @@ package Catalyst::DispatchType::Chained; use Moose; +extends 'Catalyst::DispatchType'; + use Text::SimpleTable; use Catalyst::ActionChain; +use Catalyst::Utils; use URI; - -extends 'Catalyst::DispatchType'; +use Scalar::Util (); +use Encode 2.21 'decode_utf8'; has _endpoints => ( - isa => 'rw', + is => 'rw', isa => 'ArrayRef', required => 1, default => sub{ [] }, ); has _actions => ( - isa => 'rw', + is => 'rw', isa => 'HashRef', required => 1, default => sub{ {} }, ); has _children_of => ( - isa => 'rw', + is => 'rw', isa => 'HashRef', required => 1, default => sub{ {} }, ); +no Moose; + # please don't perltidy this. hairy code within. =head1 NAME @@ -36,6 +41,8 @@ Catalyst::DispatchType::Chained - Path Part DispatchType =head1 SYNOPSIS +Path part matching, allowing several actions to sequentially take care of processing a request: + # root action - captures one argument after it sub foo_setup : Chained('/') PathPart('foo') CaptureArgs(1) { my ( $self, $c, $foo_arg ) = @_; @@ -50,7 +57,16 @@ Catalyst::DispatchType::Chained - Path Part DispatchType =head1 DESCRIPTION -See L. +Dispatch type managing default behaviour. For more information on +dispatch types, see: + +=over 4 + +=item * L for how they affect application authors + +=item * L for implementation information. + +=back =head1 METHODS @@ -65,24 +81,47 @@ sub list { return unless $self->_endpoints; + my $avail_width = Catalyst::Utils::term_width() - 9; + my $col1_width = ($avail_width * .50) < 35 ? 35 : int($avail_width * .50); + my $col2_width = $avail_width - $col1_width; my $paths = Text::SimpleTable->new( - [ 35, 'Path Spec' ], [ 36, 'Private' ] - ); + [ $col1_width, 'Path Spec' ], [ $col2_width, 'Private' ], + ); + + my $has_unattached_actions; + my $unattached_actions = Text::SimpleTable->new( + [ $col1_width, 'Private' ], [ $col2_width, 'Missing parent' ], + ); ENDPOINT: foreach my $endpoint ( sort { $a->reverse cmp $b->reverse } @{ $self->_endpoints } ) { - my $args = $endpoint->attributes->{Args}->[0]; - my @parts = (defined($args) ? (("*") x $args) : '...'); + my $args = $endpoint->list_extra_info->{Args}; + + my @parts; + if($endpoint->has_args_constraints) { + @parts = map { "{$_}" } $endpoint->all_args_constraints; + } elsif(defined $endpoint->attributes->{Args}) { + @parts = (defined($endpoint->attributes->{Args}[0]) ? (("*") x $args) : '...'); + } + my @parents = (); my $parent = "DUMMY"; + my $extra = $self->_list_extra_http_methods($endpoint); + my $consumes = $self->_list_extra_consumes($endpoint); + my $scheme = $self->_list_extra_scheme($endpoint); my $curr = $endpoint; while ($curr) { - if (my $cap = $curr->attributes->{CaptureArgs}) { - unshift(@parts, (("*") x $cap->[0])); + if (my $cap = $curr->list_extra_info->{CaptureArgs}) { + if($curr->has_captures_constraints) { + my $names = join '/', map { "{$_}" } $curr->all_captures_constraints; + unshift(@parts, $names); + } else { + unshift(@parts, (("*") x $cap)); + } } - if (my $pp = $curr->attributes->{PartPath}) { + if (my $pp = $curr->attributes->{PathPart}) { unshift(@parts, $pp->[0]) if (defined $pp->[0] && length $pp->[0]); } @@ -90,24 +129,74 @@ sub list { $curr = $self->_actions->{$parent}; unshift(@parents, $curr) if $curr; } - next ENDPOINT unless $parent eq '/'; # skip dangling action + if ($parent ne '/') { + $has_unattached_actions = 1; + $unattached_actions->row('/' . ($parents[0] || $endpoint)->reverse, $parent); + next ENDPOINT; + } my @rows; foreach my $p (@parents) { my $name = "/${p}"; - if (my $cap = $p->attributes->{CaptureArgs}) { - $name .= ' ('.$cap->[0].')'; + + if (defined(my $extra = $self->_list_extra_http_methods($p))) { + $name = "${extra} ${name}"; + } + if (defined(my $cap = $p->list_extra_info->{CaptureArgs})) { + if($p->has_captures_constraints) { + my $tc = join ',', @{$p->captures_constraints}; + $name .= " ($tc)"; + } else { + $name .= " ($cap)"; + } + } + if (defined(my $ct = $p->list_extra_info->{Consumes})) { + $name .= ' :'.$ct; + } + if (defined(my $s = $p->list_extra_info->{Scheme})) { + $scheme = uc $s; } + unless ($p eq $parents[0]) { $name = "-> ${name}"; } push(@rows, [ '', $name ]); } - push(@rows, [ '', (@rows ? "=> " : '')."/${endpoint}" ]); - $rows[0][0] = join('/', '', @parts); + + my $endpoint_arg_info; + if($endpoint->has_args_constraints) { + my $tc = join ',', @{$endpoint->args_constraints}; + $endpoint_arg_info .= " ($tc)"; + } else { + $endpoint_arg_info .= defined($endpoint->attributes->{Args}[0]) ? " ($args)" : " (...)"; + } + push(@rows, [ '', (@rows ? "=> " : '').($extra ? "$extra " : ''). ($scheme ? "$scheme: ":'')."/${endpoint_arg_info}". ($consumes ? " :$consumes":"" ) ]); + my @display_parts = map { $_ =~s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; decode_utf8 $_ } @parts; + $rows[0][0] = join('/', '', @display_parts) || '/'; $paths->row(@$_) for @rows; } $c->log->debug( "Loaded Chained actions:\n" . $paths->draw . "\n" ); + $c->log->debug( "Unattached Chained actions:\n", $unattached_actions->draw . "\n" ) + if $has_unattached_actions; +} + +sub _list_extra_http_methods { + my ( $self, $action ) = @_; + return unless defined $action->list_extra_info->{HTTP_METHODS}; + return join(', ', @{$action->list_extra_info->{HTTP_METHODS}}); + +} + +sub _list_extra_consumes { + my ( $self, $action ) = @_; + return unless defined $action->list_extra_info->{CONSUMES}; + return join(', ', @{$action->list_extra_info->{CONSUMES}}); +} + +sub _list_extra_scheme { + my ( $self, $action ) = @_; + return unless defined $action->list_extra_info->{Scheme}; + return uc $action->list_extra_info->{Scheme}; } =head2 $self->match( $c, $path ) @@ -119,20 +208,27 @@ Calls C to see if a chain matches the C<$path>. sub match { my ( $self, $c, $path ) = @_; - return 0 if @{$c->req->args}; + my $request = $c->request; + return 0 if @{$request->args}; my @parts = split('/', $path); my ($chain, $captures, $parts) = $self->recurse_match($c, '/', \@parts); - push @{$c->req->args}, @$parts if $parts && @$parts; + + if ($parts && @$parts) { + for my $arg (@$parts) { + $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + push @{$request->args}, $arg; + } + } return 0 unless $chain; my $action = Catalyst::ActionChain->from_chain($chain); - $c->req->action("/${action}"); - $c->req->match("/${action}"); - $c->req->captures($captures); + $request->action("/${action}"); + $request->match("/${action}"); + $request->captures($captures); $c->action($action); $c->namespace( $action->namespace ); @@ -164,27 +260,43 @@ sub recurse_match { } my @try_actions = @{$children->{$try_part}}; TRY_ACTION: foreach my $action (@try_actions) { + + if (my $capture_attr = $action->attributes->{CaptureArgs}) { + my $capture_count = $action->number_of_captures|| 0; # Short-circuit if not enough remaining parts - next TRY_ACTION unless @parts >= $capture_attr->[0]; + next TRY_ACTION unless @parts >= $capture_count; my @captures; my @parts = @parts; # localise # strip CaptureArgs into list - push(@captures, splice(@parts, 0, $capture_attr->[0])); + push(@captures, splice(@parts, 0, $capture_count)); + + # check if the action may fit, depending on a given test by the app + next TRY_ACTION unless $action->match_captures($c, \@captures); # try the remaining parts against children of this action - my ($actions, $captures, $action_parts) = $self->recurse_match( + my ($actions, $captures, $action_parts, $n_pathparts) = $self->recurse_match( $c, '/'.$action->reverse, \@parts ); - if ($actions && (!$best_action || $#$action_parts < $#{$best_action->{parts}})){ + # No best action currently + # OR The action has less parts + # OR The action has equal parts but less captured data (ergo more defined) + if ($actions && + (!$best_action || + $#$action_parts < $#{$best_action->{parts}} || + ($#$action_parts == $#{$best_action->{parts}} && + $#$captures < $#{$best_action->{captures}} && + $n_pathparts > $best_action->{n_pathparts}))) { + my @pathparts = split /\//, $action->attributes->{PathPart}->[0]; $best_action = { actions => [ $action, @$actions ], captures=> [ @captures, @$captures ], - parts => $action_parts - }; + parts => $action_parts, + n_pathparts => scalar(@pathparts) + $n_pathparts, + }; } } else { @@ -193,27 +305,44 @@ sub recurse_match { next TRY_ACTION unless $action->match($c); } my $args_attr = $action->attributes->{Args}->[0]; - + my $args_count = $action->comparable_arg_number; + my @pathparts = split /\//, $action->attributes->{PathPart}->[0]; # No best action currently # OR This one matches with fewer parts left than the current best action, # And therefore is a better match # OR No parts and this expects 0 # The current best action might also be Args(0), # but we couldn't chose between then anyway so we'll take the last seen - - if (!$best_action || + if ( + !$best_action || @parts < @{$best_action->{parts}} || - (!@parts && $args_attr eq 0)){ + ( + !@parts && + defined($args_attr) && + ( + $args_count eq "0" && + ( + ($c->config->{use_chained_args_0_special_case}||0) || + ( + exists($best_action->{args_count}) && defined($best_action->{args_count}) ? + ($best_action->{args_count} ne 0) : 1 + ) + ) + ) + ) + ){ $best_action = { actions => [ $action ], captures=> [], - parts => \@parts - } + parts => \@parts, + args_count => $args_count, + n_pathparts => scalar(@pathparts), + }; } } } } - return @$best_action{qw/actions captures parts/} if $best_action; + return @$best_action{qw/actions captures parts n_pathparts/} if $best_action; return (); } @@ -230,31 +359,18 @@ sub register { return 0 unless @chained_attr; - if (@chained_attr > 2) { + if (@chained_attr > 1) { Catalyst::Exception->throw( "Multiple Chained attributes not supported registering ${action}" ); } + my $chained_to = $chained_attr[0]; - my $parent = $chained_attr[0]; - - if (defined($parent) && length($parent)) { - if ($parent eq '.') { - $parent = '/'.$action->namespace; - } elsif ($parent !~ m/^\//) { - if ($action->namespace) { - $parent = '/'.join('/', $action->namespace, $parent); - } else { - $parent = '/'.$parent; # special case namespace '' (root) - } - } - } else { - $parent = '/' - } + Catalyst::Exception->throw( + "Actions cannot chain to themselves registering /${action}" + ) if ($chained_to eq '/' . $action); - $action->attributes->{Chained} = [ $parent ]; - - my $children = $self->_children_of->{$parent}; + my $children = ($self->_children_of->{ $chained_to } ||= {}); my @path_part = @{ $action->attributes->{PathPart} || [] }; @@ -264,22 +380,32 @@ sub register { $part = $path_part[0]; } elsif (@path_part > 1) { Catalyst::Exception->throw( - "Multiple PathPart attributes not supported registering ${action}" + "Multiple PathPart attributes not supported registering " . $action->reverse() ); } if ($part =~ m(^/)) { Catalyst::Exception->throw( - "Absolute parameters to PathPart not allowed registering ${action}" + "Absolute parameters to PathPart not allowed registering " . $action->reverse() ); } - $action->attributes->{PartPath} = [ $part ]; + my $encoded_part = URI->new($part)->canonical; + $encoded_part =~ s{(?<=[^/])/+\z}{}; + + $action->attributes->{PathPart} = [ $encoded_part ]; - unshift(@{ $children->{$part} ||= [] }, $action); + unshift(@{ $children->{$encoded_part} ||= [] }, $action); $self->_actions->{'/'.$action->reverse} = $action; + if (exists $action->attributes->{Args} and exists $action->attributes->{CaptureArgs}) { + Catalyst::Exception->throw( + "Combining Args and CaptureArgs attributes not supported registering " . + $action->reverse() + ); + } + unless ($action->attributes->{CaptureArgs}) { unshift(@{ $self->_endpoints }, $action); } @@ -304,14 +430,18 @@ sub uri_for_action { my @captures = @$captures; my $parent = "DUMMY"; my $curr = $action; + # If this is an action chain get the last action in the chain + if($curr->can('chain') ) { + $curr = ${$curr->chain}[-1]; + } while ($curr) { - if (my $cap = $curr->attributes->{CaptureArgs}) { - return undef unless @captures >= $cap->[0]; # not enough captures - if ($cap->[0]) { - unshift(@parts, splice(@captures, -$cap->[0])); + if (my $cap = $curr->number_of_captures) { + return undef unless @captures >= $cap; # not enough captures + if ($cap) { + unshift(@parts, splice(@captures, -$cap)); } } - if (my $pp = $curr->attributes->{PartPath}) { + if (my $pp = $curr->attributes->{PathPart}) { unshift(@parts, $pp->[0]) if (defined($pp->[0]) && length($pp->[0])); } @@ -327,6 +457,34 @@ sub uri_for_action { } +=head2 $c->expand_action($action) + +Return a list of actions that represents a chained action. See +L for more info. You probably want to +use the expand_action it provides rather than this directly. + +=cut + +sub expand_action { + my ($self, $action) = @_; + + return unless $action->attributes && $action->attributes->{Chained}; + + my @chain; + my $curr = $action; + + while ($curr) { + push @chain, $curr; + my $parent = $curr->attributes->{Chained}->[0]; + $curr = $self->_actions->{$parent}; + } + + return Catalyst::ActionChain->from_chain([reverse @chain]); +} + +__PACKAGE__->meta->make_immutable; +1; + =head1 USAGE =head2 Introduction @@ -502,13 +660,18 @@ with C would bind to C. If you don't specify C<:PathPart> it has the same effect as using C<:PathPart>, it would default to the action name. +=item PathPrefix + +Sets PathPart to the path_prefix of the current controller. + =item Chained Has to be specified for every child in the chain. Possible values are -absolute and relative private action paths, with the relatives pointing -to the current controller, or a single slash C to tell Catalyst that -this is the root of a chain. The attribute C<:Chained> without arguments -also defaults to the C behavior. +absolute and relative private action paths or a single slash C to +tell Catalyst that this is the root of a chain. The attribute +C<:Chained> without arguments also defaults to the C behavior. +Relative action paths may use C<../> to refer to actions in parent +controllers. Because you can specify an absolute path to the parent action, it doesn't matter to Catalyst where that parent is located. So, if your @@ -531,6 +694,19 @@ with the path of the current controller namespace, namely C. That action chains directly to C, so the C chain comes out as the end product. +=item ChainedParent + +Chains an action to another action with the same name in the parent +controller. For Example: + + # in MyApp::Controller::Foo + sub bar : Chained CaptureArgs(1) { ... } + + # in MyApp::Controller::Foo::Moo + sub bar : ChainedParent Args(1) { ... } + +This builds a chain like C. + =item CaptureArgs Must be specified for every part of the chain that is not an @@ -546,6 +722,32 @@ An action that is part of a chain (that is, one that has a C<:Chained> attribute) but has no C<:CaptureArgs> attribute is treated by Catalyst as a chain end. +Allowed values for CaptureArgs is a single integer (CaptureArgs(2), meaning two +allowed) or you can declare a L, L or L +named constraint such as CaptureArgs(Int,Str) would require two args with +the first being a Integer and the second a string. You may declare your own +custom type constraints and import them into the controller namespace: + + package MyApp::Controller::Root; + + use Moose; + use MooseX::MethodAttributes; + use MyApp::Types qw/Int/; + + extends 'Catalyst::Controller'; + + sub chain_base :Chained(/) CaptureArgs(1) { } + + sub any_priority_chain :Chained(chain_base) PathPart('') Args(1) { } + + sub int_priority_chain :Chained(chain_base) PathPart('') Args(Int) { } + +If you use a reference type constraint in CaptureArgs, it must be a type +like Tuple in L that allows us to determine the number of +args to match. Otherwise this will raise an error during startup. + +See L for more. + =item Args By default, endpoints receive the rest of the arguments in the path. You @@ -564,6 +766,9 @@ Just as with C<:CaptureArgs>, the arguments get passed to the action in C<@_> after the context object. They can also be reached through C<$c-Erequest-Earguments>. +You should see 'Args' in L for more details on using +type constraints in your Args declarations. + =back =head2 Auto actions, dispatching and forwarding @@ -573,17 +778,26 @@ of the endpoint of the chain, not on the chained actions way. The C actions will be run before the chain dispatching begins. In every other aspect, C actions behave as documented. -The Cing to other actions does just what you would expect. But if -you C out of a chain, the rest of the chain will not get called -after the C. +The Cing to other actions does just what you would expect. i.e. +only the target action is run. The actions that that action is chained +to are not run. +If you C out of a chain, the rest of the chain will not get +called after the C. + +=head2 match_captures + +A method which can optionally be implemented by actions to +stop chain matching. + +See L for further details. -=head1 AUTHOR +=head1 AUTHORS -Matt S Trout +Catalyst Contributors, see Catalyst.pm =head1 COPYRIGHT -This program is free software, you can redistribute it and/or modify it under +This library is free software. You can redistribute it and/or modify it under the same terms as Perl itself. =cut