File Coverage

blib/lib/Catalyst/DispatchType/Chained.pm
Criterion Covered Total %
statement 105 140 75.0
branch 54 78 69.2
condition 17 23 73.9
subroutine 9 10 90.0
pod 5 5 100.0
total 190 256 74.2


line stmt bran cond sub pod time code
1             package Catalyst::DispatchType::Chained;
2              
3 46     46   2718 use strict;
  46         477  
  46         824  
4 46     46   937 use base qw/Catalyst::DispatchType/;
  46         454  
  46         971  
5 46     46   2663 use Text::SimpleTable;
  46         451  
  46         791  
6 46     46   3700 use Catalyst::ActionChain;
  46         1309  
  46         1176  
7 46     46   948 use URI;
  46         424  
  46         894  
8              
9             # please don't perltidy this. hairy code within.
10              
11             =head1 NAME
12            
13             Catalyst::DispatchType::Chained - Path Part DispatchType
14            
15             =head1 SYNOPSIS
16            
17             # root action - captures one argument after it
18             sub foo_setup : Chained('/') PathPart('foo') CaptureArgs(1) {
19             my ( $self, $c, $foo_arg ) = @_;
20             ...
21             }
22            
23             # child action endpoint - takes one argument
24             sub bar : Chained('foo_setup') Args(1) {
25             my ( $self, $c, $bar_arg ) = @_;
26             ...
27             }
28            
29             =head1 DESCRIPTION
30            
31             See L</USAGE>.
32            
33             =head1 METHODS
34            
35             =head2 $self->list($c)
36            
37             Debug output for Path Part dispatch points
38            
39             =cut
40              
41             sub list {
42 0     0 1 0     my ( $self, $c ) = @_;
43              
44 0 0       0     return unless $self->{endpoints};
45              
46 0         0     my $paths = Text::SimpleTable->new(
47                                 [ 35, 'Path Spec' ], [ 36, 'Private' ]
48                             );
49              
50 0         0     ENDPOINT: foreach my $endpoint (
  0         0  
51 0         0                   sort { $a->reverse cmp $b->reverse }
52                                        @{ $self->{endpoints} }
53                               ) {
54 0         0         my $args = $endpoint->attributes->{Args}->[0];
55 0 0       0         my @parts = (defined($args) ? (("*") x $args) : '...');
56 0         0         my @parents = ();
57 0         0         my $parent = "DUMMY";
58 0         0         my $curr = $endpoint;
59 0         0         while ($curr) {
60 0 0       0             if (my $cap = $curr->attributes->{CaptureArgs}) {
61 0         0                 unshift(@parts, (("*") x $cap->[0]));
62                         }
63 0 0       0             if (my $pp = $curr->attributes->{PartPath}) {
64 0 0 0     0                 unshift(@parts, $pp->[0])
65                                 if (defined $pp->[0] && length $pp->[0]);
66                         }
67 0         0             $parent = $curr->attributes->{Chained}->[0];
68 0         0             $curr = $self->{actions}{$parent};
69 0 0       0             unshift(@parents, $curr) if $curr;
70                     }
71 0 0       0         next ENDPOINT unless $parent eq '/'; # skip dangling action
72 0         0         my @rows;
73 0         0         foreach my $p (@parents) {
74 0         0             my $name = "/${p}";
75 0 0       0             if (my $cap = $p->attributes->{CaptureArgs}) {
76 0         0                 $name .= ' ('.$cap->[0].')';
77                         }
78 0 0       0             unless ($p eq $parents[0]) {
79 0         0                 $name = "-> ${name}";
80                         }
81 0         0             push(@rows, [ '', $name ]);
82                     }
83 0 0       0         push(@rows, [ '', (@rows ? "=> " : '')."/${endpoint}" ]);
84 0         0         $rows[0][0] = join('/', '', @parts);
85 0         0         $paths->row(@$_) for @rows;
  0         0  
86                 }
87              
88 0         0     $c->log->debug( "Loaded Chained actions:\n" . $paths->draw . "\n" );
89             }
90              
91             =head2 $self->match( $c, $path )
92            
93             Calls C<recurse_match> to see if a chain matches the C<$path>.
94            
95             =cut
96              
97             sub match {
98 787     787 1 9996     my ( $self, $c, $path ) = @_;
99              
100 787 100       8904     return 0 if @{$c->req->args};
  787         13570  
101              
102 664         11315     my @parts = split('/', $path);
103              
104 664         9976     my ($chain, $captures) = $self->recurse_match($c, '/', \@parts);
105              
106 664 100       21064     return 0 unless $chain;
107              
108 240         5134     my $action = Catalyst::ActionChain->from_chain($chain);
109              
110 240         16484     $c->req->action("/${action}");
111 240         4794     $c->req->match("/${action}");
112 240         3151     $c->req->captures($captures);
113 240         3687     $c->action($action);
114 240         7985     $c->namespace( $action->namespace );
115              
116 240         6855     return 1;
117             }
118              
119             =head2 $self->recurse_match( $c, $parent, \@path_parts )
120            
121             Recursive search for a matching chain.
122            
123             =cut
124              
125             sub recurse_match {
126 1076     1076 1 20409     my ( $self, $c, $parent, $path_parts ) = @_;
127 1076         18447     my $children = $self->{children_of}{$parent};
128 1076 100       11743     return () unless $children;
129 1074         12823     my @captures;
130 1074         60906     TRY: foreach my $try_part (sort { length($b) <=> length($a) }
  80354         2116844  
131                                                keys %$children) {
132             # $b then $a to try longest part first
133 17074         241817         my @parts = @$path_parts;
134 17074 100       233257         if (length $try_part) { # test and strip PathPart
135                         next TRY unless
136 16646         621234               ($try_part eq join('/', # assemble equal number of parts
137                                           splice( # and strip them off @parts as well
138 16646 100       206990                                 @parts, 0, scalar(@{[split('/', $try_part)]})
139                                           ))); # @{[]} to avoid split to @_
140                     }
141 906         11299         my @try_actions = @{$children->{$try_part}};
  906         13856  
142 906         9294         TRY_ACTION: foreach my $action (@try_actions) {
143 1092 100       18277             if (my $capture_attr = $action->attributes->{CaptureArgs}) {
144              
145             # Short-circuit if not enough remaining parts
146 414 100       11923                 next TRY_ACTION unless @parts >= $capture_attr->[0];
147              
148 412         4302                 my @captures;
149 412         8600                 my @parts = @parts; # localise
150              
151             # strip CaptureArgs into list
152 412         4110                 push(@captures, splice(@parts, 0, $capture_attr->[0]));
153              
154             # try the remaining parts against children of this action
155 412         5440                 my ($actions, $captures) = $self->recurse_match(
156                                                          $c, '/'.$action->reverse, \@parts
157                                                        );
158 412 100       8188                 if ($actions) {
159 234         5079                     return [ $action, @$actions ], [ @captures, @$captures ];
160                             }
161                         } else {
162                             {
163 678         21151                     local $c->req->{arguments} = [ @{$c->req->args}, @parts ];
  678         9113  
  678         10054  
164 678 100       15191                     next TRY_ACTION unless $action->match($c);
165                             }
166 240         2651                 push(@{$c->req->args}, @parts);
  240         4349  
167 240         6003                 return [ $action ], [ ];
168                         }
169                     }
170                 }
171 600         31427     return ();
172             }
173              
174             =head2 $self->register( $c, $action )
175            
176             Calls register_path for every Path attribute for the given $action.
177            
178             =cut
179              
180             sub register {
181 21338     21338 1 289056     my ( $self, $c, $action ) = @_;
182              
183 21338 100       244219     my @chained_attr = @{ $action->attributes->{Chained} || [] };
  21338         329650  
184              
185 21338 100       469791     return 0 unless @chained_attr;
186              
187 3423 50       41583     if (@chained_attr > 2) {
188 0         0         Catalyst::Exception->throw(
189                       "Multiple Chained attributes not supported registering ${action}"
190                     );
191                 }
192              
193 3423         38272     my $parent = $chained_attr[0];
194              
195 3423 100 66     57329     if (defined($parent) && length($parent)) {
196 3017 100       56644         if ($parent eq '.') {
    100          
197 180         2137             $parent = '/'.$action->namespace;
198                     } elsif ($parent !~ m/^\//) {
199 1172 100       21069             if ($action->namespace) {
200 1127         17190                 $parent = '/'.join('/', $action->namespace, $parent);
201                         } else {
202 45         594                 $parent = '/'.$parent; # special case namespace '' (root)
203                         }
204                     }
205                 } else {
206 406         4387         $parent = '/'
207                 }
208              
209 3423         53446     $action->attributes->{Chained} = [ $parent ];
210              
211 3423   100     79279     my $children = ($self->{children_of}{$parent} ||= {});
212              
213 3423 100       37369     my @path_part = @{ $action->attributes->{PathPart} || [] };
  3423         55112  
214              
215 3423         47430     my $part = $action->name;
216              
217 3423 100 100     71614     if (@path_part == 1 && defined $path_part[0]) {
    50          
218 2836         33438         $part = $path_part[0];
219                 } elsif (@path_part > 1) {
220 0         0         Catalyst::Exception->throw(
221                       "Multiple PathPart attributes not supported registering ${action}"
222                     );
223                 }
224              
225 3423 100       44774     if ($part =~ m(^/)) {
226 1         12         Catalyst::Exception->throw(
227                       "Absolute parameters to PathPart not allowed registering ${action}"
228                     );
229                 }
230              
231 3422         54570     $action->attributes->{PartPath} = [ $part ];
232              
233 3422   100     44013     unshift(@{ $children->{$part} ||= [] }, $action);
  3422         74480  
234              
235 3422   100     66445     ($self->{actions} ||= {})->{'/'.$action->reverse} = $action;
236              
237 3422 100       60231     unless ($action->attributes->{CaptureArgs}) {
238 1845   100     20679         unshift(@{ $self->{endpoints} ||= [] }, $action);
  1845         71789  
239                 }
240              
241 3422         62366     return 1;
242             }
243              
244             =head2 $self->uri_for_action($action, $captures)
245            
246             Get the URI part for the action, using C<$captures> to fill
247             the capturing parts.
248            
249             =cut
250              
251             sub uri_for_action {
252 23     23 1 1134     my ( $self, $action, $captures ) = @_;
253              
254 23 100 66     320     return undef unless ($action->attributes->{Chained}
255                                        && !$action->attributes->{CaptureArgs});
256              
257 17         155     my @parts = ();
258 17         164     my @captures = @$captures;
259 17         157     my $parent = "DUMMY";
260 17         144     my $curr = $action;
261 17         230     while ($curr) {
262 37 100       658         if (my $cap = $curr->attributes->{CaptureArgs}) {
263 20 100       234             return undef unless @captures >= $cap->[0]; # not enough captures
264 18 100       184             if ($cap->[0]) {
265 14         201                 unshift(@parts, splice(@captures, -$cap->[0]));
266                         }
267                     }
268 35 50       884         if (my $pp = $curr->attributes->{PartPath}) {
269 35 100 66     570             unshift(@parts, $pp->[0])
270                             if (defined($pp->[0]) && length($pp->[0]));
271                     }
272 35         431         $parent = $curr->attributes->{Chained}->[0];
273 35         568         $curr = $self->{actions}{$parent};
274                 }
275              
276 15 50       233     return undef unless $parent eq '/'; # fail for dangling action
277              
278 15 100       151     return undef if @captures; # fail for too many captures
279              
280 13         225     return join('/', '', @parts);
281                
282             }
283              
284             =head1 USAGE
285            
286             =head2 Introduction
287            
288             The C<Chained> attribute allows you to chain public path parts together
289             by their private names. A chain part's path can be specified with
290             C<PathPart> and can be declared to expect an arbitrary number of
291             arguments. The endpoint of the chain specifies how many arguments it
292             gets through the C<Args> attribute. C<:Args(0)> would be none at all,
293             C<:Args> without an integer would be unlimited. The path parts that
294             aren't endpoints are using C<CaptureArgs> to specify how many parameters
295             they expect to receive. As an example setup:
296            
297             package MyApp::Controller::Greeting;
298             use base qw/ Catalyst::Controller /;
299            
300             # this is the beginning of our chain
301             sub hello : PathPart('hello') Chained('/') CaptureArgs(1) {
302             my ( $self, $c, $integer ) = @_;
303             $c->stash->{ message } = "Hello ";
304             $c->stash->{ arg_sum } = $integer;
305             }
306            
307             # this is our endpoint, because it has no :CaptureArgs
308             sub world : PathPart('world') Chained('hello') Args(1) {
309             my ( $self, $c, $integer ) = @_;
310             $c->stash->{ message } .= "World!";
311             $c->stash->{ arg_sum } += $integer;
312            
313             $c->response->body( join "<br/>\n" =>
314             $c->stash->{ message }, $c->stash->{ arg_sum } );
315             }
316            
317             The debug output provides a separate table for chained actions, showing
318             the whole chain as it would match and the actions it contains. Here's an
319             example of the startup output with our actions above:
320            
321             ...
322             [debug] Loaded Path Part actions:
323             .-----------------------+------------------------------.
324             | Path Spec | Private |
325             +-----------------------+------------------------------+
326             | /hello/*/world/* | /greeting/hello (1) |
327             | | => /greeting/world |
328             '-----------------------+------------------------------'
329             ...
330            
331             As you can see, Catalyst only deals with chains as whole paths and
332             builds one for each endpoint, which are the actions with C<:Chained> but
333             without C<:CaptureArgs>.
334            
335             Let's assume this application gets a request at the path
336             C</hello/23/world/12>. What happens then? First, Catalyst will dispatch
337             to the C<hello> action and pass the value C<23> as an argument to it
338             after the context. It does so because we have previously used
339             C<:CaptureArgs(1)> to declare that it has one path part after itself as
340             its argument. We told Catalyst that this is the beginning of the chain
341             by specifying C<:Chained('/')>. Also note that instead of saying
342             C<:PathPart('hello')> we could also just have said C<:PathPart>, as it
343             defaults to the name of the action.
344            
345             After C<hello> has run, Catalyst goes on to dispatch to the C<world>
346             action. This is the last action to be called: Catalyst knows this is an
347             endpoint because we did not specify a C<:CaptureArgs>
348             attribute. Nevertheless we specify that this action expects an argument,
349             but at this point we're using C<:Args(1)> to do that. We could also have
350             said C<:Args> or left it out altogether, which would mean this action
351             would get all arguments that are there. This action's C<:Chained>
352             attribute says C<hello> and tells Catalyst that the C<hello> action in
353             the current controller is its parent.
354            
355             With this we have built a chain consisting of two public path parts.
356             C<hello> captures one part of the path as its argument, and also
357             specifies the path root as its parent. So this part is
358             C</hello/$arg>. The next part is the endpoint C<world>, expecting one
359             argument. It sums up to the path part C<world/$arg>. This leads to a
360             complete chain of C</hello/$arg/world/$arg> which is matched against the
361             requested paths.
362            
363             This example application would, if run and called by e.g.
364             C</hello/23/world/12>, set the stash value C<message> to "Hello" and the
365             value C<arg_sum> to "23". The C<world> action would then append "World!"
366             to C<message> and add C<12> to the stash's C<arg_sum> value. For the
367             sake of simplicity no view is shown. Instead we just put the values of
368             the stash into our body. So the output would look like:
369            
370             Hello World!
371             35
372            
373             And our test server would have given us this debugging output for the
374             request:
375            
376             ...
377             [debug] "GET" request for "hello/23/world/12" from "127.0.0.1"
378             [debug] Path is "/greeting/world"
379             [debug] Arguments are "12"
380             [info] Request took 0.164113s (6.093/s)
381             .------------------------------------------+-----------.
382             | Action | Time |
383             +------------------------------------------+-----------+
384             | /greeting/hello | 0.000029s |
385             | /greeting/world | 0.000024s |
386             '------------------------------------------+-----------'
387             ...
388            
389             What would be common uses of this dispatch technique? It gives the
390             possibility to split up logic that contains steps that each depend on
391             each other. An example would be, for example, a wiki path like
392             C</wiki/FooBarPage/rev/23/view>. This chain can be easily built with
393             these actions:
394            
395             sub wiki : PathPart('wiki') Chained('/') CaptureArgs(1) {
396             my ( $self, $c, $page_name ) = @_;
397             # load the page named $page_name and put the object
398             # into the stash
399             }
400            
401             sub rev : PathPart('rev') Chained('wiki') CaptureArgs(1) {
402             my ( $self, $c, $revision_id ) = @_;
403             # use the page object in the stash to get at its
404             # revision with number $revision_id
405             }
406            
407             sub view : PathPart Chained('rev') Args(0) {
408             my ( $self, $c ) = @_;
409             # display the revision in our stash. Another option
410             # would be to forward a compatible object to the action
411             # that displays the default wiki pages, unless we want
412             # a different interface here, for example restore
413             # functionality.
414             }
415            
416             It would now be possible to add other endpoints, for example C<restore>
417             to restore this specific revision as the current state.
418            
419             You don't have to put all the chained actions in one controller. The
420             specification of the parent through C<:Chained> also takes an absolute
421             action path as its argument. Just specify it with a leading C</>.
422            
423             If you want, for example, to have actions for the public paths
424             C</foo/12/edit> and C</foo/12>, just specify two actions with
425             C<:PathPart('foo')> and C<:Chained('/')>. The handler for the former
426             path needs a C<:CaptureArgs(1)> attribute and a endpoint with
427             C<:PathPart('edit')> and C<:Chained('foo')>. For the latter path give
428             the action just a C<:Args(1)> to mark it as endpoint. This sums up to
429             this debugging output:
430            
431             ...
432             [debug] Loaded Path Part actions:
433             .-----------------------+------------------------------.
434             | Path Spec | Private |
435             +-----------------------+------------------------------+
436             | /foo/* | /controller/foo_view |
437             | /foo/*/edit | /controller/foo_load (1) |
438             | | => /controller/edit |
439             '-----------------------+------------------------------'
440             ...
441            
442             Here's a more detailed specification of the attributes belonging to
443             C<:Chained>:
444            
445             =head2 Attributes
446            
447             =over 8
448            
449             =item PathPart
450            
451             Sets the name of this part of the chain. If it is specified without
452             arguments, it takes the name of the action as default. So basically
453             C<sub foo :PathPart> and C<sub foo :PathPart('foo')> are identical.
454             This can also contain slashes to bind to a deeper level. An action
455             with C<sub bar :PathPart('foo/bar') :Chained('/')> would bind to
456             C</foo/bar/...>. If you don't specify C<:PathPart> it has the same
457             effect as using C<:PathPart>, it would default to the action name.
458            
459             =item Chained
460            
461             Has to be specified for every child in the chain. Possible values are
462             absolute and relative private action paths, with the relatives pointing
463             to the current controller, or a single slash C</> to tell Catalyst that
464             this is the root of a chain. The attribute C<:Chained> without arguments
465             also defaults to the C</> behavior.
466            
467             Because you can specify an absolute path to the parent action, it
468             doesn't matter to Catalyst where that parent is located. So, if your
469             design requests it, you can redispatch a chain through any controller or
470             namespace you want.
471            
472             Another interesting possibility gives C<:Chained('.')>, which chains
473             itself to an action with the path of the current controller's namespace.
474             For example:
475            
476             # in MyApp::Controller::Foo
477             sub bar : Chained CaptureArgs(1) { ... }
478            
479             # in MyApp::Controller::Foo::Bar
480             sub baz : Chained('.') Args(1) { ... }
481            
482             This builds up a chain like C</bar/*/baz/*>. The specification of C<.>
483             as the argument to Chained here chains the C<baz> action to an action
484             with the path of the current controller namespace, namely
485             C</foo/bar>. That action chains directly to C</>, so the C</bar/*/baz/*>
486             chain comes out as the end product.
487            
488             =item CaptureArgs
489            
490             Must be specified for every part of the chain that is not an
491             endpoint. With this attribute Catalyst knows how many of the following
492             parts of the path (separated by C</>) this action wants to capture as
493             its arguments. If it doesn't expect any, just specify
494             C<:CaptureArgs(0)>. The captures get passed to the action's C<@_> right
495             after the context, but you can also find them as array references in
496             C<$c-E<gt>request-E<gt>captures-E<gt>[$level]>. The C<$level> is the
497             level of the action in the chain that captured the parts of the path.
498            
499             An action that is part of a chain (that is, one that has a C<:Chained>
500             attribute) but has no C<:CaptureArgs> attribute is treated by Catalyst
501             as a chain end.
502            
503             =item Args
504            
505             By default, endpoints receive the rest of the arguments in the path. You
506             can tell Catalyst through C<:Args> explicitly how many arguments your
507             endpoint expects, just like you can with C<:CaptureArgs>. Note that this
508             also affects whether this chain is invoked on a request. A chain with an
509             endpoint specifying one argument will only match if exactly one argument
510             exists in the path.
511            
512             You can specify an exact number of arguments like C<:Args(3)>, including
513             C<0>. If you just say C<:Args> without any arguments, it is the same as
514             leaving it out altogether: The chain is matched regardless of the number
515             of path parts after the endpoint.
516            
517             Just as with C<:CaptureArgs>, the arguments get passed to the action in
518             C<@_> after the context object. They can also be reached through
519             C<$c-E<gt>request-E<gt>arguments>.
520            
521             =back
522            
523             =head2 Auto actions, dispatching and forwarding
524            
525             Note that the list of C<auto> actions called depends on the private path
526             of the endpoint of the chain, not on the chained actions way. The
527             C<auto> actions will be run before the chain dispatching begins. In
528             every other aspect, C<auto> actions behave as documented.
529            
530             The C<forward>ing to other actions does just what you would expect. But if
531             you C<detach> out of a chain, the rest of the chain will not get called
532             after the C<detach>.
533            
534             =head1 AUTHOR
535            
536             Matt S Trout <mst@shadowcatsystems.co.uk>
537            
538             =head1 COPYRIGHT
539            
540             This program is free software, you can redistribute it and/or modify it under
541             the same terms as Perl itself.
542            
543             =cut
544              
545             1;
546