mirror/perl
1
0
Fork 0
mirror of https://github.com/Perl/perl5.git synced 2026-01-26 08:38:23 +00:00
Code Issues Packages Projects Releases Wiki Activity

add sv_numle(), sv_numlt(), sv_numge(), sv_numgt() APIs

Browse Source 
These are all needed because overloading may make them inconsistent
with <=> overloading.
This commit is contained in:
Tony Cook 2025-11-24 15:01:05 +11:00
parent 897c610479
commit 747670eba8
8 changed files with 226 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
MANIFEST
View File

@ -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

20
embed.fnc
View File

@ -3441,6 +3441,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 \

12
embed.h
View File

@ -934,6 +934,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)
@ -2604,6 +2608,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)
@ -2710,6 +2718,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

24
ext/XS-APItest/APItest.xs
View File

@ -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:

49
ext/XS-APItest/t/sv_numlget.t Normal file
View File

@ -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;

28
proto.h generated
View File

@ -4801,6 +4801,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); */

92
sv.c
View File

@ -8736,6 +8736,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:
@ -8754,17 +8762,42 @@ Numeric equality, the same as S<C<$sv1 == $sv2>>.
Numeric inequality, the same as S<C<$sv1 != $sv2>>.
=item C<sv_numle>
=item C<sv_numle_flags>
Numeric less than or equal, the same as S<C<$sv1 E<lt>= $sv2>>.
=item C<sv_numlt>
=item C<sv_numlt_flags>
Numeric less than, the same as S<C<$sv1 E<lt> $sv2>>.
=item C<sv_numge>
=item C<sv_numge_flags>
Numeric greater than or equal, the same as S<C<$sv1 E<gt>= $sv2>>.
=item C<sv_numgt>
=item C<sv_numgt_flags>
Numeric greater than, the same as S<C<$sv1 E<gt> $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<overload> 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<undef>.
@ -8807,7 +8840,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);
@ -8815,6 +8847,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

4
sv.h
View File

@ -2323,6 +2323,10 @@ Usually accessed via the C<SvPVutf8_nolen> macro.
#define sv_cmp_locale(sv1, sv2) sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC)
#define sv_numeq(sv1, sv2) sv_numeq_flags(sv1, sv2, SV_GMAGIC)
#define sv_numne(sv1, sv2) sv_numne_flags(sv1, sv2, SV_GMAGIC)
#define sv_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)