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