2 use MooseX::Role::Parameterized ();
4 class CatalystX::Declare::Keyword::Action {
8 use Perl6::Junction qw( any );
9 use Data::Dump qw( pp );
10 use MooseX::Types::Util qw( has_available_type_export );
11 use Moose::Util qw( add_method_modifier ensure_all_roles );
16 use constant STOP_PARSING => '__MXDECLARE_STOP_PARSING__';
17 use constant UNDER_VAR => '$CatalystX::Declare::SCOPE::UNDER';
18 use constant UNDER_STACK => '@CatalystX::Declare::SCOPE::UNDER_STACK';
20 use aliased 'CatalystX::Declare::Action::CatchValidationError';
21 use aliased 'CatalystX::Declare::Context::StringParsing';
22 use aliased 'MooseX::Method::Signatures::Meta::Method';
23 use aliased 'MooseX::MethodAttributes::Role::Meta::Method', 'AttributeRole';
24 use aliased 'MooseX::MethodAttributes::Role::Meta::Role', 'AttributeMetaRole';
27 method parse (Object $ctx, Str :$modifier?, Int :$skipped_declarator = 0) {
29 # somewhere to put the attributes
34 until (do { $ctx->skipspace; $ctx->peek_next_char } eq any qw( ; { } )) {
39 if ($ctx->peek_next_char eq ',') {
41 my $linestr = $ctx->get_linestr;
42 substr($linestr, $ctx->offset, 1) = '';
43 $ctx->set_linestr($linestr);
48 # next thing should be an option name
53 $ctx->skip_declarator;
54 $skipped_declarator++;
57 or croak "Expected option token, not " . substr($ctx->get_linestr, $ctx->offset);
59 # we need to be able to handle the rest
60 my $handler = $self->can("_handle_${option}_option")
61 or croak "Unknown action option: $option";
64 my $populator = $self->$handler($ctx, \%attributes);
66 if ($populator and $populator eq STOP_PARSING) {
68 return $ctx->shadow(sub (&) {
74 push @populators, $populator
75 if defined $populator;
78 croak "Need an action specification"
79 unless exists $attributes{Signature};
81 my $name = $attributes{Subname};
83 if ($attributes{Private}) {
84 $attributes{Signature} ||= '@';
87 my $method = Method->wrap(
88 signature => qq{($attributes{Signature})},
89 package_name => $ctx->get_curstash_name,
93 AttributeRole->meta->apply($method);
95 my $count = $self->_count_positional_arguments($method);
96 $attributes{CaptureArgs} = $count
102 unless ($attributes{Private}) {
103 $attributes{PathPart} ||= $name;
105 delete $attributes{CaptureArgs}
106 if exists $attributes{Args};
108 $attributes{CaptureArgs} = 0
109 unless exists $attributes{Args}
110 or exists $attributes{CaptureArgs};
113 if ($attributes{Private}) {
114 delete $attributes{ $_ }
115 for qw( Args CaptureArgs Chained Signature Private );
118 # inject a hashref for resolving runtime attribute values
119 $self->_inject_attributes($ctx, \%attributes);
121 # our declaration is followed by a block
122 if ($ctx->peek_next_char eq '{') {
123 $ctx->inject_if_block($ctx->scope_injector_call . $method->injectable_code);
126 # there is no block, so we insert one.
128 $ctx->inject_code_parts_here(
130 $ctx->scope_injector_call,
131 $method->injectable_code,
135 my $compile_attrs = sub {
136 my $attributes = shift;;
139 for my $attr (keys %$attributes) {
140 my $value = $attributes->{ $attr };
142 # the compiletime chained attr might contain the under global var name
143 next if $attr eq 'Chained' and $value eq UNDER_VAR;
146 map { sprintf '%s%s', $attr, defined($_) ? sprintf('(%s)', $_) : '' }
147 (ref($value) eq 'ARRAY')
155 return $ctx->shadow(sub {
160 # the runtime-resolved name
161 my $name = $attrs->{Subname};
163 # in case no hashref was specified
164 $body = $attrs and $attrs = {}
165 if ref $attrs eq 'CODE';
167 # default path part to runtime-resolved name
168 unless ($attrs->{Private}) {
170 $attrs->{PathPart} = $attrs->{Subname}
171 unless defined $attrs->{PathPart};
174 # in CXD we are explicit about chained values, an undefined
175 # value means we defaulted to the outer-scope under and there
177 delete $attrs->{Chained}
178 unless defined $attrs->{Chained};
180 # some attrs need to be single quoted in their stringified forms
181 defined($attrs->{ $_ }) and $attrs->{ $_ } = sprintf "'%s'", $attrs->{ $_ }
182 for qw( Chained PathPart );
184 # merge runtime and compiletime attrs
185 my %full_attrs = (%attributes, %$attrs);
186 my $compiled_attrs = $compile_attrs->(\%full_attrs);
188 my $real_method = $method->reify(
189 actual_body => $body,
190 attributes => $compiled_attrs,
197 add_method_modifier $class, $modifier, [$name, $real_method];
201 my $prepare_meta = sub {
204 $meta->add_method($name, $real_method);
205 $meta->register_method_attributes($meta->name->can($real_method->name), $compiled_attrs);
208 if ($ctx->stack->[-1] and $ctx->stack->[-1]->is_parameterized) {
209 my $real_meta = MooseX::Role::Parameterized->current_metaclass;
211 $real_meta->meta->make_mutable
212 if $real_meta->meta->is_immutable;
213 ensure_all_roles $real_meta->meta, AttributeMetaRole
214 if $real_meta->isa('Moose::Meta::Role');
216 $real_meta->$prepare_meta;
220 $class->meta->$prepare_meta;
226 method _handle_with_option (Object $ctx, HashRef $attrs) {
228 my @roles_with_args = ();
229 push @roles_with_args, @{ $ctx->strip_names_and_args };
231 # we need to fish for aliases here since we are still unclean
233 for my $role_with_arg(@roles_with_args) {
234 my ($role, $params) = @{$role_with_arg};
236 my ($first, @rest) = eval $params;
237 my %params = ref $first eq 'HASH' ? %$first : ($first, @rest);
238 for my $key (keys %params) {
239 $attrs->{$key} = [$params{$key}];
243 if (defined(my $alias = $self->_check_for_available_import($ctx, $role))) {
249 push @{ $attrs->{CatalystX_Declarative_ActionRoles} ||= [] }, @roles;
254 method _handle_isa_option (Object $ctx, HashRef $attrs) {
256 my $class = $ctx->strip_name
257 or croak "Expected bareword action class specification for action after isa";
259 if (defined(my $alias = $self->_check_for_available_import($ctx, $class))) {
263 $attrs->{CatalystX_Declarative_ActionClass} = $class;
268 method _check_for_available_import (Object $ctx, Str $name) {
270 if (my $code = $ctx->get_curstash_name->can($name)) {
277 method _handle_action_option (Object $ctx, HashRef $attrs) {
280 my $name = $self->_strip_actionpath($ctx, interpolate => 1)
281 or croak "Anonymous actions not yet supported";
286 # shortcut under base option is basically handled by the under handler
287 if (substr($ctx->get_linestr, $ctx->offset, 2) eq '<-') {
288 my $linestr = $ctx->get_linestr;
289 substr($linestr, $ctx->offset, 2) = '';
290 $ctx->set_linestr($linestr);
291 $populator = $self->_handle_under_option($ctx, $attrs);
295 my $proto = $ctx->strip_proto || '';
296 $proto = join(', ', 'Object $self: Object $ctx', $proto || ());
298 $attrs->{Subname} = $name;
299 $attrs->{Signature} = $proto;
300 $attrs->{Action} = [];
302 push @{ $attrs->{CatalystX_Declarative_ActionRoles} ||= [] }, CatchValidationError;
304 # default chained base to the global under var, to be resolved at runtime
305 $attrs->{Chained} ||= UNDER_VAR;
307 return unless $populator;
311 method _handle_final_option (Object $ctx, HashRef $attrs) {
313 return $self->_build_flag_populator($ctx, $attrs, 'final');
316 method _handle_is_option (Object $ctx, HashRef $attrs) {
318 my $what = $ctx->strip_name
319 or croak "Expected symbol token after is symbol, not " . substr($ctx->get_linestr, $ctx->offset);
321 return $self->_build_flag_populator($ctx, $attrs, $what);
324 method _build_flag_populator (Object $ctx, HashRef $attrs, Str $what) {
326 $attrs->{Private} = []
327 if $what eq 'private';
332 if ($what eq any qw( end endpoint final )) {
333 $attrs->{Args} = delete $attrs->{CaptureArgs};
335 elsif ($what eq 'private') {
336 $attrs->{Private} = [];
341 method _handle_under_option (Object $ctx, HashRef $attrs) {
343 my $target = $self->_strip_actionpath($ctx, interpolate => 1);
346 if ($ctx->peek_next_char eq '{' and $self->identifier eq 'under') {
347 $ctx->inject_if_block(
348 $ctx->scope_injector_call .
349 sprintf ';local %s = %s;',
356 $attrs->{Chained} = $target;
363 method _handle_chains_option (Object $ctx, HashRef $attrs) {
366 $ctx->strip_name eq 'to'
367 or croak "Expected to token after chains symbol, not " . substr($ctx->get_linestr, $ctx->offset);
369 return $self->_handle_under_option($ctx, $attrs);
372 method _handle_as_option (Object $ctx, HashRef $attrs) {
376 my $path = $self->_strip_actionpath($ctx, interpolate => 1);
377 $attrs->{PathPart} = $path;
382 method _count_positional_arguments (Object $method) {
383 my $signature = $method->parsed_signature;
385 if ($signature->has_positional_params) {
386 my $count = @{ scalar($signature->positional_params) };
388 if ($count and ($signature->positional_params)[-1]->sigil eq '@') {
398 method _inject_attributes (Object $ctx, HashRef $attrs) {
400 # attrs that need to be runtime-resolved
401 my @inject = qw( Chained PathPart Subname );
403 # turn specific attributes into a hashref
404 my $code = sprintf ' +{ %s }, sub ', # the ', sub ' turns method +{ ... } { ... } into
405 join ', ', # method +{ ... }, sub { ... }
407 map { defined( $_->[1] ) ? $_ : [$_->[0], 'undef'] }
408 map { [pp($_), $attrs->{ $_ }] }
409 grep { defined $attrs->{ $_ } }
412 # inject the hashref code before the action body
413 $ctx->inject_code_parts_here($code);
414 $ctx->inc_offset(length $code);
417 method _strip_actionpath (Object $ctx, :$interpolate?) {
420 my $linestr = $ctx->get_linestr;
421 my $rest = substr($linestr, $ctx->offset);
422 my $interp = sub { $interpolate ? "'$_[0]'" : $_[0] };
424 # find simple barewords
425 if ($rest =~ /^ ( [_a-z] [_a-z0-9]* ) \b/ix) {
426 substr($linestr, $ctx->offset, length($1)) = '';
427 $ctx->set_linestr($linestr);
428 return $interp->($1);
431 # allow single quoted more complex barewords
432 elsif ($rest =~ /^ ' ( (?:[.:;,_a-z0-9]|\/)* ) ' /ix) {
433 substr($linestr, $ctx->offset, length($1) + 2) = '';
434 $ctx->set_linestr($linestr);
435 return $interp->($1);
438 # double quoted strings and variables
439 elsif ($interpolate and my $str = $ctx->get_string) {
443 # not suitable as action path
445 croak "Invalid syntax for action path: $rest";
449 # down here because it requires the parse method
450 with 'MooseX::Declare::Syntax::KeywordHandling';
452 around context_traits { $self->$orig, StringParsing }
459 CatalystX::Declare::Keyword::Action - Declare Catalyst Actions
463 use CatalystX::Declare;
465 controller MyApp::Web::Controller::Example {
467 # chain base action with path part setting of ''
468 # body-less actions don't do anything by themselves
469 action base as '' under '/';
471 # simple end-point action
472 action controller_class is final under base {
473 $ctx->response->body( 'controller: ' . ref $self );
476 # chain part actions can have arguments
477 action str (Str $string) under base {
479 $ctx->stash(chars => [split //, $string]);
482 # and end point actions too, of course
483 action uc_chars (Int $count) under str is final {
485 my $chars = $ctx->stash->{chars};
490 # you can use a shortcut for multiple actions with
494 # this is an endpoint after base
495 action normal is final;
497 # the final keyword can be used to be more
498 # visually explicit about end-points
499 final action some_action { ... }
501 # type dispatching works
502 final action with_str (Str $x) as via_type;
503 final action with_int (Int $x) as via_type;
506 # of course you can also chain to external actions
507 final action some_end under '/some/controller/some/action';
512 This handler class provides the user with C<action>, C<final> and C<under>
513 keywords. There are multiple ways to define actions to allow for greater
514 freedom of expression. While the parts of the action declaration itself do
515 not care about their order, their syntax is rather strict.
517 You can choose to separate syntax elements via C<,> if you think it is more
518 readable. The action declaration
520 action foo is final under base;
522 is parsed in exactly the same way if you write it as
524 action foo, is final, under base;
526 =head2 Basic Action Declaration
528 The simplest possible declaration is
532 This would define a chain-part action chained to nothing with the name C<foo>
533 and no arguments. Since it isn't followed by a block, the body of the action
536 You will automatically be provided with two variables: C<$self> is, as you
537 might expect, your controller instance. C<$ctx> will be the Catalyst context
538 object. Thus, the following code would stash the value returned by the
542 $ctx->stash(item => $self->get_item);
545 =head2 Why $ctx instead of $c
547 Some might ask why the context object is called C<$ctx> instead of the usual
548 C<$c>. The reason is simple: It's an opinionated best practice, since C<$ctx>
551 =head2 Setting a Path Part
553 As usual with Catalyst actions, the path part (the public name of this part of
554 the URI, if you're not familiar with the term yet) will default to the name of
555 the action itself (or more correctly: to whatever Catalyst defaults).
557 To change that, use the C<as> option:
560 action base as ''; # <empty>
561 action something as 'foo/bar'; # foo/bar
562 action barely as bareword; # bareword
565 =head2 Chaining Actions
567 Currently, L<CatalystX::Declare> is completely based on the concept of
568 L<chained actions|Catalyst::DispatchType::Chained>. Every action you declare is
569 chained or private. You can specify the action you want to chain to with the
572 action foo; # chained to nothing
573 action foo under '/'; # also chained to /
574 action foo under bar; # chained to the local bar action
575 action foo under '/bar/baz'; # chained to baz in /bar
577 C<under> is also provided as a grouping keyword. Every action inside the block
578 will be chained to the specified action:
585 You can also use the C<under> keyword for a single action. This is useful if
586 you want to highlight a single action with a significant diversion from what
589 action base under '/';
591 under '/the/sink' is final action foo;
593 final action bar under base;
595 final action baz under base;
597 Instead of the C<under> option declaration, you can also use a more english
598 variant named C<chains to>. While C<under> might be nice and concise, some
599 people might prefer this if they confuse C<under> with the specification of
600 a public path part. The argument to C<chains to> is the same as to C<under>:
602 action foo chains to bar;
603 action foo under bar;
605 By default all actions are chain-parts, not end-points. If you want an action
606 to be picked up as end-point and available via a public path, you have to say
607 so explicitely by using the C<is final> option:
609 action base under '/';
610 action foo under base is final; # /base/foo
612 You can also drop the C<is> part of the C<is final> option if you want:
614 under base, final action foo { ... }
616 You can make end-points more visually distinct by using the C<final> keyword
617 instead of the option:
619 action base under '/';
620 final action foo under base; # /base/foo
622 And of course, the C<final>, C<under> and C<action> keywords can be used in
623 combination whenever needed:
625 action base as '' under '/';
629 final action list; # /list
635 final action view; # /list/load/view
636 final action edit; # /list/load/edit
640 There is also one shorthand alternative for declaring chain targets. You can
641 specify an action after a C<E<lt>-> following the action name:
643 action base under '/';
644 final action foo <- base; # /base/foo
648 You can use signatures like you are use to from L<MooseX::Method::Signatures>
649 to declare action parameters. The number of positinoal arguments will be used
650 during dispatching as well as their types.
652 The signature follows the action name:
655 final action foo (Int $year, Int $month, Int $day);
657 If you are using the shorthand definition, the signature follows the chain
661 final action foo <- base ($x) under '/' { ... }
663 Parameters may be specified on chain-parts and end-points:
666 action base (Str $lang) under '/';
667 final action page (Int $page_num) under base;
669 Named parameters will be populated with the values in the query parameters:
672 final action view (Int $id, Int :$page = 1) under '/';
674 If you specify a query parameter to be an C<ArrayRef>, it will be specially
675 handled. For one, it will match even if there is no such value in the
676 parameters. Second, it will always be wrapped as an array reference.
678 Your end-points can also take an unspecified amount of arguments by specifying
679 an array as a variable:
681 # /find/some/deep/path/spec
682 final action find (@path) under '/';
686 The signatures are now validated during dispatching-time, and an action with
687 a non-matching signature (number of positional arguments and their types) will
688 not be dispatched to. This means that
690 action base under '/' as '';
694 final as double, action double_integer (Int $x) {
695 $ctx->response->body( $x * 2 );
698 final as double, action double_string (Str $x) {
699 $ctx->response->body( $x x 2 );
703 will return C<foofoo> when called as C</double/foo> and C<46> when called as
706 =head2 Actions and Method Modifiers
708 Method modifiers can not only be applied to methods, but also to actions. There
709 is no way yet to override the attributes of an already established action via
710 modifiers. However, you can modify the method underlying the action.
712 The following code is an example role modifying the consuming controller's
715 use CatalystX::Declare;
717 controller_role MyApp::Web::ControllerRole::RichBase {
719 before base (Object $ctx) {
720 $ctx->stash(something => $ctx->model('Item'));
724 Note that you have to specify the C<$ctx> argument yourself, since you are
725 modifying a method, not an action.
727 Any controller having a C<base> action (or method, for this purpose), can now
728 consume the C<RichBase> role declared above:
730 use CatalystX::Declare;
732 controller MyApp::Web::Controller::Foo
733 with MyApp::Web::Controller::RichBase {
735 action base as '' under '/';
737 action show, final under base {
738 $ctx->response->body(
739 $ctx->stash->{something}->render,
744 =head2 Action Classes
746 B<This option is even more experimental>
748 You might want to create an action with a different class than the usual
749 L<Catalyst::Action>. A usual suspect here is L<Catalyst::Action::RenderView>.
750 You can use the C<isa> option (did I mention it's experimental?) to specify
753 controller MyApp::Web::Controller::Root {
755 $CLASS->config(namespace => '');
757 action end isa RenderView;
760 The loaded class will be L<Moose>ified, so we are able to apply essential
763 =head2 Private Actions
765 B<This option is a bit less, but still pretty experimental>
767 You can declare private actions with the C<is private> trait:
769 action end is private isa RenderView;
775 =item L<MooseX::Declare::Syntax::KeywordHandling>
781 These methods are implementation details. Unless you are extending or
782 developing L<CatalystX::Declare>, you should not be concerned with them.
786 Object->parse (Object $ctx, Str :$modifier?, Int :$skipped_declarator = 0)
788 A hook that will be invoked by L<MooseX::Declare> when this instance is called
789 to handle syntax. It will parse the action declaration, prepare attributes and
790 add the actions to the controller.
796 =item L<CatalystX::Declare>
798 =item L<CatalystX::Declare::Keyword::Controller>
800 =item L<MooseX::Method::Signatures>
806 See L<CatalystX::Declare/AUTHOR> for author information.
810 This program is free software; you can redistribute it and/or modify it under
811 the same terms as perl itself.