Skip to content

Commit

Permalink
Merge remote-tracking branch 'origin/master' into feature/inject_BEGIN
Browse files Browse the repository at this point in the history
  • Loading branch information
@barefootcoder
barefootcoder committed Nov 4, 2012
2 parents 751ce91 + e8626d2 commit 3f11955
Show file tree
Hide file tree
Showing 9 changed files with 496 additions and 488 deletions.
15 changes: 14 additions & 1 deletion lib/Method/Signatures.pm
View file
Expand Up @@ -1019,6 +1019,19 @@ sub named_param_error {
$class->signature_error("does not take @keys as named argument(s)");
}

# Regex to determine if a where clause is a block.
my $when_block_re = qr{
^
\s*
\{
(?:
.* ; .* | # statements separated by semicolons
(?:(?! => ). )+ # doesn't look like a hash with fat commas
)
\}
\s*
$
}xs;

sub inject_for_sig {
my $self = shift;
Expand Down Expand Up @@ -1053,7 +1066,7 @@ sub inject_for_sig {
# Handle a default value
if( defined $sig->{default_when} ) {
# Handle default with 'when { block using $_ }'
if ($sig->{default_when} =~ m{^ \s* \{ (?: .* ; .* | (?:(?! => ). )* ) \} \s* $}xs) {
if ($sig->{default_when} =~ $when_block_re) {
$rhs = "!$check_exists ? ($sig->{default}) : do{ no warnings; my \$arg = $rhs; (grep $sig->{default_when} \$arg) ? ($sig->{default}) : \$arg}";
}

Expand Down
54 changes: 54 additions & 0 deletions t/before_510.t
View file
@@ -0,0 +1,54 @@
#!/usr/bin/perl

use strict;
use warnings;

use Test::More;

plan skip_all => "This only applies to Perls before 5.10" if $] >= 5.010;

use Method::Signatures;

{
eval
q{
func neg_and_odd_and_prime ($x where [0..10]) {
return 1;
}
};

like $@, qr{\Q'where' constraint only available under Perl 5.10 or later.\E},
"Perls <5.10 properly error out on where constraints";
}

{
eval
q{
package Stuff;
use Method::Signatures;
method add($this //= 23, $that //= 42) {
return $this + $that;
}
};

like $@, qr{\Q'//=' defaults only available under Perl 5.10 or later.\E},
"Perls <5.10 properly error out on //= declaration";
}

{
eval
q{
package Stuff;
use Method::Signatures;
method add($this = 23 when '', $that = 42 when '') {
no warnings 'uninitialized';
return $this + $that;
}
};

like $@, qr{\Q'when' modifier on default only available under Perl 5.10 or later.\E},
"Perls <5.10 properly error out on 'when' conditions";
}

done_testing;
104 changes: 50 additions & 54 deletions t/block_defaults.t
View file
Expand Up @@ -5,65 +5,61 @@ use warnings;

use Test::More;

BEGIN {
plan skip_all => "Perl 5.10 or higher required to test block defaults", 1 if $] < 5.010;
}

# if we don't load it up here, we get the "Devel::Declare not loaded soon enough" error
use Method::Signatures;


SKIP:
{
skip "Perl 5.10 or higher required to test block defaults", 1 if $] < 5.010;

eval
q{
package Stuff;
use Test::More;
use Method::Signatures;
method add($this = 23 when {$_ < 23}, $that = 42 when {42 < $_}) {
return $this + $that;
}
# Check that it recognizes hashes
method add_block($this = 23 when { 2 => 'bad' }, $that = 42 when { 42 < $_ } ) {
return $this + $that;
}
# Check that it disambiguates blocks
method add_dis($this = 23 when {; 2 => 'bad' }, $that = 42 when { 42 < $_ } ) {
return $this + $that;
}
method minus($this is ro = 23 when undef, $that is ro = 42 when {($_ % 2)}) {
return $this - $that;
}
is( Stuff->add(), 23 + 42 );
is( Stuff->add(undef), 23 + 42 );
is( Stuff->add(99), 99 + 42 );
is( Stuff->add(2,3), 23 + 3 );
is( Stuff->add(24,3), 24 + 3 );
is( Stuff->add_block(), 23 + 42 );
is( Stuff->add_block(99), 99 + 42 );
is( Stuff->add_block(2,3), 23 + 3 );
is( Stuff->add_block(4,3), 4 + 3 );
is( Stuff->add_block(24,3), 24 + 3 );
is( Stuff->add_dis(), 23 + 42 );
is( Stuff->add_dis(99), 23 + 42 );
is( Stuff->add_dis(2,3), 23 + 3 );
is( Stuff->add_dis(4,3), 23 + 3 );
is( Stuff->add_dis(24,3), 23 + 3 );
is( Stuff->minus(), 23 - 42 );
is( Stuff->minus(undef), 23 - 42 );
is( Stuff->minus(99), 99 - 42 );
is( Stuff->minus(2, 3), 2 - 42 );
is( Stuff->minus(2, 4), 2 - 4 );
};
fail "can't run tests: $@" if $@;
package Stuff;

use Test::More;
use Method::Signatures;

method add($this = 23 when {$_ < 23}, $that = 42 when {42 < $_}) {
return $this + $that;
}

# Check that it recognizes hashes
method add_block($this = 23 when { 2 => 'bad' }, $that = 42 when { 42 < $_ } ) {
return $this + $that;
}

# Check that it disambiguates blocks
method add_dis($this = 23 when {; 2 => 'bad' }, $that = 42 when { 42 < $_ } ) {
return $this + $that;
}

method minus($this is ro = 23 when undef, $that is ro = 42 when {($_ % 2)}) {
return $this - $that;
}

is( Stuff->add(), 23 + 42 );
is( Stuff->add(undef), 23 + 42 );
is( Stuff->add(99), 99 + 42 );
is( Stuff->add(2,3), 23 + 3 );
is( Stuff->add(24,3), 24 + 3 );

is( Stuff->add_block(), 23 + 42 );
is( Stuff->add_block(99), 99 + 42 );
is( Stuff->add_block(2,3), 23 + 3 );
is( Stuff->add_block(4,3), 4 + 3 );
is( Stuff->add_block(24,3), 24 + 3 );

is( Stuff->add_dis(), 23 + 42 );
is( Stuff->add_dis(99), 23 + 42 );
is( Stuff->add_dis(2,3), 23 + 3 );
is( Stuff->add_dis(4,3), 23 + 3 );
is( Stuff->add_dis(24,3), 23 + 3 );

is( Stuff->minus(), 23 - 42 );
is( Stuff->minus(undef), 23 - 42 );
is( Stuff->minus(99), 99 - 42 );
is( Stuff->minus(2, 3), 2 - 42 );
is( Stuff->minus(2, 4), 2 - 4 );
}


done_testing;
143 changes: 60 additions & 83 deletions t/defined_or_defaults.t
View file
Expand Up @@ -5,114 +5,91 @@ use warnings;

use Test::More;

# if we don't load it up here, we get the "Devel::Declare not loaded soon enough" error
use Method::Signatures;


if ($] < 5.010)
{
eval
q{
package Stuff;
use Method::Signatures;
method add($this //= 23, $that //= 42) {
return $this + $that;
}
};

like $@, qr{\Q'//=' defaults only available under Perl 5.10 or later.\E},
"Perls <5.10 properly error out on //= declaration";
# Skip the test before Method::Signatures can try to compile it and blow up.
BEGIN {
plan skip_all => "Perl 5.10 or higher required to test where constraints" if $] < 5.010;
}
else
{
eval
q{
package Stuff;

use Test::More;
use Method::Signatures;
{
package Stuff;

method add($this //= 23, $that //= 42) {
return $this + $that;
}
use Test::More;
use Method::Signatures;

method minus($this is ro //= 23, $that is ro //= 42) {
return $this - $that;
}
method add($this //= 23, $that //= 42) {
return $this + $that;
}

is( Stuff->add(), 23 + 42 );
is( Stuff->add(undef), 23 + 42 );
is( Stuff->add(99), 99 + 42 );
is( Stuff->add(2,3), 5 );
method minus($this is ro //= 23, $that is ro //= 42) {
return $this - $that;
}

is( Stuff->minus(), 23 - 42 );
is( Stuff->minus(undef), 23 - 42 );
is( Stuff->minus(99), 99 - 42 );
is( Stuff->minus(2, 3), 2 - 3 );
is( Stuff->add(), 23 + 42 );
is( Stuff->add(undef), 23 + 42 );
is( Stuff->add(99), 99 + 42 );
is( Stuff->add(2,3), 5 );

is( Stuff->minus(), 23 - 42 );
is( Stuff->minus(undef), 23 - 42 );
is( Stuff->minus(99), 99 - 42 );
is( Stuff->minus(2, 3), 2 - 3 );

# Test again that undef doesn't override defaults
method echo($message //= "what?") {
return $message
}

is( Stuff->echo(), "what?" );
is( Stuff->echo(undef), "what?" );
is( Stuff->echo("who?"), 'who?' );
# Test again that undef doesn't override defaults
method echo($message //= "what?") {
return $message
}

is( Stuff->echo(), "what?" );
is( Stuff->echo(undef), "what?" );
is( Stuff->echo("who?"), 'who?' );

# Test that you can reference earlier args in a default
method copy_cat($this, $that //= $this) {
return $that;
}

is( Stuff->copy_cat("wibble"), "wibble" );
is( Stuff->copy_cat("wibble", undef), "wibble" );
is( Stuff->copy_cat(23, 42), 42 );
};
fail "can't run tests: $@" if $@;
# Test that you can reference earlier args in a default
method copy_cat($this, $that //= $this) {
return $that;
}

is( Stuff->copy_cat("wibble"), "wibble" );
is( Stuff->copy_cat("wibble", undef), "wibble" );
is( Stuff->copy_cat(23, 42), 42 );
}

eval
q{
package Bar;
use Test::More;
use Method::Signatures;
{
package Bar;
use Test::More;
use Method::Signatures;

method hello($msg //= "Hello, world!") {
return $msg;
}
method hello($msg //= "Hello, world!") {
return $msg;
}

is( Bar->hello, "Hello, world!" );
is( Bar->hello(undef), "Hello, world!" );
is( Bar->hello("Greetings!"), "Greetings!" );
is( Bar->hello, "Hello, world!" );
is( Bar->hello(undef), "Hello, world!" );
is( Bar->hello("Greetings!"), "Greetings!" );


method hi($msg //= q,Hi,) {
return $msg;
}
method hi($msg //= q,Hi,) {
return $msg;
}

is( Bar->hi, "Hi" );
is( Bar->hi(undef), "Hi" );
is( Bar->hi("Yo"), "Yo" );
is( Bar->hi, "Hi" );
is( Bar->hi(undef), "Hi" );
is( Bar->hi("Yo"), "Yo" );


method list(@args = (1,2,3) when ()) {
return @args;
}
method list(@args = (1,2,3) when ()) {
return @args;
}

is_deeply [Bar->list()], [1,2,3];
is_deeply [Bar->list()], [1,2,3];


method code($num, $code //= sub { $num + 2 }) {
return $code->();
}
method code($num, $code //= sub { $num + 2 }) {
return $code->();
}

is( Bar->code(42), 44 );
};
fail "can't run tests: $@" if $@;
is( Bar->code(42), 44 );
}


done_testing;

0 comments on commit 3f11955

Please sign in to comment.