fix sv_numeq and add other SV numeric comparison APIs

MANIFEST

@@ -5199,7 +5199,10 @@ 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_numcmp.t			Test sv_numcmp
 ext/XS-APItest/t/sv_numeq.t			Test sv_numeq
+ext/XS-APItest/t/sv_numlget.t			Test sv_num[lg][et]
+ext/XS-APItest/t/sv_numne.t			Test sv_numne
 ext/XS-APItest/t/sv_streq.t			Test sv_streq
 ext/XS-APItest/t/svcat.t			Test sv_catpvn
 ext/XS-APItest/t/svcatpvf.t			Test sv_catpvf argument reordering

embed.fnc

@@ -3410,12 +3410,44 @@ ARdp	|SV *	|sv_newmortal
 Cdp	|SV *	|sv_newref	|NULLOK SV * const sv
 Adp	|void	|sv_nosharing	|NULLOK SV *sv
 : Used in pp.c, pp_hot.c, sv.c
-dpx	|SV *	|sv_2num	|NN SV * const sv
+dmp	|SV *	|sv_2num	|NN SV * const sv
+Admp	|I32	|sv_numcmp	|NULLOK SV *sv1 			\
+				|NULLOK SV *sv2
+Adp	|I32	|sv_numcmp_flags|NULLOK SV *sv1 			\
+				|NULLOK SV *sv2 			\
+				|const U32 flags
 Admp	|bool	|sv_numeq	|NULLOK SV *sv1 			\
 				|NULLOK SV *sv2
 Adp	|bool	|sv_numeq_flags |NULLOK SV *sv1 			\
 				|NULLOK SV *sv2 			\
 				|const U32 flags
+dpx	|SV *	|sv_2num_flags	|NN SV * const sv			\
+				|int flags
+Admp	|bool	|sv_numge	|NULLOK SV *sv1 			\
+				|NULLOK SV *sv2
+Adp	|bool	|sv_numge_flags |NULLOK SV *sv1 			\
+				|NULLOK SV *sv2 			\
+				|const U32 flags
+Admp	|bool	|sv_numgt	|NULLOK SV *sv1 			\
+				|NULLOK SV *sv2
+Adp	|bool	|sv_numgt_flags |NULLOK SV *sv1 			\
+				|NULLOK SV *sv2 			\
+				|const U32 flags
+Admp	|bool	|sv_numle	|NULLOK SV *sv1 			\
+				|NULLOK SV *sv2
+Adp	|bool	|sv_numle_flags |NULLOK SV *sv1 			\
+				|NULLOK SV *sv2 			\
+				|const U32 flags
+Admp	|bool	|sv_numlt	|NULLOK SV *sv1 			\
+				|NULLOK SV *sv2
+Adp	|bool	|sv_numlt_flags |NULLOK SV *sv1 			\
+				|NULLOK SV *sv2 			\
+				|const U32 flags
+Admp	|bool	|sv_numne	|NULLOK SV *sv1 			\
+				|NULLOK SV *sv2
+Adp	|bool	|sv_numne_flags |NULLOK SV *sv1 			\
+				|NULLOK SV *sv2 			\
+				|const U32 flags
 Adip	|NV	|SvNV		|NN SV *sv
 Adp	|NV	|sv_2nv_flags	|NN SV * const sv			\
 				|const I32 flags
@@ -6052,6 +6084,12 @@ S	|const char *|sv_display|NN SV * const sv			\
 				|NN char *tmpbuf			\
 				|STRLEN tmpbuf_size
 S	|bool	|sv_2iuv_common |NN SV * const sv
+Sd	|bool	|sv_numcmp_common					\
+				|NULLOK SV **sv1			\
+				|NULLOK SV **sv2			\
+				|const U32 flags			\
+				|int method				\
+				|NN SV **result
 S	|STRLEN |sv_pos_b2u_midway					\
 				|SPTR const U8 * const s		\
 				|MPTR const U8 * const target		\

embed.h

@@ -281,6 +281,7 @@
 #   undef case_98_SBOX32
 #   undef case_99_SBOX32
 #   undef case_9_SBOX32
+#   undef sv_2num
 #   if !defined(PERL_EXT)
 #     undef invlist_intersection_
 #     undef invlist_subtract_
