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