diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.pm | 2 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 14 | ||||
| -rw-r--r-- | ext/XS-APItest/Makefile.PL | 25 | ||||
| -rw-r--r-- | ext/XS-APItest/t/overload.t | 86 |
5 files changed, 118 insertions, 10 deletions
@@ -3433,6 +3433,7 @@ ext/XS-APItest/t/Null.pm Helper for ./blockhooks.t ext/XS-APItest/t/op_contextualize.t test op_contextualize() API ext/XS-APItest/t/op_list.t test OP list construction API ext/XS-APItest/t/op.t XS::APItest: tests for OP related APIs +ext/XS-APItest/t/overload.t XS::APItest: tests for overload related APIs ext/XS-APItest/t/peep.t test PL_peepp/PL_rpeepp ext/XS-APItest/t/pmflag.t Test removal of Perl_pmflag() ext/XS-APItest/t/postinc.t test op_lvalue() diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index e4b7fa22a2..1427e0dc4d 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -50,7 +50,7 @@ sub import { } } -our $VERSION = '0.25'; +our $VERSION = '0.26'; use vars '$WARNINGS_ON_BOOTSTRAP'; use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END); diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 386fda9ab6..51e898a4d2 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -913,6 +913,20 @@ INCLUDE: const-xs.inc INCLUDE: numeric.xs +MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload + +SV * +tryAMAGICunDEREF_var(sv, what) + SV *sv + int what + PPCODE: + { + SV **sp = &sv; + tryAMAGICunDEREF_var(what); + } + /* The reference is owned by something else. */ + PUSHs(sv); + MODULE = XS::APItest PACKAGE = XS::APItest::XSUB BOOT: diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL index 6a0271a913..5e2955bfd3 100644 --- a/ext/XS-APItest/Makefile.PL +++ b/ext/XS-APItest/Makefile.PL @@ -16,18 +16,25 @@ WriteMakefile( (CCFLAGS => $Config{ccflags} . ' -Wno-deprecated-declarations') : ()), ); +my @names = (qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE + HV_FETCH_ISEXISTS HV_FETCH_LVALUE HV_FETCH_JUST_SV + G_SCALAR G_ARRAY G_VOID G_DISCARD G_EVAL G_NOARGS + G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL + IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX + IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY + IS_NUMBER_NAN + ), + {name=>"G_WANT", default=>["IV", "G_ARRAY|G_VOID"]}); + +open my $fh, '../../overload.h' or die "Can't open ../../overload.h: $!"; +while (<$fh>) { + push @names, {name => $1, macro => 1} if /^\s+([A-Za-z_0-9]+_amg),/; +} + WriteConstants( PROXYSUBS => 1, NAME => 'XS::APItest', - NAMES => [qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE - HV_FETCH_ISEXISTS HV_FETCH_LVALUE HV_FETCH_JUST_SV - G_SCALAR G_ARRAY G_VOID G_DISCARD G_EVAL G_NOARGS - G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL - IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX - IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY - IS_NUMBER_NAN - ), - {name=>"G_WANT", default=>["IV", "G_ARRAY|G_VOID"]}], + NAMES => \@names, ); sub MY::install { "install ::\n" }; diff --git a/ext/XS-APItest/t/overload.t b/ext/XS-APItest/t/overload.t new file mode 100644 index 0000000000..1f7e52b8b1 --- /dev/null +++ b/ext/XS-APItest/t/overload.t @@ -0,0 +1,86 @@ +#!perl -w + +use strict; +use Test::More; + +BEGIN {use_ok('XS::APItest')}; +my (%sigils); +BEGIN { + %sigils = ( + '$' => 'sv', + '@' => 'av', + '%' => 'hv', + '&' => 'cv', + '*' => 'gv' + ); +} +my %types = map {$_, eval "&to_${_}_amg()"} values %sigils; + +{ + package None; +} + +{ + package Other; + use overload 'eq' => sub {no overloading; $_[0] == $_[1]}, + '""' => sub {no overloading; "$_[0]"}, + '~' => sub {return "Perl rules"}; +} + +{ + package Same; + use overload 'eq' => sub {no overloading; $_[0] == $_[1]}, + '""' => sub {no overloading; "$_[0]"}, + map {$_ . '{}', sub {return $_[0]}} keys %sigils; +} + +{ + package Chain; + use overload 'eq' => sub {no overloading; $_[0] == $_[1]}, + '""' => sub {no overloading; "$_[0]"}, + map {$_ . '{}', sub {no overloading; return $_[0][0]}} keys %sigils; +} + +my @non_ref = (['undef', undef], + ['number', 42], + ['string', 'Pie'], + ); + +my @ref = (['unblessed SV', do {\my $whap}], + ['unblessed AV', []], + ['unblessed HV', {}], + ['unblessed CV', sub {}], + ['unblessed GV', \*STDOUT], + ['no overloading', bless {}, 'None'], + ['other overloading', bless {}, 'Other'], + ['same overloading', bless {}, 'Same'], + ); + +while (my ($type, $enum) = each %types) { + foreach (@non_ref, @ref, + ) { + my ($desc, $input) = @$_; + my $got = tryAMAGICunDEREF_var($input, $enum); + is($got, $input, "Expect no change for to_$type $desc"); + } + foreach (@non_ref) { + my ($desc, $sucker) = @$_; + my $input = bless [$sucker], 'Chain'; + is(eval {tryAMAGICunDEREF_var($input, $enum)}, undef, + "Chain to $desc for to_$type"); + like($@, qr/Overloaded dereference did not return a reference/, + 'expected error'); + } + foreach (@ref, + ) { + my ($desc, $sucker) = @$_; + my $input = bless [$sucker], 'Chain'; + my $got = tryAMAGICunDEREF_var($input, $enum); + is($got, $sucker, "Chain to $desc for to_$type"); + $input = bless [bless [$sucker], 'Chain'], 'Chain'; + my $got = tryAMAGICunDEREF_var($input, $enum); + is($got, $sucker, "Chain to chain to $desc for to_$type"); + } +} + +done_testing; |