lib/Catalyst/DispatchType/Chained.pm

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