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

   1 use strict;
   2 use warnings;
   3
   4 package MooseX::Method::Signatures;
   5
   6 use Moose;
   7 use Devel::Declare ();
   8 use B::Hooks::EndOfScope;
   9 use Moose::Meta::Class;
  10 use MooseX::LazyRequire;
  11 use MooseX::Types::Moose qw/Str Bool CodeRef/;
  12 use Text::Balanced qw/extract_quotelike/;
  13 use MooseX::Method::Signatures::Meta::Method;
  14 use MooseX::Method::Signatures::Types qw/PrototypeInjections/;
  15 use Sub::Name;
  16 use Carp;
  17
  18 use aliased 'Devel::Declare::Context::Simple', 'ContextSimple';
  19
  20 use namespace::autoclean;
  21
  22 our $VERSION = '0.30';
  23
  24 has package => (
  25     is            => 'ro',
  26     isa           => Str,
  27     lazy_required => 1,
  28 );
  29
  30 has context => (
  31     is      => 'ro',
  32     isa     => ContextSimple,
  33     lazy    => 1,
  34     builder => '_build_context',
  35 );
  36
  37 has initialized_context => (
  38     is      => 'ro',
  39     isa     => Bool,
  40     default => 0,
  41 );
  42
  43 has custom_method_application => (
  44     is        => 'ro',
  45     isa       => CodeRef,
  46     predicate => 'has_custom_method_application',
  47 );
  48
  49 has prototype_injections => (
  50     is        => 'ro',
  51     isa       => PrototypeInjections,
  52     predicate => 'has_prototype_injections',
  53 );
  54
  55 sub _build_context {
  56     my ($self) = @_;
  57     return ContextSimple->new(into => $self->package);
  58 }
  59
  60 sub import {
  61     my ($class, %args) = @_;
  62     my $caller = caller();
  63     $class->setup_for($caller, \%args);
  64 }
  65
  66 sub setup_for {
  67     my ($class, $pkg, $args) = @_;
  68
  69     # process arguments to import
  70     while (my ($declarator, $injections) = each %{ $args }) {
  71         my $obj = $class->new(
  72             package              => $pkg,
  73             prototype_injections => {
  74                 declarator => $declarator,
  75                 injections => $injections,
  76             },
  77         );
  78
  79         Devel::Declare->setup_for($pkg, {
  80             $declarator => { const => sub { $obj->parser(@_) } },
  81         });
  82
  83         {
  84             no strict 'refs';
  85             *{ "${pkg}::$declarator" } = sub {};
  86         }
  87     }
  88
  89     my $self = $class->new(package => $pkg);
  90
  91     Devel::Declare->setup_for($pkg, {
  92         method => { const => sub { $self->parser(@_) } },
  93     });
  94
  95     {
  96         no strict 'refs';
  97         *{ "${pkg}::method" } = sub {};
  98     }
  99
 100     return;
 101 }
 102
 103 sub strip_name {
 104     my ($self) = @_;
 105     my $ctx = $self->context;
 106     my $ret = $ctx->strip_name;
 107     return $ret if defined $ret;
 108
 109     my $line = $ctx->get_linestr;
 110     my $offset = $ctx->offset;
 111     local $@;
 112     my $copy = substr($line, $offset);
 113     my ($str) = extract_quotelike($copy);
 114     return unless defined $str;
 115
 116     return if ($@ && $@ =~ /^No quotelike operator found/);
 117     die $@ if $@;
 118
 119     substr($line, $offset, length $str) = '';
 120     $ctx->set_linestr($line);
 121
 122     return \$str;
 123 }
 124
 125 sub strip_traits {
 126     my ($self) = @_;
 127
 128     my $ctx = $self->context;
 129     my $linestr = $ctx->get_linestr;
 130
 131     unless (substr($linestr, $ctx->offset, 2) eq 'is') {
 132         # No 'is' means no traits
 133         return;
 134     }
 135
 136     my @traits;
 137
 138     while (substr($linestr, $ctx->offset, 2) eq 'is') {
 139         # Eat the 'is' so we can call strip_names_and_args
 140         substr($linestr, $ctx->offset, 2) = '';
 141         $ctx->set_linestr($linestr);
 142         push @traits, @{ $ctx->strip_names_and_args };
 143         # Get the current linestr so that the loop can look for more 'is'
 144         $ctx->skipspace;
 145         $linestr = $ctx->get_linestr;
 146     }
 147
 148     confess "expected traits after 'is', found nothing"
 149         unless scalar(@traits);
 150
 151     # Let's check to make sure these traits aren't aliased locally
 152     for my $t (@traits) {
 153         my $class = $ctx->get_curstash_name;
 154         my $meta = Class::MOP::class_of($class) || Moose::Meta::Class->initialize($class);
 155         my $func = $meta->get_package_symbol('&' . $t->[0]);
 156         next unless $func;
 157
 158         my $proto = prototype $func;
 159         next if !defined $proto || length $proto;
 160
 161         $t->[0] = $func->();
 162     }
 163
 164     return \@traits;
 165 }
 166
 167 sub strip_return_type_constraint {
 168     my ($self) = @_;
 169     my $ctx = $self->context;
 170     my $returns = $ctx->strip_name;
 171     return unless defined $returns;
 172     confess "expected 'returns', found '${returns}'"
 173         unless $returns eq 'returns';
 174     return $ctx->strip_proto;
 175 }
 176
 177 sub parser {
 178     my $self = shift;
 179     my $err;
 180
 181     # Keep any previous compile errors from getting stepped on. But report
 182     # errors from inside MXMS nicely.
 183     {
 184         local $@;
 185         eval { $self->_parser(@_) };
 186         $err = $@;
 187     }
 188
 189     die $err if $err;
 190 }
 191
 192 sub _parser {
 193     my $self = shift;
 194     my $ctx = $self->context;
 195     $ctx->init(@_) unless $self->initialized_context;
 196
 197     $ctx->skip_declarator;
 198     my $name   = $self->strip_name;
 199     my $proto  = $ctx->strip_proto;
 200     my $attrs  = $ctx->strip_attrs || '';
 201     my $traits = $self->strip_traits;
 202     my $ret_tc = $self->strip_return_type_constraint;
 203
 204     my $compile_stash = $ctx->get_curstash_name;
 205
 206     my %args = (
 207       # This might get reset later, but its where we search for exported
 208       # symbols at compile time
 209       package_name => $compile_stash,
 210     );
 211     $args{ signature        } = qq{($proto)} if defined $proto;
 212     $args{ traits           } = $traits      if $traits;
 213     $args{ return_signature } = $ret_tc      if defined $ret_tc;
 214
 215     if ($self->has_prototype_injections) {
 216         confess('Configured declarator does not match context declarator')
 217             if $ctx->declarator ne $self->prototype_injections->{declarator};
 218         $args{prototype_injections} = $self->prototype_injections->{injections};
 219     }
 220
 221     my $proto_method = MooseX::Method::Signatures::Meta::Method->wrap(%args);
 222
 223     my $after_block = ')';
 224
 225     if ($traits) {
 226         if (my @trait_args = grep { defined } map { $_->[1] } @{ $traits }) {
 227             $after_block = q{, } . join(q{,} => @trait_args) . $after_block;
 228         }
 229     }
 230
 231     if (defined $name) {
 232         my $name_arg = q{, } . (ref $name ? ${$name} : qq{q[${name}]});
 233         $after_block = $name_arg . $after_block . q{;};
 234     }
 235
 236     my $inject = $proto_method->injectable_code;
 237     $inject = $self->scope_injector_call($after_block) . $inject;
 238
 239     $ctx->inject_if_block($inject, "(sub ${attrs} ");
 240
 241     my $create_meta_method = sub {
 242         my ($code, $pkg, $meth_name, @args) = @_;
 243         subname $pkg . "::" .$meth_name, $code;
 244         return $proto_method->reify(
 245             actual_body  => $code,
 246             package_name => $pkg,
 247             name         => $meth_name,
 248             trait_args   => \@args,
 249         );
 250     };
 251
 252     if (defined $name) {
 253         my $apply = $self->has_custom_method_application
 254             ? $self->custom_method_application
 255             : sub {
 256                 my ($meta, $name, $method) = @_;
 257
 258                 if (warnings::enabled("redefine") && (my $meta_meth = $meta->get_method($name))) {
 259                     warnings::warn("redefine", "Method $name redefined on package ${ \$meta->name }")
 260                         if $meta_meth->isa('MooseX::Method::Signatures::Meta::Method');
 261                 }
 262
 263                 $meta->add_method($name => $method);
 264             };
 265
 266         $ctx->shadow(sub {
 267             my ($code, $name, @args) = @_;
 268
 269             my $pkg = $compile_stash;
 270             ($pkg, $name) = $name =~ /^(.*)::([^:]+)$/
 271                 if $name =~ /::/;
 272
 273             my $meth = $create_meta_method->($code, $pkg, $name, @args);
 274             my $meta = Moose::Meta::Class->initialize($pkg);
 275
 276             $meta->$apply($name, $meth);
 277             return;
 278         });
 279     }
 280     else {
 281         $ctx->shadow(sub {
 282             return $create_meta_method->(shift, $compile_stash, '__ANON__', @_);
 283         });
 284     }
 285 }
 286
 287 sub scope_injector_call {
 288     my ($self, $code) = @_;
 289     $code =~ s/'/\\'/g; # we're generating code that's quoted with single quotes
 290     return qq[BEGIN { ${\ref $self}->inject_scope('${code}') }];
 291 }
 292
 293 sub inject_scope {
 294     my ($class, $inject) = @_;
 295     on_scope_end {
 296         my $line = Devel::Declare::get_linestr();
 297         return unless defined $line;
 298         my $offset = Devel::Declare::get_linestr_offset();
 299         substr($line, $offset, 0) = $inject;
 300         Devel::Declare::set_linestr($line);
 301     };
 302 }
 303
 304 __PACKAGE__->meta->make_immutable;
 305
 306 1;
 307
 308 __END__
 309 =head1 NAME
 310
 311 MooseX::Method::Signatures - Method declarations with type constraints and no source filter
 312
 313 =head1 SYNOPSIS
 314
 315     package Foo;
 316
 317     use Moose;
 318     use MooseX::Method::Signatures;
 319
 320     method morning (Str $name) {
 321         $self->say("Good morning ${name}!");
 322     }
 323
 324     method hello (Str :$who, Int :$age where { $_ > 0 }) {
 325         $self->say("Hello ${who}, I am ${age} years old!");
 326     }
 327
 328     method greet (Str $name, Bool :$excited = 0) {
 329         if ($excited) {
 330             $self->say("GREETINGS ${name}!");
 331         }
 332         else {
 333             $self->say("Hi ${name}!");
 334         }
 335     }
 336
 337     $foo->morning('Resi');                          # This works.
 338
 339     $foo->hello(who => 'world', age => 42);         # This too.
 340
 341     $foo->greet('Resi', excited => 1);              # And this as well.
 342
 343     $foo->hello(who => 'world', age => 'fortytwo'); # This doesn't.
 344
 345     $foo->hello(who => 'world', age => -23);        # This neither.
 346
 347     $foo->morning;                                  # Won't work.
 348
 349     $foo->greet;                                    # Will fail.
 350
 351 =head1 DESCRIPTION
 352
 353 Provides a proper method keyword, like "sub" but specifically for making methods
 354 and validating their arguments against Moose type constraints.
 355
 356 =head1 SIGNATURE SYNTAX
 357
 358 The signature syntax is heavily based on Perl 6. However not the full Perl 6
 359 signature syntax is supported yet and some of it never will be.
 360
 361 =head2 Type Constraints
 362
 363     method foo (             $affe) # no type checking
 364     method bar (Animal       $affe) # $affe->isa('Animal')
 365     method baz (Animal|Human $affe) # $affe->isa('Animal') || $affe->isa('Human')
 366
 367 =head2 Positional vs. Named
 368
 369     method foo ( $a,  $b,  $c) # positional
 370     method bar (:$a, :$b, :$c) # named
 371     method baz ( $a,  $b, :$c) # combined
 372
 373 =head2 Required vs. Optional
 374
 375     method foo ($a , $b!, :$c!, :$d!) # required
 376     method bar ($a?, $b?, :$c , :$d?) # optional
 377
 378 =head2 Defaults
 379
 380     method foo ($a = 42) # defaults to 42
 381
 382 =head2 Constraints
 383
 384     method foo ($foo where { $_ % 2 == 0 }) # only even
 385
 386 =head2 Invocant
 387
 388     method foo (        $moo) # invocant is called $self and is required
 389     method bar ($self:  $moo) # same, but explicit
 390     method baz ($class: $moo) # invocant is called $class
 391
 392 =head2 Labels
 393
 394     method foo (:     $affe ) # called as $obj->foo(affe => $value)
 395     method bar (:apan($affe)) # called as $obj->foo(apan => $value)
 396
 397 =head2 Traits
 398
 399     method foo (Affe $bar does trait)
 400     method foo (Affe $bar is trait)
 401
 402 The only currently supported trait is C<coerce>, which will attempt to coerce
 403 the value provided if it doesn't satisfy the requirements of the type
 404 constraint.
 405
 406 =head2 Placeholders
 407
 408     method foo ($bar, $, $baz)
 409
 410 Sometimes you don't care about some params you're being called with. Just put
 411 the bare sigil instead of a full variable name into the signature to avoid an
 412 extra lexical variable to be created.
 413
 414 =head2 Complex Example
 415
 416     method foo ( SomeClass $thing where { $_->can('stuff') }:
 417                  Str  $bar  = "apan",
 418                  Int :$baz! = 42 where { $_ % 2 == 0 } where { $_ > 10 } )
 419
 420     # the invocant is called $thing, must be an instance of SomeClass and
 421            has to implement a 'stuff' method
 422     # $bar is positional, required, must be a string and defaults to "apan"
 423     # $baz is named, required, must be an integer, defaults to 42 and needs
 424     #      to be even and greater than 10
 425
 426 =head1 BUGS, CAVEATS AND NOTES
 427
 428 This module is as stable now, but this is not to say that it is entirely bug
 429 free. If you notice any odd behaviour (messages not being as good as they could
 430 for example) then please raise a bug.
 431
 432 =head2 Fancy signatures
 433
 434 L<Parse::Method::Signatures> is used to parse the signatures. However, some
 435 signatures that can be parsed by it aren't supported by this module (yet).
 436
 437 =head2 No source filter
 438
 439 While this module does rely on the hairy black magic of L<Devel::Declare> it
 440 does not depend on a source filter. As such, it doesn't try to parse and
 441 rewrite your source code and there should be no weird side effects.
 442
 443 Devel::Declare only effects compilation. After that, it's a normal subroutine.
 444 As such, for all that hairy magic, this module is surprisingly stable.
 445
 446 =head2 What about regular subroutines?
 447
 448 L<Devel::Declare> cannot yet change the way C<sub> behaves. However, the
 449 L<signatures|signatures> module can. Right now it only provides very basic
 450 signatures, but it's extendable enough that plugging MooseX::Method::Signatures
 451 signatures into that should be quite possible.
 452
 453 =head2 What about the return value?
 454
 455 Type constraints for return values can be declared using
 456
 457   method foo (Int $x, Str $y) returns (Bool) { ... }
 458
 459 however, this feature only works with scalar return values and is still
 460 considered to be experimental.
 461
 462 =head2 Interaction with L<Moose::Role>
 463
 464 =head3 Methods not seen by a role's C<requires>
 465
 466 Because the processing of the L<MooseX::Method::Signatures>
 467 C<method> and the L<Moose> C<with> keywords are both
 468 done at runtime, it can happen that a role will require
 469 a method before it is declared (which will cause
 470 Moose to complain very loudly and abort the program).
 471
 472 For example, the following will not work:
 473
 474     # in file Canine.pm
 475
 476     package Canine;
 477
 478     use Moose;
 479     use MooseX::Method::Signatures;
 480
 481     with 'Watchdog';
 482
 483     method bark { print "Woof!\n"; }
 484
 485     1;
 486
 487
 488     # in file Watchdog.pm
 489
 490     package Watchdog;
 491
 492     use Moose::Role;
 493
 494     requires 'bark';  # will assert! evaluated before 'method' is processed
 495
 496     sub warn_intruder {
 497         my $self = shift;
 498         my $intruder = shift;
 499
 500         $self->bark until $intruder->gone;
 501     }
 502
 503     1;
 504
 505
 506 A workaround for this problem is to use C<with> only
 507 after the methods have been defined.  To take our previous
 508 example, B<Canine> could be reworked thus:
 509
 510     package Canine;
 511
 512     use Moose;
 513     use MooseX::Method::Signatures;
 514
 515     method bark { print "Woof!\n"; }
 516
 517     with 'Watchdog';
 518
 519     1;
 520
 521
 522 A better solution is to use L<MooseX::Declare> instead of plain
 523 L<MooseX::Method::Signatures>. It defers application of roles until the end
 524 of the class definition. With it, our example would becomes:
 525
 526
 527     # in file Canine.pm
 528
 529     use MooseX::Declare;
 530
 531     class Canine with Watchdog {
 532         method bark { print "Woof!\n"; }
 533     }
 534
 535     1;
 536
 537     # in file Watchdog.pm
 538
 539     use MooseX::Declare;
 540
 541     role Watchdog {
 542         requires 'bark';
 543
 544         method warn_intruder ( $intruder ) {
 545             $self->bark until $intruder->gone;
 546         }
 547     }
 548
 549     1;
 550
 551
 552 =head3 I<Subroutine redefined> warnings
 553
 554 When composing a L<Moose::Role> into a class that uses
 555 L<MooseX::Method::Signatures>, you may get a "Subroutine redefined"
 556 warning. This happens when both the role and the class define a
 557 method/subroutine of the same name. (The way roles work, the one
 558 defined in the class takes precedence.) To eliminate this warning,
 559 make sure that your C<with> declaration happens after any
 560 method/subroutine declarations that may have the same name as a
 561 method/subroutine within a role.
 562
 563 =head1 SEE ALSO
 564
 565 L<MooseX::Declare>
 566
 567 L<Method::Signatures::Simple>
 568
 569 L<Method::Signatures>
 570
 571 L<Perl6::Subs>
 572
 573 L<Devel::Declare>
 574
 575 L<Parse::Method::Signatures>
 576
 577 L<Moose>
 578
 579 =head1 AUTHOR
 580
 581 Florian Ragwitz E<lt>rafl@debian.orgE<gt>
 582
 583 With contributions from:
 584
 585 =over 4
 586
 587 =item Ash Berlin E<lt>ash@cpan.orgE<gt>
 588
 589 =item Cory Watson E<lt>gphat@cpan.orgE<gt>
 590
 591 =item Hakim Cassimally E<lt>hakim.cassimally@gmail.comE<gt>
 592
 593 =item Jonathan Scott Duff E<lt>duff@pobox.comE<gt>
 594
 595 =item Justin Hunter E<lt>justin.d.hunter@gmail.comE<gt>
 596
 597 =item Kent Fredric E<lt>kentfredric@gmail.comE<gt>
 598
 599 =item Maik Hentsche E<lt>maik.hentsche@amd.comE<gt>
 600
 601 =item Matt Kraai E<lt>kraai@ftbfs.orgE<gt>
 602
 603 =item Rhesa Rozendaal E<lt>rhesa@cpan.orgE<gt>
 604
 605 =item Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
 606
 607 =item Steffen Schwigon E<lt>ss5@renormalist.netE<gt>
 608
 609 =item Yanick Champoux E<lt>yanick@babyl.dyndns.orgE<gt>
 610
 611 =item Nicholas Perez E<lt>nperez@cpan.orgE<gt>
 612
 613 =back
 614
 615 =head1 COPYRIGHT AND LICENSE
 616
 617 Copyright (c) 2008, 2009  Florian Ragwitz
 618
 619 Code based on the tests for L<Devel::Declare>.
 620
 621 Documentation based on L<MooseX::Method> and L<Method::Signatures>.
 622
 623 Licensed under the same terms as Perl itself.
 624
 625 =cut