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.xs | 14 | ||||
| -rw-r--r-- | ext/XS-APItest/t/sv_streq.t | 29 | ||||
| -rw-r--r-- | proto.h | 4 | ||||
| -rw-r--r-- | sv.c | 48 | ||||
| -rw-r--r-- | sv.h | 1 |
8 files changed, 100 insertions, 0 deletions
@@ -4643,6 +4643,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_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 ext/XS-APItest/t/sviscow.t Test SvIsCOW @@ -1937,6 +1937,8 @@ Apd |void |sv_setrv_inc |NN SV *const sv|NN SV *const ref Apd |void |sv_setrv_noinc_mg |NN SV *const sv|NN SV *const ref Apd |void |sv_setrv_inc_mg |NN SV *const sv|NN SV *const ref ApMdb |void |sv_setsv |NN SV *dsv|NULLOK SV *ssv +Amd |bool |sv_streq |NULLOK SV* sv1|NULLOK SV* sv2 +Apd |bool |sv_streq_flags |NULLOK SV* sv1|NULLOK SV* sv2|const U32 flags CpMdb |void |sv_taint |NN SV* sv CpdR |bool |sv_tainted |NN SV *const sv Apd |int |sv_unmagic |NN SV *const sv|const int type @@ -707,6 +707,7 @@ #define sv_setsv_mg(a,b) Perl_sv_setsv_mg(aTHX_ a,b) #define sv_setuv(a,b) Perl_sv_setuv(aTHX_ a,b) #define sv_setuv_mg(a,b) Perl_sv_setuv_mg(aTHX_ a,b) +#define sv_streq_flags(a,b,c) Perl_sv_streq_flags(aTHX_ a,b,c) #define sv_string_from_errnum(a,b) Perl_sv_string_from_errnum(aTHX_ a,b) #define sv_tainted(a) Perl_sv_tainted(aTHX_ a) #define sv_true(a) Perl_sv_true(aTHX_ a) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index c101e995d0..088afff840 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -4591,6 +4591,20 @@ sv_numeq_flags(SV *sv1, SV *sv2, U32 flags) OUTPUT: RETVAL +bool +sv_streq(SV *sv1, SV *sv2) + CODE: + RETVAL = sv_streq(sv1, sv2); + OUTPUT: + RETVAL + +bool +sv_streq_flags(SV *sv1, SV *sv2, U32 flags) + CODE: + RETVAL = sv_streq_flags(sv1, sv2, flags); + OUTPUT: + RETVAL + MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest int diff --git a/ext/XS-APItest/t/sv_streq.t b/ext/XS-APItest/t/sv_streq.t new file mode 100644 index 0000000000..f8ca1378b1 --- /dev/null +++ b/ext/XS-APItest/t/sv_streq.t @@ -0,0 +1,29 @@ +#!perl + +use Test::More tests => 7; +use XS::APItest; + +my $abc = "abc"; +ok sv_streq($abc, "abc"), '$abc eq "abc"'; +ok !sv_streq($abc, "def"), '$abc ne "def"'; + +# consider also UTF-8 vs not + +# GMAGIC +"ABC" =~ m/(\w+)/; +ok !sv_streq_flags($1, "ABC", 0), 'sv_streq_flags with no flags does not GETMAGIC'; +ok sv_streq_flags($1, "ABC", SV_GMAGIC), 'sv_streq_flags with SV_GMAGIC does'; + +# overloading +{ + package AlwaysABC { + use overload + 'eq' => sub { return $_[1] eq "ABC" }, + '""' => sub { "not-a-string" }; + } + + ok sv_streq(bless([], "AlwaysABC"), "ABC"), 'AlwaysABC is "ABC"'; + ok !sv_streq(bless([], "AlwaysABC"), "DEF"), 'AlwaysABC is not "DEF"'; + + ok !sv_streq_flags(bless([], "AlwaysABC"), "ABC", SV_SKIP_OVERLOAD), 'AlwaysABC is not "ABC" with SV_SKIP_OVERLOAD'; +} @@ -3865,6 +3865,10 @@ PERL_CALLCONV void Perl_sv_setuv(pTHX_ SV *const sv, const UV num); PERL_CALLCONV void Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u); #define PERL_ARGS_ASSERT_SV_SETUV_MG \ assert(sv) +/* PERL_CALLCONV bool sv_streq(pTHX_ SV* sv1, SV* sv2); */ +#define PERL_ARGS_ASSERT_SV_STREQ +PERL_CALLCONV bool Perl_sv_streq_flags(pTHX_ SV* sv1, SV* sv2, const U32 flags); +#define PERL_ARGS_ASSERT_SV_STREQ_FLAGS PERL_CALLCONV SV* Perl_sv_string_from_errnum(pTHX_ int errnum, SV* tgtsv); #define PERL_ARGS_ASSERT_SV_STRING_FROM_ERRNUM #ifndef NO_MATHOMS @@ -8180,6 +8180,54 @@ Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) } /* +=for apidoc sv_streq_flags + +Returns a boolean indicating whether the strings 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 strings if necessary. Treats +C<NULL> as undef. + +If flags does not have the C<SV_SKIP_OVERLOAD> set, an attempt to use C<eq> +overloading will be made. If such overloading does not exist or the flag is +set, then regular string comparison will be used instead. + +=for apidoc sv_streq + +A convenient shortcut for calling C<sv_streq_flags> with the C<SV_GMAGIC> +flag. + +=cut +*/ + +bool +Perl_sv_streq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) +{ + PERL_ARGS_ASSERT_SV_STREQ_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, seq_amg, 0); + if(ret) + return SvTRUE(ret); + } + + return sv_eq_flags(sv1, sv2, 0); +} + +/* =for apidoc sv_numeq_flags Returns a boolean indicating whether the numbers in the two SVs are @@ -2160,6 +2160,7 @@ Returns the hash for C<sv> created by C<L</newSVpvn_share>>. #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_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) #define sv_2bool_nomg(sv) sv_2bool_flags(sv, 0) |