3 class CatalystX::Declarative::Keyword::Action
4 with MooseX::Declare::Syntax::KeywordHandling {
8 use Perl6::Junction qw( any );
9 use Data::Dump qw( pp );
10 use MooseX::Types::Util qw( has_available_type_export );
15 use constant STOP_PARSING => '__MXDECLARE_STOP_PARSING__';
16 use constant UNDER_VAR => '$CatalystX::Declarative::SCOPE::UNDER';
18 use aliased 'MooseX::Method::Signatures::Meta::Method';
19 use aliased 'MooseX::MethodAttributes::Role::Meta::Method', 'AttributeRole';
22 method parse (Object $ctx) {
24 # somewhere to put the attributes
27 my $skipped_declarator;
30 until (do { $ctx->skipspace; $ctx->peek_next_char } eq any qw( ; { } )) {
35 if ($ctx->peek_next_char eq ',') {
37 my $linestr = $ctx->get_linestr;
38 substr($linestr, $ctx->offset, 1) = '';
39 $ctx->set_linestr($linestr);
44 # next thing should be an option name
49 $ctx->skip_declarator;
50 $skipped_declarator++;
53 or croak "Expected option token, not " . substr($ctx->get_linestr, $ctx->offset);
55 # we need to be able to handle the rest
56 my $handler = $self->can("_handle_${option}_option")
57 or croak "Unknown action option: $option";
60 my $populator = $self->$handler($ctx, \%attributes);
62 if ($populator and $populator eq STOP_PARSING) {
64 return $ctx->shadow(sub (&) {
70 push @populators, $populator
71 if defined $populator;
74 croak "Need an action specification"
75 unless exists $attributes{Signature};
77 my $name = $attributes{Subname};
78 my $method = Method->wrap(
79 signature => qq{($attributes{Signature})},
80 package_name => $ctx->get_curstash_name,
84 AttributeRole->meta->apply($method);
89 unless ($attributes{Private}) {
90 $attributes{PathPart} ||= "'$name'";
92 delete $attributes{CaptureArgs}
93 if exists $attributes{Args};
95 $attributes{CaptureArgs} = 0
96 unless exists $attributes{Args}
97 or exists $attributes{CaptureArgs};
100 if ($attributes{Private}) {
101 delete $attributes{ $_ }
102 for qw( Args CaptureArgs Chained Signature Subname Action );
105 if ($ctx->peek_next_char eq '{') {
106 $ctx->inject_if_block($ctx->scope_injector_call . $method->injectable_code);
109 $ctx->inject_code_parts_here(
111 $ctx->scope_injector_call,
112 $method->injectable_code,
116 my @attributes = map {
119 ref($attributes{ $_ }) eq 'ARRAY'
120 ? ( scalar(@{ $attributes{ $_ } })
121 ? sprintf('(%s)', join(' ', @{ $attributes{ $_ } }))
123 : "($attributes{ $_ })"
127 return $ctx->shadow(sub (&) {
130 $method->_set_actual_body(shift);
131 $method->{attributes} = \@attributes;
133 $class->meta->add_method($name, $method);
134 $class->meta->register_method_attributes($class->can($method->name), \@attributes);
138 method _handle_with_option (Object $ctx, HashRef $attrs) {
140 my $role = $ctx->strip_name
141 or croak "Expected bareword role specification for action after with";
143 # we need to fish for aliases here since we are still unclean
144 if (defined(my $alias = $self->_check_for_available_import($ctx, $role))) {
148 push @{ $attrs->{CatalystX_Declarative_ActionRoles} ||= [] }, $role;
153 method _handle_isa_option (Object $ctx, HashRef $attrs) {
155 my $class = $ctx->strip_name
156 or croak "Expected bareword action class specification for action after isa";
158 if (defined(my $alias = $self->_check_for_available_import($ctx, $class))) {
162 $attrs->{CatalystX_Declarative_ActionClass} = $class;
167 method _check_for_available_import (Object $ctx, Str $name) {
169 if (my $code = $ctx->get_curstash_name->can($name)) {
176 method _handle_action_option (Object $ctx, HashRef $attrs) {
179 my $name = $ctx->strip_name
180 or croak "Anonymous actions not yet supported";
185 if (substr($ctx->get_linestr, $ctx->offset, 2) eq '<-') {
186 my $linestr = $ctx->get_linestr;
187 substr($linestr, $ctx->offset, 2) = '';
188 $ctx->set_linestr($linestr);
189 $populator = $self->_handle_under_option($ctx, $attrs);
193 my $proto = $ctx->strip_proto || '';
194 $proto = join(', ', 'Object $self: Object $ctx', $proto || ());
196 $attrs->{Subname} = $name;
197 $attrs->{Signature} = $proto;
198 $attrs->{Action} = [];
200 if (defined $CatalystX::Declarative::SCOPE::UNDER) {
201 $attrs->{Chained} ||= $CatalystX::Declarative::SCOPE::UNDER;
204 return unless $populator;
208 method _handle_final_option (Object $ctx, HashRef $attrs) {
210 return $self->_build_flag_populator($ctx, $attrs, 'final');
213 method _handle_is_option (Object $ctx, HashRef $attrs) {
215 my $what = $ctx->strip_name
216 or croak "Expected symbol token after is symbol, not " . substr($ctx->get_linestr, $ctx->offset);
218 return $self->_build_flag_populator($ctx, $attrs, $what);
221 method _build_flag_populator (Object $ctx, HashRef $attrs, Str $what) {
226 if ($what eq any qw( end endpoint final )) {
227 my $count = $self->_count_positional_arguments($method);
228 $attrs->{Args} = defined($count) ? $count : '';
230 elsif ($what eq 'private') {
231 $attrs->{Private} = [];
236 method _handle_under_option (Object $ctx, HashRef $attrs) {
238 my $target = $self->_strip_actionpath($ctx);
241 if ($ctx->peek_next_char eq '{' and $self->identifier eq 'under') {
242 $ctx->inject_if_block(
243 sprintf '%s; local %s; BEGIN { %s = qq(%s) };',
244 $ctx->scope_injector_call,
252 $attrs->{Chained} = "'$target'";
257 my $count = $self->_count_positional_arguments($method);
258 $attrs->{CaptureArgs} = $count
263 method _handle_chains_option (Object $ctx, HashRef $attrs) {
266 $ctx->strip_name eq 'to'
267 or croak "Expected to token after chains symbol, not " . substr($ctx->get_linestr, $ctx->offset);
269 return $self->_handle_under_option($ctx, $attrs);
272 method _handle_as_option (Object $ctx, HashRef $attrs) {
276 my $path = $self->_strip_actionpath($ctx);
277 $attrs->{PathPart} = "'$path'";
282 method _count_positional_arguments (Object $method) {
283 my $signature = $method->_parsed_signature;
285 if ($signature->has_positional_params) {
286 my $count = @{ scalar($signature->positional_params) };
288 if ($count and ($signature->positional_params)[-1]->sigil eq '@') {
298 method _strip_actionpath (Object $ctx) {
301 my $linestr = $ctx->get_linestr;
302 my $rest = substr($linestr, $ctx->offset);
304 if ($rest =~ /^ ( [_a-z] [_a-z0-9]* ) \b/ix) {
305 substr($linestr, $ctx->offset, length($1)) = '';
306 $ctx->set_linestr($linestr);
309 elsif ($rest =~ /^ ' ( (?:[.:;,_a-z0-9]|\/)* ) ' /ix) {
310 substr($linestr, $ctx->offset, length($1) + 2) = '';
311 $ctx->set_linestr($linestr);
315 croak "Invalid syntax for action path: $rest";