Add tests for tryAMAGICunDEREF_var().

diff --git a/MANIFEST b/MANIFEST
index 19f375e..a6a0939 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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 e4b7fa2..1427e0d 100644 (file)
--- 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 386fda9..51e898a 100644 (file)
--- 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 6a0271a..5e2955b 100644 (file)
--- 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 (file)
index 0000000..1f7e52b
--- /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;