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