use strict;
use warnings;
use Test::More 'no_plan';
use Test::Exception;
use Test::Differences;
use_ok("Parse::Method::Signatures") or BAIL_OUT("$@");
is( Parse::Method::Signatures->new("ArrayRef")->_ident(), "ArrayRef");
is( Parse::Method::Signatures->new("where::Foo")->_ident(), "where::Foo");
is( Parse::Method::Signatures->new("where Foo")->_ident(), undef);
throws_ok {
Parse::Method::Signatures->new("Foo[Bar")->tc()
} qr/^\QRunaway '[]' in type constraint near '[Bar' at\E/,
q/Runaway '[]' in type constraint near '[Bar' at/;
throws_ok {
Parse::Method::Signatures->new("Foo[Bar:]")->tc()
} qr/^\QError parsing type constraint near ':' in 'Bar:' at\E/,
q/Error parsing type constraint near ':' in 'Bar:' at/;
is( Parse::Method::Signatures->new("ArrayRef")->tc(), "ArrayRef");
is( Parse::Method::Signatures->new("ArrayRef[Str => Str]")->tc(), 'ArrayRef["Str",Str]');
is( Parse::Method::Signatures->new("ArrayRef[Str]")->tc(), "ArrayRef[Str]");
is( Parse::Method::Signatures->new("ArrayRef[0 => Foo]")->tc(), "ArrayRef[0,Foo]");
is( Parse::Method::Signatures->new("ArrayRef[qq/0/]")->tc(), "ArrayRef[qq/0/]");
is( Parse::Method::Signatures->new("Foo|Bar")->tc(), "Foo|Bar");
lives_ok { Parse::Method::Signatures->new('$x')->param() };
throws_ok {
Parse::Method::Signatures->new('$x[0]')->param()
} qr/Error parsing parameter near '\$x' in '\$x\[0\]' at /,
q{Error parsing parameter near '\$x' in '\$x\[0\]' at };
test_param(
Parse::Method::Signatures->new('$x')->param(),
{ required => 1,
sigil => '$',
variable_name => '$x',
__does => ["Parse::Method::Signatures::Param::Positional"],
}
);
test_param(
Parse::Method::Signatures->new('$x!')->param(),
{ required => 1,
sigil => '$',
variable_name => '$x',
__does => ["Parse::Method::Signatures::Param::Positional"],
}
);
test_param(
Parse::Method::Signatures->new('$x?')->param(),
{ required => 0,
sigil => '$',
variable_name => '$x',
__does => ["Parse::Method::Signatures::Param::Positional"],
}
);
test_param(
Parse::Method::Signatures->new('@x')->param(),
{ required => 1,
sigil => '@',
variable_name => '@x',
__does => ["Parse::Method::Signatures::Param::Positional"],
}
);
test_param(
Parse::Method::Signatures->new(':$x')->param(),
{ required => 0,
sigil => '$',
variable_name => '$x',
__does => ["Parse::Method::Signatures::Param::Named"],
}
);
# ":y($x)" is an important test, as this tests the replacment of PPI's regexp operators
test_param(
Parse::Method::Signatures->new(':y($x)')->param(),
{ required => 0,
sigil => '$',
variable_name => '$x',
label => 'y',
__does => ["Parse::Method::Signatures::Param::Named"],
}
);
test_param(
Parse::Method::Signatures->new('$x?')->param(),
{ required => 0,
sigil => '$',
variable_name => '$x',
__does => ["Parse::Method::Signatures::Param::Positional"],
}
);
throws_ok {
Parse::Method::Signatures->new(':foo( [$x, @y?])')->param(),
} qr/^Cannot have optional parameters in an unpacked-array near '\@y' in '\$x, \@y\?' at /,
q/Cannot have optional parameters in an unpacked-array near '@y' in '$x, @y?' at /;
throws_ok {
Parse::Method::Signatures->new(':foo( [$x, :$y])')->param(),
} qr/^Cannot have named parameters in an unpacked-array near ':' in '\$x, :\$y' at /,
q/Cannot have named parameters in an unpacked-array near ':' in '$x, :$y' at /;
throws_ok {
Parse::Method::Signatures->new(':foo( [$x, :@y])')->param(),
} qr/^Arrays or hashes cannot be named near '\@y' in '\$x, :\@y' at /,
q/Arrays or hashes cannot be named near '@y' in '$x, :@y' at /;
throws_ok {
Parse::Method::Signatures->new(':foo( {$x, :@y])')->param(),
} qr/^Runaway '{}' in unpacked parameter near '{\$x, :\@y' at /,
q/Runaway '{}' in unpacked parameter near '{$x, :@y' at /;
test_param(
my $param = Parse::Method::Signatures->new(':foo( {:$x, @y})')->param(),
{ label => 'foo',
sigil => '$',
required => 0,
__does => ['Parse::Method::Signatures::Param::Unpacked::Hash'],
}
);
throws_ok {
Parse::Method::Signatures->new('($x = 0xfG)')->signature(),
} qr/^'\)' expected whilst parsing signature near 'G' in '\$x = 0xfG' at/,
q/')' expected whilst paring signautre near 'G' in '$x = 0xfG' at/;
test_param(
$param->params->[0],
{ required => 0,
sigil => '$',
variable_name => '$x'
}
);
test_param(
$param->params->[1],
{ required => 1,
sigil => '@',
variable_name => '@y'
}
);
#test_param(
# Parse::Method::Signatures->new(':foo( [$x, @y?])')->param(),
# { required => 1,
# sigil => '$',
# variable_name => '$x',
# label => 'y',
# __does => ["Parse::Method::Signatures::Param::Named"],
# }
#);
sub test_param {
my ($param, $wanted, $msg) = @_;
local $Test::Builder::Level = 2;
if (my $isa = delete $wanted->{__isa}) {
isa_ok($param, $isa, $msg)
or diag("@{[$param->meta->linearized_isa]}");
}
for ( @{ delete $wanted->{__does} || [] }) {
ok(0 , "Param doesn't do $_" ) && last
unless $param->does($_)
}
my $p = { %$param };
delete $p->{_trait_namespace};
delete $p->{_params};
delete $p->{__MOP__};
eq_or_diff($p, $wanted, $msg);
}