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