diff options
-rw-r--r-- | MANIFEST | 1 | ||||
-rw-r--r-- | embed.fnc | 2 | ||||
-rw-r--r-- | embed.h | 1 | ||||
-rw-r--r-- | ext/XS-APItest/APItest.pm | 2 | ||||
-rw-r--r-- | ext/XS-APItest/APItest.xs | 14 | ||||
-rw-r--r-- | ext/XS-APItest/Makefile.PL | 1 | ||||
-rw-r--r-- | ext/XS-APItest/t/sv_numeq.t | 17 | ||||
-rw-r--r-- | proto.h | 4 | ||||
-rw-r--r-- | sv.c | 37 | ||||
-rw-r--r-- | sv.h | 1 |
10 files changed, 79 insertions, 1 deletions
@@ -4642,6 +4642,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_numeq.t Test sv_numeq ext/XS-APItest/t/svcat.t Test sv_catpvn ext/XS-APItest/t/svcatpvf.t Test sv_catpvf argument reordering ext/XS-APItest/t/sviscow.t Test SvIsCOW @@ -1892,6 +1892,8 @@ ApdbMR |SV* |sv_mortalcopy |NULLOK SV *const oldsv ApdR |SV* |sv_mortalcopy_flags|NULLOK SV *const oldsv|U32 flags ApdR |SV* |sv_newmortal Cpd |SV* |sv_newref |NULLOK SV *const sv +Amd |bool |sv_numeq |NULLOK SV* sv1|NULLOK SV* sv2 +Apd |bool |sv_numeq_flags |NULLOK SV* sv1|NULLOK SV* sv2|const U32 flags Ap |char* |sv_peek |NULLOK SV* sv Apd |void |sv_pos_u2b |NULLOK SV *const sv|NN I32 *const offsetp|NULLOK I32 *const lenp Apd |STRLEN |sv_pos_u2b_flags|NN SV *const sv|STRLEN uoffset \ @@ -641,6 +641,7 @@ #ifndef NO_MATHOMS #define sv_nounlocking(a) Perl_sv_nounlocking(aTHX_ a) #endif +#define sv_numeq_flags(a,b,c) Perl_sv_numeq_flags(aTHX_ a,b,c) #ifndef NO_MATHOMS #define sv_nv(a) Perl_sv_nv(aTHX_ a) #endif diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 1abb45f685..b586c8f3cd 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -4,7 +4,7 @@ use strict; use warnings; use Carp; -our $VERSION = '1.20'; +our $VERSION = '1.21'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index f0a2ca3921..c101e995d0 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -4577,6 +4577,20 @@ test_MAX_types() OUTPUT: RETVAL +bool +sv_numeq(SV *sv1, SV *sv2) + CODE: + RETVAL = sv_numeq(sv1, sv2); + OUTPUT: + RETVAL + +bool +sv_numeq_flags(SV *sv1, SV *sv2, U32 flags) + CODE: + RETVAL = sv_numeq_flags(sv1, sv2, flags); + OUTPUT: + RETVAL + MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest int diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL index c075db20d8..16b024e97c 100644 --- a/ext/XS-APItest/Makefile.PL +++ b/ext/XS-APItest/Makefile.PL @@ -25,6 +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 + SV_GMAGIC 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_numeq.t b/ext/XS-APItest/t/sv_numeq.t new file mode 100644 index 0000000000..d183e67548 --- /dev/null +++ b/ext/XS-APItest/t/sv_numeq.t @@ -0,0 +1,17 @@ +#!perl + +use Test::More tests => 6; +use XS::APItest; + +my $four = 4; +ok sv_numeq($four, 4), '$four == 4'; +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'; + +# GMAGIC +"10" =~ m/(\d+)/; +ok !sv_numeq_flags($1, 10, 0), 'sv_numeq_flags with no flags does not GETMAGIC'; +ok sv_numeq_flags($1, 10, SV_GMAGIC), 'sv_numeq_flags with SV_GMAGIC does'; @@ -3641,6 +3641,10 @@ PERL_CALLCONV void Perl_sv_nounlocking(pTHX_ SV *sv) #define PERL_ARGS_ASSERT_SV_NOUNLOCKING #endif +/* PERL_CALLCONV bool sv_numeq(pTHX_ SV* sv1, SV* sv2); */ +#define PERL_ARGS_ASSERT_SV_NUMEQ +PERL_CALLCONV bool Perl_sv_numeq_flags(pTHX_ SV* sv1, SV* sv2, const U32 flags); +#define PERL_ARGS_ASSERT_SV_NUMEQ_FLAGS #ifndef NO_MATHOMS PERL_CALLCONV NV Perl_sv_nv(pTHX_ SV* sv) __attribute__deprecated__; @@ -8180,6 +8180,43 @@ Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) } /* +=for apidoc sv_numeq_flags + +Returns a boolean indicating whether the numbers in the two SVs are +identical. If the flags has the C<SV_GMAGIC> bit set, it handles +get-magic too. Will coerce its args to numbers if necessary. Treats +C<NULL> as undef. + +=for apidoc sv_numeq + +A convenient shortcut for calling C<sv_numeq_flags> with the C<SV_GMAGIC> +flag. + +=cut +*/ + +bool +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; + + return do_ncmp(sv1, sv2) == 0; +} + +/* =for apidoc sv_cmp Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the @@ -2159,6 +2159,7 @@ Returns the hash for C<sv> created by C<L</newSVpvn_share>>. #define sv_eq(sv1, sv2) sv_eq_flags(sv1, sv2, SV_GMAGIC) #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_collxfrm(sv, nxp) sv_collxfrm_flags(sv, nxp, SV_GMAGIC) #define sv_2bool(sv) sv_2bool_flags(sv, SV_GMAGIC) #define sv_2bool_nomg(sv) sv_2bool_flags(sv, 0) |