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 $role = $ctx->strip_name
229 or croak "Expected bareword role specification for action after with";
231 # we need to fish for aliases here since we are still unclean
232 if (defined(my $alias = $self->_check_for_available_import($ctx, $role))) {
236 push @{ $attrs->{CatalystX_Declarative_ActionRoles} ||= [] }, $role;
241 method _handle_isa_option (Object $ctx, HashRef $attrs) {
243 my $class = $ctx->strip_name
244 or croak "Expected bareword action class specification for action after isa";
246 if (defined(my $alias = $self->_check_for_available_import($ctx, $class))) {
250 $attrs->{CatalystX_Declarative_ActionClass} = $class;
255 method _check_for_available_import (Object $ctx, Str $name) {
257 if (my $code = $ctx->get_curstash_name->can($name)) {
264 method _handle_action_option (Object $ctx, HashRef $attrs) {
267 my $name = $self->_strip_actionpath($ctx, interpolate => 1)
268 or croak "Anonymous actions not yet supported";
273 # shortcut under base option is basically handled by the under handler
274 if (substr($ctx->get_linestr, $ctx->offset, 2) eq '<-') {
275 my $linestr = $ctx->get_linestr;
276 substr($linestr, $ctx->offset, 2) = '';
277 $ctx->set_linestr($linestr);
278 $populator = $self->_handle_under_option($ctx, $attrs);
282 my $proto = $ctx->strip_proto || '';
283 $proto = join(', ', 'Object $self: Object $ctx', $proto || ());
285 $attrs->{Subname} = $name;
286 $attrs->{Signature} = $proto;
287 $attrs->{Action} = [];
289 push @{ $attrs->{CatalystX_Declarative_ActionRoles} ||= [] }, CatchValidationError;
291 # default chained base to the global under var, to be resolved at runtime
292 $attrs->{Chained} ||= UNDER_VAR;
294 return unless $populator;
298 method _handle_final_option (Object $ctx, HashRef $attrs) {
300 return $self->_build_flag_populator($ctx, $attrs, 'final');
303 method _handle_is_option (Object $ctx, HashRef $attrs) {
305 my $what = $ctx->strip_name
306 or croak "Expected symbol token after is symbol, not " . substr($ctx->get_linestr, $ctx->offset);
308 return $self->_build_flag_populator($ctx, $attrs, $what);
311 method _build_flag_populator (Object $ctx, HashRef $attrs, Str $what) {
313 $attrs->{Private} = []
314 if $what eq 'private';
319 if ($what eq any qw( end endpoint final )) {
320 $attrs->{Args} = delete $attrs->{CaptureArgs};
322 elsif ($what eq 'private') {
323 $attrs->{Private} = [];
328 method _handle_under_option (Object $ctx, HashRef $attrs) {
330 my $target = $self->_strip_actionpath($ctx, interpolate => 1);
333 if ($ctx->peek_next_char eq '{' and $self->identifier eq 'under') {
334 $ctx->inject_if_block(
335 $ctx->scope_injector_call .
336 sprintf ';local %s = %s;',
343 $attrs->{Chained} = $target;
350 method _handle_chains_option (Object $ctx, HashRef $attrs) {
353 $ctx->strip_name eq 'to'
354 or croak "Expected to token after chains symbol, not " . substr($ctx->get_linestr, $ctx->offset);
356 return $self->_handle_under_option($ctx, $attrs);
359 method _handle_as_option (Object $ctx, HashRef $attrs) {
363 my $path = $self->_strip_actionpath($ctx, interpolate => 1);
364 $attrs->{PathPart} = $path;
369 method _count_positional_arguments (Object $method) {
370 my $signature = $method->parsed_signature;
372 if ($signature->has_positional_params) {
373 my $count = @{ scalar($signature->positional_params) };
375 if ($count and ($signature->positional_params)[-1]->sigil eq '@') {
385 method _inject_attributes (Object $ctx, HashRef $attrs) {
387 # attrs that need to be runtime-resolved
388 my @inject = qw( Chained PathPart Subname );
390 # turn specific attributes into a hashref
391 my $code = sprintf ' +{ %s }, sub ', # the ', sub ' turns method +{ ... } { ... } into
392 join ', ', # method +{ ... }, sub { ... }
394 map { defined( $_->[1] ) ? $_ : [$_->[0], 'undef'] }
395 map { [pp($_), $attrs->{ $_ }] }
396 grep { defined $attrs->{ $_ } }
399 # inject the hashref code before the action body
400 $ctx->inject_code_parts_here($code);
401 $ctx->inc_offset(length $code);
404 method _strip_actionpath (Object $ctx, :$interpolate?) {
407 my $linestr = $ctx->get_linestr;
408 my $rest = substr($linestr, $ctx->offset);
409 my $interp = sub { $interpolate ? "'$_[0]'" : $_[0] };
411 # find simple barewords
412 if ($rest =~ /^ ( [_a-z] [_a-z0-9]* ) \b/ix) {
413 substr($linestr, $ctx->offset, length($1)) = '';
414 $ctx->set_linestr($linestr);
415 return $interp->($1);
418 # allow single quoted more complex barewords
419 elsif ($rest =~ /^ ' ( (?:[.:;,_a-z0-9]|\/)* ) ' /ix) {
420 substr($linestr, $ctx->offset, length($1) + 2) = '';
421 $ctx->set_linestr($linestr);
422 return $interp->($1);
425 # double quoted strings and variables
426 elsif ($interpolate and my $str = $ctx->get_string) {
430 # not suitable as action path
432 croak "Invalid syntax for action path: $rest";
436 # down here because it requires the parse method
437 with 'MooseX::Declare::Syntax::KeywordHandling';
439 around context_traits { $self->$orig, StringParsing }
446 CatalystX::Declare::Keyword::Action - Declare Catalyst Actions
450 use CatalystX::Declare;
452 controller MyApp::Web::Controller::Example {
454 # chain base action with path part setting of ''
455 # body-less actions don't do anything by themselves
456 action base as '' under '/';
458 # simple end-point action
459 action controller_class is final under base {
460 $ctx->response->body( 'controller: ' . ref $self );
463 # chain part actions can have arguments
464 action str (Str $string) under base {
466 $ctx->stash(chars => [split //, $string]);
469 # and end point actions too, of course
470 action uc_chars (Int $count) under str is final {
472 my $chars = $ctx->stash->{chars};
477 # you can use a shortcut for multiple actions with
481 # this is an endpoint after base
482 action normal is final;
484 # the final keyword can be used to be more
485 # visually explicit about end-points
486 final action some_action { ... }
488 # type dispatching works
489 final action with_str (Str $x) as via_type;
490 final action with_int (Int $x) as via_type;
493 # of course you can also chain to external actions
494 final action some_end under '/some/controller/some/action';
499 This handler class provides the user with C<action>, C<final> and C<under>
500 keywords. There are multiple ways to define actions to allow for greater
501 freedom of expression. While the parts of the action declaration itself do
502 not care about their order, their syntax is rather strict.
504 You can choose to separate syntax elements via C<,> if you think it is more
505 readable. The action declaration
507 action foo is final under base;
509 is parsed in exactly the same way if you write it as
511 action foo, is final, under base;
513 =head2 Basic Action Declaration
515 The simplest possible declaration is
519 This would define a chain-part action chained to nothing with the name C<foo>
520 and no arguments. Since it isn't followed by a block, the body of the action
523 You will automatically be provided with two variables: C<$self> is, as you
524 might expect, your controller instance. C<$ctx> will be the Catalyst context
525 object. Thus, the following code would stash the value returned by the
529 $ctx->stash(item => $self->get_item);
532 =head2 Why $ctx instead of $c
534 Some might ask why the context object is called C<$ctx> instead of the usual
535 C<$c>. The reason is simple: It's an opinionated best practice, since C<$ctx>
538 =head2 Setting a Path Part
540 As usual with Catalyst actions, the path part (the public name of this part of
541 the URI, if you're not familiar with the term yet) will default to the name of
542 the action itself (or more correctly: to whatever Catalyst defaults).
544 To change that, use the C<as> option:
547 action base as ''; # <empty>
548 action something as 'foo/bar'; # foo/bar
549 action barely as bareword; # bareword
552 =head2 Chaining Actions
554 Currently, L<CatalystX::Declare> is completely based on the concept of
555 L<chained actions|Catalyst::DispatchType::Chained>. Every action you declare is
556 chained or private. You can specify the action you want to chain to with the
559 action foo; # chained to nothing
560 action foo under '/'; # also chained to /
561 action foo under bar; # chained to the local bar action
562 action foo under '/bar/baz'; # chained to baz in /bar
564 C<under> is also provided as a grouping keyword. Every action inside the block
565 will be chained to the specified action:
572 You can also use the C<under> keyword for a single action. This is useful if
573 you want to highlight a single action with a significant diversion from what
576 action base under '/';
578 under '/the/sink' is final action foo;
580 final action bar under base;
582 final action baz under base;
584 Instead of the C<under> option declaration, you can also use a more english
585 variant named C<chains to>. While C<under> might be nice and concise, some
586 people might prefer this if they confuse C<under> with the specification of
587 a public path part. The argument to C<chains to> is the same as to C<under>:
589 action foo chains to bar;
590 action foo under bar;
592 By default all actions are chain-parts, not end-points. If you want an action
593 to be picked up as end-point and available via a public path, you have to say
594 so explicitely by using the C<is final> option:
596 action base under '/';
597 action foo under base is final; # /base/foo
599 You can also drop the C<is> part of the C<is final> option if you want:
601 under base, final action foo { ... }
603 You can make end-points more visually distinct by using the C<final> keyword
604 instead of the option:
606 action base under '/';
607 final action foo under base; # /base/foo
609 And of course, the C<final>, C<under> and C<action> keywords can be used in
610 combination whenever needed:
612 action base as '' under '/';
616 final action list; # /list
622 final action view; # /list/load/view
623 final action edit; # /list/load/edit
627 There is also one shorthand alternative for declaring chain targets. You can
628 specify an action after a C<E<lt>-> following the action name:
630 action base under '/';
631 final action foo <- base; # /base/foo
635 You can use signatures like you are use to from L<MooseX::Method::Signatures>
636 to declare action parameters. The number of positinoal arguments will be used
637 during dispatching as well as their types.
639 The signature follows the action name:
642 final action foo (Int $year, Int $month, Int $day);
644 If you are using the shorthand definition, the signature follows the chain
648 final action foo <- base ($x) under '/' { ... }
650 Parameters may be specified on chain-parts and end-points:
653 action base (Str $lang) under '/';
654 final action page (Int $page_num) under base;
656 Named parameters will be populated with the values in the query parameters:
659 final action view (Int $id, Int :$page = 1) under '/';
661 Your end-points can also take an unspecified amount of arguments by specifying
662 an array as a variable:
664 # /find/some/deep/path/spec
665 final action find (@path) under '/';
669 The signatures are now validated during dispatching-time, and an action with
670 a non-matching signature (number of positional arguments and their types) will
671 not be dispatched to. This means that
673 action base under '/' as '';
677 final as double, action double_integer (Int $x) {
678 $ctx->response->body( $x * 2 );
681 final as double, action double_string (Str $x) {
682 $ctx->response->body( $x x 2 );
686 will return C<foofoo> when called as C</double/foo> and C<46> when called as
689 =head2 Actions and Method Modifiers
691 Method modifiers can not only be applied to methods, but also to actions. There
692 is no way yet to override the attributes of an already established action via
693 modifiers. However, you can modify the method underlying the action.
695 The following code is an example role modifying the consuming controller's
698 use CatalystX::Declare;
700 controller_role MyApp::Web::ControllerRole::RichBase {
702 before base (Object $ctx) {
703 $ctx->stash(something => $ctx->model('Item'));
707 Note that you have to specify the C<$ctx> argument yourself, since you are
708 modifying a method, not an action.
710 Any controller having a C<base> action (or method, for this purpose), can now
711 consume the C<RichBase> role declared above:
713 use CatalystX::Declare;
715 controller MyApp::Web::Controller::Foo
716 with MyApp::Web::Controller::RichBase {
718 action base as '' under '/';
720 action show, final under base {
721 $ctx->response->body(
722 $ctx->stash->{something}->render,
727 =head2 Action Classes
729 B<This option is even more experimental>
731 You might want to create an action with a different class than the usual
732 L<Catalyst::Action>. A usual suspect here is L<Catalyst::Action::RenderView>.
733 You can use the C<isa> option (did I mention it's experimental?) to specify
736 controller MyApp::Web::Controller::Root {
738 $CLASS->config(namespace => '');
740 action end isa RenderView;
743 The loaded class will be L<Moose>ified, so we are able to apply essential
746 =head2 Private Actions
748 B<This option is a bit less, but still pretty experimental>
750 You can declare private actions with the C<is private> trait:
752 action end is private isa RenderView;
758 =item L<MooseX::Declare::Syntax::KeywordHandling>
764 These methods are implementation details. Unless you are extending or
765 developing L<CatalystX::Declare>, you should not be concerned with them.
769 Object->parse (Object $ctx, Str :$modifier?, Int :$skipped_declarator = 0)
771 A hook that will be invoked by L<MooseX::Declare> when this instance is called
772 to handle syntax. It will parse the action declaration, prepare attributes and
773 add the actions to the controller.
779 =item L<CatalystX::Declare>
781 =item L<CatalystX::Declare::Keyword::Controller>
783 =item L<MooseX::Method::Signatures>
789 See L<CatalystX::Declare/AUTHOR> for author information.
793 This program is free software; you can redistribute it and/or modify it under
794 the same terms as perl itself.