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     my $chained_to = $chained_attr[0];
 226
 227     Catalyst::Exception->throw(
 228       "Actions cannot chain to themselves registering /${action}"
 229     ) if ($chained_to eq '/' . $action);
 230
 231     my $children = ($self->{children_of}->{ $chained_to } ||= {});
 232
 233     my @path_part = @{ $action->attributes->{PathPart} || [] };
 234
 235     my $part = $action->name;
 236
 237     if (@path_part == 1 && defined $path_part[0]) {
 238         $part = $path_part[0];
 239     } elsif (@path_part > 1) {
 240         Catalyst::Exception->throw(
 241           "Multiple PathPart attributes not supported registering ${action}"
 242         );
 243     }
 244
 245     if ($part =~ m(^/)) {
 246         Catalyst::Exception->throw(
 247           "Absolute parameters to PathPart not allowed registering ${action}"
 248         );
 249     }
 250
 251     $action->attributes->{PartPath} = [ $part ];
 252
 253     unshift(@{ $children->{$part} ||= [] }, $action);
 254
 255     ($self->{actions} ||= {})->{'/'.$action->reverse} = $action;
 256
 257     unless ($action->attributes->{CaptureArgs}) {
 258         unshift(@{ $self->{endpoints} ||= [] }, $action);
 259     }
 260
 261     return 1;
 262 }
 263
 264 =head2 $self->uri_for_action($action, $captures)
 265
 266 Get the URI part for the action, using C<$captures> to fill
 267 the capturing parts.
 268
 269 =cut
 270
 271 sub uri_for_action {
 272     my ( $self, $action, $captures ) = @_;
 273
 274     return undef unless ($action->attributes->{Chained}
 275                            && !$action->attributes->{CaptureArgs});
 276
 277     my @parts = ();
 278     my @captures = @$captures;
 279     my $parent = "DUMMY";
 280     my $curr = $action;
 281     while ($curr) {
 282         if (my $cap = $curr->attributes->{CaptureArgs}) {
 283             return undef unless @captures >= $cap->[0]; # not enough captures
 284             if ($cap->[0]) {
 285                 unshift(@parts, splice(@captures, -$cap->[0]));
 286             }
 287         }
 288         if (my $pp = $curr->attributes->{PartPath}) {
 289             unshift(@parts, $pp->[0])
 290                 if (defined($pp->[0]) && length($pp->[0]));
 291         }
 292         $parent = $curr->attributes->{Chained}->[0];
 293         $curr = $self->{actions}{$parent};
 294     }
 295
 296     return undef unless $parent eq '/'; # fail for dangling action
 297
 298     return undef if @captures; # fail for too many captures
 299
 300     return join('/', '', @parts);
 301
 302 }
 303
 304 =head2 $c->expand_action($action)
 305
 306 Return a list of actions that represents a chained action. See
 307 L<Catalyst::Dispatcher> for more info. You probably want to
 308 use the expand_action it provides rather than this directly.
 309
 310 =cut
 311
 312 sub expand_action {
 313     my ($self, $action) = @_;
 314
 315     return unless $action->attributes && $action->attributes->{Chained};
 316
 317     my @chain;
 318     my $curr = $action;
 319
 320     while ($curr) {
 321         push @chain, $curr;
 322         my $parent = $curr->attributes->{Chained}->[0];
 323         $curr = $self->{'actions'}{$parent};
 324     }
 325
 326     return Catalyst::ActionChain->from_chain([reverse @chain]);
 327 }
 328
 329 =head1 USAGE
 330
 331 =head2 Introduction
 332
 333 The C<Chained> attribute allows you to chain public path parts together
 334 by their private names. A chain part's path can be specified with
 335 C<PathPart> and can be declared to expect an arbitrary number of
 336 arguments. The endpoint of the chain specifies how many arguments it
 337 gets through the C<Args> attribute. C<:Args(0)> would be none at all,
 338 C<:Args> without an integer would be unlimited. The path parts that
 339 aren't endpoints are using C<CaptureArgs> to specify how many parameters
 340 they expect to receive. As an example setup:
 341
 342   package MyApp::Controller::Greeting;
 343   use base qw/ Catalyst::Controller /;
 344
 345   #   this is the beginning of our chain
 346   sub hello : PathPart('hello') Chained('/') CaptureArgs(1) {
 347       my ( $self, $c, $integer ) = @_;
 348       $c->stash->{ message } = "Hello ";
 349       $c->stash->{ arg_sum } = $integer;
 350   }
 351
 352   #   this is our endpoint, because it has no :CaptureArgs
 353   sub world : PathPart('world') Chained('hello') Args(1) {
 354       my ( $self, $c, $integer ) = @_;
 355       $c->stash->{ message } .= "World!";
 356       $c->stash->{ arg_sum } += $integer;
 357
 358       $c->response->body( join "<br/>\n" =>
 359           $c->stash->{ message }, $c->stash->{ arg_sum } );
 360   }
 361
 362 The debug output provides a separate table for chained actions, showing
 363 the whole chain as it would match and the actions it contains. Here's an
 364 example of the startup output with our actions above:
 365
 366   ...
 367   [debug] Loaded Path Part actions:
 368   .-----------------------+------------------------------.
 369   | Path Spec             | Private                      |
 370   +-----------------------+------------------------------+
 371   | /hello/*/world/*      | /greeting/hello (1)          |
 372   |                       | => /greeting/world           |
 373   '-----------------------+------------------------------'
 374   ...
 375
 376 As you can see, Catalyst only deals with chains as whole paths and
 377 builds one for each endpoint, which are the actions with C<:Chained> but
 378 without C<:CaptureArgs>.
 379
 380 Let's assume this application gets a request at the path
 381 C</hello/23/world/12>. What happens then? First, Catalyst will dispatch
 382 to the C<hello> action and pass the value C<23> as an argument to it
 383 after the context. It does so because we have previously used
 384 C<:CaptureArgs(1)> to declare that it has one path part after itself as
 385 its argument. We told Catalyst that this is the beginning of the chain
 386 by specifying C<:Chained('/')>. Also note that instead of saying
 387 C<:PathPart('hello')> we could also just have said C<:PathPart>, as it
 388 defaults to the name of the action.
 389
 390 After C<hello> has run, Catalyst goes on to dispatch to the C<world>
 391 action. This is the last action to be called: Catalyst knows this is an
 392 endpoint because we did not specify a C<:CaptureArgs>
 393 attribute. Nevertheless we specify that this action expects an argument,
 394 but at this point we're using C<:Args(1)> to do that. We could also have
 395 said C<:Args> or left it out altogether, which would mean this action
 396 would get all arguments that are there. This action's C<:Chained>
 397 attribute says C<hello> and tells Catalyst that the C<hello> action in
 398 the current controller is its parent.
 399
 400 With this we have built a chain consisting of two public path parts.
 401 C<hello> captures one part of the path as its argument, and also
 402 specifies the path root as its parent. So this part is
 403 C</hello/$arg>. The next part is the endpoint C<world>, expecting one
 404 argument. It sums up to the path part C<world/$arg>. This leads to a
 405 complete chain of C</hello/$arg/world/$arg> which is matched against the
 406 requested paths.
 407
 408 This example application would, if run and called by e.g.
 409 C</hello/23/world/12>, set the stash value C<message> to "Hello" and the
 410 value C<arg_sum> to "23". The C<world> action would then append "World!"
 411 to C<message> and add C<12> to the stash's C<arg_sum> value.  For the
 412 sake of simplicity no view is shown. Instead we just put the values of
 413 the stash into our body. So the output would look like:
 414
 415   Hello World!
 416   35
 417
 418 And our test server would have given us this debugging output for the
 419 request:
 420
 421   ...
 422   [debug] "GET" request for "hello/23/world/12" from "127.0.0.1"
 423   [debug] Path is "/greeting/world"
 424   [debug] Arguments are "12"
 425   [info] Request took 0.164113s (6.093/s)
 426   .------------------------------------------+-----------.
 427   | Action                                   | Time      |
 428   +------------------------------------------+-----------+
 429   | /greeting/hello                          | 0.000029s |
 430   | /greeting/world                          | 0.000024s |
 431   '------------------------------------------+-----------'
 432   ...
 433
 434 What would be common uses of this dispatch technique? It gives the
 435 possibility to split up logic that contains steps that each depend on
 436 each other. An example would be, for example, a wiki path like
 437 C</wiki/FooBarPage/rev/23/view>. This chain can be easily built with
 438 these actions:
 439
 440   sub wiki : PathPart('wiki') Chained('/') CaptureArgs(1) {
 441       my ( $self, $c, $page_name ) = @_;
 442       #  load the page named $page_name and put the object
 443       #  into the stash
 444   }
 445
 446   sub rev : PathPart('rev') Chained('wiki') CaptureArgs(1) {
 447       my ( $self, $c, $revision_id ) = @_;
 448       #  use the page object in the stash to get at its
 449       #  revision with number $revision_id
 450   }
 451
 452   sub view : PathPart Chained('rev') Args(0) {
 453       my ( $self, $c ) = @_;
 454       #  display the revision in our stash. Another option
 455       #  would be to forward a compatible object to the action
 456       #  that displays the default wiki pages, unless we want
 457       #  a different interface here, for example restore
 458       #  functionality.
 459   }
 460
 461 It would now be possible to add other endpoints, for example C<restore>
 462 to restore this specific revision as the current state.
 463
 464 You don't have to put all the chained actions in one controller. The
 465 specification of the parent through C<:Chained> also takes an absolute
 466 action path as its argument. Just specify it with a leading C</>.
 467
 468 If you want, for example, to have actions for the public paths
 469 C</foo/12/edit> and C</foo/12>, just specify two actions with
 470 C<:PathPart('foo')> and C<:Chained('/')>. The handler for the former
 471 path needs a C<:CaptureArgs(1)> attribute and a endpoint with
 472 C<:PathPart('edit')> and C<:Chained('foo')>. For the latter path give
 473 the action just a C<:Args(1)> to mark it as endpoint. This sums up to
 474 this debugging output:
 475
 476   ...
 477   [debug] Loaded Path Part actions:
 478   .-----------------------+------------------------------.
 479   | Path Spec             | Private                      |
 480   +-----------------------+------------------------------+
 481   | /foo/*                | /controller/foo_view         |
 482   | /foo/*/edit           | /controller/foo_load (1)     |
 483   |                       | => /controller/edit          |
 484   '-----------------------+------------------------------'
 485   ...
 486
 487 Here's a more detailed specification of the attributes belonging to
 488 C<:Chained>:
 489
 490 =head2 Attributes
 491
 492 =over 8
 493
 494 =item PathPart
 495
 496 Sets the name of this part of the chain. If it is specified without
 497 arguments, it takes the name of the action as default. So basically
 498 C<sub foo :PathPart> and C<sub foo :PathPart('foo')> are identical.
 499 This can also contain slashes to bind to a deeper level. An action
 500 with C<sub bar :PathPart('foo/bar') :Chained('/')> would bind to
 501 C</foo/bar/...>. If you don't specify C<:PathPart> it has the same
 502 effect as using C<:PathPart>, it would default to the action name.
 503
 504 =item PathPrefix
 505
 506 Sets PathPart to the path_prefix of the current controller.
 507
 508 =item Chained
 509
 510 Has to be specified for every child in the chain. Possible values are
 511 absolute and relative private action paths or a single slash C</> to
 512 tell Catalyst that this is the root of a chain. The attribute
 513 C<:Chained> without arguments also defaults to the C</> behavior.
 514 Relative action paths may use C<../> to refer to actions in parent
 515 controllers.
 516
 517 Because you can specify an absolute path to the parent action, it
 518 doesn't matter to Catalyst where that parent is located. So, if your
 519 design requests it, you can redispatch a chain through any controller or
 520 namespace you want.
 521
 522 Another interesting possibility gives C<:Chained('.')>, which chains
 523 itself to an action with the path of the current controller's namespace.
 524 For example:
 525
 526   #   in MyApp::Controller::Foo
 527   sub bar : Chained CaptureArgs(1) { ... }
 528
 529   #   in MyApp::Controller::Foo::Bar
 530   sub baz : Chained('.') Args(1) { ... }
 531
 532 This builds up a chain like C</bar/*/baz/*>. The specification of C<.>
 533 as the argument to Chained here chains the C<baz> action to an action
 534 with the path of the current controller namespace, namely
 535 C</foo/bar>. That action chains directly to C</>, so the C</bar/*/baz/*>
 536 chain comes out as the end product.
 537
 538 =item ChainedParent
 539
 540 Chains an action to another action with the same name in the parent
 541 controller. For Example:
 542
 543   # in MyApp::Controller::Foo
 544   sub bar : Chained CaptureArgs(1) { ... }
 545
 546   # in MyApp::Controller::Foo::Moo
 547   sub bar : ChainedParent Args(1) { ... }
 548
 549 This builds a chain like C</bar/*/bar/*>.
 550
 551 =item CaptureArgs
 552
 553 Must be specified for every part of the chain that is not an
 554 endpoint. With this attribute Catalyst knows how many of the following
 555 parts of the path (separated by C</>) this action wants to capture as
 556 its arguments. If it doesn't expect any, just specify
 557 C<:CaptureArgs(0)>.  The captures get passed to the action's C<@_> right
 558 after the context, but you can also find them as array references in
 559 C<$c-E<gt>request-E<gt>captures-E<gt>[$level]>. The C<$level> is the
 560 level of the action in the chain that captured the parts of the path.
 561
 562 An action that is part of a chain (that is, one that has a C<:Chained>
 563 attribute) but has no C<:CaptureArgs> attribute is treated by Catalyst
 564 as a chain end.
 565
 566 =item Args
 567
 568 By default, endpoints receive the rest of the arguments in the path. You
 569 can tell Catalyst through C<:Args> explicitly how many arguments your
 570 endpoint expects, just like you can with C<:CaptureArgs>. Note that this
 571 also affects whether this chain is invoked on a request. A chain with an
 572 endpoint specifying one argument will only match if exactly one argument
 573 exists in the path.
 574
 575 You can specify an exact number of arguments like C<:Args(3)>, including
 576 C<0>. If you just say C<:Args> without any arguments, it is the same as
 577 leaving it out altogether: The chain is matched regardless of the number
 578 of path parts after the endpoint.
 579
 580 Just as with C<:CaptureArgs>, the arguments get passed to the action in
 581 C<@_> after the context object. They can also be reached through
 582 C<$c-E<gt>request-E<gt>arguments>.
 583
 584 =back
 585
 586 =head2 Auto actions, dispatching and forwarding
 587
 588 Note that the list of C<auto> actions called depends on the private path
 589 of the endpoint of the chain, not on the chained actions way. The
 590 C<auto> actions will be run before the chain dispatching begins. In
 591 every other aspect, C<auto> actions behave as documented.
 592
 593 The C<forward>ing to other actions does just what you would expect. But if
 594 you C<detach> out of a chain, the rest of the chain will not get called
 595 after the C<detach>.
 596
 597 =head1 AUTHORS
 598
 599 Catalyst Contributors, see Catalyst.pm
 600
 601 =head1 COPYRIGHT
 602
 603 This program is free software, you can redistribute it and/or modify it under
 604 the same terms as Perl itself.
 605
 606 =cut
 607
 608 1;