lib/Catalyst/DispatchType/Chained.pm

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