Skip to content

Commit

Permalink
Merge pull request #96 from schwern/refactor/signature_class
Browse files Browse the repository at this point in the history 
Refactor signature parsing into its own class
  • Loading branch information
@barefootcoder
barefootcoder committed Mar 24, 2014
2 parents db41c3c + 89c73ac commit 2666fd3
Show file tree
Hide file tree
Showing 8 changed files with 429 additions and 338 deletions.
246 changes: 26 additions & 220 deletions lib/Method/Signatures.pm
View file
Expand Up @@ -5,24 +5,16 @@ use warnings;

use Lexical::SealRequireHints;
use base 'Devel::Declare::MethodInstaller::Simple';
use Method::Signatures::Parser;
use Method::Signatures::Utils;
use Method::Signatures::Parameter;
use Method::Signatures::Signature;

our $VERSION = '20140224';

our $DEBUG = $ENV{METHOD_SIGNATURES_DEBUG} || 0;

our @CARP_NOT;

our $INF = ( 0 + "inf" ) == 0 ? 9e9999 : "inf";

sub DEBUG {
return unless $DEBUG;

require Data::Dumper;
print STDERR "DEBUG: ", map { ref $_ ? Data::Dumper::Dumper($_) : $_ } @_;
}

# copied from Devel::Pragma
sub my_hints() {
$^H |= 0x20000;
Expand Down Expand Up @@ -754,12 +746,6 @@ sub _do_compile_at_BEGIN {
}


sub _strip_ws {
$_[0] =~ s/^\s+//;
$_[0] =~ s/\s+$//;
}


# Sometimes a compilation error will happen but not throw an error causing the
# code to continue compiling and producing an unrelated error down the road.
#
Expand Down Expand Up @@ -801,192 +787,16 @@ sub parse_proto {
# Before we try to compile signatures, make sure there isn't a hidden compilation error.
die $@ if _parser_is_fucked;

return $self->parse_signature(
proto => $proto,
invocant => $self->{invocant},
pre_invocant => $self->{pre_invocant}
$self->{signature} = Method::Signatures::Signature->new(
signature_string => defined $proto ? $proto : "",
invocant => $self->{invocant},
pre_invocant => $self->{pre_invocant}
);
}


# Parse a signature
sub parse_signature {
my $self = shift;
my %args = @_;
my @protos = $self->_split_proto($args{proto} || []);
my $signature = $args{signature} || {};

# JIC there's anything we need to pull out before the invocant
# (primary example would be the $orig for around modifiers in Moose/Mouse
$signature->{pre_invocant} = $args{pre_invocant};

# Special case for methods, they will pass in an invocant to use as the default
if( $signature->{invocant} = $args{invocant} ) {
if( @protos ) {
$signature->{invocant} = $_ for extract_invocant(\$protos[0]);
shift @protos unless $protos[0] =~ /\S/;
}
}

return $self->parse_func( proto => \@protos, signature => $signature );
}


sub _split_proto {
my $self = shift;
my $proto = shift;

my @protos;
if( ref $proto ) {
@protos = @$proto;
}
else {
_strip_ws($proto);
@protos = split_proto($proto);
}

return @protos;
}


# Parse a subroutine signature
sub parse_func {
my $self = shift;
my %args = @_;
my @protos = $self->_split_proto($args{proto} || []);
my $signature = $args{signature} || {};

$signature->{named} = [];
$signature->{positional} = [];
$signature->{overall} = {
num_optional => 0,
num_optional_positional => 0,
num_named => 0,
num_positional => 0,
has_invocant => $signature->{invocant} ? 1 : 0,
num_slurpy => 0
};

my $idx = 0;
for my $proto (@protos) {
DEBUG( "proto: $proto\n" );

my $sig = Method::Signatures::Parameter->new(
original_code => $proto,
position => $idx,
);
$idx++ if $sig->is_positional;

# Handle "don't care" specifier
if ($sig->is_yadayada) {
$signature->{overall}{num_slurpy}++;
$signature->{overall}{yadayada}++;
next;
}

$self->_check_sig($sig, $signature);

if( $sig->is_named ) {
push @{$signature->{named}}, $sig;
}
else {
push @{$signature->{positional}}, $sig;
}

my $overall = $signature->{overall};
$overall->{num_optional}++ if $sig->is_optional;
$overall->{num_named}++ if $sig->is_named;
$overall->{num_positional}++ if $sig->is_positional;
$overall->{num_optional_positional}++ if $sig->is_optional and $sig->is_positional;
$overall->{num_slurpy}++ if $sig->is_slurpy;

DEBUG( "sig: ", $sig );
}

$self->{signature} = $signature;

$self->_calculate_max_args;
$self->_check_signature;

# Then turn it into Perl code
my $inject = $self->inject_from_signature($signature);
return $inject;
}


sub _calculate_max_args {
my $self = shift;
my $overall = $self->{signature}{overall};

# If there's a slurpy argument, the max is infinity.
if( $overall->{num_slurpy} ) {
$overall->{max_argv_size} = $INF;
$overall->{max_args} = $INF;

return;
}

# How big can @_ be?
$overall->{max_argv_size} = ($overall->{num_named} * 2) + $overall->{num_positional};
my $inject = $self->inject_from_signature($self->{signature});

# The maximum logical arguments (name => value counts as one argument)
$overall->{max_args} = $overall->{num_named} + $overall->{num_positional};

return;
}


# Check the integrity of one piece of the signature
sub _check_sig {
my($self, $sig, $signature) = @_;

if( $sig->is_slurpy ) {
sig_parsing_error("Signature can only have one slurpy parameter")
if $signature->{overall}{num_slurpy} >= 1;
sig_parsing_error("Slurpy parameter '@{[$sig->variable]}' cannot be named; use a reference instead")
if $sig->is_named;
}

if( $sig->is_named ) {
if( $signature->{overall}{num_optional_positional} ) {
my $pos_var = $signature->{positional}[-1]->variable;
my $var = $sig->variable;
sig_parsing_error("Named parameter '$var' mixed with optional positional '$pos_var'");
}
}
else {
if( $signature->{overall}{num_named} ) {
my $named_var = $signature->{named}[-1]->variable;
my $var = $sig->variable;
sig_parsing_error("Positional parameter '$var' after named param '$named_var'");
}
}
}


# Check the integrity of the signature as a whole
sub _check_signature {
my $self = shift;
my $signature = $self->{signature};
my $overall = $signature->{overall};

# Check that slurpy arguments come at the end
if(
$overall->{num_slurpy} &&
!($overall->{yadayada} || $signature->{positional}[-1]->is_slurpy)
)
{
my($slurpy_param) = $self->_find_slurpy_params;
sig_parsing_error("Slurpy parameter '@{[$slurpy_param->variable]}' must come at the end");
}
}


sub _find_slurpy_params {
my $self = shift;
my $signature = $self->{signature};

return grep { $_->is_slurpy } @{ $signature->{named} }, @{ $signature->{positional} };
return $inject;
}


Expand All @@ -997,16 +807,16 @@ sub inject_from_signature {
my $signature = shift;

my @code;
push @code, "my $signature->{pre_invocant} = shift;" if $signature->{pre_invocant};
push @code, "my $signature->{invocant} = shift;" if $signature->{invocant};
push @code, "my @{[$signature->pre_invocant]} = shift;" if $signature->pre_invocant;
push @code, "my @{[$signature->invocant]} = shift;" if $signature->invocant;

for my $sig (@{$signature->{positional}}) {
for my $sig (@{$signature->positional_parameters}) {
push @code, $self->inject_for_sig($sig);
}

if( @{$signature->{named}} ) {
my $first_named_idx = @{$signature->{positional}};
if (grep { $_->is_ref_alias or $_->traits->{alias} } @{$signature->{named}})
if( @{$signature->named_parameters} ) {
my $first_named_idx = @{$signature->positional_parameters};
if (grep { $_->is_ref_alias or $_->traits->{alias} } @{$signature->named_parameters})
{
require Data::Alias;
push @code, "Data::Alias::alias( my (\%args) = \@_[$first_named_idx..\$#_] );";
Expand All @@ -1016,18 +826,16 @@ sub inject_from_signature {
push @code, "my (\%args) = \@_[$first_named_idx..\$#_];";
}

for my $sig (@{$signature->{named}}) {
for my $sig (@{$signature->named_parameters}) {
push @code, $self->inject_for_sig($sig);
}

push @code, $class . '->named_param_error(\%args) if keys %args;'
if $signature->{overall}{num_named} && !$signature->{overall}{yadayada};
if $signature->num_named && !$signature->num_yadayada;
}

push @code, $class . '->named_param_error(\%args) if keys %args;' if $signature->{overall}{has_named};

my $max_argv = $signature->{overall}{max_argv_size};
my $max_args = $signature->{overall}{max_args};
my $max_argv = $signature->max_argv_size;
my $max_args = $signature->max_args;
push @code, qq[$class->too_many_args_error($max_args) if \@_ > $max_argv; ]
unless $max_argv == $INF;

Expand Down Expand Up @@ -1143,16 +951,14 @@ sub inject_for_sig {
push @code, "delete( $deletion_target );" if $deletion_target;

# Handle 'where' constraints (after defaults are resolved)
if ( $sig->where ) {
for my $constraint ( keys %{$sig->where} ) {
# Handle 'where { block using $_ }'
my $constraint_impl =
$constraint =~ m{^ \s* \{ (?: .* ; .* | (?:(?! => ). )* ) \} \s* $}xs
? "sub $constraint"
: $constraint;
my $error = sprintf q{ %s->where_error(%s, '%s', '%s') }, $class, $var, $var, $constraint;
push @code, "$error unless do { no if \$] >= 5.017011, warnings => 'experimental::smartmatch'; grep { \$_ ~~ $constraint_impl } $var }; ";
}
for my $constraint ( @{$sig->where} ) {
# Handle 'where { block using $_ }'
my $constraint_impl =
$constraint =~ m{^ \s* \{ (?: .* ; .* | (?:(?! => ). )* ) \} \s* $}xs
? "sub $constraint"
: $constraint;
my $error = sprintf q{ %s->where_error(%s, '%s', '%s') }, $class, $var, $var, $constraint;
push @code, "$error unless do { no if \$] >= 5.017011, warnings => 'experimental::smartmatch'; grep { \$_ ~~ $constraint_impl } $var }; ";
}

return @code;
Expand Down

0 comments on commit 2666fd3

Please sign in to comment.