lib/Catalyst/DispatchType/Chained.pm

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