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