lib/Catalyst/DispatchType/Chained.pm

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