fix sv_numeq and add other SV numeric comparison APIs

MANIFEST

@@ -5191,7 +5191,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

@@ -3414,11 +3414,41 @@ 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
+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
+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
@@ -6055,6 +6085,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
+S	|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

@@ -726,7 +726,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)
@@ -1685,6 +1691,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
@@ -2344,7 +2351,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)
@@ -2445,7 +2458,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.pm

@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '1.47';
+our $VERSION = '1.48';
 
 require XSLoader;
 

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
@@ -5005,21 +5007,75 @@ 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
 
+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/t/sv_numcmp.t

@@ -0,0 +1,84 @@
+#!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:
+{
+    $Config{d_double_has_nan}
+      or skip "No NAN", 2;
+    my $nan = 0+"NaN";
+    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_numecmp_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";
+}

ext/XS-APItest/t/sv_numeq.t

@@ -1,15 +1,29 @@
 #!perl
 
-use Test::More tests => 9;
+use Test::More tests => 22;
 use XS::APItest;
+use Config;
 
 my $four = 4;
 ok  sv_numeq($four, 4), '$four == 4';
 ok !sv_numeq($four, 5), '$four != 5';
 
+SKIP:
+{
+    $Config{d_double_has_nan}
+      or skip "No NAN", 2;
+    my $nan = 0+"NaN";
+    ok !sv_numeq($nan, 0),  '$nan != 0';
+    ok !sv_numeq($nan, $nan), '$nan != $nan';
+}
+
 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';
+ok !sv_numeq($six_point_five, 6.6), '$six_point_five != 6.6';
+
+# NULLs
+ok sv_numeq(undef, 0), "NULL sv1";
+ok sv_numeq(0, undef), "NULL sv2";
 
 # GMAGIC
 "10" =~ m/(\d+)/;
@@ -27,6 +41,30 @@ ok  sv_numeq_flags($1, 10, SV_GMAGIC), 'sv_numeq_flags with SV_GMAGIC does';
 
     ok  sv_numeq($obj, 10), 'AlwaysTen is 10';
     ok !sv_numeq($obj, 11), 'AlwaysTen is not 11';
+    ok  sv_numeq(10, $obj), 'AlwaysTen is 10 on the right';
+    ok !sv_numeq(11, $obj), 'AlwaysTen is not 11 on the right';
 
     ok !sv_numeq_flags($obj, 10, SV_SKIP_OVERLOAD), '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";
+
+    ok $o1 == $o2, "perl op gets it right";
+    ok $o1 == $big, "perl op still gets it right for left overload";
+    ok !($o1 == $o3), "perl op still gets it right for different values";
+    ok sv_numeq($o1, $o2), "sv_numeq two overloads";
+    ok !sv_numeq($o1, $o3), "sv_numeq two different overloads"
+      or diag sprintf "%x vs %x", $o1, $o3;
+    ok sv_numeq($o1, $big), "sv_numeq left overload";
+    ok sv_numeq($bigm1, $o3), "sv_numeq right overload";
+}