--- /dev/null
+use strict;
+use warnings;
+
+package MooseX::Method::Signatures;
+
+use Moose;
+use Devel::Declare ();
+use B::Hooks::EndOfScope;
+use Moose::Meta::Class;
+use MooseX::LazyRequire;
+use MooseX::Types::Moose qw/Str Bool CodeRef/;
+use Text::Balanced qw/extract_quotelike/;
+use MooseX::Method::Signatures::Meta::Method;
+use MooseX::Method::Signatures::Types qw/PrototypeInjections/;
+use Sub::Name;
+use Carp;
+
+use aliased 'Devel::Declare::Context::Simple', 'ContextSimple';
+
+use namespace::autoclean;
+
+our $VERSION = '0.30';
+
+has package => (
+ is => 'ro',
+ isa => Str,
+ lazy_required => 1,
+);
+
+has context => (
+ is => 'ro',
+ isa => ContextSimple,
+ lazy => 1,
+ builder => '_build_context',
+);
+
+has initialized_context => (
+ is => 'ro',
+ isa => Bool,
+ default => 0,
+);
+
+has custom_method_application => (
+ is => 'ro',
+ isa => CodeRef,
+ predicate => 'has_custom_method_application',
+);
+
+has prototype_injections => (
+ is => 'ro',
+ isa => PrototypeInjections,
+ predicate => 'has_prototype_injections',
+);
+
+sub _build_context {
+ my ($self) = @_;
+ return ContextSimple->new(into => $self->package);
+}
+
+sub import {
+ my ($class, %args) = @_;
+ my $caller = caller();
+ $class->setup_for($caller, \%args);
+}
+
+sub setup_for {
+ my ($class, $pkg, $args) = @_;
+
+ # process arguments to import
+ while (my ($declarator, $injections) = each %{ $args }) {
+ my $obj = $class->new(
+ package => $pkg,
+ prototype_injections => {
+ declarator => $declarator,
+ injections => $injections,
+ },
+ );
+
+ Devel::Declare->setup_for($pkg, {
+ $declarator => { const => sub { $obj->parser(@_) } },
+ });
+
+ {
+ no strict 'refs';
+ *{ "${pkg}::$declarator" } = sub {};
+ }
+ }
+
+ my $self = $class->new(package => $pkg);
+
+ Devel::Declare->setup_for($pkg, {
+ method => { const => sub { $self->parser(@_) } },
+ });
+
+ {
+ no strict 'refs';
+ *{ "${pkg}::method" } = sub {};
+ }
+
+ return;
+}
+
+sub strip_name {
+ my ($self) = @_;
+ my $ctx = $self->context;
+ my $ret = $ctx->strip_name;
+ return $ret if defined $ret;
+
+ my $line = $ctx->get_linestr;
+ my $offset = $ctx->offset;
+ local $@;
+ my $copy = substr($line, $offset);
+ my ($str) = extract_quotelike($copy);
+ return unless defined $str;
+
+ return if ($@ && $@ =~ /^No quotelike operator found/);
+ die $@ if $@;
+
+ substr($line, $offset, length $str) = '';
+ $ctx->set_linestr($line);
+
+ return \$str;
+}
+
+sub strip_traits {
+ my ($self) = @_;
+
+ my $ctx = $self->context;
+ my $linestr = $ctx->get_linestr;
+
+ unless (substr($linestr, $ctx->offset, 2) eq 'is') {
+ # No 'is' means no traits
+ return;
+ }
+
+ my @traits;
+
+ while (substr($linestr, $ctx->offset, 2) eq 'is') {
+ # Eat the 'is' so we can call strip_names_and_args
+ substr($linestr, $ctx->offset, 2) = '';
+ $ctx->set_linestr($linestr);
+ push @traits, @{ $ctx->strip_names_and_args };
+ # Get the current linestr so that the loop can look for more 'is'
+ $ctx->skipspace;
+ $linestr = $ctx->get_linestr;
+ }
+
+ confess "expected traits after 'is', found nothing"
+ unless scalar(@traits);
+
+ # Let's check to make sure these traits aren't aliased locally
+ for my $t (@traits) {
+ my $class = $ctx->get_curstash_name;
+ my $meta = Class::MOP::class_of($class) || Moose::Meta::Class->initialize($class);
+ my $func = $meta->get_package_symbol('&' . $t->[0]);
+ next unless $func;
+
+ my $proto = prototype $func;
+ next if !defined $proto || length $proto;
+
+ $t->[0] = $func->();
+ }
+
+ return \@traits;
+}
+
+sub strip_return_type_constraint {
+ my ($self) = @_;
+ my $ctx = $self->context;
+ my $returns = $ctx->strip_name;
+ return unless defined $returns;
+ confess "expected 'returns', found '${returns}'"
+ unless $returns eq 'returns';
+ return $ctx->strip_proto;
+}
+
+sub parser {
+ my $self = shift;
+ my $err;
+
+ # Keep any previous compile errors from getting stepped on. But report
+ # errors from inside MXMS nicely.
+ {
+ local $@;
+ eval { $self->_parser(@_) };
+ $err = $@;
+ }
+
+ die $err if $err;
+}
+
+sub _parser {
+ my $self = shift;
+ my $ctx = $self->context;
+ $ctx->init(@_) unless $self->initialized_context;
+
+ $ctx->skip_declarator;
+ my $name = $self->strip_name;
+ my $proto = $ctx->strip_proto;
+ my $attrs = $ctx->strip_attrs || '';
+ my $traits = $self->strip_traits;
+ my $ret_tc = $self->strip_return_type_constraint;
+
+ my $compile_stash = $ctx->get_curstash_name;
+
+ my %args = (
+ # This might get reset later, but its where we search for exported
+ # symbols at compile time
+ package_name => $compile_stash,
+ );
+ $args{ signature } = qq{($proto)} if defined $proto;
+ $args{ traits } = $traits if $traits;
+ $args{ return_signature } = $ret_tc if defined $ret_tc;
+
+ if ($self->has_prototype_injections) {
+ confess('Configured declarator does not match context declarator')
+ if $ctx->declarator ne $self->prototype_injections->{declarator};
+ $args{prototype_injections} = $self->prototype_injections->{injections};
+ }
+
+ my $proto_method = MooseX::Method::Signatures::Meta::Method->wrap(%args);
+
+ my $after_block = ')';
+
+ if ($traits) {
+ if (my @trait_args = grep { defined } map { $_->[1] } @{ $traits }) {
+ $after_block = q{, } . join(q{,} => @trait_args) . $after_block;
+ }
+ }
+
+ if (defined $name) {
+ my $name_arg = q{, } . (ref $name ? ${$name} : qq{q[${name}]});
+ $after_block = $name_arg . $after_block . q{;};
+ }
+
+ my $inject = $proto_method->injectable_code;
+ $inject = $self->scope_injector_call($after_block) . $inject;
+
+ $ctx->inject_if_block($inject, "(sub ${attrs} ");
+
+ my $create_meta_method = sub {
+ my ($code, $pkg, $meth_name, @args) = @_;
+ subname $pkg . "::" .$meth_name, $code;
+ return $proto_method->reify(
+ actual_body => $code,
+ package_name => $pkg,
+ name => $meth_name,
+ trait_args => \@args,
+ );
+ };
+
+ if (defined $name) {
+ my $apply = $self->has_custom_method_application
+ ? $self->custom_method_application
+ : sub {
+ my ($meta, $name, $method) = @_;
+
+ if (warnings::enabled("redefine") && (my $meta_meth = $meta->get_method($name))) {
+ warnings::warn("redefine", "Method $name redefined on package ${ \$meta->name }")
+ if $meta_meth->isa('MooseX::Method::Signatures::Meta::Method');
+ }
+
+ $meta->add_method($name => $method);
+ };
+
+ $ctx->shadow(sub {
+ my ($code, $name, @args) = @_;
+
+ my $pkg = $compile_stash;
+ ($pkg, $name) = $name =~ /^(.*)::([^:]+)$/
+ if $name =~ /::/;
+
+ my $meth = $create_meta_method->($code, $pkg, $name, @args);
+ my $meta = Moose::Meta::Class->initialize($pkg);
+
+ $meta->$apply($name, $meth);
+ return;
+ });
+ }
+ else {
+ $ctx->shadow(sub {
+ return $create_meta_method->(shift, $compile_stash, '__ANON__', @_);
+ });
+ }
+}
+
+sub scope_injector_call {
+ my ($self, $code) = @_;
+ $code =~ s/'/\\'/g; # we're generating code that's quoted with single quotes
+ return qq[BEGIN { ${\ref $self}->inject_scope('${code}') }];
+}
+
+sub inject_scope {
+ my ($class, $inject) = @_;
+ on_scope_end {
+ my $line = Devel::Declare::get_linestr();
+ return unless defined $line;
+ my $offset = Devel::Declare::get_linestr_offset();
+ substr($line, $offset, 0) = $inject;
+ Devel::Declare::set_linestr($line);
+ };
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
+
+__END__
+=head1 NAME
+
+MooseX::Method::Signatures - Method declarations with type constraints and no source filter
+
+=head1 SYNOPSIS
+
+ package Foo;
+
+ use Moose;
+ use MooseX::Method::Signatures;
+
+ method morning (Str $name) {
+ $self->say("Good morning ${name}!");
+ }
+
+ method hello (Str :$who, Int :$age where { $_ > 0 }) {
+ $self->say("Hello ${who}, I am ${age} years old!");
+ }
+
+ method greet (Str $name, Bool :$excited = 0) {
+ if ($excited) {
+ $self->say("GREETINGS ${name}!");
+ }
+ else {
+ $self->say("Hi ${name}!");
+ }
+ }
+
+ $foo->morning('Resi'); # This works.
+
+ $foo->hello(who => 'world', age => 42); # This too.
+
+ $foo->greet('Resi', excited => 1); # And this as well.
+
+ $foo->hello(who => 'world', age => 'fortytwo'); # This doesn't.
+
+ $foo->hello(who => 'world', age => -23); # This neither.
+
+ $foo->morning; # Won't work.
+
+ $foo->greet; # Will fail.
+
+=head1 DESCRIPTION
+
+Provides a proper method keyword, like "sub" but specifically for making methods
+and validating their arguments against Moose type constraints.
+
+=head1 SIGNATURE SYNTAX
+
+The signature syntax is heavily based on Perl 6. However not the full Perl 6
+signature syntax is supported yet and some of it never will be.
+
+=head2 Type Constraints
+
+ method foo ( $affe) # no type checking
+ method bar (Animal $affe) # $affe->isa('Animal')
+ method baz (Animal|Human $affe) # $affe->isa('Animal') || $affe->isa('Human')
+
+=head2 Positional vs. Named
+
+ method foo ( $a, $b, $c) # positional
+ method bar (:$a, :$b, :$c) # named
+ method baz ( $a, $b, :$c) # combined
+
+=head2 Required vs. Optional
+
+ method foo ($a , $b!, :$c!, :$d!) # required
+ method bar ($a?, $b?, :$c , :$d?) # optional
+
+=head2 Defaults
+
+ method foo ($a = 42) # defaults to 42
+
+=head2 Constraints
+
+ method foo ($foo where { $_ % 2 == 0 }) # only even
+
+=head2 Invocant
+
+ method foo ( $moo) # invocant is called $self and is required
+ method bar ($self: $moo) # same, but explicit
+ method baz ($class: $moo) # invocant is called $class
+
+=head2 Labels
+
+ method foo (: $affe ) # called as $obj->foo(affe => $value)
+ method bar (:apan($affe)) # called as $obj->foo(apan => $value)
+
+=head2 Traits
+
+ method foo (Affe $bar does trait)
+ method foo (Affe $bar is trait)
+
+The only currently supported trait is C<coerce>, which will attempt to coerce
+the value provided if it doesn't satisfy the requirements of the type
+constraint.
+
+=head2 Placeholders
+
+ method foo ($bar, $, $baz)
+
+Sometimes you don't care about some params you're being called with. Just put
+the bare sigil instead of a full variable name into the signature to avoid an
+extra lexical variable to be created.
+
+=head2 Complex Example
+
+ method foo ( SomeClass $thing where { $_->can('stuff') }:
+ Str $bar = "apan",
+ Int :$baz! = 42 where { $_ % 2 == 0 } where { $_ > 10 } )
+
+ # the invocant is called $thing, must be an instance of SomeClass and
+ has to implement a 'stuff' method
+ # $bar is positional, required, must be a string and defaults to "apan"
+ # $baz is named, required, must be an integer, defaults to 42 and needs
+ # to be even and greater than 10
+
+=head1 BUGS, CAVEATS AND NOTES
+
+This module is as stable now, but this is not to say that it is entirely bug
+free. If you notice any odd behaviour (messages not being as good as they could
+for example) then please raise a bug.
+
+=head2 Fancy signatures
+
+L<Parse::Method::Signatures> is used to parse the signatures. However, some
+signatures that can be parsed by it aren't supported by this module (yet).
+
+=head2 No source filter
+
+While this module does rely on the hairy black magic of L<Devel::Declare> it
+does not depend on a source filter. As such, it doesn't try to parse and
+rewrite your source code and there should be no weird side effects.
+
+Devel::Declare only effects compilation. After that, it's a normal subroutine.
+As such, for all that hairy magic, this module is surprisingly stable.
+
+=head2 What about regular subroutines?
+
+L<Devel::Declare> cannot yet change the way C<sub> behaves. However, the
+L<signatures|signatures> module can. Right now it only provides very basic
+signatures, but it's extendable enough that plugging MooseX::Method::Signatures
+signatures into that should be quite possible.
+
+=head2 What about the return value?
+
+Type constraints for return values can be declared using
+
+ method foo (Int $x, Str $y) returns (Bool) { ... }
+
+however, this feature only works with scalar return values and is still
+considered to be experimental.
+
+=head2 Interaction with L<Moose::Role>
+
+=head3 Methods not seen by a role's C<requires>
+
+Because the processing of the L<MooseX::Method::Signatures>
+C<method> and the L<Moose> C<with> keywords are both
+done at runtime, it can happen that a role will require
+a method before it is declared (which will cause
+Moose to complain very loudly and abort the program).
+
+For example, the following will not work:
+
+ # in file Canine.pm
+
+ package Canine;
+
+ use Moose;
+ use MooseX::Method::Signatures;
+
+ with 'Watchdog';
+
+ method bark { print "Woof!\n"; }
+
+ 1;
+
+
+ # in file Watchdog.pm
+
+ package Watchdog;
+
+ use Moose::Role;
+
+ requires 'bark'; # will assert! evaluated before 'method' is processed
+
+ sub warn_intruder {
+ my $self = shift;
+ my $intruder = shift;
+
+ $self->bark until $intruder->gone;
+ }
+
+ 1;
+
+
+A workaround for this problem is to use C<with> only
+after the methods have been defined. To take our previous
+example, B<Canine> could be reworked thus:
+
+ package Canine;
+
+ use Moose;
+ use MooseX::Method::Signatures;
+
+ method bark { print "Woof!\n"; }
+
+ with 'Watchdog';
+
+ 1;
+
+
+A better solution is to use L<MooseX::Declare> instead of plain
+L<MooseX::Method::Signatures>. It defers application of roles until the end
+of the class definition. With it, our example would becomes:
+
+
+ # in file Canine.pm
+
+ use MooseX::Declare;
+
+ class Canine with Watchdog {
+ method bark { print "Woof!\n"; }
+ }
+
+ 1;
+
+ # in file Watchdog.pm
+
+ use MooseX::Declare;
+
+ role Watchdog {
+ requires 'bark';
+
+ method warn_intruder ( $intruder ) {
+ $self->bark until $intruder->gone;
+ }
+ }
+
+ 1;
+
+
+=head3 I<Subroutine redefined> warnings
+
+When composing a L<Moose::Role> into a class that uses
+L<MooseX::Method::Signatures>, you may get a "Subroutine redefined"
+warning. This happens when both the role and the class define a
+method/subroutine of the same name. (The way roles work, the one
+defined in the class takes precedence.) To eliminate this warning,
+make sure that your C<with> declaration happens after any
+method/subroutine declarations that may have the same name as a
+method/subroutine within a role.
+
+=head1 SEE ALSO
+
+L<MooseX::Declare>
+
+L<Method::Signatures::Simple>
+
+L<Method::Signatures>
+
+L<Perl6::Subs>
+
+L<Devel::Declare>
+
+L<Parse::Method::Signatures>
+
+L<Moose>
+
+=head1 AUTHOR
+
+Florian Ragwitz E<lt>rafl@debian.orgE<gt>
+
+With contributions from:
+
+=over 4
+
+=item Ash Berlin E<lt>ash@cpan.orgE<gt>
+
+=item Cory Watson E<lt>gphat@cpan.orgE<gt>
+
+=item Hakim Cassimally E<lt>hakim.cassimally@gmail.comE<gt>
+
+=item Jonathan Scott Duff E<lt>duff@pobox.comE<gt>
+
+=item Justin Hunter E<lt>justin.d.hunter@gmail.comE<gt>
+
+=item Kent Fredric E<lt>kentfredric@gmail.comE<gt>
+
+=item Maik Hentsche E<lt>maik.hentsche@amd.comE<gt>
+
+=item Matt Kraai E<lt>kraai@ftbfs.orgE<gt>
+
+=item Rhesa Rozendaal E<lt>rhesa@cpan.orgE<gt>
+
+=item Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
+
+=item Steffen Schwigon E<lt>ss5@renormalist.netE<gt>
+
+=item Yanick Champoux E<lt>yanick@babyl.dyndns.orgE<gt>
+
+=item Nicholas Perez E<lt>nperez@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2008, 2009 Florian Ragwitz
+
+Code based on the tests for L<Devel::Declare>.
+
+Documentation based on L<MooseX::Method> and L<Method::Signatures>.
+
+Licensed under the same terms as Perl itself.
+
+=cut
projects / catagits/Gitalist.git / blobdiff