lib/CatalystX/Declarative/Keyword/Action.pm

   1 use MooseX::Declare;
   2
   3 class CatalystX::Declarative::Keyword::Action
   4     with MooseX::Declare::Syntax::KeywordHandling {
   5
   6
   7     use Carp            qw( croak );
   8     use Perl6::Junction qw( any );
   9     use Data::Dump      qw( pp );
  10
  11     use constant STOP_PARSING   => '__MXDECLARE_STOP_PARSING__';
  12     use constant UNDER_VAR      => '$CatalystX::Declarative::SCOPE::UNDER';
  13
  14     use aliased 'MooseX::Method::Signatures::Meta::Method';
  15     use aliased 'MooseX::MethodAttributes::Role::Meta::Method', 'AttributeRole';
  16
  17
  18     method parse (Object $ctx) {
  19
  20         # somewhere to put the attributes
  21         my %attributes;
  22         my @populators;
  23         my $skipped_declarator;
  24
  25         # parse declarations
  26         until (do { $ctx->skipspace; $ctx->peek_next_char } eq any qw( ; { } )) {
  27
  28             $ctx->skipspace;
  29
  30             # optional commas
  31             if ($ctx->peek_next_char eq ',') {
  32
  33                 my $linestr = $ctx->get_linestr;
  34                 substr($linestr, $ctx->offset, 1) = '';
  35                 $ctx->set_linestr($linestr);
  36
  37                 next;
  38             }
  39
  40             # next thing should be an option name
  41             my $option = (
  42                 $skipped_declarator
  43                 ? $ctx->strip_name
  44                 : do {
  45                     $ctx->skip_declarator;
  46                     $skipped_declarator++;
  47                     $ctx->declarator;
  48                 })
  49               or croak "Expected option token, not " . substr($ctx->get_linestr, $ctx->offset);
  50
  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";
  54
  55             # call the handler
  56             my $populator = $self->$handler($ctx, \%attributes);
  57
  58             if ($populator and $populator eq STOP_PARSING) {
  59
  60                 return $ctx->shadow(sub (&) {
  61                     my ($body) = @_;
  62                     return $body->();
  63                 });
  64             }
  65
  66             push @populators, $populator
  67                 if defined $populator;
  68         }
  69
  70         croak "Need an action specification"
  71             unless exists $attributes{Signature};
  72
  73         my $name   = $attributes{Subname};
  74         my $method = Method->wrap(
  75             signature       => qq{($attributes{Signature})},
  76             package_name    => $ctx->get_curstash_name,
  77             name            => $name,
  78         );
  79
  80         $_->($method)
  81             for @populators;
  82
  83         $attributes{PathPart} ||= "'$name'";
  84
  85         delete $attributes{CaptureArgs}
  86             if exists $attributes{Args};
  87
  88         $attributes{CaptureArgs} = 0
  89             unless exists $attributes{Args}
  90                 or exists $attributes{CaptureArgs};
  91
  92         if ($ctx->peek_next_char eq '{') {
  93             $ctx->inject_if_block($ctx->scope_injector_call . $method->injectable_code);
  94         }
  95         else {
  96             $ctx->inject_code_parts_here(
  97                 sprintf '{ %s%s }',
  98                     $ctx->scope_injector_call,
  99                     $method->injectable_code,
 100             );
 101         }
 102
 103         AttributeRole->meta->apply($method);
 104
 105         my @attributes = map {
 106             join('',
 107                 $_,
 108                 sprintf('(%s)', $attributes{ $_ }),
 109             );
 110         } keys %attributes;
 111
 112         return $ctx->shadow(sub (&) {
 113             my $class = caller;
 114
 115             $method->_set_actual_body(shift);
 116             $method->{attributes} = \@attributes;
 117
 118             $class->meta->add_method($name, $method);
 119             $class->meta->register_method_attributes($class->can($method->name), \@attributes);
 120         });
 121     }
 122
 123     method _handle_action_option (Object $ctx, HashRef $attrs) {
 124
 125         # action name
 126         my $name = $ctx->strip_name
 127             or croak "Anonymous actions not yet supported";
 128
 129         # signature
 130         my $proto = $ctx->strip_proto || '';
 131         $proto = join(', ', 'Object $self: Object $ctx', $proto || ());
 132
 133         $attrs->{Subname}   = $name;
 134         $attrs->{Signature} = $proto;
 135
 136         if (defined $CatalystX::Declarative::SCOPE::UNDER) {
 137             $attrs->{Chained} ||= $CatalystX::Declarative::SCOPE::UNDER;
 138         }
 139
 140         return;
 141     }
 142
 143     method _handle_is_option (Object $ctx, HashRef $attrs) {
 144
 145         my $what = $ctx->strip_name
 146             or croak "Expected symbol token after is symbol, not " . substr($ctx->get_linestr, $ctx->offset);
 147
 148         return sub {
 149             my $method = shift;
 150
 151             if ($what eq any qw( end endpoint final )) {
 152                 my $count = $self->_count_positional_arguments($method);
 153                 $attrs->{Args} = defined($count) ? $count : '';
 154             }
 155             elsif ($what eq 'private') {
 156                 $attrs->{Private} = 1;
 157             }
 158         };
 159     }
 160
 161     method _handle_under_option (Object $ctx, HashRef $attrs) {
 162
 163         my $target = $self->_strip_actionpath($ctx);
 164         $ctx->skipspace;
 165
 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) };',
 169                     UNDER_VAR,
 170                     UNDER_VAR,
 171                     $target,
 172             );
 173             return STOP_PARSING;
 174         }
 175
 176         $attrs->{Chained} = "'$target'";
 177
 178         return sub {
 179             my $method = shift;
 180
 181             my $count = $self->_count_positional_arguments($method);
 182             $attrs->{CaptureArgs} = $count
 183                 if defined $count;
 184         };
 185     }
 186
 187     method _handle_chains_option (Object $ctx, HashRef $attrs) {
 188
 189         $ctx->skipspace;
 190         $ctx->strip_name eq 'to'
 191             or croak "Expected to token after chains symbol, not " . substr($ctx->get_linestr, $ctx->offset);
 192
 193         return $self->_handle_under_option($ctx, $attrs);
 194     }
 195
 196     method _handle_as_option (Object $ctx, HashRef $attrs) {
 197
 198         $ctx->skipspace;
 199
 200         my $path = $self->_strip_actionpath($ctx);
 201         $attrs->{PathPart} = "'$path'";
 202
 203         return;
 204     }
 205
 206     method _count_positional_arguments (Object $method) {
 207         my $signature = $method->_parsed_signature;
 208
 209         if ($signature->has_positional_params) {
 210             my $count = @{ scalar($signature->positional_params) };
 211
 212             if ($count and ($signature->positional_params)[-1]->sigil eq '@') {
 213                 return undef;
 214             }
 215
 216             return $count - 1;
 217         }
 218
 219         return 0;
 220     }
 221
 222     method _strip_actionpath (Object $ctx) {
 223
 224         $ctx->skipspace;
 225         my $linestr = $ctx->get_linestr;
 226         my $rest    = substr($linestr, $ctx->offset);
 227
 228         if ($rest =~ /^ ( [_a-z] [_a-z0-9]* ) \b/ix) {
 229             substr($linestr, $ctx->offset, length($1)) = '';
 230             $ctx->set_linestr($linestr);
 231             return $1;
 232         }
 233         elsif ($rest =~ /^ ' ( (?:[.:;,_a-z0-9]|\/)* ) ' /ix) {
 234             substr($linestr, $ctx->offset, length($1) + 2) = '';
 235             $ctx->set_linestr($linestr);
 236             return $1;
 237         }
 238         else {
 239             croak "Invalid syntax for action path: $rest";
 240         }
 241     }
 242 }
 243
 244
 245