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