@@ -924,7 +925,13 @@
 # define sv_newmortal()                         Perl_sv_newmortal(aTHX)
 # define sv_newref(a)                           Perl_sv_newref(aTHX_ a)
 # define sv_nosharing(a)                        Perl_sv_nosharing(aTHX_ a)
+# define sv_numcmp_flags(a,b,c)                 Perl_sv_numcmp_flags(aTHX_ a,b,c)
 # define sv_numeq_flags(a,b,c)                  Perl_sv_numeq_flags(aTHX_ a,b,c)
+# define sv_numge_flags(a,b,c)                  Perl_sv_numge_flags(aTHX_ a,b,c)
+# define sv_numgt_flags(a,b,c)                  Perl_sv_numgt_flags(aTHX_ a,b,c)
+# define sv_numle_flags(a,b,c)                  Perl_sv_numle_flags(aTHX_ a,b,c)
+# define sv_numlt_flags(a,b,c)                  Perl_sv_numlt_flags(aTHX_ a,b,c)
+# define sv_numne_flags(a,b,c)                  Perl_sv_numne_flags(aTHX_ a,b,c)
 # define sv_peek(a)                             Perl_sv_peek(aTHX_ a)
 # define sv_pos_b2u(a,b)                        Perl_sv_pos_b2u(aTHX_ a,b)
 # define sv_pos_b2u_flags(a,b,c)                Perl_sv_pos_b2u_flags(aTHX_ a,b,c)
@@ -1377,7 +1384,7 @@
 #   define subsignature_append_slurpy(a,b)      Perl_subsignature_append_slurpy(aTHX_ a,b)
 #   define subsignature_finish()                Perl_subsignature_finish(aTHX)
 #   define subsignature_start()                 Perl_subsignature_start(aTHX)
-#   define sv_2num(a)                           Perl_sv_2num(aTHX_ a)
+#   define sv_2num_flags(a,b)                   Perl_sv_2num_flags(aTHX_ a,b)
 #   define sv_clean_all()                       Perl_sv_clean_all(aTHX)
 #   define sv_clean_objs()                      Perl_sv_clean_objs(aTHX)
 #   define sv_del_backref(a,b)                  Perl_sv_del_backref(aTHX_ a,b)
@@ -1896,6 +1903,7 @@
 #     define sv_2iuv_common(a)                  S_sv_2iuv_common(aTHX_ a)
 #     define sv_add_arena(a,b,c)                S_sv_add_arena(aTHX_ a,b,c)
 #     define sv_display(a,b,c)                  S_sv_display(aTHX_ a,b,c)
+#     define sv_numcmp_common(a,b,c,d,e)        S_sv_numcmp_common(aTHX_ a,b,c,d,e)
 #     define sv_pos_b2u_midway(a,b,c,d)         S_sv_pos_b2u_midway(aTHX_ a,b,c,d)
 #     define sv_pos_u2b_cached(a,b,c,d,e,f,g)   S_sv_pos_u2b_cached(aTHX_ a,b,c,d,e,f,g)
 #     define sv_pos_u2b_forwards                S_sv_pos_u2b_forwards
@@ -2040,6 +2048,11 @@
 #     define quadmath_format_needed             Perl_quadmath_format_needed
 #     define quadmath_format_valid              Perl_quadmath_format_valid
 #   endif
+#   if defined(USE_THREADS)
+#     define Perl_sv_2num(mTHX,a)               sv_2num(a)
+#   else
+#     define Perl_sv_2num                       sv_2num
+#   endif
 #   if defined(WIN32)
 #     define get_win32_message_utf8ness(a)      Perl_get_win32_message_utf8ness(aTHX_ a)
 #   else
@@ -2590,7 +2603,13 @@
 #   define Perl_sv_force_normal(mTHX,a)         sv_force_normal(a)
 #   define Perl_sv_insert(mTHX,a,b,c,d,e)       sv_insert(a,b,c,d,e)
 #   define Perl_sv_mortalcopy(mTHX,a)           sv_mortalcopy(a)
+#   define Perl_sv_numcmp(mTHX,a,b)             sv_numcmp(a,b)
 #   define Perl_sv_numeq(mTHX,a,b)              sv_numeq(a,b)
