Initial implementation of sv_numeq() and _flags() variant

10 files changed, 79 insertions, 1 deletions

diff --git a/MANIFEST b/MANIFEST
index 061b3437bd..5913e322f7 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4642,6 +4642,7 @@ ext/XS-APItest/t/stuff_modify_bug.t	test for eval side-effecting source string
 ext/XS-APItest/t/stuff_svcur_bug.t	test for a bug in lex_stuff_pvn
 ext/XS-APItest/t/subcall.t	Test XSUB calls
 ext/XS-APItest/t/subsignature.t	Test parse_subsignature()
+ext/XS-APItest/t/sv_numeq.t	Test sv_numeq
 ext/XS-APItest/t/svcat.t	Test sv_catpvn
 ext/XS-APItest/t/svcatpvf.t	Test sv_catpvf argument reordering
 ext/XS-APItest/t/sviscow.t	Test SvIsCOW
diff --git a/embed.fnc b/embed.fnc
index 74c0058c2e..c0aa472053 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1892,6 +1892,8 @@ ApdbMR	|SV*	|sv_mortalcopy	|NULLOK SV *const oldsv
 ApdR	|SV*	|sv_mortalcopy_flags|NULLOK SV *const oldsv|U32 flags
 ApdR	|SV*	|sv_newmortal
 Cpd	|SV*	|sv_newref	|NULLOK SV *const sv
+Amd	|bool	|sv_numeq	|NULLOK SV* sv1|NULLOK SV* sv2
+Apd	|bool	|sv_numeq_flags	|NULLOK SV* sv1|NULLOK SV* sv2|const U32 flags
 Ap	|char*	|sv_peek	|NULLOK SV* sv
 Apd	|void	|sv_pos_u2b	|NULLOK SV *const sv|NN I32 *const offsetp|NULLOK I32 *const lenp
 Apd	|STRLEN	|sv_pos_u2b_flags|NN SV *const sv|STRLEN uoffset \
diff --git a/embed.h b/embed.h
index 4c8bd41e96..75634e28e8 100644
--- a/embed.h
+++ b/embed.h
@@ -641,6 +641,7 @@
 #ifndef NO_MATHOMS
 #define sv_nounlocking(a)	Perl_sv_nounlocking(aTHX_ a)
 #endif
+#define sv_numeq_flags(a,b,c)	Perl_sv_numeq_flags(aTHX_ a,b,c)
 #ifndef NO_MATHOMS
 #define sv_nv(a)		Perl_sv_nv(aTHX_ a)
 #endif
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index 1abb45f685..b586c8f3cd 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '1.20';
+our $VERSION = '1.21';
 
 require XSLoader;
 
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index f0a2ca3921..c101e995d0 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -4577,6 +4577,20 @@ test_MAX_types()
     OUTPUT:
         RETVAL
 
+bool
+sv_numeq(SV *sv1, SV *sv2)
+    CODE:
+        RETVAL = sv_numeq(sv1, sv2);
+    OUTPUT:
+        RETVAL
+
+bool
+sv_numeq_flags(SV *sv1, SV *sv2, U32 flags)
+    CODE:
+        RETVAL = sv_numeq_flags(sv1, sv2, flags);
+    OUTPUT:
+        RETVAL
+
 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
 
 int
diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL
index c075db20d8..16b024e97c 100644
--- a/ext/XS-APItest/Makefile.PL
+++ b/ext/XS-APItest/Makefile.PL
@@ -25,6 +25,7 @@ my @names = (qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE
 		G_SCALAR G_LIST G_VOID G_DISCARD G_EVAL G_NOARGS
 		G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL G_RETHROW
 		GV_NOADD_NOINIT
+		SV_GMAGIC
 		IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX
 		IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY
 		IS_NUMBER_NAN IS_NUMBER_TRAILING PERL_SCAN_TRAILING
diff --git a/ext/XS-APItest/t/sv_numeq.t b/ext/XS-APItest/t/sv_numeq.t
new file mode 100644
index 0000000000..d183e67548
--- /dev/null
+++ b/ext/XS-APItest/t/sv_numeq.t
@@ -0,0 +1,17 @@
+#!perl
+
+use Test::More tests => 6;
+use XS::APItest;
+
+my $four = 4;
+ok  sv_numeq($four, 4), '$four == 4';
+ok !sv_numeq($four, 5), '$four != 5';
+
+my $six_point_five = 6.5; # an exact float, so == is fine
+ok  sv_numeq($six_point_five, 6.5), '$six_point_five == 6.5';
+ok !sv_numeq($six_point_five, 6.6), '$six_point_five == 6.6';
+
+# GMAGIC
+"10" =~ m/(\d+)/;
+ok !sv_numeq_flags($1, 10, 0), 'sv_numeq_flags with no flags does not GETMAGIC';
+ok  sv_numeq_flags($1, 10, SV_GMAGIC), 'sv_numeq_flags with SV_GMAGIC does';
diff --git a/proto.h b/proto.h
index 2a02ac0fa2..d1b24898d5 100644
--- a/proto.h
+++ b/proto.h
@@ -3641,6 +3641,10 @@ PERL_CALLCONV void	Perl_sv_nounlocking(pTHX_ SV *sv)
 #define PERL_ARGS_ASSERT_SV_NOUNLOCKING
 #endif
 
+/* PERL_CALLCONV bool	sv_numeq(pTHX_ SV* sv1, SV* sv2); */
+#define PERL_ARGS_ASSERT_SV_NUMEQ
+PERL_CALLCONV bool	Perl_sv_numeq_flags(pTHX_ SV* sv1, SV* sv2, const U32 flags);
+#define PERL_ARGS_ASSERT_SV_NUMEQ_FLAGS
 #ifndef NO_MATHOMS
 PERL_CALLCONV NV	Perl_sv_nv(pTHX_ SV* sv)
 			__attribute__deprecated__;
diff --git a/sv.c b/sv.c
index 748c5dc225..6b6ade70d1 100644
--- a/sv.c
+++ b/sv.c
@@ -8180,6 +8180,43 @@ Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
 }
 
 /*
+=for apidoc sv_numeq_flags
+
+Returns a boolean indicating whether the numbers in the two SVs are
+identical. If the flags has the C<SV_GMAGIC> bit set, it handles
+get-magic too. Will coerce its args to numbers if necessary. Treats
+C<NULL> as undef.
+
+=for apidoc sv_numeq
+
+A convenient shortcut for calling C<sv_numeq_flags> with the C<SV_GMAGIC>
+flag.
+
+=cut
+*/
+
+bool
+Perl_sv_numeq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
+{
+    PERL_ARGS_ASSERT_SV_NUMEQ_FLAGS;
+
+    if(flags & SV_GMAGIC) {
+        if(sv1)
+            SvGETMAGIC(sv1);
+        if(sv2)
+            SvGETMAGIC(sv2);
+    }
+
+    /* Treat NULL as undef */
+    if(!sv1)
+        sv1 = &PL_sv_undef;
+    if(!sv2)
+        sv2 = &PL_sv_undef;
+
+    return do_ncmp(sv1, sv2) == 0;
+}
+
+/*
 =for apidoc sv_cmp
 
 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
diff --git a/sv.h b/sv.h
index c4ee152989..9bce3ce0b2 100644
--- a/sv.h
+++ b/sv.h
@@ -2159,6 +2159,7 @@ Returns the hash for C<sv> created by C<L</newSVpvn_share>>.
 #define sv_eq(sv1, sv2) sv_eq_flags(sv1, sv2, SV_GMAGIC)
 #define sv_cmp(sv1, sv2) sv_cmp_flags(sv1, sv2, SV_GMAGIC)
 #define sv_cmp_locale(sv1, sv2) sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC)
+#define sv_numeq(sv1, sv2) sv_numeq_flags(sv1, sv2, SV_GMAGIC)
 #define sv_collxfrm(sv, nxp) sv_collxfrm_flags(sv, nxp, SV_GMAGIC)
 #define sv_2bool(sv) sv_2bool_flags(sv, SV_GMAGIC)
 #define sv_2bool_nomg(sv) sv_2bool_flags(sv, 0)