diff options
| -rw-r--r-- | embed.fnc | 5 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | ext/XS/APItest/APItest.xs | 22 | ||||
| -rw-r--r-- | ext/XS/APItest/Makefile.PL | 9 | ||||
| -rw-r--r-- | ext/XS/APItest/t/hash.t | 32 | ||||
| -rw-r--r-- | hv.c | 18 | ||||
| -rw-r--r-- | proto.h | 5 |
7 files changed, 79 insertions, 14 deletions
@@ -1141,7 +1141,10 @@ sanR |HEK* |save_hek_flags |NN const char *str|I32 len|U32 hash|int flags sn |void |hv_magic_check |NN HV *hv|NN bool *needs_copy|NN bool *needs_store s |void |unshare_hek_or_pvn|NULLOK const HEK* hek|NULLOK const char* str|I32 len|U32 hash sR |HEK* |share_hek_flags|NN const char* sv|I32 len|U32 hash|int flags -sR |SV* |hv_magic_uvar_xkey|NN HV* hv|NN SV* keysv|int action +sR |SV* |hv_magic_uvar_xkey|NN HV* hv|NULLOK SV* keysv \ + |NULLOK const char *const key \ + |const STRLEN klen |const int k_flags \ + |int action rs |void |hv_notallowed |int flags|NN const char *key|I32 klen|NN const char *msg sn |struct xpvhv_aux*|hv_auxinit|NN HV *hv sM |SV* |hv_delete_common|NULLOK HV* tb|NULLOK SV* keysv|NULLOK const char* key \ @@ -3423,7 +3423,7 @@ #define hv_magic_check S_hv_magic_check #define unshare_hek_or_pvn(a,b,c,d) S_unshare_hek_or_pvn(aTHX_ a,b,c,d) #define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d) -#define hv_magic_uvar_xkey(a,b,c) S_hv_magic_uvar_xkey(aTHX_ a,b,c) +#define hv_magic_uvar_xkey(a,b,c,d,e,f) S_hv_magic_uvar_xkey(aTHX_ a,b,c,d,e,f) #define hv_notallowed(a,b,c,d) S_hv_notallowed(aTHX_ a,b,c,d) #define hv_auxinit S_hv_auxinit #define hv_delete_common(a,b,c,d,e,f,g) S_hv_delete_common(aTHX_ a,b,c,d,e,f,g) diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs index da865e693d..96efd9bf77 100644 --- a/ext/XS/APItest/APItest.xs +++ b/ext/XS/APItest/APItest.xs @@ -195,8 +195,12 @@ rot13_key(pTHX_ IV action, SV *field) { return 0; } +#include "const-c.inc" + MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash +INCLUDE: const-xs.inc + void rot13_hash(hash) HV *hash @@ -227,17 +231,31 @@ exists(hash, key_sv) RETVAL SV * -delete(hash, key_sv) +delete(hash, key_sv, flags = 0) PREINIT: STRLEN len; const char *key; INPUT: HV *hash SV *key_sv + I32 flags; CODE: key = SvPV(key_sv, len); /* It's already mortal, so need to increase reference count. */ - RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0)); + RETVAL + = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags)); + OUTPUT: + RETVAL + +SV * +delete_ent(hash, key_sv, flags = 0) + INPUT: + HV *hash + SV *key_sv + I32 flags; + CODE: + /* It's already mortal, so need to increase reference count. */ + RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0)); OUTPUT: RETVAL diff --git a/ext/XS/APItest/Makefile.PL b/ext/XS/APItest/Makefile.PL index 76aa60ac35..05bcfb06dc 100644 --- a/ext/XS/APItest/Makefile.PL +++ b/ext/XS/APItest/Makefile.PL @@ -1,5 +1,6 @@ use 5.008; use ExtUtils::MakeMaker; +use ExtUtils::Constant 0.11 'WriteConstants'; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( @@ -17,6 +18,14 @@ WriteMakefile( # Un-comment this if you add C files to link with later: # 'OBJECT' => '$(O_FILES)', # link all the C files too MAN3PODS => {}, # Pods will be built by installman. + realclean => {FILES => 'const-c.inc const-xs.inc'}, +); + +WriteConstants( + PROXYSUBS => 1, + NAME => 'XS::APItest', + NAMES => [qw(HV_DELETE HV_DISABLE_UVAR_XKEY G_DISCARD HV_FETCH_ISSTORE + HV_FETCH_ISEXISTS HV_FETCH_LVALUE HV_FETCH_JUST_SV)], ); sub MY::install { "install ::\n" }; diff --git a/ext/XS/APItest/t/hash.t b/ext/XS/APItest/t/hash.t index 4af7f88ad6..949f175e0a 100644 --- a/ext/XS/APItest/t/hash.t +++ b/ext/XS/APItest/t/hash.t @@ -18,7 +18,7 @@ use utf8; use Tie::Hash; use Test::More 'no_plan'; -use_ok('XS::APItest'); +BEGIN {use_ok('XS::APItest')}; sub preform_test; sub test_present; @@ -95,7 +95,7 @@ foreach my $in ("", "N", "a\0b") { is ($got, $in, "test_share_unshare_pvn"); } -{ +if ($] > 5.009) { my %hash; XS::APItest::Hash::rot13_hash(\%hash); $hash{a}++; @hash{qw(p i e)} = (2, 4, 8); @@ -105,6 +105,34 @@ foreach my $in ("", "N", "a\0b") { "uvar magic called exactly once on store"); is($hash{i}, 4); + + is(delete $hash{a}, 1); + + is(keys %hash, 3); + @keys = sort keys %hash; + is("@keys", join(' ', sort(rot13(qw(p i e))))); + + is (XS::APItest::Hash::delete_ent (\%hash, 'p', + XS::APItest::HV_DISABLE_UVAR_XKEY), + undef, "Deleting a known key with conversion disabled fails (ent)"); + is(keys %hash, 3); + + is (XS::APItest::Hash::delete_ent (\%hash, 'p', 0), + 2, "Deleting a known key with conversion enabled works (ent)"); + is(keys %hash, 2); + @keys = sort keys %hash; + is("@keys", join(' ', sort(rot13(qw(i e))))); + + is (XS::APItest::Hash::delete (\%hash, 'i', + XS::APItest::HV_DISABLE_UVAR_XKEY), + undef, "Deleting a known key with conversion disabled fails"); + is(keys %hash, 2); + + is (XS::APItest::Hash::delete (\%hash, 'i', 0), + 4, "Deleting a known key with conversion enabled works"); + is(keys %hash, 1); + @keys = sort keys %hash; + is("@keys", join(' ', sort(rot13(qw(e))))); } exit; @@ -426,7 +426,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (keysv) { if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) { - keysv = hv_magic_uvar_xkey(hv, keysv, action); + keysv = hv_magic_uvar_xkey(hv, keysv, 0, 0, 0, action); /* If a fetch-as-store fails on the fetch, then the action is to recurse once into "hv_store". If we didn't do this, then that recursive call would call the key conversion routine again. @@ -966,10 +966,10 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (!hv) return NULL; + if (SvSMAGICAL(hv) && SvGMAGICAL(hv) + && !(d_flags & HV_DISABLE_UVAR_XKEY)) + keysv = hv_magic_uvar_xkey(hv, keysv, key, klen, k_flags, HV_DELETE); if (keysv) { - if (SvSMAGICAL(hv) && SvGMAGICAL(hv) - && !(d_flags & HV_DISABLE_UVAR_XKEY)) - keysv = hv_magic_uvar_xkey(hv, keysv, HV_DELETE); if (k_flags & HVhek_FREEKEY) Safefree(key); key = SvPV_const(keysv, klen); @@ -2533,13 +2533,21 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) } STATIC SV * -S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, int action) +S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, const char *const key, + const STRLEN klen, const int k_flags, int action) { MAGIC* mg; if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) { struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; if (uf->uf_set == NULL) { SV* obj = mg->mg_obj; + + if (!keysv) { + keysv = sv_2mortal(newSVpvn(key, klen)); + if (k_flags & HVhek_UTF8) + SvUTF8_on(keysv); + } + mg->mg_obj = keysv; /* pass key */ uf->uf_index = action; /* pass action */ magic_getuvar((SV*)hv, mg); @@ -3044,10 +3044,9 @@ STATIC HEK* S_share_hek_flags(pTHX_ const char* sv, I32 len, U32 hash, int flags __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); -STATIC SV* S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, int action) +STATIC SV* S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, const char *const key, const STRLEN klen, const int k_flags, int action) __attribute__warn_unused_result__ - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); + __attribute__nonnull__(pTHX_1); STATIC void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg) __attribute__noreturn__ |