lib/Catalyst/DispatchType/Chained.pm

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