3 class CatalystX::Declarative::Keyword::Action
4 with MooseX::Declare::Syntax::KeywordHandling {
8 use Perl6::Junction qw( any );
9 use Data::Dump qw( pp );
11 use constant STOP_PARSING => '__MXDECLARE_STOP_PARSING__';
12 use constant UNDER_VAR => '$CatalystX::Declarative::SCOPE::UNDER';
14 use aliased 'MooseX::Method::Signatures::Meta::Method';
15 use aliased 'MooseX::MethodAttributes::Role::Meta::Method', 'AttributeRole';
18 method parse (Object $ctx) {
20 # somewhere to put the attributes
23 my $skipped_declarator;
26 until (do { $ctx->skipspace; $ctx->peek_next_char } eq any qw( ; { } )) {
31 if ($ctx->peek_next_char eq ',') {
33 my $linestr = $ctx->get_linestr;
34 substr($linestr, $ctx->offset, 1) = '';
35 $ctx->set_linestr($linestr);
40 # next thing should be an option name
45 $ctx->skip_declarator;
46 $skipped_declarator++;
49 or croak "Expected option token, not " . substr($ctx->get_linestr, $ctx->offset);
51 # we need to be able to handle the rest
52 my $handler = $self->can("_handle_${option}_option")
53 or croak "Unknown action option: $option";
56 my $populator = $self->$handler($ctx, \%attributes);
58 if ($populator and $populator eq STOP_PARSING) {
60 return $ctx->shadow(sub (&) {
66 push @populators, $populator
67 if defined $populator;
70 croak "Need an action specification"
71 unless exists $attributes{Signature};
73 my $name = $attributes{Subname};
74 my $method = Method->wrap(
75 signature => qq{($attributes{Signature})},
76 package_name => $ctx->get_curstash_name,
83 $attributes{PathPart} ||= "'$name'";
85 delete $attributes{CaptureArgs}
86 if exists $attributes{Args};
88 $attributes{CaptureArgs} = 0
89 unless exists $attributes{Args}
90 or exists $attributes{CaptureArgs};
92 if ($ctx->peek_next_char eq '{') {
93 $ctx->inject_if_block($ctx->scope_injector_call . $method->injectable_code);
96 $ctx->inject_code_parts_here(
98 $ctx->scope_injector_call,
99 $method->injectable_code,
103 AttributeRole->meta->apply($method);
105 my @attributes = map {
108 sprintf('(%s)', $attributes{ $_ }),
112 return $ctx->shadow(sub (&) {
115 $method->_set_actual_body(shift);
116 $method->{attributes} = \@attributes;
118 $class->meta->add_method($name, $method);
119 $class->meta->register_method_attributes($class->can($method->name), \@attributes);
123 method _handle_action_option (Object $ctx, HashRef $attrs) {
126 my $name = $ctx->strip_name
127 or croak "Anonymous actions not yet supported";
130 my $proto = $ctx->strip_proto || '';
131 $proto = join(', ', 'Object $self: Object $ctx', $proto || ());
133 $attrs->{Subname} = $name;
134 $attrs->{Signature} = $proto;
136 if (defined $CatalystX::Declarative::SCOPE::UNDER) {
137 $attrs->{Chained} ||= $CatalystX::Declarative::SCOPE::UNDER;
143 method _handle_is_option (Object $ctx, HashRef $attrs) {
145 my $what = $ctx->strip_name
146 or croak "Expected symbol token after is symbol, not " . substr($ctx->get_linestr, $ctx->offset);
151 if ($what eq any qw( end endpoint final )) {
152 my $count = $self->_count_positional_arguments($method);
153 $attrs->{Args} = defined($count) ? $count : '';
155 elsif ($what eq 'private') {
156 $attrs->{Private} = 1;
161 method _handle_under_option (Object $ctx, HashRef $attrs) {
163 my $target = $self->_strip_actionpath($ctx);
166 if ($ctx->peek_next_char eq '{' and $self->identifier eq 'under') {
167 $ctx->inject_if_block(
168 sprintf 'local %s; BEGIN { %s = qq(%s) };',
176 $attrs->{Chained} = "'$target'";
181 my $count = $self->_count_positional_arguments($method);
182 $attrs->{CaptureArgs} = $count
187 method _handle_chains_option (Object $ctx, HashRef $attrs) {
190 $ctx->strip_name eq 'to'
191 or croak "Expected to token after chains symbol, not " . substr($ctx->get_linestr, $ctx->offset);
193 return $self->_handle_under_option($ctx, $attrs);
196 method _handle_as_option (Object $ctx, HashRef $attrs) {
200 my $path = $self->_strip_actionpath($ctx);
201 $attrs->{PathPart} = "'$path'";
206 method _count_positional_arguments (Object $method) {
207 my $signature = $method->_parsed_signature;
209 if ($signature->has_positional_params) {
210 my $count = @{ scalar($signature->positional_params) };
212 if ($count and ($signature->positional_params)[-1]->sigil eq '@') {
222 method _strip_actionpath (Object $ctx) {
225 my $linestr = $ctx->get_linestr;
226 my $rest = substr($linestr, $ctx->offset);
228 if ($rest =~ /^ ( [_a-z] [_a-z0-9]* ) \b/ix) {
229 substr($linestr, $ctx->offset, length($1)) = '';
230 $ctx->set_linestr($linestr);
233 elsif ($rest =~ /^ ' ( (?:[.:;,_a-z0-9]|\/)* ) ' /ix) {
234 substr($linestr, $ctx->offset, length($1) + 2) = '';
235 $ctx->set_linestr($linestr);
239 croak "Invalid syntax for action path: $rest";