diff --git a/MANIFEST b/MANIFEST index 175133ea24b7..7ef585b864b1 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5199,7 +5199,10 @@ ext/XS-APItest/t/stuff_modify_bug.t test for eval side-effecting source string ext/XS-APItest/t/stuff_svcur_bug.t test for a bug in lex_stuff_pvn ext/XS-APItest/t/subcall.t Test XSUB calls ext/XS-APItest/t/subsignature.t Test parse_subsignature() +ext/XS-APItest/t/sv_numcmp.t Test sv_numcmp ext/XS-APItest/t/sv_numeq.t Test sv_numeq +ext/XS-APItest/t/sv_numlget.t Test sv_num[lg][et] +ext/XS-APItest/t/sv_numne.t Test sv_numne ext/XS-APItest/t/sv_streq.t Test sv_streq ext/XS-APItest/t/svcat.t Test sv_catpvn ext/XS-APItest/t/svcatpvf.t Test sv_catpvf argument reordering diff --git a/embed.fnc b/embed.fnc index 7f10a3cd9261..b1762c447fd1 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3410,12 +3410,44 @@ ARdp |SV * |sv_newmortal Cdp |SV * |sv_newref |NULLOK SV * const sv Adp |void |sv_nosharing |NULLOK SV *sv : Used in pp.c, pp_hot.c, sv.c -dpx |SV * |sv_2num |NN SV * const sv +dmp |SV * |sv_2num |NN SV * const sv +Admp |I32 |sv_numcmp |NULLOK SV *sv1 \ + |NULLOK SV *sv2 +Adp |I32 |sv_numcmp_flags|NULLOK SV *sv1 \ + |NULLOK SV *sv2 \ + |const U32 flags Admp |bool |sv_numeq |NULLOK SV *sv1 \ |NULLOK SV *sv2 Adp |bool |sv_numeq_flags |NULLOK SV *sv1 \ |NULLOK SV *sv2 \ |const U32 flags +dpx |SV * |sv_2num_flags |NN SV * const sv \ + |int flags +Admp |bool |sv_numge |NULLOK SV *sv1 \ + |NULLOK SV *sv2 +Adp |bool |sv_numge_flags |NULLOK SV *sv1 \ + |NULLOK SV *sv2 \ + |const U32 flags +Admp |bool |sv_numgt |NULLOK SV *sv1 \ + |NULLOK SV *sv2 +Adp |bool |sv_numgt_flags |NULLOK SV *sv1 \ + |NULLOK SV *sv2 \ + |const U32 flags +Admp |bool |sv_numle |NULLOK SV *sv1 \ + |NULLOK SV *sv2 +Adp |bool |sv_numle_flags |NULLOK SV *sv1 \ + |NULLOK SV *sv2 \ + |const U32 flags +Admp |bool |sv_numlt |NULLOK SV *sv1 \ + |NULLOK SV *sv2 +Adp |bool |sv_numlt_flags |NULLOK SV *sv1 \ + |NULLOK SV *sv2 \ + |const U32 flags +Admp |bool |sv_numne |NULLOK SV *sv1 \ + |NULLOK SV *sv2 +Adp |bool |sv_numne_flags |NULLOK SV *sv1 \ + |NULLOK SV *sv2 \ + |const U32 flags Adip |NV |SvNV |NN SV *sv Adp |NV |sv_2nv_flags |NN SV * const sv \ |const I32 flags @@ -6052,6 +6084,12 @@ S |const char *|sv_display|NN SV * const sv \ |NN char *tmpbuf \ |STRLEN tmpbuf_size S |bool |sv_2iuv_common |NN SV * const sv +Sd |bool |sv_numcmp_common \ + |NULLOK SV **sv1 \ + |NULLOK SV **sv2 \ + |const U32 flags \ + |int method \ + |NN SV **result S |STRLEN |sv_pos_b2u_midway \ |SPTR const U8 * const s \ |MPTR const U8 * const target \ diff --git a/embed.h b/embed.h index b83f2510f004..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_ @@ -924,7 +925,13 @@ # define sv_newmortal() Perl_sv_newmortal(aTHX) # define sv_newref(a) Perl_sv_newref(aTHX_ a) # define sv_nosharing(a) Perl_sv_nosharing(aTHX_ a) +# define sv_numcmp_flags(a,b,c) Perl_sv_numcmp_flags(aTHX_ a,b,c) # define sv_numeq_flags(a,b,c) Perl_sv_numeq_flags(aTHX_ a,b,c) +# define sv_numge_flags(a,b,c) Perl_sv_numge_flags(aTHX_ a,b,c) +# define sv_numgt_flags(a,b,c) Perl_sv_numgt_flags(aTHX_ a,b,c) +# define sv_numle_flags(a,b,c) Perl_sv_numle_flags(aTHX_ a,b,c) +# define sv_numlt_flags(a,b,c) Perl_sv_numlt_flags(aTHX_ a,b,c) +# define sv_numne_flags(a,b,c) Perl_sv_numne_flags(aTHX_ a,b,c) # define sv_peek(a) Perl_sv_peek(aTHX_ a) # define sv_pos_b2u(a,b) Perl_sv_pos_b2u(aTHX_ a,b) # define sv_pos_b2u_flags(a,b,c) Perl_sv_pos_b2u_flags(aTHX_ a,b,c) @@ -1377,7 +1384,7 @@ # define subsignature_append_slurpy(a,b) Perl_subsignature_append_slurpy(aTHX_ a,b) # define subsignature_finish() Perl_subsignature_finish(aTHX) # define subsignature_start() Perl_subsignature_start(aTHX) -# define sv_2num(a) Perl_sv_2num(aTHX_ a) +# define sv_2num_flags(a,b) Perl_sv_2num_flags(aTHX_ a,b) # define sv_clean_all() Perl_sv_clean_all(aTHX) # define sv_clean_objs() Perl_sv_clean_objs(aTHX) # define sv_del_backref(a,b) Perl_sv_del_backref(aTHX_ a,b) @@ -1896,6 +1903,7 @@ # define sv_2iuv_common(a) S_sv_2iuv_common(aTHX_ a) # define sv_add_arena(a,b,c) S_sv_add_arena(aTHX_ a,b,c) # define sv_display(a,b,c) S_sv_display(aTHX_ a,b,c) +# define sv_numcmp_common(a,b,c,d,e) S_sv_numcmp_common(aTHX_ a,b,c,d,e) # define sv_pos_b2u_midway(a,b,c,d) S_sv_pos_b2u_midway(aTHX_ a,b,c,d) # define sv_pos_u2b_cached(a,b,c,d,e,f,g) S_sv_pos_u2b_cached(aTHX_ a,b,c,d,e,f,g) # define sv_pos_u2b_forwards S_sv_pos_u2b_forwards @@ -2040,6 +2048,11 @@ # define quadmath_format_needed Perl_quadmath_format_needed # define quadmath_format_valid Perl_quadmath_format_valid # endif +# if defined(USE_THREADS) +# define Perl_sv_2num(mTHX,a) sv_2num(a) +# else +# define Perl_sv_2num sv_2num +# endif # if defined(WIN32) # define get_win32_message_utf8ness(a) Perl_get_win32_message_utf8ness(aTHX_ a) # else @@ -2590,7 +2603,13 @@ # define Perl_sv_force_normal(mTHX,a) sv_force_normal(a) # define Perl_sv_insert(mTHX,a,b,c,d,e) sv_insert(a,b,c,d,e) # define Perl_sv_mortalcopy(mTHX,a) sv_mortalcopy(a) +# define Perl_sv_numcmp(mTHX,a,b) sv_numcmp(a,b) # define Perl_sv_numeq(mTHX,a,b) sv_numeq(a,b) +# define Perl_sv_numge(mTHX,a,b) sv_numge(a,b) +# define Perl_sv_numgt(mTHX,a,b) sv_numgt(a,b) +# define Perl_sv_numle(mTHX,a,b) sv_numle(a,b) +# define Perl_sv_numlt(mTHX,a,b) sv_numlt(a,b) +# define Perl_sv_numne(mTHX,a,b) sv_numne(a,b) # define Perl_sv_pv(mTHX,a) sv_pv(a) # define Perl_sv_pvbyte(mTHX,a) sv_pvbyte(a) # define Perl_sv_pvn_force(mTHX,a,b) sv_pvn_force(a,b) @@ -2690,7 +2709,13 @@ # define Perl_sv_force_normal sv_force_normal # define Perl_sv_insert sv_insert # define Perl_sv_mortalcopy sv_mortalcopy +# define Perl_sv_numcmp sv_numcmp # define Perl_sv_numeq sv_numeq +# define Perl_sv_numge sv_numge +# define Perl_sv_numgt sv_numgt +# define Perl_sv_numle sv_numle +# define Perl_sv_numlt sv_numlt +# define Perl_sv_numne sv_numne # define Perl_sv_pv sv_pv # define Perl_sv_pvbyte sv_pvbyte # define Perl_sv_pvn_force sv_pvn_force diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index aa68c1fc689f..78afb3a992db 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,21 +5030,83 @@ test_HvNAMEf_QUOTEDPREFIX(sv) OUTPUT: RETVAL +TYPEMAP: < 24; +use XS::APItest; +use Config; +use strict; + +my $four = 4; +is sv_numcmp($four, 4), 0, '$four == 4'; +is sv_numcmp($four, 5), -1, '$four < 5'; + +is sv_numcmp(5, $four), 1, '5 > $four'; + +SKIP: +{ + no warnings 'experimental'; + my $nan = eval { builtin::nan }; + defined $nan + or skip "No NAN", 2; + is sv_numcmp($nan, 0), 2, '$nan not comparable'; + is sv_numcmp($nan, $nan), 2, '$nan not comparable even with itself'; +} + +my $six_point_five = 6.5; # an exact float, so == is fine +is sv_numcmp($six_point_five, 6.5), 0, '$six_point_five == 6.5'; +is sv_numcmp($six_point_five, 6.6), -1, '$six_point_five < 6.6'; + +# NULLs +is sv_numcmp(undef, 1), -1, "NULL sv1"; +is sv_numcmp(1, undef), 1, "NULL sv2"; + +# GMAGIC +"10" =~ m/(\d+)/; +is sv_numcmp_flags($1, 10, 0), -1, 'sv_numcmp_flags with no flags does not GETMAGIC'; +is sv_numcmp_flags($1, 10, SV_GMAGIC), 0, 'sv_numcmp_flags with SV_GMAGIC does'; + +# overloading +{ + package AlwaysTen { + use overload + '<=>' => sub { + return $_[2] ? $_[1] <=> 10 : 10 <=> $_[1] + }, + '0+' => sub { 123456 }; + } + my $obj = bless([], "AlwaysTen"); + + is sv_numcmp($obj, 10), 0, 'AlwaysTen is 10'; + is sv_numcmp($obj, 11), -1, 'AlwaysTen is not 11'; + is sv_numcmp(10, $obj), 0, 'AlwaysTen is 10 on the right'; + is sv_numcmp(11, $obj), 1, 'AlwaysTen is not 11 on the right'; + + SKIP: + { + $Config{d_double_has_nan} + or skip "No NAN", 1; + my $nan = 0+"NaN"; + + is sv_numcmp($obj, $nan), 2, 'AlwaysTen vs $nan is not comparable'; + } + + is sv_numcmp_flags($obj, 10, SV_SKIP_OVERLOAD), 1, + 'AlwaysTen is not 10 with SV_SKIP_OVERLOAD'; +} + +# +0 overloading with large numbers and using fallback +{ + my $big = ~0; + my $bigm1 = $big-1; + package MyBigNum { + use overload "0+" => sub { $_[0][0] }, + fallback => 1; + } + my $o1 = bless [ $big ], "MyBigNum"; + my $o2 = bless [ $big ], "MyBigNum"; + my $o3 = bless [ $bigm1 ], "MyBigNum"; + + is $o1 <=> $o2, 0, "perl op gets it right"; + is $o1 <=> $bigm1, 1, "perl op still gets it right for left overload"; + is $o1 <=> $o3, 1, "perl op still gets it right for different values"; + is sv_numcmp($o1, $o2), 0, "sv_numcmp two overloads"; + is sv_numcmp($o1, $o3), 1, "sv_numcmp two different overloads"; + is sv_numcmp($o1, $big), 0, "sv_numcmp left overload"; + is sv_numcmp($bigm1, $o3), 0, "sv_numcmp right overload"; +} diff --git a/ext/XS-APItest/t/sv_numeq.t b/ext/XS-APItest/t/sv_numeq.t index 6439a48d2b6b..f789fc8668ba 100644 --- a/ext/XS-APItest/t/sv_numeq.t +++ b/ext/XS-APItest/t/sv_numeq.t @@ -1,15 +1,31 @@ #!perl -use Test::More tests => 9; +use Test::More tests => 25; 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'; +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 +43,37 @@ 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'; + 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 +{ + 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 !sv_numeq_flags($obj, 10, SV_SKIP_OVERLOAD), 'AlwaysTen is not 10 with SV_SKIP_OVERLOAD' + 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_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/ext/XS-APItest/t/sv_numne.t b/ext/XS-APItest/t/sv_numne.t new file mode 100644 index 000000000000..4e523ff11500 --- /dev/null +++ b/ext/XS-APItest/t/sv_numne.t @@ -0,0 +1,92 @@ +#!perl + +use Test::More tests => 34; +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'; + +# 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'; +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'; + + # 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 +{ + 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/gv.c b/gv.c index bfbce344cbb0..232701e52d5b 100644 --- a/gv.c +++ b/gv.c @@ -3748,8 +3748,25 @@ 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. + +=item C + +Perform overloading even in the context of C. + =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 +=for apidoc Amnh||AMGf_force_overload + =cut */ @@ -3773,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; } @@ -4142,7 +4160,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 || !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/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/pp.h b/pp.h index c06817ddef17..0eb254b1c209 100644 --- a/pp.h +++ b/pp.h @@ -653,14 +653,16 @@ 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_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 0x40 -#define AMGf_numarg 0x80 +#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 */ @@ -676,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/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 diff --git a/proto.h b/proto.h index 95eb1aa7d501..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 @@ -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); */ @@ -4804,6 +4811,41 @@ 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); */ + +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 @@ -9242,6 +9284,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, SV **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 4e161322646f..f061d5399ac8 100644 --- a/sv.c +++ b/sv.c @@ -2763,27 +2763,48 @@ 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 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 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 */ 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|SV_FORCE_OVERLOAD)) == 0); if (!SvROK(sv)) return sv; - if (SvAMAGIC(sv)) { - SV * const tmpsv = AMG_CALLunary(sv, numer_amg); + if (SvAMAGIC(sv) && !(flags & SV_SKIP_OVERLOAD)) { + 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)))); } @@ -8711,28 +8732,175 @@ 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) { + if(flags & SV_GMAGIC) { + if(*sv1) + SvGETMAGIC(*sv1); + if(*sv2 && (!*sv1 || *sv1 != *sv2)) + SvGETMAGIC(*sv2); + } + + /* Treat NULL as undef */ + if(!*sv1) + *sv1 = &PL_sv_undef; + if(!*sv2) + *sv2 = &PL_sv_undef; + + if (SvAMAGIC(*sv1) || SvAMAGIC(*sv2)) { + 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; + } + + /* 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_flags(*sv1, flags & SV_SKIP_OVERLOAD); + if (SvROK(*sv2)) + *sv2 = sv_2num_flags(*sv2, flags & SV_SKIP_OVERLOAD); + } + + return false; +} + /* =for apidoc sv_numeq =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: -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>. +=over + +=item C, C + +Numeric equality, the same as S>. + +=item C, C + +Numeric inequality, the same as S>. + +=item C, C + +Numeric less than or equal, the same as S= $sv2>>. + +=item C, C + +Numeric less than, the same as S $sv2>>. + +=item C, C + +Numeric greater than or equal, the same as S= $sv2>>. + +=item C, C + +Numeric greater than, the same as S $sv2>>. + +=back + +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. 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 +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 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 */ @@ -8742,27 +8910,169 @@ 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); - } + SV *result; + if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, eq_amg, &result))) + return SvTRUE(result); - /* Treat NULL as undef */ - if(!sv1) - sv1 = &PL_sv_undef; - if(!sv2) - sv2 = &PL_sv_undef; + return do_ncmp(sv1, sv2) == 0; +} - if(!(flags & SV_SKIP_OVERLOAD) && - (SvAMAGIC(sv1) || SvAMAGIC(sv2))) { - SV *ret = amagic_call(sv1, sv2, eq_amg, 0); - if(ret) - return SvTRUE(ret); +bool +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); + + 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 + +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. + + accepts these flags: + +=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 +*/ + +#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) == 0; + return do_ncmp(sv1, sv2); } /* diff --git a/sv.h b/sv.h index 29f81f907c18..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 @@ -2311,6 +2312,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) @@ -2322,6 +2324,12 @@ 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_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) #define sv_2bool(sv) sv_2bool_flags(sv, SV_GMAGIC) @@ -2360,6 +2368,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) \