add sv_numcmp() to the API

Author: tonycoz

MANIFEST

@@ -5191,6 +5191,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_numcmp.t			Test sv_numcmp
 ext/XS-APItest/t/sv_numeq.t			Test sv_numeq
 ext/XS-APItest/t/sv_numne.t			Test sv_numne
 ext/XS-APItest/t/sv_streq.t			Test sv_streq

embed.fnc

@@ -3414,6 +3414,11 @@ 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 			\
@@ -6065,7 +6070,7 @@ S	|bool	|sv_numcmp_common					\
 				|NULLOK SV **sv2			\
 				|const U32 flags			\
 				|int method				\
-				|NN bool *result
+				|NN SV **result
 S	|STRLEN |sv_pos_b2u_midway					\
 				|SPTR const U8 * const s		\
 				|MPTR const U8 * const target		\

embed.h

@@ -726,6 +726,7 @@
 # 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_numne_flags(a,b,c)                  Perl_sv_numne_flags(aTHX_ a,b,c)
 # define sv_peek(a)                             Perl_sv_peek(aTHX_ a)
@@ -2346,6 +2347,7 @@
 #   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_numne(mTHX,a,b)              sv_numne(a,b)
 #   define Perl_sv_pv(mTHX,a)                   sv_pv(a)
@@ -2448,6 +2450,7 @@
 #   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_numne                        sv_numne
 #   define Perl_sv_pv                           sv_pv

ext/XS-APItest/APItest.xs

@@ -5038,6 +5038,12 @@ sv_numne(nullable_SV sv1, nullable_SV sv2)
 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_streq(SV *sv1, SV *sv2)
     CODE:

ext/XS-APItest/t/sv_numcmp.t

@@ -0,0 +1,64 @@
+#!perl
+
+use Test::More tests => 17;
+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';
+}
+

ext/XS-APItest/t/sv_numeq.t

@@ -1,12 +1,22 @@
 #!perl
 
-use Test::More tests => 13;
+use Test::More tests => 15;
 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';

ext/XS-APItest/t/sv_numne.t

@@ -1,12 +1,22 @@
 #!perl
 
-use Test::More tests => 13;
+use Test::More tests => 15;
 use XS::APItest;
+use Config;
 
 my $four = 4;
 ok !sv_numne($four, 4), '$four != 4';
 ok  sv_numne($four, 5), '$four == 5';
 
+SKIP:
+{
+    $Config{d_double_has_nan}
+      or skip "No NAN", 2;
+    my $nan = 0+"NaN";
+    ok  sv_numne($nan, 0),  '$nan != 0';
+    ok  sv_numne($nan, $nan), '$nan != $nan';
+}
+
 my $six_point_five = 6.5; # an exact float, so == is fine
 ok !sv_numne($six_point_five, 6.5), '$six_point_five == 6.5';
 ok  sv_numne($six_point_five, 6.6), '$six_point_five != 6.6';
@@ -35,5 +45,3 @@ ok !sv_numne_flags($1, 11, SV_GMAGIC), 'sv_numne_flags with SV_GMAGIC does';
 
     ok !sv_numne_flags($obj, 11, SV_SKIP_OVERLOAD), 'AlwaysTwelve is 12 with SV_SKIP_OVERLOAD'
 }
-
-done_testing();

proto.h

@@ -8713,7 +8713,7 @@ Perl_sv_streq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
 
 PERL_STATIC_INLINE bool
 S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags,
-                   int method, bool *result) {
+                   int method, SV **result) {
     if(flags & SV_GMAGIC) {
         if(*sv1)
             SvGETMAGIC(*sv1);
@@ -8727,11 +8727,10 @@ S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags,
     if(!*sv2)
         *sv2 = &PL_sv_undef;
 
-    SV *sv_result;
+    /* FIXME: do_ncmp doesn't handle "+0" overloads well */
     if(!(flags & SV_SKIP_OVERLOAD) &&
        (SvAMAGIC(*sv1) || SvAMAGIC(*sv2)) &&
-       (sv_result = amagic_call(*sv1, *sv2, method, 0))) {
-        *result = SvTRUE(sv_result);
+       (*result = amagic_call(*sv1, *sv2, method, 0))) {
         return true;
     }
 
@@ -8803,9 +8802,9 @@ Perl_sv_numeq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
 {
     PERL_ARGS_ASSERT_SV_NUMEQ_FLAGS;
 
-    bool result;
+    SV *result;
     if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, eq_amg, &result)))
-        return result;
+        return SvTRUE(result);
 
     return do_ncmp(sv1, sv2) == 0;
 }
@@ -8816,13 +8815,86 @@ Perl_sv_numne_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
     PERL_ARGS_ASSERT_SV_NUMNE_FLAGS;
 
 
-    bool result;
+    SV *result;
     if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, ne_amg, &result)))
-        return result;
+        return SvTRUE(result);
 
     return do_ncmp(sv1, sv2) != 0;
 }
 
+/*
+=for apidoc      sv_numcmp
+=for apidoc_item sv_numcmp_flags
+
+This returns an integer indicating the ordering of the two SV
+arguments, coercing them to numbers if necessary, basically behaving
+like the Perl code S<C<$sv1 <=> $sv2 >>.
+
+A NULL SV is treated as C<undef>.
+
+This will return one of the following values:
+
+=over
+
+=item *
+
+C<1> - C<sv2> is numerically greater than C<sv1>
+
+=item *
+
+C<0> - C<sv1> and C<sv2> are numerically equal.
+
+=item *
+
+C<-1> - C<sv2> is numerically less than C<sv1>
+
+=item *
+
+C<2> - C<sv1> and C<sv2> are not numerically comparable, probably
+because one of them is C<NaN>, though overloads can extend that.
+
+=back
+
+C<sv_numcmp> always performs 'get' magic.  C<sv_numcmp_flags> performs
+'get' magic on if C<flags> has the C<SV_GMAGIC> bit set.
+
+C<sv_numcmp> always checks for, and if present, handles C<< <=> >>
+overloading.  If not present, regular numerical comparison will be
+used instead.
+C<sv_numcmp_flags> normally does the same, but if the
+C<SV_SKIP_OVERLOAD> bit is set in C<flags> any C<< <=> >> overloading
+is ignored and a regular numerical comparison is done instead.
+
+=cut
+*/
+
+#define SANE_ORDERING_RESULT(val) \
+    ((val) < 0 ? -1 : (val) > 0 ? 1 : 0)
+
+I32
+Perl_sv_numcmp_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
+{
+    PERL_ARGS_ASSERT_SV_NUMCMP_FLAGS;
+
+    SV *result;
+    if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, ncmp_amg, &result))) {
+        /* Similar to what sort() does in amagic_ncmp() */
+        if (SvIOK(result) && !SvIsUV(result)) {
+            IV i = SvIVX(result);
+            return SANE_ORDERING_RESULT(i);
+        }
+        else if (!SvOK(result)) {
+            return 2;
+        }
+        else {
+            NV nv = SvNV(result);
+            return SANE_ORDERING_RESULT(nv);
+        }
+    }
+
+    return do_ncmp(sv1, sv2);
+}
+
 /*
 =for apidoc      sv_cmp
 =for apidoc_item sv_cmp_flags

sv.c

@@ -2323,6 +2323,7 @@ Usually accessed via the C<SvPVutf8_nolen> macro.
 #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_numne(sv1, sv2) sv_numne_flags(sv1, sv2, SV_GMAGIC)
+#define sv_numcmp(sv1, sv2) sv_numcmp_flags(sv1, sv2, SV_GMAGIC)
 #define sv_streq(sv1, sv2) sv_streq_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)