local-lib5/lib/perl5/MooseX/Method/Signatures/Meta/Method.pm

   1 package MooseX::Method::Signatures::Meta::Method;
   2
   3 use Moose;
   4 use Carp qw/cluck/;
   5 use Context::Preserve;
   6 use Parse::Method::Signatures;
   7 use Parse::Method::Signatures::TypeConstraint;
   8 use Scalar::Util qw/weaken/;
   9 use Moose::Util qw/does_role/;
  10 use Moose::Util::TypeConstraints;
  11 use MooseX::Meta::TypeConstraint::ForceCoercion;
  12 use MooseX::Types::Util qw/has_available_type_export/;
  13 use MooseX::Types::Structured qw/Tuple Dict Optional slurpy/;
  14 use MooseX::Types::Moose qw/ArrayRef Str Maybe Object Any CodeRef Bool/;
  15 use MooseX::Method::Signatures::Types qw/Injections Params/;
  16 use aliased 'Parse::Method::Signatures::Param::Named';
  17 use aliased 'Parse::Method::Signatures::Param::Placeholder';
  18
  19 use namespace::autoclean;
  20
  21 extends 'Moose::Meta::Method';
  22
  23 has signature => (
  24     is       => 'ro',
  25     isa      => Str,
  26     default  => '(@)',
  27     required => 1,
  28 );
  29
  30 has parsed_signature => (
  31     is      => 'ro',
  32     isa     => class_type('Parse::Method::Signatures::Sig'),
  33     lazy    => 1,
  34     builder => '_build_parsed_signature',
  35 );
  36
  37 sub _parsed_signature {
  38     cluck '->_parsed_signature is deprecated. use ->parsed_signature instead.';
  39     shift->parsed_signature;
  40 }
  41
  42 has _lexicals => (
  43     is      => 'ro',
  44     isa     => ArrayRef[Str],
  45     lazy    => 1,
  46     builder => '_build__lexicals',
  47 );
  48
  49 has injectable_code => (
  50     is      => 'ro',
  51     isa     => Str,
  52     lazy    => 1,
  53     builder => '_build_injectable_code',
  54 );
  55
  56 has _positional_args => (
  57     is      => 'ro',
  58     isa     => ArrayRef,
  59     lazy    => 1,
  60     builder => '_build__positional_args',
  61 );
  62
  63 has _named_args => (
  64     is      => 'ro',
  65     isa     => ArrayRef,
  66     lazy    => 1,
  67     builder => '_build__named_args',
  68 );
  69
  70 has _has_slurpy_positional => (
  71     is   => 'rw',
  72     isa  => Bool,
  73 );
  74
  75 has type_constraint => (
  76     is      => 'ro',
  77     isa     => class_type('Moose::Meta::TypeConstraint'),
  78     lazy    => 1,
  79     builder => '_build_type_constraint',
  80 );
  81
  82 has return_signature => (
  83     is        => 'ro',
  84     isa       => Str,
  85     predicate => 'has_return_signature',
  86 );
  87
  88 has _return_type_constraint => (
  89     is      => 'ro',
  90     isa     => class_type('Moose::Meta::TypeConstraint'),
  91     lazy    => 1,
  92     builder => '_build__return_type_constraint',
  93 );
  94
  95 has actual_body => (
  96     is        => 'ro',
  97     isa       => CodeRef,
  98     predicate => '_has_actual_body',
  99 );
 100
 101 has prototype_injections => (
 102     is          => 'rw',
 103     isa         => Injections,
 104     trigger     => \&_parse_prototype_injections
 105 );
 106
 107 has _parsed_prototype_injections => (
 108     is          => 'ro',
 109     isa         => Params,
 110     predicate   => '_has_parsed_prototype_injections',
 111     writer      => '_set_parsed_prototype_injections',
 112 );
 113
 114 before actual_body => sub {
 115     my ($self) = @_;
 116     confess "method doesn't have an actual body yet"
 117         unless $self->_has_actual_body;
 118 };
 119
 120 around name => sub {
 121     my ($next, $self) = @_;
 122     my $ret = $self->$next;
 123     confess "method doesn't have a name yet"
 124         unless defined $ret;
 125     return $ret;
 126 };
 127
 128 sub _wrapped_body {
 129     my ($class, $self, %args) = @_;
 130
 131     if (exists $args{return_signature}) {
 132         return sub {
 133             my @args = ${ $self }->validate(\@_);
 134             return preserve_context { ${ $self }->actual_body->(@args) }
 135                 after => sub {
 136                     if (defined (my $msg = ${ $self }->_return_type_constraint->validate(\@_))) {
 137                         confess $msg;
 138                     }
 139                 };
 140         };
 141     }
 142
 143     my $actual_body;
 144     return sub {
 145         @_ = ${ $self }->validate(\@_);
 146         $actual_body ||= ${ $self }->actual_body;
 147         goto &{ $actual_body };
 148     };
 149
 150 }
 151
 152 sub wrap {
 153     my ($class, %args) = @_;
 154
 155     $args{actual_body} = delete $args{body}
 156         if exists $args{body};
 157
 158     my $self;
 159     my $to_wrap = $class->_wrapped_body(\$self, %args);
 160
 161
 162     if ($args{traits}) {
 163         my @traits = map {
 164             Class::MOP::load_class($_->[0]); $_->[0];
 165         } @{ $args{traits} };
 166
 167         my $meta = Moose::Meta::Class->create_anon_class(
 168             superclasses => [ $class  ],
 169             roles        => [ @traits ],
 170             cache        => 1,
 171         );
 172         $meta->add_method(meta => sub { $meta });
 173
 174         $class = $meta->name;
 175     }
 176
 177     $self = $class->_new(%args, body => $to_wrap);
 178
 179     # Vivify the type constraints so TC lookups happen before namespace::clean
 180     # removes them
 181     $self->type_constraint;
 182     $self->_return_type_constraint if $self->has_return_signature;
 183
 184     weaken($self->{associated_metaclass})
 185         if $self->{associated_metaclass};
 186
 187     return $self;
 188 }
 189
 190 sub reify {
 191     my ($self, %params) = @_;
 192     my $trait_args = delete $params{trait_args};
 193
 194     my $clone;
 195     $clone = $self->meta->clone_object($self,
 196         %params, @{ $trait_args || [] },
 197         body => $self->_wrapped_body(\$clone,
 198             ($self->has_return_signature
 199               ? (return_signature => $self->return_signature)
 200               : ()),
 201         ),
 202     );
 203
 204     return $clone;
 205 }
 206
 207 sub _build_parsed_signature {
 208     my ($self) = @_;
 209     return Parse::Method::Signatures->signature(
 210         input => $self->signature,
 211         from_namespace => $self->package_name,
 212     );
 213 }
 214
 215 sub _build__return_type_constraint {
 216     my ($self) = @_;
 217     confess 'no return type constraint'
 218         unless $self->has_return_signature;
 219
 220     my $parser = Parse::Method::Signatures->new(
 221         input => $self->return_signature,
 222         from_namespace => $self->package_name,
 223     );
 224
 225     my $param = $parser->_param_typed({});
 226     confess 'failed to parse return value type constraint'
 227         unless exists $param->{type_constraints};
 228
 229     return Tuple[$param->{type_constraints}->tc];
 230 }
 231
 232 sub _param_to_spec {
 233     my ($self, $param) = @_;
 234
 235     my $tc = Any;
 236     {
 237         # Ensure errors get reported from the right place
 238         local $Carp::Internal{'MooseX::Method::Signatures::Meta::Method'} = 1;
 239         local $Carp::Internal{'Moose::Meta::Method::Delegation'} = 1;
 240         local $Carp::Internal{'Moose::Meta::Method::Accessor'} = 1;
 241         local $Carp::Internal{'MooseX::Method::Signatures'} = 1;
 242         local $Carp::Internal{'Devel::Declare'} = 1;
 243         $tc = $param->meta_type_constraint
 244           if $param->has_type_constraints;
 245     }
 246
 247     if ($param->has_constraints) {
 248         my $cb = join ' && ', map { "sub {${_}}->(\\\@_)" } $param->constraints;
 249         my $code = eval "sub {${cb}}";
 250         $tc = subtype($tc, $code);
 251     }
 252
 253     my %spec;
 254     if ($param->sigil ne '$') {
 255         $spec{slurpy} = 1;
 256         $tc = slurpy ArrayRef[$tc];
 257     }
 258
 259     $spec{tc} = $param->required
 260         ? $tc
 261         : Optional[$tc];
 262
 263     $spec{default} = $param->default_value
 264         if $param->has_default_value;
 265
 266     if ($param->has_traits) {
 267         for my $trait (@{ $param->param_traits }) {
 268             next unless $trait->[1] eq 'coerce';
 269             $spec{coerce} = 1;
 270         }
 271     }
 272
 273     return \%spec;
 274 }
 275
 276 sub _parse_prototype_injections {
 277     my $self = shift;
 278
 279     my @params;
 280     for my $inject (@{ $self->prototype_injections }) {
 281         my $param;
 282         eval {
 283             $param = Parse::Method::Signatures->param($inject);
 284         };
 285
 286         confess "There was a problem parsing the prototype injection '$inject': $@"
 287             if $@ || !defined $param;
 288
 289         push @params, $param;
 290     }
 291
 292     my @return = reverse @params;
 293     $self->_set_parsed_prototype_injections(\@return);
 294 }
 295
 296 sub _build__lexicals {
 297     my ($self) = @_;
 298     my ($sig) = $self->parsed_signature;
 299
 300     my @lexicals;
 301
 302     if ($self->_has_parsed_prototype_injections) {
 303         push @lexicals, $_->variable_name
 304             for @{ $self->_parsed_prototype_injections };
 305     }
 306
 307     push @lexicals, $sig->has_invocant
 308         ? $sig->invocant->variable_name
 309         : '$self';
 310
 311     push @lexicals,
 312         (does_role($_, Placeholder)
 313             ? 'undef'
 314             : $_->variable_name)
 315         for (($sig->has_positional_params ? $sig->positional_params : ()),
 316              ($sig->has_named_params      ? $sig->named_params      : ()));
 317
 318     return \@lexicals;
 319 }
 320
 321 sub _build_injectable_code {
 322     my ($self) = @_;
 323     my $vars = join q{,}, @{ $self->_lexicals };
 324     return "my (${vars}) = \@_;";
 325 }
 326
 327 sub _build__positional_args {
 328     my ($self) = @_;
 329     my $sig = $self->parsed_signature;
 330
 331     my @positional;
 332     if ($self->_has_parsed_prototype_injections) {
 333         push @positional, map {
 334             $self->_param_to_spec($_)
 335         } @{ $self->_parsed_prototype_injections };
 336     }
 337
 338     push @positional, $sig->has_invocant
 339         ? $self->_param_to_spec($sig->invocant)
 340         : { tc => Object };
 341
 342     my $slurpy = 0;
 343     if ($sig->has_positional_params) {
 344         for my $param ($sig->positional_params) {
 345             my $spec = $self->_param_to_spec($param);
 346             $slurpy ||= 1 if $spec->{slurpy};
 347             push @positional, $spec;
 348         }
 349     }
 350
 351     $self->_has_slurpy_positional($slurpy);
 352     return \@positional;
 353 }
 354
 355 sub _build__named_args {
 356     my ($self) = @_;
 357     my $sig = $self->parsed_signature;
 358
 359     # triggering building of positionals before named params is important
 360     # because the latter needs to know if there have been any slurpy
 361     # positionals to report errors
 362     $self->_positional_args;
 363
 364     my @named;
 365
 366     if ($sig->has_named_params) {
 367         confess 'Named parameters can not be combined with slurpy positionals'
 368             if $self->_has_slurpy_positional;
 369         for my $param ($sig->named_params) {
 370             push @named, $param->label => $self->_param_to_spec($param);
 371         }
 372     }
 373
 374     return \@named;
 375 }
 376
 377 sub _build_type_constraint {
 378     my ($self) = @_;
 379     my ($positional, $named) = map { $self->$_ } map { "_${_}_args" } qw/positional named/;
 380
 381     my $tc = Tuple[
 382         Tuple[ map { $_->{tc}               } @{ $positional } ],
 383         Dict[  map { ref $_ ? $_->{tc} : $_ } @{ $named      } ],
 384     ];
 385
 386     my $coerce_param = sub {
 387         my ($spec, $value) = @_;
 388         return $value unless exists $spec->{coerce};
 389         return $spec->{tc}->coerce($value);
 390     };
 391
 392     my %named = @{ $named };
 393
 394     coerce $tc,
 395         from ArrayRef,
 396         via {
 397             my (@positional_args, %named_args);
 398
 399             my $i = 0;
 400             for my $param (@{ $positional }) {
 401                 push @positional_args,
 402                     $#{ $_ } < $i
 403                         ? (exists $param->{default} ? eval $param->{default} : ())
 404                         : $coerce_param->($param, $_->[$i]);
 405                 $i++;
 406             }
 407
 408             if (%named) {
 409                 my %rest = @{ $_ }[$i .. $#{ $_ }];
 410                 while (my ($key, $spec) = each %named) {
 411                     if (exists $rest{$key}) {
 412                         $named_args{$key} = $coerce_param->($spec, delete $rest{$key});
 413                         next;
 414                     }
 415
 416                     if (exists $spec->{default}) {
 417                         $named_args{$key} = eval $spec->{default};
 418                     }
 419                 }
 420
 421                 @named_args{keys %rest} = values %rest;
 422             }
 423             elsif ($#{ $_ } >= $i) {
 424                 push @positional_args, @{ $_ }[$i .. $#{ $_ }];
 425             }
 426
 427             return [\@positional_args, \%named_args];
 428         };
 429
 430     return MooseX::Meta::TypeConstraint::ForceCoercion->new(
 431         type_constraint => $tc,
 432     );
 433 }
 434
 435 sub validate {
 436     my ($self, $args) = @_;
 437
 438     my @named = grep { !ref $_ } @{ $self->_named_args };
 439
 440     my $coerced;
 441     if (defined (my $msg = $self->type_constraint->validate($args, \$coerced))) {
 442         confess $msg;
 443     }
 444
 445     return @{ $coerced->[0] }, map { $coerced->[1]->{$_} } @named;
 446 }
 447
 448 __PACKAGE__->meta->make_immutable;
 449
 450 1;