Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

428 lines (299 sloc) 11.046 kb
use strict;
use warnings;
package MooseX::Method::Signatures;
use Carp qw/croak/;
use Sub::Name;
use Scope::Guard;
use Devel::Declare ();
use Perl6::Signature;
use Moose::Util::TypeConstraints ();
use MooseX::Meta::Signature::Combined;
our $VERSION = '0.05';
our ($Declarator, $Offset);
sub import {
my $caller = caller();
Devel::Declare->setup_for(
$caller,
{ method => { const => \&parser } },
);
{
no strict 'refs';
*{$caller.'::method'} = sub (&) {};
}
}
sub skip_declarator {
$Offset += Devel::Declare::toke_move_past_token($Offset);
}
sub skipspace {
$Offset += Devel::Declare::toke_skipspace($Offset);
}
sub strip_name {
skipspace;
if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
my $linestr = Devel::Declare::get_linestr();
my $name = substr($linestr, $Offset, $len);
substr($linestr, $Offset, $len) = '';
Devel::Declare::set_linestr($linestr);
return $name;
}
return;
}
sub strip_proto {
skipspace;
my $linestr = Devel::Declare::get_linestr();
if (substr($linestr, $Offset, 1) eq '(') {
my $length = Devel::Declare::toke_scan_str($Offset);
my $proto = Devel::Declare::get_lex_stuff();
Devel::Declare::clear_lex_stuff();
$linestr = Devel::Declare::get_linestr();
substr($linestr, $Offset, $length) = '';
Devel::Declare::set_linestr($linestr);
return $proto;
}
return;
}
sub shadow {
my $pack = Devel::Declare::get_curstash_name;
Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
}
sub param_to_spec {
my ($param, $required) = @_;
$required ||= 0;
my $spec = q{};
my $type;
if (my @types = @{ $param->p_types }) {
$type = join '|', @types;
$type = qq{'${type}'};
}
if (my $constraints = $param->p_constraints) {
my $cb = join ' && ', map { "sub {${_}}->(\\\@_)" } @{ $constraints };
$type = "Moose::Util::TypeConstraints::subtype(${type}, sub {${cb}})";
}
my $default = $param->p_default;
$spec .= "{";
$spec .= "required => ${required},";
$spec .= "isa => ${type}," if defined $type;
$spec .= "default => ${default}," if defined $default;
$spec .= "},";
return $spec;
}
sub parse_proto {
my ($proto) = @_;
my ($vars, $param_spec) = (q//) x 2;
my $sig = Perl6::Signature->parse(":(${proto})");
croak "Invalid method signature (${proto})"
unless $sig;
if (my $invocant = $sig->s_invocant) {
$vars .= $invocant->p_variable . q{,};
$param_spec .= param_to_spec($invocant, 1);
}
else {
$vars .= '$self,';
$param_spec .= '{ required => 1 },';
}
my $i = 1;
for my $param (@{ $sig->s_positionalList }) {
$vars .= $param->p_variable . q{,};
my $required = $i > $sig->s_requiredPositionalCount ? 0 : 1;
$param_spec .= param_to_spec($param, $required);
$i++;
}
for my $param (@{ $sig->s_namedList }) {
$vars .= $param->p_variable . q{,};
my $label = $param->p_label;
my $required = $sig->s_requiredNames->{ $label };
$param_spec .= "${label} => " . param_to_spec($param, $required);
}
return ($vars, $param_spec);
}
sub make_proto_unwrap {
my ($proto) = @_;
if (!defined $proto) {
$proto = '';
}
my ($vars, $param_spec) = parse_proto($proto);
my $inject = "my (${vars}) = MooseX::Method::Signatures::validate(\\\@_, ${param_spec});";
return $inject;
}
sub inject_if_block {
my $inject = shift;
skipspace;
my $linestr = Devel::Declare::get_linestr;
my $attrs = '';
if (substr($linestr, $Offset, 1) eq ':') {
while (substr($linestr, $Offset, 1) ne '{') {
if (substr($linestr, $Offset, 1) eq ':') {
substr($linestr, $Offset, 1) = '';
Devel::Declare::set_linestr($linestr);
$attrs .= ' :';
}
skipspace;
$linestr = Devel::Declare::get_linestr();
if (my $len = Devel::Declare::toke_scan_word($Offset, 0)) {
my $name = substr($linestr, $Offset, $len);
substr($linestr, $Offset, $len) = '';
Devel::Declare::set_linestr($linestr);
$attrs .= " ${name}";
if (substr($linestr, $Offset, 1) eq '(') {
my $length = Devel::Declare::toke_scan_str($Offset);
my $arg = Devel::Declare::get_lex_stuff();
Devel::Declare::clear_lex_stuff();
$linestr = Devel::Declare::get_linestr();
substr($linestr, $Offset, $length) = '';
Devel::Declare::set_linestr($linestr);
$attrs .= "(${arg})";
}
}
}
$linestr = Devel::Declare::get_linestr();
}
if (substr($linestr, $Offset, 1) eq '{') {
substr($linestr, $Offset + 1, 0) = $inject;
substr($linestr, $Offset, 0) = "sub ${attrs}";
Devel::Declare::set_linestr($linestr);
}
}
sub scope_injector_call {
return ' BEGIN { MooseX::Method::Signatures::inject_scope }; ';
}
sub parser {
local ($Declarator, $Offset) = @_;
skip_declarator;
my $name = strip_name;
my $proto = strip_proto;
my $inject = make_proto_unwrap($proto);
if (defined $name) {
$inject = scope_injector_call().$inject;
}
inject_if_block($inject);
if (defined $name) {
$name = join('::', Devel::Declare::get_curstash_name(), $name)
unless ($name =~ /::/);
shadow(sub (&) { no strict 'refs'; *{$name} = subname $name => shift; });
}
else {
shadow(sub (&) { shift });
}
}
sub inject_scope {
$^H |= 0x120000;
$^H{DD_METHODHANDLERS} = Scope::Guard->new(sub {
my $linestr = Devel::Declare::get_linestr;
my $offset = Devel::Declare::get_linestr_offset;
substr($linestr, $offset, 0) = ';';
Devel::Declare::set_linestr($linestr);
});
}
sub validate {
my ($args, @param_spec) = @_;
my @named = grep { !ref $_ } @param_spec;
my @ret = MooseX::Meta::Signature::Combined->new(@param_spec)->validate(@{ $args });
return @ret unless @named;
my $named_vals = pop @ret;
return (@ret, map { $named_vals->{$_} } @named);
}
1;
__END__
=head1 NAME
MooseX::Method::Signatures - Method declarations with type constraints and no source filter
=head1 SYNOPSIS
package Foo;
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 DISCLAIMER
This is B<ALPHA SOFTWARE>. Use at your own risk. Features may change.
=head1 DESCRIPTION
Provides a proper method keyword, like "sub" but specificly 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
=for later, when mx::method::signature::combined is fixed
method baz ($a , $b?, :$c , $d?) # combined
=back
=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 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 "affe"
# $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
=head2 Non-scalar parameters
Currently parameters that aren't scalars are unsupported. This is going to
change soon.
=head2 Fancy signatures
L<Perl6::Signature> is used to parse the signatures. However, some signatures
that can be parsed by it aren't supported by this module (yet).
=head2 Debugging
This totally breaks the debugger. Will have to wait on Devel::Declare fixes.
=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 surprisnigly stable.
=head2 What about regular subroutines?
L<Devel::Declare> cannot yet change the way C<sub> behaves.
=head2 What about the return value?
Currently there is no support for types or declaring the type of the return
value.
=head1 SEE ALSO
L<Method::Signatures>
L<MooseX::Method>
L<Perl6::Subs>
L<Devel::Declare>
L<Perl6::Signature>
L<Moose>
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2008 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.
=head1 AUTHOR
Florian Ragwitz E<lt>rafl@debian.orgE<gt>
=cut
Jump to Line
Something went wrong with that request. Please try again.