+#   define Perl_sv_numge(mTHX,a,b)              sv_numge(a,b)
+#   define Perl_sv_numgt(mTHX,a,b)              sv_numgt(a,b)
+#   define Perl_sv_numle(mTHX,a,b)              sv_numle(a,b)
+#   define Perl_sv_numlt(mTHX,a,b)              sv_numlt(a,b)
+#   define Perl_sv_numne(mTHX,a,b)              sv_numne(a,b)
 #   define Perl_sv_pv(mTHX,a)                   sv_pv(a)
 #   define Perl_sv_pvbyte(mTHX,a)               sv_pvbyte(a)
 #   define Perl_sv_pvn_force(mTHX,a,b)          sv_pvn_force(a,b)
@@ -2690,7 +2709,13 @@
 #   define Perl_sv_force_normal                 sv_force_normal
 #   define Perl_sv_insert                       sv_insert
 #   define Perl_sv_mortalcopy                   sv_mortalcopy
+#   define Perl_sv_numcmp                       sv_numcmp
 #   define Perl_sv_numeq                        sv_numeq
+#   define Perl_sv_numge                        sv_numge
+#   define Perl_sv_numgt                        sv_numgt
+#   define Perl_sv_numle                        sv_numle
+#   define Perl_sv_numlt                        sv_numlt
+#   define Perl_sv_numne                        sv_numne
 #   define Perl_sv_pv                           sv_pv
 #   define Perl_sv_pvbyte                       sv_pvbyte
 #   define Perl_sv_pvn_force                    sv_pvn_force

ext/XS-APItest/APItest.xs

