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