From: Matt S Trout Date: Thu, 22 Jun 2006 14:49:21 +0000 (+0000) Subject: first cut at :ChildOf X-Git-Tag: 5.7099_04~506 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=141459fa3fc9852fd6f05138caddb410bbe2949c;hp=a8762dd4f8ea1338b9b45ecf37c0107f2710d398 first cut at :ChildOf r9738@cain (orig r4287): matthewt | 2006-06-05 03:45:08 +0000 --- diff --git a/lib/Catalyst/Action.pm b/lib/Catalyst/Action.pm index ce587ac..0ddd796 100644 --- a/lib/Catalyst/Action.pm +++ b/lib/Catalyst/Action.pm @@ -79,7 +79,9 @@ Check Args attribute, and makes sure number of args matches the setting. sub match { my ( $self, $c ) = @_; return 1 unless exists $self->attributes->{Args}; - return scalar( @{ $c->req->args } ) == $self->attributes->{Args}[0]; + my $args = $self->attributes->{Args}[0]; + return 1 unless defined($args) && length($args); + return scalar( @{ $c->req->args } ) == $args; } =head2 namespace diff --git a/lib/Catalyst/ActionChain.pm b/lib/Catalyst/ActionChain.pm new file mode 100644 index 0000000..2bcc31f --- /dev/null +++ b/lib/Catalyst/ActionChain.pm @@ -0,0 +1,80 @@ +package Catalyst::ActionChain; + +use strict; +use base qw/Catalyst::Action/; + +__PACKAGE__->mk_accessors(qw/chain/); + +use overload ( + + # Stringify to reverse for debug output etc. + q{""} => sub { shift->{reverse} }, + + # Codulate to execute to invoke the encapsulated action coderef + '&{}' => sub { my $self = shift; sub { $self->execute(@_); }; }, + + # Make general $stuff still work + fallback => 1, + +); + +=head1 NAME + +Catalyst::ActionChain - Chain of Catalyst Actions + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +This class represents a chain of Catalyst Actions. It behaves exactly like +the action at the *end* of the chain except on dispatch it will execute all +the actions in the chain in order. + +=head1 METHODS + +=head2 chain + +Accessor for the action chain; will be an arrayref of the Catalyst::Action +objects encapsulated by this chain. + +=head2 dispatch( $c ) + +Dispatch this action chain against a context; will dispatch the encapsulated +actions in order. + +=cut + +sub dispatch { + my ( $self, $c ) = @_; + foreach my $action ( @{ $self->chain } ) { + $action->dispatch( $c ); + } +} + +=head2 from_chain( \@actions ) + +Takes a list of Catalyst::Action objects and constructs and returns a +Catalyst::ActionChain object representing a chain of these actions + +=cut + +sub from_chain { + my ( $self, $actions ) = @_; + my $final = $actions->[-1]; + return $self->new({ %$final, chain => $actions }); +} + +=head1 AUTHOR + +Matt S. Trout + +=head1 COPYRIGHT + +This program is free software, you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +1; diff --git a/lib/Catalyst/DispatchType/ChildOf.pm b/lib/Catalyst/DispatchType/ChildOf.pm new file mode 100644 index 0000000..094337d --- /dev/null +++ b/lib/Catalyst/DispatchType/ChildOf.pm @@ -0,0 +1,201 @@ +package Catalyst::DispatchType::ChildOf; + +use strict; +use base qw/Catalyst::DispatchType/; +use Text::SimpleTable; +use Catalyst::ActionChain; +use URI; + +=head1 NAME + +Catalyst::DispatchType::Path - Path DispatchType + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 $self->list($c) + +Debug output for Path Part dispatch points + +Matt is an idiot and hasn't implemented this yet. + +=cut + +#sub list { +# my ( $self, $c ) = @_; +# my $paths = Text::SimpleTable->new( [ 35, 'Path' ], [ 36, 'Private' ] ); +# foreach my $path ( sort keys %{ $self->{paths} } ) { +# foreach my $action ( @{ $self->{paths}->{$path} } ) { +# $path = "/$path" unless $path eq '/'; +# $paths->row( "$path", "/$action" ); +# } +# } +# $c->log->debug( "Loaded Path actions:\n" . $paths->draw ) +# if ( keys %{ $self->{paths} } ); +#} + +=head2 $self->match( $c, $path ) + +Matt is an idiot and hasn't documented this yet. + +=cut + +sub match { + my ( $self, $c, $path ) = @_; + + return 0 if @{$c->req->args}; + + my @parts = split('/', $path); + + my ($chain, $captures) = $self->recurse_match($c, '/', \@parts); + + return 0 unless $chain; + + my $action = Catalyst::ActionChain->from_chain($chain); + + $c->req->action("/${action}"); + $c->req->match("/${action}"); + $c->req->captures($captures); + $c->action($action); + $c->namespace( $action->namespace ); + + return 1; +} + +=head2 $self->recurse_match( $c, $parent, \@path_parts ) + +Matt is an idiot and hasn't documented this yet. + +=cut + +sub recurse_match { + my ( $self, $c, $parent, $path_parts ) = @_; + my $children = $self->{children_of}{$parent}; + return () unless $children; + my @captures; + TRY: foreach my $try_part (sort length, keys %$children) { + my @parts = @$path_parts; + if (length $try_part) { # test and strip PathPart + next TRY unless + ($try_part eq join('/', # assemble equal number of parts + splice( # and strip them off @parts as well + @parts, 0, scalar(split('/', $try_part)) + ))); + } + my @try_actions = @{$children->{$try_part}}; + TRY_ACTION: foreach my $action (@try_actions) { + if (my $args_attr = $action->attributes->{Args}) { + # XXX alternative non-Args way to identify an endpoint? + { + local $c->req->{arguments} = [ @{$c->req->args}, @parts ]; + next TRY_ACTION unless $action->match($c); + } + push(@{$c->req->args}, @parts); + return [ $action ], [ ]; + } else { + my @captures; + my @parts = @parts; # localise + if (my $capture_attr = $action->attributes->{Captures}) { + # strip Captures into list + push(@captures, splice(@parts, 0, $capture_attr->[0])); + } + # try the remaining parts against children of this action + my ($actions, $captures) = $self->recurse_match( + $c, '/'.$action->reverse, \@parts + ); + if ($actions) { + return [ $action, @$actions ], [ @captures, @$captures ]; + } + } + } + } + return (); +} + +=head2 $self->register( $c, $action ) + +Matt is an idiot and hasn't documented this yet. + +=cut + +sub register { + my ( $self, $c, $action ) = @_; + + my @child_of_attr = @{ $action->attributes->{ChildOf} || [] }; + + return 0 unless @child_of_attr; + + if (@child_of_attr > 2) { + Catalyst::Exception->throw( + "Multiple ChildOf attributes not supported registering ${action}" + ); + } + + my $parent = $child_of_attr[0]; + + if (defined($parent) && length($parent)) { + unless ($parent =~ m/^\//) { + $parent = '/'.join('/', $action->namespace, $parent); + } + } else { + $parent = '/'.$action->namespace; + } + + my $children = ($self->{children_of}{$parent} ||= {}); + + my @path_part = @{ $action->attributes->{PathPart} || [] }; + + my $part = ''; + + if (@path_part == 1) { + $part = (defined $path_part[0] ? $path_part[0] : $action->name); + } elsif (@path_part > 1) { + Catalyst::Exception->throw( + "Multiple PathPart attributes not supported registering ${action}" + ); + } + + unshift(@{ $children->{$part} ||= [] }, $action); + +} + +=head2 $self->uri_for_action($action, $captures) + +Matt is an idiot and hasn't documented this yet. + +=cut + +sub uri_for_action { + my ( $self, $action, $captures ) = @_; + + return undef if @$captures; + + if (my $paths = $action->attributes->{Path}) { + my $path = $paths->[0]; + $path = '/' unless length($path); + $path = "/${path}" unless ($path =~ m/^\//); + $path = URI->new($path)->canonical; + return $path; + } else { + return undef; + } +} + +=head1 AUTHOR + +Matt S Trout +Sebastian Riedel, C + +=head1 COPYRIGHT + +This program is free software, you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +1; diff --git a/lib/Catalyst/Manual/Intro.pod b/lib/Catalyst/Manual/Intro.pod index b0429ef..314ced4 100644 --- a/lib/Catalyst/Manual/Intro.pod +++ b/lib/Catalyst/Manual/Intro.pod @@ -480,6 +480,10 @@ would match any URL starting /foo/bar/. To restrict this you can do to only match /foo/bar/*/ +=item * B, B and B + +Matt is an idiot and hasn't documented this yet. + =back B After seeing these examples, you probably wonder what the point diff --git a/t/lib/TestApp/Controller/Action/ChildOf.pm b/t/lib/TestApp/Controller/Action/ChildOf.pm new file mode 100644 index 0000000..2bb2818 --- /dev/null +++ b/t/lib/TestApp/Controller/Action/ChildOf.pm @@ -0,0 +1,25 @@ +package TestApp::Controller::Action::ChildOf; + +use strict; +use warnings; + +use base qw/Catalyst::Controller/; + +sub begin :Private { } + +sub foo :PathPart('childof/foo') :Captures(1) :ChildOf('/') { } + +sub bar :PathPart('childof/bar') :ChildOf('/') { } + +sub endpoint :PathPart('end') :ChildOf('/action/childof/foo') :Args(1) { } + +sub finale :ChildOf('bar') :Args { } + +sub end :Private { + my ($self, $c) = @_; + my $out = join('; ', map { join(', ', @$_) } + ($c->req->captures, $c->req->args)); + $c->res->body($out); +} + +1; diff --git a/t/lib/TestApp/Controller/Action/ChildOf/Foo.pm b/t/lib/TestApp/Controller/Action/ChildOf/Foo.pm new file mode 100644 index 0000000..ffba0b3 --- /dev/null +++ b/t/lib/TestApp/Controller/Action/ChildOf/Foo.pm @@ -0,0 +1,10 @@ +package TestApp::Controller::Action::ChildOf::Foo; + +use strict; +use warnings; + +use base qw/Catalyst::Controller/; + +sub spoon :PathPart :ChildOf('') :Args(0) { } + +1; diff --git a/t/live_component_controller_action_childof.t b/t/live_component_controller_action_childof.t new file mode 100644 index 0000000..3fc9140 --- /dev/null +++ b/t/live_component_controller_action_childof.t @@ -0,0 +1,72 @@ +#!perl + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/lib"; + +our $iters; + +BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 2; } + +use Test::More tests => 9*$iters; +use Catalyst::Test 'TestApp'; + +if ( $ENV{CAT_BENCHMARK} ) { + require Benchmark; + Benchmark::timethis( $iters, \&run_tests ); +} +else { + for ( 1 .. $iters ) { + run_tests(); + } +} + +sub run_tests { + { + my @expected = qw[ + TestApp::Controller::Action::ChildOf->begin + TestApp::Controller::Action::ChildOf->foo + TestApp::Controller::Action::ChildOf->endpoint + TestApp::Controller::Action::ChildOf->end + ]; + + my $expected = join( ", ", @expected ); + + ok( my $response = request('http://localhost/childof/foo/1/end/2'), 'childof + local endpoint' ); + is( $response->header('X-Catalyst-Executed'), + $expected, 'Executed actions' ); + is( $response->content, '1; 2', 'Content OK' ); + } + { + my @expected = qw[ + TestApp::Controller::Action::ChildOf->begin + TestApp::Controller::Action::ChildOf->foo + TestApp::Controller::Action::ChildOf::Foo->spoon + TestApp::Controller::Action::ChildOf->end + ]; + + my $expected = join( ", ", @expected ); + + ok( my $response = request('http://localhost/childof/foo/1/spoon'), 'childof + subcontroller endpoint' ); + is( $response->header('X-Catalyst-Executed'), + $expected, 'Executed actions' ); + is( $response->content, '1; ', 'Content OK' ); + } + { + my @expected = qw[ + TestApp::Controller::Action::ChildOf->begin + TestApp::Controller::Action::ChildOf->bar + TestApp::Controller::Action::ChildOf->finale + TestApp::Controller::Action::ChildOf->end + ]; + + my $expected = join( ", ", @expected ); + + ok( my $response = request('http://localhost/childof/bar/1/spoon'), 'childof + relative endpoint' ); + is( $response->header('X-Catalyst-Executed'), + $expected, 'Executed actions' ); + is( $response->content, '; 1, spoon', 'Content OK' ); + } +}