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=28886075d40dbee2e5acc2ab7160a5b55a9d0c51;hp=71a8fd3e979f22ee5736aa7e95051d6cddd73d20;hb=0ca510f0aa1cabe138d81897d38111d7b772449c;hpb=39fc2ce1e456c4e2a272204aa8fe67896984b3a6 diff --git a/lib/Catalyst/DispatchType/Chained.pm b/lib/Catalyst/DispatchType/Chained.pm index 71a8fd3..2888607 100644 --- a/lib/Catalyst/DispatchType/Chained.pm +++ b/lib/Catalyst/DispatchType/Chained.pm @@ -7,6 +7,8 @@ use Text::SimpleTable; use Catalyst::ActionChain; use Catalyst::Utils; use URI; +use Scalar::Util (); +use Encode 2.21 'decode_utf8'; has _endpoints => ( is => 'rw', @@ -39,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 ) = @_; @@ -53,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 @@ -68,30 +81,34 @@ sub list { return unless $self->_endpoints; - my $column_width = Catalyst::Utils::term_width() - 35 - 9; + 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' ], [ $column_width, 'Private' ] + [ $col1_width, 'Path Spec' ], [ $col2_width, 'Private' ], ); my $has_unattached_actions; my $unattached_actions = Text::SimpleTable->new( - [ 35, 'Private' ], [ 36, 'Missing parent' ], + [ $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 $args = $endpoint->list_extra_info->{Args}; my @parts = (defined($args) ? (("*") x $args) : '...'); my @parents = (); my $parent = "DUMMY"; + my $extra = $self->_list_extra_http_methods($endpoint); + my $consumes = $self->_list_extra_consumes($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}) { + 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]); } @@ -101,22 +118,31 @@ sub list { } if ($parent ne '/') { $has_unattached_actions = 1; - $unattached_actions->row('/'.$parents[0]->reverse, $parent); + $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})) { + $name .= ' ('.$cap.')'; + } + if (defined(my $ct = $p->list_extra_info->{Consumes})) { + $name .= ' :'.$ct; } + unless ($p eq $parents[0]) { $name = "-> ${name}"; } push(@rows, [ '', $name ]); } - push(@rows, [ '', (@rows ? "=> " : '')."/${endpoint}" ]); - $rows[0][0] = join('/', '', @parts); + push(@rows, [ '', (@rows ? "=> " : '').($extra ? "$extra " : '')."/${endpoint}". ($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; } @@ -125,6 +151,20 @@ sub list { 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}}); +} + + =head2 $self->match( $c, $path ) Calls C to see if a chain matches the C<$path>. @@ -140,7 +180,13 @@ sub match { my @parts = split('/', $path); my ($chain, $captures, $parts) = $self->recurse_match($c, '/', \@parts); - push @{$request->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; @@ -181,18 +227,22 @@ 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 = $capture_attr->[0] || 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 + if ($action->can('match_captures')) { 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 ); # No best action currently @@ -202,12 +252,15 @@ sub recurse_match { (!$best_action || $#$action_parts < $#{$best_action->{parts}} || ($#$action_parts == $#{$best_action->{parts}} && - $#$captures < $#{$best_action->{captures}}))){ + $#$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 { @@ -216,27 +269,28 @@ sub recurse_match { next TRY_ACTION unless $action->match($c); } my $args_attr = $action->attributes->{Args}->[0]; - + 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 + # 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 || @parts < @{$best_action->{parts}} || - (!@parts && $args_attr eq 0)){ + (!@parts && defined($args_attr) && $args_attr eq "0")){ $best_action = { actions => [ $action ], captures=> [], - parts => \@parts - } + parts => \@parts, + 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 (); } @@ -246,6 +300,32 @@ Calls register_path for every Path attribute for the given $action. =cut +sub _check_args_attr { + my ( $self, $action, $name ) = @_; + + return unless exists $action->attributes->{$name}; + + if (@{$action->attributes->{$name}} > 1) { + Catalyst::Exception->throw( + "Multiple $name attributes not supported registering " . $action->reverse() + ); + } + my $args = $action->attributes->{$name}->[0]; + if (defined($args) and not ( + Scalar::Util::looks_like_number($args) and + int($args) == $args and $args >= 0 + )) { + require Data::Dumper; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Indent = 0; + $args = Data::Dumper::Dumper($args); + Catalyst::Exception->throw( + "Invalid $name($args) for action " . $action->reverse() . + " (use '$name' or '$name()')" + ); + } +} + sub register { my ( $self, $c, $action ) = @_; @@ -258,8 +338,13 @@ sub register { "Multiple Chained attributes not supported registering ${action}" ); } + my $chained_to = $chained_attr[0]; - my $children = ($self->_children_of->{ $chained_attr[0] } ||= {}); + Catalyst::Exception->throw( + "Actions cannot chain to themselves registering /${action}" + ) if ($chained_to eq '/' . $action); + + my $children = ($self->_children_of->{ $chained_to } ||= {}); my @path_part = @{ $action->attributes->{PathPart} || [] }; @@ -279,12 +364,26 @@ sub register { ); } - $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; + foreach my $name (qw(Args CaptureArgs)) { + $self->_check_args_attr($action, $name); + } + + 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); } @@ -311,12 +410,12 @@ sub uri_for_action { my $curr = $action; while ($curr) { if (my $cap = $curr->attributes->{CaptureArgs}) { - return undef unless @captures >= $cap->[0]; # not enough captures + return undef unless @captures >= ($cap->[0]||0); # not enough captures if ($cap->[0]) { unshift(@parts, splice(@captures, -$cap->[0])); } } - if (my $pp = $curr->attributes->{PartPath}) { + if (my $pp = $curr->attributes->{PathPart}) { unshift(@parts, $pp->[0]) if (defined($pp->[0]) && length($pp->[0])); } @@ -329,12 +428,12 @@ sub uri_for_action { return undef if @captures; # fail for too many captures return join('/', '', @parts); - + } =head2 $c->expand_action($action) -Return a list of actions that represents a chained action. See +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. @@ -358,6 +457,7 @@ sub expand_action { } __PACKAGE__->meta->make_immutable; +1; =head1 USAGE @@ -517,7 +617,7 @@ this debugging output: '-----------------------+------------------------------' ... -Here's a more detailed specification of the attributes belonging to +Here's a more detailed specification of the attributes belonging to C<:Chained>: =head2 Attributes @@ -623,9 +723,18 @@ 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 AUTHORS @@ -633,7 +742,7 @@ 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