@@ -1640,6 +1640,8 @@ signal_thread_start(void *arg) {
 #  define hwm_checks_enabled() false
 #endif
 
+typedef SV *nullable_SV;
+
 MODULE = XS::APItest            PACKAGE = XS::APItest
 
 INCLUDE: const-xs.inc
@@ -5028,21 +5030,83 @@ test_HvNAMEf_QUOTEDPREFIX(sv)
     OUTPUT:
         RETVAL
 
+TYPEMAP: <<HERE
+
+nullable_SV	T_NULLABLE_SV
+
+INPUT
+
+T_NULLABLE_SV
+    $var = $arg == &PL_sv_undef ? NULL : $arg;
+
+HERE
 
 bool
-sv_numeq(SV *sv1, SV *sv2)
+sv_numeq(nullable_SV sv1, nullable_SV sv2)
     CODE:
         RETVAL = sv_numeq(sv1, sv2);
     OUTPUT:
         RETVAL
 
 bool
-sv_numeq_flags(SV *sv1, SV *sv2, U32 flags)
+sv_numeq_flags(nullable_SV sv1, nullable_SV sv2, U32 flags)
     CODE:
         RETVAL = sv_numeq_flags(sv1, sv2, flags);
     OUTPUT:
         RETVAL
 
+# deliberately void context
+void
+void_sv_numeq(nullable_SV sv1, nullable_SV sv2, SV *out)
+    CODE:
+        sv_setbool(out, sv_numeq(sv1, sv2));
+    OUTPUT:
+        out
+
+bool
+sv_numne(nullable_SV sv1, nullable_SV sv2)
+
+# deliberately void context
+void
+void_sv_numne(nullable_SV sv1, nullable_SV sv2, SV *out)
+    CODE:
+        sv_setbool(out, sv_numne(sv1, sv2));
+    OUTPUT:
+        out
+
+bool
+sv_numne_flags(nullable_SV sv1, nullable_SV sv2, U32 flags)
+
+I32
+sv_numcmp(nullable_SV sv1, nullable_SV sv2)
+
+I32
+sv_numcmp_flags(nullable_SV sv1, nullable_SV sv2, U32 flags)
+
+bool
+sv_numle(nullable_SV sv1, nullable_SV sv2)
+
+bool
+sv_numle_flags(nullable_SV sv1, nullable_SV sv2, U32 flags)
+
+bool
+sv_numlt(nullable_SV sv1, nullable_SV sv2)
+
+bool
+sv_numlt_flags(nullable_SV sv1, nullable_SV sv2, U32 flags)
+
+bool
+sv_numge(nullable_SV sv1, nullable_SV sv2)
+
+bool
+sv_numge_flags(nullable_SV sv1, nullable_SV sv2, U32 flags)
+
+bool
+sv_numgt(nullable_SV sv1, nullable_SV sv2)
+
+bool
+sv_numgt_flags(nullable_SV sv1, nullable_SV sv2, U32 flags)
+
 bool
 sv_streq(SV *sv1, SV *sv2)
     CODE:

ext/XS-APItest/Makefile.PL

@@ -25,7 +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 G_USEHINTS
-		SV_GMAGIC SV_SKIP_OVERLOAD SV_POSBYTES
+		SV_GMAGIC SV_SKIP_OVERLOAD SV_FORCE_OVERLOAD SV_POSBYTES
 		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

ext/XS-APItest/t/sv_numcmp.t

@@ -0,0 +1,85 @@
+#!perl
+
+use Test::More tests => 24;
+use XS::APItest;
+use Config;
+use strict;
+
+my $four = 4;
+is sv_numcmp($four, 4),  0, '$four == 4';
+is sv_numcmp($four, 5), -1, '$four < 5';
+
+is sv_numcmp(5, $four),  1, '5 > $four';
+
+SKIP:
+{
+    no warnings 'experimental';
+    my $nan = eval { builtin::nan };
+    defined $nan
+      or skip "No NAN", 2;
+    is sv_numcmp($nan, 0),    2, '$nan not comparable';
+    is sv_numcmp($nan, $nan), 2, '$nan not comparable even with itself';
+}
+
+my $six_point_five = 6.5; # an exact float, so == is fine
+is sv_numcmp($six_point_five, 6.5),  0, '$six_point_five == 6.5';
+is sv_numcmp($six_point_five, 6.6), -1, '$six_point_five < 6.6';
+
+# NULLs
+is sv_numcmp(undef, 1), -1, "NULL sv1";
+is sv_numcmp(1, undef),  1, "NULL sv2";
+
+# GMAGIC
+"10" =~ m/(\d+)/;
+is sv_numcmp_flags($1, 10, 0), -1, 'sv_numcmp_flags with no flags does not GETMAGIC';
+is sv_numcmp_flags($1, 10, SV_GMAGIC), 0, 'sv_numcmp_flags with SV_GMAGIC does';
+
+# overloading
+{
+    package AlwaysTen {
+        use overload
+            '<=>' => sub {
+                return $_[2] ? $_[1] <=> 10  : 10 <=> $_[1]
+            },
+            '0+' => sub { 123456 };
+    }
+    my $obj = bless([], "AlwaysTen");
+
+    is sv_numcmp($obj, 10),   0, 'AlwaysTen is 10';
+    is sv_numcmp($obj, 11),  -1, 'AlwaysTen is not 11';
+    is sv_numcmp(10, $obj),   0, 'AlwaysTen is 10 on the right';
+    is sv_numcmp(11, $obj),   1, 'AlwaysTen is not 11 on the right';
+
+  SKIP:
+    {
+        $Config{d_double_has_nan}
+          or skip "No NAN", 1;
+        my $nan = 0+"NaN";
+
+        is sv_numcmp($obj, $nan), 2, 'AlwaysTen vs $nan is not comparable';
+    }
+
+    is sv_numcmp_flags($obj, 10, SV_SKIP_OVERLOAD), 1,
+      'AlwaysTen is not 10 with SV_SKIP_OVERLOAD';
+}
+
+# +0 overloading with large numbers and using fallback
+{
+    my $big = ~0;
+    my $bigm1 = $big-1;
+    package MyBigNum {
+        use overload "0+" => sub { $_[0][0] },
+          fallback => 1;
+    }
+    my $o1 = bless [ $big   ], "MyBigNum";
+    my $o2 = bless [ $big   ], "MyBigNum";
+    my $o3 = bless [ $bigm1 ], "MyBigNum";
+
+    is $o1 <=> $o2,     0, "perl op gets it right";
+    is $o1 <=> $bigm1,  1, "perl op still gets it right for left overload";
+    is $o1 <=> $o3,     1, "perl op still gets it right for different values";
+    is sv_numcmp($o1, $o2),    0, "sv_numcmp two overloads";
+    is sv_numcmp($o1, $o3),    1, "sv_numcmp two different overloads";
+    is sv_numcmp($o1, $big),   0, "sv_numcmp left overload";
+    is sv_numcmp($bigm1, $o3), 0, "sv_numcmp right overload";
+}