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     use MooseX::Types::Util qw( has_available_type_export );
  11     use Class::Inspector;
  12     use Class::MOP;
  13
  14
  15     use constant STOP_PARSING   => '__MXDECLARE_STOP_PARSING__';
  16     use constant UNDER_VAR      => '$CatalystX::Declarative::SCOPE::UNDER';
  17
  18     use aliased 'MooseX::Method::Signatures::Meta::Method';
  19     use aliased 'MooseX::MethodAttributes::Role::Meta::Method', 'AttributeRole';
  20
  21
  22     method parse (Object $ctx) {
  23
  24         # somewhere to put the attributes
  25         my %attributes;
  26         my @populators;
  27         my $skipped_declarator;
  28
  29         # parse declarations
  30         until (do { $ctx->skipspace; $ctx->peek_next_char } eq any qw( ; { } )) {
  31
  32             $ctx->skipspace;
  33
  34             # optional commas
  35             if ($ctx->peek_next_char eq ',') {
  36
  37                 my $linestr = $ctx->get_linestr;
  38                 substr($linestr, $ctx->offset, 1) = '';
  39                 $ctx->set_linestr($linestr);
  40
  41                 next;
  42             }
  43
  44             # next thing should be an option name
  45             my $option = (
  46                 $skipped_declarator
  47                 ? $ctx->strip_name
  48                 : do {
  49                     $ctx->skip_declarator;
  50                     $skipped_declarator++;
  51                     $ctx->declarator;
  52                 })
  53               or croak "Expected option token, not " . substr($ctx->get_linestr, $ctx->offset);
  54
  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";
  58
  59             # call the handler
  60             my $populator = $self->$handler($ctx, \%attributes);
  61
  62             if ($populator and $populator eq STOP_PARSING) {
  63
  64                 return $ctx->shadow(sub (&) {
  65                     my ($body) = @_;
  66                     return $body->();
  67                 });
  68             }
  69
  70             push @populators, $populator
  71                 if defined $populator;
  72         }
  73
  74         croak "Need an action specification"
  75             unless exists $attributes{Signature};
  76
  77         my $name   = $attributes{Subname};
  78         my $method = Method->wrap(
  79             signature       => qq{($attributes{Signature})},
  80             package_name    => $ctx->get_curstash_name,
  81             name            => $name,
  82         );
  83
  84         AttributeRole->meta->apply($method);
  85
  86         $_->($method)
  87             for @populators;
  88
  89         unless ($attributes{Private}) {
  90             $attributes{PathPart} ||= "'$name'";
  91
  92             delete $attributes{CaptureArgs}
  93                 if exists $attributes{Args};
  94
  95             $attributes{CaptureArgs} = 0
  96                 unless exists $attributes{Args}
  97                     or exists $attributes{CaptureArgs};
  98         }
  99
 100         if ($attributes{Private}) {
 101             delete $attributes{ $_ }
 102                 for qw( Args CaptureArgs Chained Signature Subname Action );
 103         }
 104
 105         if ($ctx->peek_next_char eq '{') {
 106             $ctx->inject_if_block($ctx->scope_injector_call . $method->injectable_code);
 107         }
 108         else {
 109             $ctx->inject_code_parts_here(
 110                 sprintf '{ %s%s }',
 111                     $ctx->scope_injector_call,
 112                     $method->injectable_code,
 113             );
 114         }
 115
 116         my @attributes = map {
 117             join('',
 118                 $_,
 119                 ref($attributes{ $_ }) eq 'ARRAY'
 120                 ? ( scalar(@{ $attributes{ $_ } })
 121                     ? sprintf('(%s)', join(' ', @{ $attributes{ $_ } }))
 122                     : '' )
 123                 : "($attributes{ $_ })"
 124             );
 125         } keys %attributes;
 126
 127         return $ctx->shadow(sub (&) {
 128             my $class = caller;
 129
 130             $method->_set_actual_body(shift);
 131             $method->{attributes} = \@attributes;
 132
 133             $class->meta->add_method($name, $method);
 134             $class->meta->register_method_attributes($class->can($method->name), \@attributes);
 135         });
 136     }
 137
 138     method _handle_with_option (Object $ctx, HashRef $attrs) {
 139
 140         my $role = $ctx->strip_name
 141             or croak "Expected bareword role specification for action after with";
 142
 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))) {
 145             $role = $alias;
 146         }
 147
 148         push @{ $attrs->{CatalystX_Declarative_ActionRoles} ||= [] }, $role;
 149
 150         return;
 151     }
 152
 153     method _handle_isa_option (Object $ctx, HashRef $attrs) {
 154
 155         my $class = $ctx->strip_name
 156             or croak "Expected bareword action class specification for action after isa";
 157
 158         if (defined(my $alias = $self->_check_for_available_import($ctx, $class))) {
 159             $class = $alias;
 160         }
 161
 162         $attrs->{CatalystX_Declarative_ActionClass} = $class;
 163
 164         return;
 165     }
 166
 167     method _check_for_available_import (Object $ctx, Str $name) {
 168
 169         if (my $code = $ctx->get_curstash_name->can($name)) {
 170             return $code->();
 171         }
 172
 173         return undef;
 174     }
 175
 176     method _handle_action_option (Object $ctx, HashRef $attrs) {
 177
 178         # action name
 179         my $name = $ctx->strip_name
 180             or croak "Anonymous actions not yet supported";
 181
 182         $ctx->skipspace;
 183         my $populator;
 184
 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);
 190         }
 191
 192         # signature
 193         my $proto = $ctx->strip_proto || '';
 194         $proto = join(', ', 'Object $self: Object $ctx', $proto || ());
 195
 196         $attrs->{Subname}   = $name;
 197         $attrs->{Signature} = $proto;
 198         $attrs->{Action}    = [];
 199
 200         if (defined $CatalystX::Declarative::SCOPE::UNDER) {
 201             $attrs->{Chained} ||= $CatalystX::Declarative::SCOPE::UNDER;
 202         }
 203
 204         return unless $populator;
 205         return $populator;
 206     }
 207
 208     method _handle_final_option (Object $ctx, HashRef $attrs) {
 209
 210         return $self->_build_flag_populator($ctx, $attrs, 'final');
 211     }
 212
 213     method _handle_is_option (Object $ctx, HashRef $attrs) {
 214
 215         my $what = $ctx->strip_name
 216             or croak "Expected symbol token after is symbol, not " . substr($ctx->get_linestr, $ctx->offset);
 217
 218         return $self->_build_flag_populator($ctx, $attrs, $what);
 219     }
 220
 221     method _build_flag_populator (Object $ctx, HashRef $attrs, Str $what) {
 222
 223         return sub {
 224             my $method = shift;
 225
 226             if ($what eq any qw( end endpoint final )) {
 227                 my $count = $self->_count_positional_arguments($method);
 228                 $attrs->{Args} = defined($count) ? $count : '';
 229             }
 230             elsif ($what eq 'private') {
 231                 $attrs->{Private} = [];
 232             }
 233         };
 234     }
 235
 236     method _handle_under_option (Object $ctx, HashRef $attrs) {
 237
 238         my $target = $self->_strip_actionpath($ctx);
 239         $ctx->skipspace;
 240
 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,
 245                     UNDER_VAR,
 246                     UNDER_VAR,
 247                     $target,
 248             );
 249             return STOP_PARSING;
 250         }
 251
 252         $attrs->{Chained} = "'$target'";
 253
 254         return sub {
 255             my $method = shift;
 256
 257             my $count = $self->_count_positional_arguments($method);
 258             $attrs->{CaptureArgs} = $count
 259                 if defined $count;
 260         };
 261     }
 262
 263     method _handle_chains_option (Object $ctx, HashRef $attrs) {
 264
 265         $ctx->skipspace;
 266         $ctx->strip_name eq 'to'
 267             or croak "Expected to token after chains symbol, not " . substr($ctx->get_linestr, $ctx->offset);
 268
 269         return $self->_handle_under_option($ctx, $attrs);
 270     }
 271
 272     method _handle_as_option (Object $ctx, HashRef $attrs) {
 273
 274         $ctx->skipspace;
 275
 276         my $path = $self->_strip_actionpath($ctx);
 277         $attrs->{PathPart} = "'$path'";
 278
 279         return;
 280     }
 281
 282     method _count_positional_arguments (Object $method) {
 283         my $signature = $method->_parsed_signature;
 284
 285         if ($signature->has_positional_params) {
 286             my $count = @{ scalar($signature->positional_params) };
 287
 288             if ($count and ($signature->positional_params)[-1]->sigil eq '@') {
 289                 return undef;
 290             }
 291
 292             return $count - 1;
 293         }
 294
 295         return 0;
 296     }
 297
 298     method _strip_actionpath (Object $ctx) {
 299
 300         $ctx->skipspace;
 301         my $linestr = $ctx->get_linestr;
 302         my $rest    = substr($linestr, $ctx->offset);
 303
 304         if ($rest =~ /^ ( [_a-z] [_a-z0-9]* ) \b/ix) {
 305             substr($linestr, $ctx->offset, length($1)) = '';
 306             $ctx->set_linestr($linestr);
 307             return $1;
 308         }
 309         elsif ($rest =~ /^ ' ( (?:[.:;,_a-z0-9]|\/)* ) ' /ix) {
 310             substr($linestr, $ctx->offset, length($1) + 2) = '';
 311             $ctx->set_linestr($linestr);
 312             return $1;
 313         }
 314         else {
 315             croak "Invalid syntax for action path: $rest";
 316         }
 317     }
 318 }
 319
 320
 321