From 16717d448459b076eee9955b9b9923de17cbf6b5 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 19 Nov 2025 14:17:35 +1100 Subject: [PATCH 01/15] add sv_numne() to the API some refactoring next, since sv_numeq_flags and sv_numne_flags are similar. Used a separate test file since putting every sv_num*() variant in the one file would be ugly Addresses GH #23918 but isn't a direct fix --- MANIFEST | 1 + embed.fnc | 5 ++++ embed.h | 3 +++ ext/XS-APItest/APItest.xs | 6 +++++ ext/XS-APItest/t/sv_numeq.t | 8 ++++-- ext/XS-APItest/t/sv_numne.t | 35 ++++++++++++++++++++++++ proto.h | 7 +++++ sv.c | 54 +++++++++++++++++++++++++++++++++++++ sv.h | 1 + 9 files changed, 118 insertions(+), 2 deletions(-) create mode 100644 ext/XS-APItest/t/sv_numne.t diff --git a/MANIFEST b/MANIFEST index 175133ea24b7..c4942968723b 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5200,6 +5200,7 @@ 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/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 diff --git a/embed.fnc b/embed.fnc index 7f10a3cd9261..5652ffd54927 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3416,6 +3416,11 @@ Admp |bool |sv_numeq |NULLOK SV *sv1 \ Adp |bool |sv_numeq_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 diff --git a/embed.h b/embed.h index b83f2510f004..9394e6da6e14 100644 --- a/embed.h +++ b/embed.h @@ -925,6 +925,7 @@ # define sv_newref(a) Perl_sv_newref(aTHX_ a) # define sv_nosharing(a) Perl_sv_nosharing(aTHX_ a) # 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) # 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) @@ -2591,6 +2592,7 @@ # 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_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) # define Perl_sv_pvbyte(mTHX,a) sv_pvbyte(a) # define Perl_sv_pvn_force(mTHX,a,b) sv_pvn_force(a,b) @@ -2691,6 +2693,7 @@ # define Perl_sv_insert sv_insert # define Perl_sv_mortalcopy sv_mortalcopy # define Perl_sv_numeq sv_numeq +# 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 diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index aa68c1fc689f..524aedfb7d83 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -5043,6 +5043,12 @@ sv_numeq_flags(SV *sv1, SV *sv2, U32 flags) OUTPUT: RETVAL +bool +sv_numne(SV *sv1, SV *sv2) + +bool +sv_numne_flags(SV *sv1, SV *sv2, U32 flags) + bool sv_streq(SV *sv1, SV *sv2) CODE: diff --git a/ext/XS-APItest/t/sv_numeq.t b/ext/XS-APItest/t/sv_numeq.t index 6439a48d2b6b..bb8fc3aab29c 100644 --- a/ext/XS-APItest/t/sv_numeq.t +++ b/ext/XS-APItest/t/sv_numeq.t @@ -1,6 +1,6 @@ #!perl -use Test::More tests => 9; +use Test::More tests => 11; use XS::APItest; my $four = 4; @@ -9,7 +9,7 @@ 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'; +ok !sv_numeq($six_point_five, 6.6), '$six_point_five != 6.6'; # GMAGIC "10" =~ m/(\d+)/; @@ -27,6 +27,10 @@ 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' } + + diff --git a/ext/XS-APItest/t/sv_numne.t b/ext/XS-APItest/t/sv_numne.t new file mode 100644 index 000000000000..35af07300966 --- /dev/null +++ b/ext/XS-APItest/t/sv_numne.t @@ -0,0 +1,35 @@ +#!perl + +use Test::More tests => 11; +use XS::APItest; + +my $four = 4; +ok !sv_numne($four, 4), '$four != 4'; +ok sv_numne($four, 5), '$four == 5'; + +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'; + +# GMAGIC +"11" =~ m/(\d+)/; +ok sv_numne_flags($1, 11, 0), 'sv_numne_flags with no flags does not GETMAGIC'; +ok !sv_numne_flags($1, 11, SV_GMAGIC), 'sv_numne_flags with SV_GMAGIC does'; + +{ + package AlwaysTwelve { + use overload + '!=' => sub { return $_[1] != 12 }, + '0+' => sub { 11 }; + } + my $obj = bless([], "AlwaysTwelve"); + + ok !sv_numne($obj, 12), 'AlwaysTwelve is 12'; + ok sv_numne($obj, 11), 'AlwaysTwelve is not 11'; + ok !sv_numne(12, $obj), 'AlwaysTwelve is 12 on right'; + ok sv_numne(11, $obj), 'AlwayeTwelve is not 11 on the right'; + + ok !sv_numne_flags($obj, 11, SV_SKIP_OVERLOAD), 'AlwaysTwelve is 12 with SV_SKIP_OVERLOAD' +} + +done_testing(); diff --git a/proto.h b/proto.h index 95eb1aa7d501..e398ab836262 100644 --- a/proto.h +++ b/proto.h @@ -4804,6 +4804,13 @@ PERL_CALLCONV bool Perl_sv_numeq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); #define PERL_ARGS_ASSERT_SV_NUMEQ_FLAGS +/* PERL_CALLCONV bool +Perl_sv_numne(pTHX_ SV *sv1, SV *sv2); */ + +PERL_CALLCONV bool +Perl_sv_numne_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); +#define PERL_ARGS_ASSERT_SV_NUMNE_FLAGS + PERL_CALLCONV char * Perl_sv_peek(pTHX_ SV *sv); #define PERL_ARGS_ASSERT_SV_PEEK diff --git a/sv.c b/sv.c index 4e161322646f..153e711237ed 100644 --- a/sv.c +++ b/sv.c @@ -8765,6 +8765,60 @@ Perl_sv_numeq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) return do_ncmp(sv1, sv2) == 0; } +/* + +=for apidoc sv_numne +=for apidoc_item sv_numne_flags + +These each return a boolean indicating if the numbers in the two SV arguments +are different, coercing them to numbers if necessary, basically behaving like +the Perl code S>. + +A NULL SV is treated as C. + +C always performs 'get' magic. C performs 'get' +magic only if C has the C bit set. + +C always checks for, and if present, handles C overloading. If +not present, regular numerical comparison will be used instead. +C normally does the same, but setting the C +bit set in C causes it to use regular numerical comparison. + +Otherwise, the functions behave identically. + +=for apidoc Amnh||SV_SKIP_OVERLOAD + +=cut +*/ + +bool +Perl_sv_numne_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) +{ + PERL_ARGS_ASSERT_SV_NUMNE_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; + + if(!(flags & SV_SKIP_OVERLOAD) && + (SvAMAGIC(sv1) || SvAMAGIC(sv2))) { + SV *ret = amagic_call(sv1, sv2, ne_amg, 0); + if(ret) + return SvTRUE(ret); + } + + return do_ncmp(sv1, sv2) != 0; +} + /* =for apidoc sv_cmp =for apidoc_item sv_cmp_flags diff --git a/sv.h b/sv.h index 29f81f907c18..c79bcd3a62bc 100644 --- a/sv.h +++ b/sv.h @@ -2322,6 +2322,7 @@ Usually accessed via the C macro. #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_numne(sv1, sv2) sv_numne_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) From d06055fc3362aa7ca9af4eb22fa414cfeb431dc7 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 19 Nov 2025 14:40:42 +1100 Subject: [PATCH 02/15] sv.c: extract the common parts of sv_numeq_flags and sv_numne_flags --- embed.fnc | 6 ++++ embed.h | 1 + ext/XS-APItest/APItest.xs | 20 ++++++++--- ext/XS-APItest/t/sv_numeq.t | 6 +++- ext/XS-APItest/t/sv_numne.t | 6 +++- proto.h | 5 +++ sv.c | 70 +++++++++++++++++-------------------- 7 files changed, 71 insertions(+), 43 deletions(-) diff --git a/embed.fnc b/embed.fnc index 5652ffd54927..10ea39ab53ab 100644 --- a/embed.fnc +++ b/embed.fnc @@ -6057,6 +6057,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 bool *result S |STRLEN |sv_pos_b2u_midway \ |SPTR const U8 * const s \ |MPTR const U8 * const target \ diff --git a/embed.h b/embed.h index 9394e6da6e14..a3450aa67d9f 100644 --- a/embed.h +++ b/embed.h @@ -1897,6 +1897,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 diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 524aedfb7d83..88e4a565f58e 100644 --- a/ext/XS-APItest/APItest.xs +++ b/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,26 +5030,36 @@ test_HvNAMEf_QUOTEDPREFIX(sv) OUTPUT: RETVAL +TYPEMAP: < 11; +use Test::More tests => 13; use XS::APItest; my $four = 4; @@ -11,6 +11,10 @@ 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'; +# NULLs +ok sv_numeq(undef, 0), "NULL sv1"; +ok sv_numeq(0, undef), "NULL sv2"; + # GMAGIC "10" =~ m/(\d+)/; ok !sv_numeq_flags($1, 10, 0), 'sv_numeq_flags with no flags does not GETMAGIC'; diff --git a/ext/XS-APItest/t/sv_numne.t b/ext/XS-APItest/t/sv_numne.t index 35af07300966..6b3d9e20b697 100644 --- a/ext/XS-APItest/t/sv_numne.t +++ b/ext/XS-APItest/t/sv_numne.t @@ -1,6 +1,6 @@ #!perl -use Test::More tests => 11; +use Test::More tests => 13; use XS::APItest; my $four = 4; @@ -11,6 +11,10 @@ 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'; +# NULLs +ok sv_numne(undef, 1), "NULL sv1"; +ok sv_numne(1, undef), "NULL sv2"; + # GMAGIC "11" =~ m/(\d+)/; ok sv_numne_flags($1, 11, 0), 'sv_numne_flags with no flags does not GETMAGIC'; diff --git a/proto.h b/proto.h index e398ab836262..ad3f62456f83 100644 --- a/proto.h +++ b/proto.h @@ -9249,6 +9249,11 @@ S_sv_display(pTHX_ SV * const sv, char *tmpbuf, STRLEN tmpbuf_size); # define PERL_ARGS_ASSERT_SV_DISPLAY \ assert(sv); assert(tmpbuf) +STATIC bool +S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, int method, bool *result); +# define PERL_ARGS_ASSERT_SV_NUMCMP_COMMON \ + assert(result) + STATIC STRLEN S_sv_pos_b2u_midway(pTHX_ const U8 * const s, const U8 * const target, const U8 *end, STRLEN endu); # define PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY \ diff --git a/sv.c b/sv.c index 153e711237ed..a6bbc9108cbb 100644 --- a/sv.c +++ b/sv.c @@ -8711,6 +8711,33 @@ Perl_sv_streq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) return sv_eq_flags(sv1, sv2, 0); } +PERL_STATIC_INLINE bool +S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, + int method, bool *result) { + 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; + + SV *sv_result; + if(!(flags & SV_SKIP_OVERLOAD) && + (SvAMAGIC(*sv1) || SvAMAGIC(*sv2)) && + (sv_result = amagic_call(*sv1, *sv2, method, 0))) { + *result = SvTRUE(sv_result); + return true; + } + + return false; +} + /* =for apidoc sv_numeq @@ -8742,25 +8769,9 @@ 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; - - if(!(flags & SV_SKIP_OVERLOAD) && - (SvAMAGIC(sv1) || SvAMAGIC(sv2))) { - SV *ret = amagic_call(sv1, sv2, eq_amg, 0); - if(ret) - return SvTRUE(ret); - } + bool result; + if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, eq_amg, &result))) + return result; return do_ncmp(sv1, sv2) == 0; } @@ -8796,25 +8807,10 @@ Perl_sv_numne_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) { PERL_ARGS_ASSERT_SV_NUMNE_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; - if(!(flags & SV_SKIP_OVERLOAD) && - (SvAMAGIC(sv1) || SvAMAGIC(sv2))) { - SV *ret = amagic_call(sv1, sv2, ne_amg, 0); - if(ret) - return SvTRUE(ret); - } + bool result; + if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, ne_amg, &result))) + return result; return do_ncmp(sv1, sv2) != 0; } From bd4bba678c8e556fa082f87eeaa8eda489693b8f Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 19 Nov 2025 16:28:48 +1100 Subject: [PATCH 03/15] sv_numeq/sv_numne: consolidate the similar documentation If nothing else putting them together may avoid someone doing `!sv_numeq(...)` --- sv.c | 80 +++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 44 insertions(+), 36 deletions(-) diff --git a/sv.c b/sv.c index a6bbc9108cbb..826f9e62225f 100644 --- a/sv.c +++ b/sv.c @@ -8742,22 +8742,56 @@ S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, =for apidoc sv_numeq =for apidoc_item sv_numeq_flags +=for apidoc_item sv_numne +=for apidoc_item sv_numne_flags + +These return a boolean that is the result of the corresponding numeric +comparison: + +=over + +=item C -These each return a boolean indicating if the numbers in the two SV arguments -are identical, coercing them to numbers if necessary, basically behaving like -the Perl code S>. +=item C + +Numeric equality, the same as S>. + +=item C + +=item C + +Numeric inequality, the same as S>. + +=back + +Beware that in the presence of overloading C<==> may not be a strict +inverse of C. + +The non-C<_flags> suffix versions of these functions always perform +get magic and handle the appropriate type of overloading. See +L for details. + +These each return a boolean indicating if the numbers in the two SV +arguments are equal or not equal, coercing them to numbers if +necessary, basically behaving like the Perl code. A NULL SV is treated as C. -C always performs 'get' magic. C performs 'get' -magic only if C has the C bit set. +The C<_flags> variants of these functions accept these flags: -C always checks for, and if present, handles C<==> overloading. If -not present, regular numerical comparison will be used instead. -C normally does the same, but setting the C -bit set in C causes it to use regular numerical comparison. +=over -Otherwise, the functions behave identically. +=item C + +Perform 'get' magic on both C amd C if this flag is set, +otherwise 'get' magic is ignored. + +=item C + +Skip any operator overloading implemented for this type and operator. +Be aware that numeric, C<+0>, overloading will still be applied, unless in the scope of C. + +=back =for apidoc Amnh||SV_SKIP_OVERLOAD @@ -8776,32 +8810,6 @@ Perl_sv_numeq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) return do_ncmp(sv1, sv2) == 0; } -/* - -=for apidoc sv_numne -=for apidoc_item sv_numne_flags - -These each return a boolean indicating if the numbers in the two SV arguments -are different, coercing them to numbers if necessary, basically behaving like -the Perl code S>. - -A NULL SV is treated as C. - -C always performs 'get' magic. C performs 'get' -magic only if C has the C bit set. - -C always checks for, and if present, handles C overloading. If -not present, regular numerical comparison will be used instead. -C normally does the same, but setting the C -bit set in C causes it to use regular numerical comparison. - -Otherwise, the functions behave identically. - -=for apidoc Amnh||SV_SKIP_OVERLOAD - -=cut -*/ - bool Perl_sv_numne_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) { From d41101a00dfbe22df4ee5c25c1ead01a6668c632 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Tue, 25 Nov 2025 14:11:25 +1100 Subject: [PATCH 04/15] add sv_numcmp() to the API --- MANIFEST | 1 + embed.fnc | 7 ++- embed.h | 3 ++ ext/XS-APItest/APItest.xs | 6 +++ ext/XS-APItest/t/sv_numcmp.t | 65 ++++++++++++++++++++++++++ ext/XS-APItest/t/sv_numeq.t | 14 +++++- ext/XS-APItest/t/sv_numne.t | 15 ++++-- proto.h | 9 +++- sv.c | 88 ++++++++++++++++++++++++++++++++---- sv.h | 1 + 10 files changed, 195 insertions(+), 14 deletions(-) create mode 100644 ext/XS-APItest/t/sv_numcmp.t diff --git a/MANIFEST b/MANIFEST index c4942968723b..002e7a1acef4 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5199,6 +5199,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 diff --git a/embed.fnc b/embed.fnc index 10ea39ab53ab..d3045ed36917 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3411,6 +3411,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 \ @@ -6062,7 +6067,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 \ diff --git a/embed.h b/embed.h index a3450aa67d9f..a718bafcdfea 100644 --- a/embed.h +++ b/embed.h @@ -924,6 +924,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) @@ -2592,6 +2593,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) @@ -2693,6 +2695,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 diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 88e4a565f58e..4dbfa8596575 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -5061,6 +5061,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: diff --git a/ext/XS-APItest/t/sv_numcmp.t b/ext/XS-APItest/t/sv_numcmp.t new file mode 100644 index 000000000000..e54190e913a2 --- /dev/null +++ b/ext/XS-APItest/t/sv_numcmp.t @@ -0,0 +1,65 @@ +#!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: +{ + 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'; +} + diff --git a/ext/XS-APItest/t/sv_numeq.t b/ext/XS-APItest/t/sv_numeq.t index a1629e714c1b..2d5438840cf9 100644 --- a/ext/XS-APItest/t/sv_numeq.t +++ b/ext/XS-APItest/t/sv_numeq.t @@ -1,12 +1,24 @@ #!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: +{ + no warnings 'experimental'; + my $nan = eval { builtin::nan }; + defined $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'; diff --git a/ext/XS-APItest/t/sv_numne.t b/ext/XS-APItest/t/sv_numne.t index 6b3d9e20b697..f4bb16feb6de 100644 --- a/ext/XS-APItest/t/sv_numne.t +++ b/ext/XS-APItest/t/sv_numne.t @@ -1,12 +1,23 @@ #!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: +{ + no warnings 'experimental'; + my $nan = eval { builtin::nan }; + defined $nan + or skip "No NAN", 2; + 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 +46,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(); diff --git a/proto.h b/proto.h index ad3f62456f83..1480012a90e7 100644 --- a/proto.h +++ b/proto.h @@ -4797,6 +4797,13 @@ PERL_CALLCONV void Perl_sv_nosharing(pTHX_ SV *sv); #define PERL_ARGS_ASSERT_SV_NOSHARING +/* PERL_CALLCONV I32 +Perl_sv_numcmp(pTHX_ SV *sv1, SV *sv2); */ + +PERL_CALLCONV I32 +Perl_sv_numcmp_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); +#define PERL_ARGS_ASSERT_SV_NUMCMP_FLAGS + /* PERL_CALLCONV bool Perl_sv_numeq(pTHX_ SV *sv1, SV *sv2); */ @@ -9250,7 +9257,7 @@ S_sv_display(pTHX_ SV * const sv, char *tmpbuf, STRLEN tmpbuf_size); assert(sv); assert(tmpbuf) STATIC bool -S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, int method, bool *result); +S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, int method, SV **result); # define PERL_ARGS_ASSERT_SV_NUMCMP_COMMON \ assert(result) diff --git a/sv.c b/sv.c index 826f9e62225f..c3a1c1220141 100644 --- a/sv.c +++ b/sv.c @@ -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 $sv2 >>. + +A NULL SV is treated as C. + +This will return one of the following values: + +=over + +=item * + +C<1> - C is numerically greater than C + +=item * + +C<0> - C and C are numerically equal. + +=item * + +C<-1> - C is numerically less than C + +=item * + +C<2> - C and C are not numerically comparable, probably +because one of them is C, though overloads can extend that. + +=back + +C always performs 'get' magic. C performs +'get' magic on if C has the C bit set. + +C always checks for, and if present, handles C<< <=> >> +overloading. If not present, regular numerical comparison will be +used instead. +C normally does the same, but if the +C bit is set in C 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 diff --git a/sv.h b/sv.h index c79bcd3a62bc..a91c05a61c47 100644 --- a/sv.h +++ b/sv.h @@ -2323,6 +2323,7 @@ Usually accessed via the C 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) From ecff2db8c63f27bd4f055e13f2176b18910c9b28 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 26 Nov 2025 14:36:41 +1100 Subject: [PATCH 05/15] sv_num*: correctly handle "0+" overloaded values do_ncmp() expects simple SVs and for overloaded SVs will just compare the SvNV() of each SV, mishandling the case where the 0+ overload returns a large UV or IV that isn't exactly representable as an NV. # Conflicts: # ext/XS-APItest/t/sv_numeq.t # ext/XS-APItest/t/sv_numne.t # sv.c --- ext/XS-APItest/t/sv_numcmp.t | 22 +++++++++++++++++++++- ext/XS-APItest/t/sv_numeq.t | 22 +++++++++++++++++++++- ext/XS-APItest/t/sv_numne.t | 23 ++++++++++++++++++++++- sv.c | 13 +++++++++---- 4 files changed, 73 insertions(+), 7 deletions(-) diff --git a/ext/XS-APItest/t/sv_numcmp.t b/ext/XS-APItest/t/sv_numcmp.t index e54190e913a2..746b3794bd89 100644 --- a/ext/XS-APItest/t/sv_numcmp.t +++ b/ext/XS-APItest/t/sv_numcmp.t @@ -1,6 +1,6 @@ #!perl -use Test::More tests => 17; +use Test::More tests => 24; use XS::APItest; use Config; use strict; @@ -63,3 +63,23 @@ is sv_numcmp_flags($1, 10, SV_GMAGIC), 0, 'sv_numcmp_flags with SV_GMAGIC does'; '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"; +} diff --git a/ext/XS-APItest/t/sv_numeq.t b/ext/XS-APItest/t/sv_numeq.t index 2d5438840cf9..9eceefbd1f2d 100644 --- a/ext/XS-APItest/t/sv_numeq.t +++ b/ext/XS-APItest/t/sv_numeq.t @@ -1,6 +1,6 @@ #!perl -use Test::More tests => 15; +use Test::More tests => 22; use XS::APItest; use Config; @@ -49,4 +49,24 @@ ok sv_numeq_flags($1, 10, SV_GMAGIC), 'sv_numeq_flags with SV_GMAGIC does'; 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"; +} diff --git a/ext/XS-APItest/t/sv_numne.t b/ext/XS-APItest/t/sv_numne.t index f4bb16feb6de..50afaa267126 100644 --- a/ext/XS-APItest/t/sv_numne.t +++ b/ext/XS-APItest/t/sv_numne.t @@ -1,6 +1,6 @@ #!perl -use Test::More tests => 15; +use Test::More tests => 22; use XS::APItest; use Config; @@ -46,3 +46,24 @@ 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' } + +# +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 != $bigm1, "perl op still gets it right for left overload"; + ok $o1 != $o3, "perl op still gets it right for different values"; + ok !sv_numne($o1, $o2), "sv_numne two overloads"; + ok sv_numne($o1, $o3), "sv_numne two different overloads"; + ok !sv_numne($o1, $big), "sv_numne left overload"; + ok !sv_numne($bigm1, $o3), "sv_numne right overload"; +} diff --git a/sv.c b/sv.c index c3a1c1220141..54ef9fee25ab 100644 --- a/sv.c +++ b/sv.c @@ -8727,11 +8727,16 @@ S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, if(!*sv2) *sv2 = &PL_sv_undef; - /* FIXME: do_ncmp doesn't handle "+0" overloads well */ if(!(flags & SV_SKIP_OVERLOAD) && - (SvAMAGIC(*sv1) || SvAMAGIC(*sv2)) && - (*result = amagic_call(*sv1, *sv2, method, 0))) { - return true; + (SvAMAGIC(*sv1) || SvAMAGIC(*sv2))) { + if ((*result = amagic_call(*sv1, *sv2, method, 0))) + return true; + + /* normally handled by try_amagic_bin */ + if (SvROK(*sv1)) + *sv1 = sv_2num(*sv1); + if (SvROK(*sv2)) + *sv2 = sv_2num(*sv2); } return false; From 5c2ee02593cacca06d81769bc9486627d7c1a046 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Mon, 24 Nov 2025 15:01:05 +1100 Subject: [PATCH 06/15] add sv_numle(), sv_numlt(), sv_numge(), sv_numgt() APIs These are all needed because overloading may make them inconsistent with <=> overloading. --- MANIFEST | 1 + embed.fnc | 20 ++++++++ embed.h | 12 +++++ ext/XS-APItest/APItest.xs | 24 +++++++++ ext/XS-APItest/t/sv_numlget.t | 49 +++++++++++++++++++ proto.h | 28 +++++++++++ sv.c | 92 +++++++++++++++++++++++++++++++++-- sv.h | 4 ++ 8 files changed, 226 insertions(+), 4 deletions(-) create mode 100644 ext/XS-APItest/t/sv_numlget.t diff --git a/MANIFEST b/MANIFEST index 002e7a1acef4..7ef585b864b1 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5201,6 +5201,7 @@ 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 diff --git a/embed.fnc b/embed.fnc index d3045ed36917..c750d667e1ec 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3421,6 +3421,26 @@ Admp |bool |sv_numeq |NULLOK SV *sv1 \ 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 \ diff --git a/embed.h b/embed.h index a718bafcdfea..0a79cac3a9ba 100644 --- a/embed.h +++ b/embed.h @@ -926,6 +926,10 @@ # 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) @@ -2595,6 +2599,10 @@ # 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) @@ -2697,6 +2705,10 @@ # 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 diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 4dbfa8596575..b48b7b4118f5 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -5067,6 +5067,30 @@ 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: diff --git a/ext/XS-APItest/t/sv_numlget.t b/ext/XS-APItest/t/sv_numlget.t new file mode 100644 index 000000000000..e3f00a78b60a --- /dev/null +++ b/ext/XS-APItest/t/sv_numlget.t @@ -0,0 +1,49 @@ +#!perl +# tests the numeric sv_num[lg][te]() APIs + +use Test::More; +use XS::APItest; +use strict; + +# +0 overloading with large numbers and using fallback +package MyBigNum { + use overload + "0+" => sub { $_[0][0] }, + fallback => 1; +} + +my $nan = eval { + no warnings "experimental"; + builtin::nan(); +}; + +my @values = + ( + [ ~0 ], + [ ~0-1 ], + [ -int(~0/2) ], + [ 1.001 ], + [ 1.002 ], + [ bless([ ~0 ], "MyBigNum"), "bignum ~0" ], + [ bless([ ~0 ], "MyBigNum"), "bignum ~0 #2" ], + [ bless([ ~0-1 ], "MyBigNum"), "bignum ~0-1" ], + [ undef(), "undef" ], + defined $nan ? ( [ $nan, "NaN" ] ) : (), + ); + +for my $x (@values) { + for my $y (@values) { + for my $func ( [ "le", sub { $_[0] <= $_[1] }, \&sv_numle ], + [ "lt", sub { $_[0] < $_[1] }, \&sv_numlt ], + [ "ge", sub { $_[0] >= $_[1] }, \&sv_numge ], + [ "gt", sub { $_[0] > $_[1] }, \&sv_numgt ]) { + my ($op, $native, $api) = @$func; + my $lname = $x->[1] // $x->[0]; + my $rname = $y->[1] // $y->[0]; + is($api->($x->[0], $x->[1]), $native->($x->[0], $x->[1]), + "$lname $op $rname"); + } + } +} + +done_testing; diff --git a/proto.h b/proto.h index 1480012a90e7..0418c85d27cc 100644 --- a/proto.h +++ b/proto.h @@ -4811,6 +4811,34 @@ PERL_CALLCONV bool Perl_sv_numeq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); #define PERL_ARGS_ASSERT_SV_NUMEQ_FLAGS +/* PERL_CALLCONV bool +Perl_sv_numge(pTHX_ SV *sv1, SV *sv2); */ + +PERL_CALLCONV bool +Perl_sv_numge_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); +#define PERL_ARGS_ASSERT_SV_NUMGE_FLAGS + +/* PERL_CALLCONV bool +Perl_sv_numgt(pTHX_ SV *sv1, SV *sv2); */ + +PERL_CALLCONV bool +Perl_sv_numgt_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); +#define PERL_ARGS_ASSERT_SV_NUMGT_FLAGS + +/* PERL_CALLCONV bool +Perl_sv_numle(pTHX_ SV *sv1, SV *sv2); */ + +PERL_CALLCONV bool +Perl_sv_numle_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); +#define PERL_ARGS_ASSERT_SV_NUMLE_FLAGS + +/* PERL_CALLCONV bool +Perl_sv_numlt(pTHX_ SV *sv1, SV *sv2); */ + +PERL_CALLCONV bool +Perl_sv_numlt_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); +#define PERL_ARGS_ASSERT_SV_NUMLT_FLAGS + /* PERL_CALLCONV bool Perl_sv_numne(pTHX_ SV *sv1, SV *sv2); */ diff --git a/sv.c b/sv.c index 54ef9fee25ab..ce9003507345 100644 --- a/sv.c +++ b/sv.c @@ -8748,6 +8748,14 @@ S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, =for apidoc_item sv_numeq_flags =for apidoc_item sv_numne =for apidoc_item sv_numne_flags +=for apidoc_item sv_numge +=for apidoc_item sv_numge_flags +=for apidoc_item sv_numgt +=for apidoc_item sv_numgt_flags +=for apidoc_item sv_numle +=for apidoc_item sv_numle_flags +=for apidoc_item sv_numlt +=for apidoc_item sv_numlt_flags These return a boolean that is the result of the corresponding numeric comparison: @@ -8766,17 +8774,42 @@ Numeric equality, the same as S>. Numeric inequality, the same as S>. +=item C + +=item C + +Numeric less than or equal, the same as S= $sv2>>. + +=item C + +=item C + +Numeric less than, the same as S $sv2>>. + +=item C + +=item C + +Numeric greater than or equal, the same as S= $sv2>>. + +=item C + +=item C + +Numeric greater than, the same as S $sv2>>. + =back -Beware that in the presence of overloading C<==> may not be a strict -inverse of C. +Beware that in the presence of overloading the comparisons might not +have their normal properties, eg. C< sv_numeq(sv1, sv2) > might be +different to C< !sv_numne(sv1, sv2) >. The non-C<_flags> suffix versions of these functions always perform get magic and handle the appropriate type of overloading. See L for details. These each return a boolean indicating if the numbers in the two SV -arguments are equal or not equal, coercing them to numbers if +arguments satisfy the given relationship, coercing them to numbers if necessary, basically behaving like the Perl code. A NULL SV is treated as C. @@ -8819,7 +8852,6 @@ Perl_sv_numne_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) { PERL_ARGS_ASSERT_SV_NUMNE_FLAGS; - SV *result; if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, ne_amg, &result))) return SvTRUE(result); @@ -8827,6 +8859,58 @@ Perl_sv_numne_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) return do_ncmp(sv1, sv2) != 0; } +bool +Perl_sv_numle_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) +{ + PERL_ARGS_ASSERT_SV_NUMLE_FLAGS; + + SV *result; + if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, le_amg, &result))) + return SvTRUE(result); + + return do_ncmp(sv1, sv2) <= 0; +} + +bool +Perl_sv_numlt_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) +{ + PERL_ARGS_ASSERT_SV_NUMLT_FLAGS; + + SV *result; + if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, lt_amg, &result))) + return SvTRUE(result); + + return do_ncmp(sv1, sv2) < 0; +} + +bool +Perl_sv_numge_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) +{ + PERL_ARGS_ASSERT_SV_NUMGE_FLAGS; + + SV *result; + if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, ge_amg, &result))) + return SvTRUE(result); + + I32 cmp = do_ncmp(sv1, sv2); + + return cmp != 2 && cmp >= 0; +} + +bool +Perl_sv_numgt_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) +{ + PERL_ARGS_ASSERT_SV_NUMGT_FLAGS; + + SV *result; + if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, gt_amg, &result))) + return SvTRUE(result); + + I32 cmp = do_ncmp(sv1, sv2); + + return cmp != 2 && cmp > 0; +} + /* =for apidoc sv_numcmp =for apidoc_item sv_numcmp_flags diff --git a/sv.h b/sv.h index a91c05a61c47..65592bd67981 100644 --- a/sv.h +++ b/sv.h @@ -2323,6 +2323,10 @@ Usually accessed via the C 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_numle(sv1, sv2) sv_numle_flags(sv1, sv2, SV_GMAGIC) +#define sv_numlt(sv1, sv2) sv_numlt_flags(sv1, sv2, SV_GMAGIC) +#define sv_numge(sv1, sv2) sv_numge_flags(sv1, sv2, SV_GMAGIC) +#define sv_numgt(sv1, sv2) sv_numgt_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) From 2dd07a2e7fca1f23aba7e89992259301d3673849 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Fri, 28 Nov 2025 09:47:48 +1100 Subject: [PATCH 07/15] sv_numcmp_common: only call magic once if the SVs are the same similar to try_amagic_bin() --- sv.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sv.c b/sv.c index ce9003507345..9f5692c2cf77 100644 --- a/sv.c +++ b/sv.c @@ -8717,7 +8717,7 @@ S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, if(flags & SV_GMAGIC) { if(*sv1) SvGETMAGIC(*sv1); - if(*sv2) + if(*sv2 && (!*sv1 || *sv1 != *sv2)) SvGETMAGIC(*sv2); } From 09fe3a12eea2360fa8d24811ed99727292d66681 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 3 Dec 2025 09:52:23 +1100 Subject: [PATCH 08/15] add tests for void context calls to overloads Discovered while working on another module, in many amagic_call() will use the current context when calling the overload sub, but these APIs might be called in XS code that simply needs a comparison, regardless of the current OP context. --- ext/XS-APItest/APItest.xs | 8 ++++++++ ext/XS-APItest/t/sv_numne.t | 10 ++++++++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index b48b7b4118f5..f8b36a291bc7 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -5058,6 +5058,14 @@ sv_numeq_flags(nullable_SV sv1, nullable_SV sv2, U32 flags) 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) diff --git a/ext/XS-APItest/t/sv_numne.t b/ext/XS-APItest/t/sv_numne.t index 50afaa267126..1d5c9b1af1ac 100644 --- a/ext/XS-APItest/t/sv_numne.t +++ b/ext/XS-APItest/t/sv_numne.t @@ -1,6 +1,6 @@ #!perl -use Test::More tests => 22; +use Test::More tests => 24; use XS::APItest; use Config; @@ -44,7 +44,13 @@ ok !sv_numne_flags($1, 11, SV_GMAGIC), 'sv_numne_flags with SV_GMAGIC does'; ok !sv_numne(12, $obj), 'AlwaysTwelve is 12 on right'; ok sv_numne(11, $obj), 'AlwayeTwelve is not 11 on the right'; - ok !sv_numne_flags($obj, 11, SV_SKIP_OVERLOAD), 'AlwaysTwelve is 12 with SV_SKIP_OVERLOAD' + ok !sv_numne_flags($obj, 11, SV_SKIP_OVERLOAD), 'AlwaysTwelve is 12 with SV_SKIP_OVERLOAD'; + + my $result; + void_sv_numne($obj, 11, $result); + ok($result, "overloaded sv_numne() (ne) in void context"); + void_sv_numne($obj, 12, $result); + ok(!$result, "overloaded sv_numne() (eq) in void context"); } # +0 overloading with large numbers and using fallback From 0bb419d9ace4835b7d119b2d5b93f52dc4c6efb3 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 3 Dec 2025 14:34:07 +1100 Subject: [PATCH 09/15] amagic_call: accept a AMGf_force_scalar flag to force scalar context and use it from the numeric comparison APIs. --- gv.c | 15 ++++++++++++++- pp.h | 17 +++++++++-------- sv.c | 2 +- 3 files changed, 24 insertions(+), 10 deletions(-) diff --git a/gv.c b/gv.c index bfbce344cbb0..f12e7165a4d1 100644 --- a/gv.c +++ b/gv.c @@ -3748,8 +3748,20 @@ The operation is done only on just one operand. The operation changes one of the operands, e.g., $x += 1 +=item C + +In many cases amagic_call() uses the L context of the +current OP when calling the sub handling the overload. This flag +forces amagic_call() to use scalar context. + =back +=for apidoc Amnh||AMGf_noleft +=for apidoc Amnh||AMGf_noright +=for apidoc Amnh||AMGf_unary +=for apidoc Amnh||AMGf_assign +=for apidoc Amnh||AMGf_force_scalar + =cut */ @@ -4142,7 +4154,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) * with the context of individual concats being scalar, * regardless of the overall context of the multiconcat op */ - U8 gimme = (force_scalar || !PL_op || PL_op->op_type == OP_MULTICONCAT) + U8 gimme = (force_scalar || (flags & AMGf_force_scalar) + || !PL_op || PL_op->op_type == OP_MULTICONCAT) ? G_SCALAR : GIMME_V; CATCH_SET(TRUE); diff --git a/pp.h b/pp.h index c06817ddef17..c1ae8c3ad55e 100644 --- a/pp.h +++ b/pp.h @@ -653,14 +653,15 @@ Does not use C. See also C>, C> and C>. (void)Perl_tmps_grow_p(aTHX_ eMiX); \ } STMT_END -#define AMGf_noright 1 -#define AMGf_noleft 2 -#define AMGf_assign 4 /* op supports mutator variant, e.g. $x += 1 */ -#define AMGf_unary 8 -#define AMGf_numeric 0x10 /* for Perl_try_amagic_bin */ - -#define AMGf_want_list 0x40 -#define AMGf_numarg 0x80 +#define AMGf_noright 1 +#define AMGf_noleft 2 +#define AMGf_assign 4 /* op supports mutator variant, e.g. $x += 1 */ +#define AMGf_unary 8 +#define AMGf_numeric 0x0010 /* for Perl_try_amagic_bin */ + +#define AMGf_want_list 0x0040 +#define AMGf_numarg 0x0080 +#define AMGf_force_scalar 0x0100 /* do SvGETMAGIC on the stack args before checking for overload */ diff --git a/sv.c b/sv.c index 9f5692c2cf77..8e7405fbe76d 100644 --- a/sv.c +++ b/sv.c @@ -8729,7 +8729,7 @@ S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, if(!(flags & SV_SKIP_OVERLOAD) && (SvAMAGIC(*sv1) || SvAMAGIC(*sv2))) { - if ((*result = amagic_call(*sv1, *sv2, method, 0))) + if ((*result = amagic_call(*sv1, *sv2, method, AMGf_force_scalar))) return true; /* normally handled by try_amagic_bin */ From 1ce4bc0d13d6268cce62bd1ac221c1f3b44069b8 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 3 Dec 2025 14:51:11 +1100 Subject: [PATCH 10/15] pp_multiconcat: use the new AMGf_force_scalar instead of a special case in amagic_call() --- gv.c | 3 +-- pp_hot.c | 3 ++- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/gv.c b/gv.c index f12e7165a4d1..b0fcd1751a8e 100644 --- a/gv.c +++ b/gv.c @@ -4154,8 +4154,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) * with the context of individual concats being scalar, * regardless of the overall context of the multiconcat op */ - U8 gimme = (force_scalar || (flags & AMGf_force_scalar) - || !PL_op || PL_op->op_type == OP_MULTICONCAT) + U8 gimme = (force_scalar || (flags & AMGf_force_scalar) || !PL_op ) ? G_SCALAR : GIMME_V; CATCH_SET(TRUE); diff --git a/pp_hot.c b/pp_hot.c index b8ec0eb46875..ac5d2067c26b 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1377,7 +1377,8 @@ PP(pp_multiconcat) ) { SV * const tmpsv = amagic_call(left, right, concat_amg, - (nextappend ? AMGf_assign: 0)); + (nextappend ? AMGf_assign: 0) + | AMGf_force_scalar); if (tmpsv) { /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test * here, which isn't needed as any implicit From f4f735a8eb264c0c079b578c83dd1e790b436734 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Thu, 4 Dec 2025 09:58:51 +1100 Subject: [PATCH 11/15] sv_numeq etc: don't do numify overloading with SV_SKIP_OVERLOAD --- embed.fnc | 4 +++- embed.h | 8 +++++++- ext/XS-APItest/t/sv_numeq.t | 5 +++-- proto.h | 4 ++-- sv.c | 34 ++++++++++++++++++++++------------ sv.h | 5 +++++ 6 files changed, 42 insertions(+), 18 deletions(-) diff --git a/embed.fnc b/embed.fnc index c750d667e1ec..4859f73f63fc 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3410,7 +3410,7 @@ 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 \ @@ -3421,6 +3421,8 @@ Admp |bool |sv_numeq |NULLOK SV *sv1 \ 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 \ diff --git a/embed.h b/embed.h index 0a79cac3a9ba..0818d6d4dec4 100644 --- a/embed.h +++ b/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_ @@ -1383,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) @@ -2047,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 diff --git a/ext/XS-APItest/t/sv_numeq.t b/ext/XS-APItest/t/sv_numeq.t index 9eceefbd1f2d..1c242b6a284c 100644 --- a/ext/XS-APItest/t/sv_numeq.t +++ b/ext/XS-APItest/t/sv_numeq.t @@ -1,6 +1,6 @@ #!perl -use Test::More tests => 22; +use Test::More tests => 23; use XS::APItest; use Config; @@ -46,7 +46,8 @@ ok sv_numeq_flags($1, 10, SV_GMAGIC), 'sv_numeq_flags with SV_GMAGIC does'; 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' + ok !sv_numeq_flags($obj, 10, SV_SKIP_OVERLOAD), 'AlwaysTen is not 10 with SV_SKIP_OVERLOAD'; + ok !sv_numeq_flags($obj, 123456, SV_SKIP_OVERLOAD), 'AlwaysTen is not its overloaded numeric value with SV_SKIP_OVERLOAD'; } # +0 overloading with large numbers and using fallback diff --git a/proto.h b/proto.h index 0418c85d27cc..bedae005051f 100644 --- a/proto.h +++ b/proto.h @@ -4416,9 +4416,9 @@ Perl_sv_2mortal(pTHX_ SV * const sv); #define PERL_ARGS_ASSERT_SV_2MORTAL PERL_CALLCONV SV * -Perl_sv_2num(pTHX_ SV * const sv) +Perl_sv_2num_flags(pTHX_ SV * const sv, int flags) __attribute__visibility__("hidden"); -#define PERL_ARGS_ASSERT_SV_2NUM \ +#define PERL_ARGS_ASSERT_SV_2NUM_FLAGS \ assert(sv) PERL_CALLCONV NV diff --git a/sv.c b/sv.c index 8e7405fbe76d..5873cad4f9b0 100644 --- a/sv.c +++ b/sv.c @@ -2763,23 +2763,30 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) } /* -=for apidoc sv_2num +=for apidoc sv_2num_flags +=for apidoc_item sv_2num +X Return an SV with the numeric value of the source SV, doing any necessary reference or overload conversion. The caller is expected to have handled get-magic already. +For sv_2num_flags() you can set C in flags to avoid +any numeric context overloading. + =cut */ SV * -Perl_sv_2num(pTHX_ SV *const sv) +Perl_sv_2num_flags(pTHX_ SV *const sv, int flags) { - PERL_ARGS_ASSERT_SV_2NUM; + PERL_ARGS_ASSERT_SV_2NUM_FLAGS; + + assert((flags & ~SV_SKIP_OVERLOAD) == 0); if (!SvROK(sv)) return sv; - if (SvAMAGIC(sv)) { + if (SvAMAGIC(sv) && !(flags & SV_SKIP_OVERLOAD)) { SV * const tmpsv = AMG_CALLunary(sv, numer_amg); TAINT_IF(tmpsv && SvTAINTED(tmpsv)); if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) @@ -8727,16 +8734,20 @@ S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, if(!*sv2) *sv2 = &PL_sv_undef; - if(!(flags & SV_SKIP_OVERLOAD) && - (SvAMAGIC(*sv1) || SvAMAGIC(*sv2))) { - if ((*result = amagic_call(*sv1, *sv2, method, AMGf_force_scalar))) - return true; + if (SvAMAGIC(*sv1) || SvAMAGIC(*sv2)) { + if (!(flags & SV_SKIP_OVERLOAD)) { + if ((*result = amagic_call(*sv1, *sv2, method, AMGf_force_scalar))) + return true; + } - /* normally handled by try_amagic_bin */ + /* Normally handled by try_amagic_bin + This will do the normal RV to UV conversion + with SV_SKIP_OVERLOAD. + */ if (SvROK(*sv1)) - *sv1 = sv_2num(*sv1); + *sv1 = sv_2num_flags(*sv1, flags & SV_SKIP_OVERLOAD); if (SvROK(*sv2)) - *sv2 = sv_2num(*sv2); + *sv2 = sv_2num_flags(*sv2, flags & SV_SKIP_OVERLOAD); } return false; @@ -8826,7 +8837,6 @@ otherwise 'get' magic is ignored. =item C Skip any operator overloading implemented for this type and operator. -Be aware that numeric, C<+0>, overloading will still be applied, unless in the scope of C. =back diff --git a/sv.h b/sv.h index 65592bd67981..4c1102288c44 100644 --- a/sv.h +++ b/sv.h @@ -2311,6 +2311,7 @@ Usually accessed via the C macro. =cut */ +#define sv_2num(sv) sv_2num_flags(sv, 0) #define sv_2pvutf8_nolen(sv) sv_2pvutf8(sv, 0) #define sv_2pv_nomg(sv, lp) sv_2pv_flags(sv, lp, 0) #define sv_pvn_force(sv, lp) sv_pvn_force_flags(sv, lp, SV_GMAGIC) @@ -2366,6 +2367,10 @@ Usually accessed via the C macro. #define sv_catpvn_nomg_maybeutf8(dsv, sstr, len, is_utf8) \ sv_catpvn_flags(dsv, sstr, len, (is_utf8)?SV_CATUTF8:SV_CATBYTES) +#if defined(PERL_CORE) +#define sv_2num(sv) sv_2num_flags(sv, 0) +#endif + #if defined(PERL_CORE) || defined(PERL_EXT) # define sv_or_pv_len_utf8(sv, pv, bytelen) \ (SvGAMAGIC(sv) \ From 2f8d46d1fef55f2cc85b77de1562e81b6eae4a9a Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Thu, 11 Dec 2025 14:05:25 +1100 Subject: [PATCH 12/15] add SV_FORCE_OVERLOAD to the sv_numcmp() APIs and add AMGf_force_overload to amagic_call() which does the actual work. --- ext/XS-APItest/Makefile.PL | 2 +- ext/XS-APItest/t/sv_numne.t | 21 ++++++++- gv.c | 8 +++- pp.h | 15 +++++++ sv.c | 87 +++++++++++++++++++++++++++++-------- sv.h | 1 + 6 files changed, 112 insertions(+), 22 deletions(-) diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL index 479d5566d622..bf0e6a4144e8 100644 --- a/ext/XS-APItest/Makefile.PL +++ b/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 diff --git a/ext/XS-APItest/t/sv_numne.t b/ext/XS-APItest/t/sv_numne.t index 1d5c9b1af1ac..4e523ff11500 100644 --- a/ext/XS-APItest/t/sv_numne.t +++ b/ext/XS-APItest/t/sv_numne.t @@ -1,6 +1,6 @@ #!perl -use Test::More tests => 24; +use Test::More tests => 34; use XS::APItest; use Config; @@ -44,13 +44,30 @@ ok !sv_numne_flags($1, 11, SV_GMAGIC), 'sv_numne_flags with SV_GMAGIC does'; ok !sv_numne(12, $obj), 'AlwaysTwelve is 12 on right'; ok sv_numne(11, $obj), 'AlwayeTwelve is not 11 on the right'; - ok !sv_numne_flags($obj, 11, SV_SKIP_OVERLOAD), 'AlwaysTwelve is 12 with SV_SKIP_OVERLOAD'; + # neither '!=' nor '0+' overloading applies + ok sv_numne_flags($obj, 11, SV_SKIP_OVERLOAD), 'AlwaysTwelve is not 11 with SV_SKIP_OVERLOAD'; + ok sv_numne_flags($obj, 12, SV_SKIP_OVERLOAD), 'AlwaysTwelve is not 12 with SV_SKIP_OVERLOAD'; my $result; void_sv_numne($obj, 11, $result); ok($result, "overloaded sv_numne() (ne) in void context"); void_sv_numne($obj, 12, $result); ok(!$result, "overloaded sv_numne() (eq) in void context"); + + no overloading; + ok sv_numne($obj, 11), 'AlwaysTwelve is not 11 with no overloading (api)'; + ok $obj != 11, 'AlwaysTwelve is not 11 with no overloading (op)'; + + ok sv_numne($obj, 12), 'AlwaysTwelve is not 12 with no overloading (api)'; + ok $obj != 12, 'AlwaysTwelve is not 12 with no overloading (op)'; + + ok !sv_numne_flags($obj, 12, SV_FORCE_OVERLOAD), 'AlwaysTwelve is 12 with no overloading and SV_FORCE_OVERLOAD'; + use overloading; + no overloading '!='; + ok !sv_numne($obj, 11), 'AlwaysTwelve is 11 with no overloading "!=" (api)'; + ok !($obj != 11), 'AlwaysTwelve is 11 with no overloading "!=" (op)'; + ok sv_numne($obj, 12), 'AlwaysTwelve is not 12 with no overloading "!=" (api)'; + ok $obj != 12, 'AlwaysTwelve is not 12 with no overloading "!=" (op)'; } # +0 overloading with large numbers and using fallback diff --git a/gv.c b/gv.c index b0fcd1751a8e..232701e52d5b 100644 --- a/gv.c +++ b/gv.c @@ -3754,6 +3754,10 @@ In many cases amagic_call() uses the L context of the current OP when calling the sub handling the overload. This flag forces amagic_call() to use scalar context. +=item C + +Perform overloading even in the context of C. + =back =for apidoc Amnh||AMGf_noleft @@ -3761,6 +3765,7 @@ forces amagic_call() to use scalar context. =for apidoc Amnh||AMGf_unary =for apidoc Amnh||AMGf_assign =for apidoc Amnh||AMGf_force_scalar +=for apidoc Amnh||AMGf_force_overload =cut */ @@ -3785,7 +3790,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PERL_ARGS_ASSERT_AMAGIC_CALL; - if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) { + if ( (PL_curcop->cop_hints & HINT_NO_AMAGIC) + && !(flags & AMGf_force_overload)) { if (!amagic_is_enabled(method)) return NULL; } diff --git a/pp.h b/pp.h index c1ae8c3ad55e..0eb254b1c209 100644 --- a/pp.h +++ b/pp.h @@ -662,6 +662,7 @@ Does not use C. See also C>, C> and C>. #define AMGf_want_list 0x0040 #define AMGf_numarg 0x0080 #define AMGf_force_scalar 0x0100 +#define AMGf_force_overload SV_FORCE_OVERLOAD /* ignore HINTS_NO_AMAGIC */ /* do SvGETMAGIC on the stack args before checking for overload */ @@ -677,9 +678,23 @@ Does not use C. See also C>, C> and C>. return NORMAL; \ } STMT_END +/* +=for apidoc Am|SV *|AMG_CALLunary|SV *sv|int meth +=for apidoc_item |SV *|AMG_CALLunary_flags|SV *sv|int meth|int flags + +Macro wrappers around L to call any unary magic. + +Sets the C and C flags. + +=cut +*/ + #define AMG_CALLunary(sv,meth) \ amagic_call(sv,&PL_sv_undef, meth, AMGf_noright | AMGf_unary) +#define AMG_CALLunary_flags(sv,meth, flags) \ + amagic_call(sv,&PL_sv_undef, meth, AMGf_noright | AMGf_unary | (flags)) + /* No longer used in core. Use AMG_CALLunary instead */ #define AMG_CALLun(sv,meth) AMG_CALLunary(sv, CAT2(meth,_amg)) diff --git a/sv.c b/sv.c index 5873cad4f9b0..de47fff73df4 100644 --- a/sv.c +++ b/sv.c @@ -2765,14 +2765,25 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) /* =for apidoc sv_2num_flags =for apidoc_item sv_2num -X Return an SV with the numeric value of the source SV, doing any necessary reference or overload conversion. The caller is expected to have handled get-magic already. -For sv_2num_flags() you can set C in flags to avoid -any numeric context overloading. +For sv_2num_flags() you can set the following flags: + +=over + +=item * + +C - avoid any numeric context overloading. + +=item * + +C - use numeric context overloading even if +disabled in hints by C. + +=back =cut */ @@ -2782,15 +2793,18 @@ Perl_sv_2num_flags(pTHX_ SV *const sv, int flags) { PERL_ARGS_ASSERT_SV_2NUM_FLAGS; - assert((flags & ~SV_SKIP_OVERLOAD) == 0); + assert((flags & ~(SV_SKIP_OVERLOAD|SV_FORCE_OVERLOAD)) == 0); if (!SvROK(sv)) return sv; if (SvAMAGIC(sv) && !(flags & SV_SKIP_OVERLOAD)) { - SV * const tmpsv = AMG_CALLunary(sv, numer_amg); + STATIC_ASSERT_STMT(AMGf_force_overload == SV_FORCE_OVERLOAD); + SV * const tmpsv = + AMG_CALLunary_flags(sv, numer_amg, + (flags & SV_FORCE_OVERLOAD)); TAINT_IF(tmpsv && SvTAINTED(tmpsv)); if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) - return sv_2num(tmpsv); + return sv_2num_flags(tmpsv, flags); } return sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))); } @@ -8735,8 +8749,12 @@ S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, *sv2 = &PL_sv_undef; if (SvAMAGIC(*sv1) || SvAMAGIC(*sv2)) { - if (!(flags & SV_SKIP_OVERLOAD)) { - if ((*result = amagic_call(*sv1, *sv2, method, AMGf_force_scalar))) + STATIC_ASSERT_STMT(AMGf_force_overload == SV_FORCE_OVERLOAD); + if (!(flags & SV_SKIP_OVERLOAD) + || (flags & SV_FORCE_OVERLOAD)) { + int amg_flags = AMGf_force_scalar + | (flags & AMGf_force_overload); + if ((*result = amagic_call(*sv1, *sv2, method, amg_flags))) return true; } @@ -8817,7 +8835,8 @@ different to C< !sv_numne(sv1, sv2) >. The non-C<_flags> suffix versions of these functions always perform get magic and handle the appropriate type of overloading. See -L for details. +L for details. Be aware that like the builtin operators, +C will disable overloading. These each return a boolean indicating if the numbers in the two SV arguments satisfy the given relationship, coercing them to numbers if @@ -8836,11 +8855,22 @@ otherwise 'get' magic is ignored. =item C -Skip any operator overloading implemented for this type and operator. +Skip any operator or numeric overloading implemented for this type and +operator. Be aware that for overloaded values this will compare the +addresses of the references, as for the usual numeric comparison of +non-overloaded references. + +=item C + +Force overloading on even in the context of C. =back +If neither overload flag is set overloading is honored unless C has disabled it. + =for apidoc Amnh||SV_SKIP_OVERLOAD +=for apidoc Amnh||SV_FORCE_OVERLOAD =cut */ @@ -8954,15 +8984,36 @@ because one of them is C, though overloads can extend that. =back -C always performs 'get' magic. C performs -'get' magic on if C has the C bit set. +C always performs 'get' magic. + + accepts these flags: -C always checks for, and if present, handles C<< <=> >> -overloading. If not present, regular numerical comparison will be -used instead. -C normally does the same, but if the -C bit is set in C any C<< <=> >> overloading -is ignored and a regular numerical comparison is done instead. +=over + +=item * + +C - Perform 'get' magic on both C amd C if this +flag is set, otherwise 'get' magic is ignored. + +=item * + +C - If this is set any C<< <=> >> or numeric +overloading implemented for this type is ignored. Be aware that for +overloaded values this will compare the addresses of the references, +as for the usual numeric comparison of non-overloaded references. + +=item * + +C - Force overloading on even in the context of +C. + +=back + +If neither overload flag is set overloading is honored unless C has disabled it. + +=for apidoc Amnh||SV_SKIP_OVERLOAD +=for apidoc Amnh||SV_FORCE_OVERLOAD =cut */ diff --git a/sv.h b/sv.h index 4c1102288c44..4f90807deaa4 100644 --- a/sv.h +++ b/sv.h @@ -2147,6 +2147,7 @@ Returns the hash for C created by C>. #define SV_SKIP_OVERLOAD (1 << 13) /* 0x2000 - 8192 */ #define SV_CATBYTES (1 << 14) /* 0x4000 - 16384 */ #define SV_CATUTF8 (1 << 15) /* 0x8000 - 32768 */ +#define SV_FORCE_OVERLOAD (1 << 16) /* 0x10000 - 65536 */ /* sv_regex_global_pos_*() should count in bytes, not chars */ #define SV_POSBYTES SV_CATBYTES From 15e9ee5594598906c45e939b0d43a43d8eb2caa4 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Thu, 11 Dec 2025 14:06:41 +1100 Subject: [PATCH 13/15] check the void context fix for sv_numeq too --- ext/XS-APItest/APItest.xs | 8 ++++++++ ext/XS-APItest/t/sv_numeq.t | 8 +++++++- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index f8b36a291bc7..78afb3a992db 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -5055,6 +5055,14 @@ sv_numeq_flags(nullable_SV sv1, nullable_SV sv2, U32 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) diff --git a/ext/XS-APItest/t/sv_numeq.t b/ext/XS-APItest/t/sv_numeq.t index 1c242b6a284c..f789fc8668ba 100644 --- a/ext/XS-APItest/t/sv_numeq.t +++ b/ext/XS-APItest/t/sv_numeq.t @@ -1,6 +1,6 @@ #!perl -use Test::More tests => 23; +use Test::More tests => 25; use XS::APItest; use Config; @@ -48,6 +48,12 @@ ok sv_numeq_flags($1, 10, SV_GMAGIC), 'sv_numeq_flags with SV_GMAGIC does'; ok !sv_numeq_flags($obj, 10, SV_SKIP_OVERLOAD), 'AlwaysTen is not 10 with SV_SKIP_OVERLOAD'; ok !sv_numeq_flags($obj, 123456, SV_SKIP_OVERLOAD), 'AlwaysTen is not its overloaded numeric value with SV_SKIP_OVERLOAD'; + + my $result; + void_sv_numeq($obj, 10, $result); + ok($result, "overloaded sv_numeq() (eq) in void context"); + void_sv_numeq($obj, 12, $result); + ok(!$result, "overloaded sv_numeq() (ne) in void context"); } # +0 overloading with large numbers and using fallback From 9db4e168080eaea3c6f9df8782220250b7171a2b Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Thu, 27 Nov 2025 09:47:03 +1100 Subject: [PATCH 14/15] add perldelta for sv_numeq fix and other sv_num* additions modified the sv.c documentation since the perldelta sv_numeq link had multiple targets. --- pod/perldelta.pod | 32 +++++++++++++++++++++++++++++++- sv.c | 24 ++++++------------------ 2 files changed, 37 insertions(+), 19 deletions(-) diff --git a/pod/perldelta.pod b/pod/perldelta.pod index b3cc104a1ae8..723a894d1a2c 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -368,7 +368,37 @@ See GH#23967 for an example of where such a copy was noticeable. =item * -XXX +Fixed a bug in the L API where values with numeric +("0+") overloading but not equality or numeric comparison overloading +would always be compared as floating point values. This could lead to +large integers being reported as equal when they weren't. + +=item * + +Fixed a bug in L where the C flag +would skip operator overloading, but would still honor numeric ("0+") +overloading. + +=item * + +Added L, sv_numle, sv_numlt, sv_numge, sv_numgt and +L APIs that perform numeric comparison in the same +way perl does, including overloading. Separate APIs for each +comparison are needed to invoke their corresponding overload when +needed. Inspired by [GH #23918] + +This also extends the sv_numeq API to support C. + +=item * + +Added the C flag to the L> +API to force scalar context for overload calls. + +=item * + +Added the C flag to the L> +API to allow forcing overloading to be honored even in the context of +C. =back diff --git a/sv.c b/sv.c index de47fff73df4..6cbf2e784969 100644 --- a/sv.c +++ b/sv.c @@ -8791,39 +8791,27 @@ These return a boolean that is the result of the corresponding numeric =over -=item C - -=item C +=item C, C Numeric equality, the same as S>. -=item C - -=item C +=item C, C Numeric inequality, the same as S>. -=item C - -=item C +=item C, C Numeric less than or equal, the same as S= $sv2>>. -=item C - -=item C +=item C, C Numeric less than, the same as S $sv2>>. -=item C - -=item C +=item C, C Numeric greater than or equal, the same as S= $sv2>>. -=item C - -=item C +=item C, C Numeric greater than, the same as S $sv2>>. From 178011c1679060e99d900a0e2e949be08faee2e3 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Tue, 16 Dec 2025 15:31:33 +1100 Subject: [PATCH 15/15] Add some documentation for sv_numcmp_common() --- embed.fnc | 2 +- sv.c | 42 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 43 insertions(+), 1 deletion(-) diff --git a/embed.fnc b/embed.fnc index 4859f73f63fc..b1762c447fd1 100644 --- a/embed.fnc +++ b/embed.fnc @@ -6084,7 +6084,7 @@ 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 \ +Sd |bool |sv_numcmp_common \ |NULLOK SV **sv1 \ |NULLOK SV **sv2 \ |const U32 flags \ diff --git a/sv.c b/sv.c index 6cbf2e784969..f061d5399ac8 100644 --- a/sv.c +++ b/sv.c @@ -8732,6 +8732,48 @@ Perl_sv_streq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) return sv_eq_flags(sv1, sv2, 0); } +/* +=for apidoc sv_numcmp_common + +Handles the common parts of the L, sv_numne, +sv_numlt, sv_numle, sv_numge, sv_numgt, sv_numcmp APIs. + +C should be the C<*_amg> constant for the operator being +handled, such as C for numeric equality. + +C takes the same flags as the numeric comparison APIs. + +This includes: + +=over + +=item * + +treating possible NULL C<*sv1> and C<*sv2> arguments as undef. + +=item * + +calling get magic + +=item * + +handling the pain of overloading, including numericizing the SVs if +there is no numeric overload, but there is a numeric "0+" overload. + +=back + +If there is operator overloading this function will populate +C<*result> with the SV returned by the overloading and return true. +The caller will need to convert this to an integer for sv_numcmp() or +to bool for the rest of the APIs. + +If there is no operator overloading, this function will return true. +Before returning it will convert C<*sv1> and C<*sv2> to numbers if +they are references so do_cmp() can be used safely. + +=cut +*/ + PERL_STATIC_INLINE bool S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, int method, SV **result) {