diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | cop.h | 310 | ||||
| -rw-r--r-- | embed.fnc | 50 | ||||
| -rw-r--r-- | embed.h | 12 | ||||
| -rw-r--r-- | ext/B/B.xs | 4 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 140 | ||||
| -rw-r--r-- | ext/XS-APItest/t/cophh.t | 18 | ||||
| -rw-r--r-- | global.sym | 12 | ||||
| -rw-r--r-- | gv.c | 3 | ||||
| -rw-r--r-- | hv.c | 471 | ||||
| -rw-r--r-- | hv.h | 37 | ||||
| -rw-r--r-- | mg.c | 24 | ||||
| -rw-r--r-- | op.c | 17 | ||||
| -rw-r--r-- | perl.c | 4 | ||||
| -rw-r--r-- | perlio.c | 3 | ||||
| -rw-r--r-- | pp_ctl.c | 20 | ||||
| -rw-r--r-- | proto.h | 64 | ||||
| -rw-r--r-- | scope.c | 15 | ||||
| -rw-r--r-- | sv.c | 12 |
19 files changed, 865 insertions, 352 deletions
@@ -3391,6 +3391,7 @@ ext/XS-APItest/t/Block.pm Helper for ./blockhooks.t ext/XS-APItest/t/call_checker.t test call checker plugin API ext/XS-APItest/t/caller.t XS::APItest: tests for caller_cx ext/XS-APItest/t/call.t XS::APItest extension +ext/XS-APItest/t/cophh.t test COPHH API ext/XS-APItest/t/copyhints.t test hv_copy_hints_hv() API ext/XS-APItest/t/exception.t XS::APItest extension ext/XS-APItest/t/grok.t XS::APItest: tests for grok* functions @@ -152,6 +152,230 @@ typedef struct jmpenv JMPENV; PL_top_env->je_mustcatch = (v); \ } STMT_END +/* +=head1 COP Hint Hashes +*/ + +typedef struct refcounted_he COPHH; + +#define COPHH_KEY_UTF8 REFCOUNTED_HE_KEY_UTF8 + +/* +=for apidoc Am|SV *|cophh_fetch_pvn|const COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|U32 flags + +Look up the entry in the cop hints hash I<cophh> with the key specified by +I<keypv> and I<keylen>. If I<flags> has the C<COPHH_KEY_UTF8> bit set, +the key octets are interpreted as UTF-8, otherwise they are interpreted +as Latin-1. I<hash> is a precomputed hash of the key string, or zero if +it has not been precomputed. Returns a mortal scalar copy of the value +associated with the key, or C<&PL_sv_placeholder> if there is no value +associated with the key. + +=cut +*/ + +#define cophh_fetch_pvn(cophh, keypv, keylen, hash, flags) \ + Perl_refcounted_he_fetch_pvn(aTHX_ cophh, keypv, keylen, hash, flags) + +/* +=for apidoc Am|SV *|cophh_fetch_pvs|const COPHH *cophh|const char *key|U32 flags + +Like L</cophh_fetch_pvn>, but takes a literal string instead of a +string/length pair, and no precomputed hash. + +=cut +*/ + +#define cophh_fetch_pvs(cophh, key, flags) \ + Perl_refcounted_he_fetch_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, flags) + +/* +=for apidoc Am|SV *|cophh_fetch_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags + +Like L</cophh_fetch_pvn>, but takes a nul-terminated string instead of +a string/length pair. + +=cut +*/ + +#define cophh_fetch_pv(cophh, key, hash, flags) \ + Perl_refcounted_he_fetch_pv(aTHX_ cophh, key, hash, flags) + +/* +=for apidoc Am|SV *|cophh_fetch_sv|const COPHH *cophh|SV *key|U32 hash|U32 flags + +Like L</cophh_fetch_pvn>, but takes a Perl scalar instead of a +string/length pair. + +=cut +*/ + +#define cophh_fetch_sv(cophh, key, hash, flags) \ + Perl_refcounted_he_fetch_sv(aTHX_ cophh, key, hash, flags) + +/* +=for apidoc Am|HV *|cophh_2hv|const COPHH *cophh|U32 flags + +Generates and returns a standard Perl hash representing the full set of +key/value pairs in the cop hints hash I<cophh>. I<flags> is currently +unused and must be zero. + +=cut +*/ + +#define cophh_2hv(cophh, flags) \ + Perl_refcounted_he_chain_2hv(aTHX_ cophh, flags) + +/* +=for apidoc Am|COPHH *|cophh_copy|COPHH *cophh + +Make and return a complete copy of the cop hints hash I<cophh>. + +=cut +*/ + +#define cophh_copy(cophh) Perl_refcounted_he_inc(aTHX_ cophh) + +/* +=for apidoc Am|void|cophh_free|COPHH *cophh + +Discard the cop hints hash I<cophh>, freeing all resources associated +with it. + +=cut +*/ + +#define cophh_free(cophh) Perl_refcounted_he_free(aTHX_ cophh) + +/* +=for apidoc Am|COPHH *|cophh_new_empty + +Generate and return a fresh cop hints hash containing no entries. + +=cut +*/ + +#define cophh_new_empty() ((COPHH *)NULL) + +/* +=for apidoc Am|COPHH *|cophh_store_pvn|COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags + +Stores a value, associated with a key, in the cop hints hash I<cophh>, +and returns the modified hash. The returned hash pointer is in general +not the same as the hash pointer that was passed in. The input hash is +consumed by the function, and the pointer to it must not be subsequently +used. Use L</cophh_copy> if you need both hashes. + +The key is specified by I<keypv> and I<keylen>. If I<flags> has the +C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8, +otherwise they are interpreted as Latin-1. I<hash> is a precomputed +hash of the key string, or zero if it has not been precomputed. + +I<value> is the scalar value to store for this key. I<value> is copied +by this function, which thus does not take ownership of any reference +to it, and later changes to the scalar will not be reflected in the +value visible in the cop hints hash. Complex types of scalar will not +be stored with referential integrity, but will be coerced to strings. + +=cut +*/ + +#define cophh_store_pvn(cophh, keypv, keylen, hash, value, flags) \ + Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, value, flags) + +/* +=for apidoc Am|COPHH *|cophh_store_pvs|const COPHH *cophh|const char *key|SV *value|U32 flags + +Like L</cophh_store_pvn>, but takes a literal string instead of a +string/length pair, and no precomputed hash. + +=cut +*/ + +#define cophh_store_pvs(cophh, key, value, flags) \ + Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, value, flags) + +/* +=for apidoc Am|COPHH *|cophh_store_pv|const COPHH *cophh|const char *key|U32 hash|SV *value|U32 flags + +Like L</cophh_store_pvn>, but takes a nul-terminated string instead of +a string/length pair. + +=cut +*/ + +#define cophh_store_pv(cophh, key, hash, value, flags) \ + Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, value, flags) + +/* +=for apidoc Am|COPHH *|cophh_store_sv|const COPHH *cophh|SV *key|U32 hash|SV *value|U32 flags + +Like L</cophh_store_pvn>, but takes a Perl scalar instead of a +string/length pair. + +=cut +*/ + +#define cophh_store_sv(cophh, key, hash, value, flags) \ + Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, value, flags) + +/* +=for apidoc Am|COPHH *|cophh_delete_pvn|COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|U32 flags + +Delete a key and its associated value from the cop hints hash I<cophh>, +and returns the modified hash. The returned hash pointer is in general +not the same as the hash pointer that was passed in. The input hash is +consumed by the function, and the pointer to it must not be subsequently +used. Use L</cophh_copy> if you need both hashes. + +The key is specified by I<keypv> and I<keylen>. If I<flags> has the +C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8, +otherwise they are interpreted as Latin-1. I<hash> is a precomputed +hash of the key string, or zero if it has not been precomputed. + +=cut +*/ + +#define cophh_delete_pvn(cophh, keypv, keylen, hash, flags) \ + Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, \ + (SV *)NULL, flags) + +/* +=for apidoc Am|COPHH *|cophh_delete_pvs|const COPHH *cophh|const char *key|U32 flags + +Like L</cophh_delete_pvn>, but takes a literal string instead of a +string/length pair, and no precomputed hash. + +=cut +*/ + +#define cophh_delete_pvs(cophh, key, flags) \ + Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, \ + (SV *)NULL, flags) + +/* +=for apidoc Am|COPHH *|cophh_delete_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags + +Like L</cophh_delete_pvn>, but takes a nul-terminated string instead of +a string/length pair. + +=cut +*/ + +#define cophh_delete_pv(cophh, key, hash, flags) \ + Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, (SV *)NULL, flags) + +/* +=for apidoc Am|COPHH *|cophh_delete_sv|const COPHH *cophh|SV *key|U32 hash|U32 flags + +Like L</cophh_delete_pvn>, but takes a Perl scalar instead of a +string/length pair. + +=cut +*/ + +#define cophh_delete_sv(cophh, key, hash, flags) \ + Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, (SV *)NULL, flags) #include "mydtrace.h" @@ -174,7 +398,7 @@ struct cop { STRLEN * cop_warnings; /* lexical warnings bitmask */ /* compile time state of %^H. See the comment in op.c for how this is used to recreate a hash to return from caller. */ - struct refcounted_he * cop_hints_hash; + COPHH * cop_hints_hash; }; #ifdef USE_ITHREADS @@ -243,6 +467,80 @@ struct cop { # define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL)) #endif /* USE_ITHREADS */ + +#define CopHINTHASH_get(c) ((COPHH*)((c)->cop_hints_hash)) +#define CopHINTHASH_set(c,h) ((c)->cop_hints_hash = (h)) + +/* +=head1 COP Hint Reading +*/ + +/* +=for apidoc Am|SV *|cop_hints_fetch_pvn|const COP *cop|const char *keypv|STRLEN keylen|U32 hash|U32 flags + +Look up the hint entry in the cop I<cop> with the key specified by +I<keypv> and I<keylen>. If I<flags> has the C<COPHH_KEY_UTF8> bit set, +the key octets are interpreted as UTF-8, otherwise they are interpreted +as Latin-1. I<hash> is a precomputed hash of the key string, or zero if +it has not been precomputed. Returns a mortal scalar copy of the value +associated with the key, or C<&PL_sv_placeholder> if there is no value +associated with the key. + +=cut +*/ + +#define cop_hints_fetch_pvn(cop, keypv, keylen, hash, flags) \ + cophh_fetch_pvn(CopHINTHASH_get(cop), keypv, keylen, hash, flags) + +/* +=for apidoc Am|SV *|cop_hints_fetch_pvs|const COP *cop|const char *key|U32 flags + +Like L</cop_hints_fetch_pvn>, but takes a literal string instead of a +string/length pair, and no precomputed hash. + +=cut +*/ + +#define cop_hints_fetch_pvs(cop, key, flags) \ + cophh_fetch_pvs(CopHINTHASH_get(cop), key, flags) + +/* +=for apidoc Am|SV *|cop_hints_fetch_pv|const COP *cop|const char *key|U32 hash|U32 flags + +Like L</cop_hints_fetch_pvn>, but takes a nul-terminated string instead +of a string/length pair. + +=cut +*/ + +#define cop_hints_fetch_pv(cop, key, hash, flags) \ + cophh_fetch_pv(CopHINTHASH_get(cop), key, hash, flags) + +/* +=for apidoc Am|SV *|cop_hints_fetch_sv|const COP *cop|SV *key|U32 hash|U32 flags + +Like L</cop_hints_fetch_pvn>, but takes a Perl scalar instead of a +string/length pair. + +=cut +*/ + +#define cop_hints_fetch_sv(cop, key, hash, flags) \ + cophh_fetch_sv(CopHINTHASH_get(cop), key, hash, flags) + +/* +=for apidoc Am|HV *|cop_hints_2hv|const COP *cop|U32 flags + +Generates and returns a standard Perl hash representing the full set of +hint entries in the cop I<cop>. I<flags> is currently unused and must +be zero. + +=cut +*/ + +#define cop_hints_2hv(cop, flags) \ + cophh_2hv(CopHINTHASH_get(cop), flags) + #define CopLABEL(c) Perl_fetch_cop_label(aTHX_ (c), NULL, NULL) #define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL) @@ -261,8 +559,7 @@ struct cop { using $[ is highly discouraged, no sane Perl code will be using it. */ #define CopARYBASE_get(c) \ ((CopHINTS_get(c) & HINT_ARYBASE) \ - ? SvIV(Perl_refcounted_he_fetch(aTHX_ (c)->cop_hints_hash, 0, \ - "$[", 2, 0, 0)) \ + ? SvIV(cop_hints_fetch_pvs((c), "$[", 0)) \ : 0) #define CopARYBASE_set(c, b) STMT_START { \ if (b || ((c)->cop_hints & HINT_ARYBASE)) { \ @@ -273,10 +570,9 @@ struct cop { mg_set(val); \ PL_hints |= HINT_ARYBASE; \ } else { \ - (c)->cop_hints_hash \ - = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash, \ - newSVpvs_flags("$[", SVs_TEMP), \ - sv_2mortal(newSViv(b))); \ + CopHINTHASH_set((c), \ + cophh_store_pvs(CopHINTHASH_get((c)), "$[", \ + sv_2mortal(newSViv(b)), 0)); \ } \ } \ } STMT_END @@ -229,13 +229,6 @@ ApR |I32 |my_chsize |int fd|Off_t length #endif : Used in perly.y pR |OP* |convert |I32 optype|I32 flags|NULLOK OP* o -Apd |HV* |cop_hints_2hv |NN const COP *cop -Apd |SV* |cop_hints_fetchpvn|NN const COP *cop|NN const char *key \ - |STRLEN klen|int flags|U32 hash -Amd |SV* |cop_hints_fetchpvs|NN const COP *cop|NN const char *const key -Amd |SV* |cop_hints_fetchpv|NN const COP *cop|NN const char *const key \ - |int flags|U32 hash -Amd |SV* |cop_hints_fetchsv|NN const COP *cop|NN SV *keysv|U32 hash : Used in op.c and perl.c pM |PERL_CONTEXT* |create_eval_scope|U32 flags Aprd |void |croak_sv |NN SV *baseex @@ -480,26 +473,30 @@ ApMdR |HE* |hv_iternext_flags|NN HV *hv|I32 flags ApdR |SV* |hv_iterval |NN HV *hv|NN HE *entry Ap |void |hv_ksplit |NN HV *hv|IV newmax Apdbm |void |hv_magic |NN HV *hv|NULLOK GV *gv|int how -: Used in B.xs -XEdpoM |HV * |refcounted_he_chain_2hv|NULLOK const struct refcounted_he *c -: Used in APItest.xs -XEpoM |SV * |refcounted_he_fetch|NULLOK const struct refcounted_he *chain \ - |NULLOK SV *keysv|NULLOK const char *key \ - |STRLEN klen, int flags, U32 hash -: Used in various files -dpoM |void |refcounted_he_free|NULLOK struct refcounted_he *he -: Used in various files -XEdpoM |struct refcounted_he *|refcounted_he_new \ - |NULLOK struct refcounted_he *const parent \ - |NULLOK SV *const key|NULLOK SV *const value #if defined(PERL_IN_HV_C) -s |struct refcounted_he * |refcounted_he_new_common \ - |NULLOK struct refcounted_he *const parent \ - |NN const char *const key_p \ - |const STRLEN key_len|const char flags \ - |char value_type|NN const void *value \ - |const STRLEN value_len -#endif +s |SV * |refcounted_he_value |NN const struct refcounted_he *he +#endif +Xpd |HV * |refcounted_he_chain_2hv|NULLOK const struct refcounted_he *c|U32 flags +Xpd |SV * |refcounted_he_fetch_pvn|NULLOK const struct refcounted_he *chain \ + |NN const char *keypv|STRLEN keylen|U32 hash|U32 flags +Xpd |SV * |refcounted_he_fetch_pv|NULLOK const struct refcounted_he *chain \ + |NN const char *key|U32 hash|U32 flags +Xpd |SV * |refcounted_he_fetch_sv|NULLOK const struct refcounted_he *chain \ + |NN SV *key|U32 hash|U32 flags +Xpd |struct refcounted_he *|refcounted_he_new_pvn \ + |NULLOK struct refcounted_he *parent \ + |NN const char *keypv|STRLEN keylen \ + |U32 hash|NULLOK SV *value|U32 flags +Xpd |struct refcounted_he *|refcounted_he_new_pv \ + |NULLOK struct refcounted_he *parent \ + |NN const char *key \ + |U32 hash|NULLOK SV *value|U32 flags +Xpd |struct refcounted_he *|refcounted_he_new_sv \ + |NULLOK struct refcounted_he *parent \ + |NN SV *key \ + |U32 hash|NULLOK SV *value|U32 flags +Xpd |void |refcounted_he_free|NULLOK struct refcounted_he *he +Xpd |struct refcounted_he *|refcounted_he_inc|NULLOK struct refcounted_he *he Abmd |SV** |hv_store |NULLOK HV *hv|NULLOK const char *key \ |I32 klen|NULLOK SV *val|U32 hash Abmd |HE* |hv_store_ent |NULLOK HV *hv|NULLOK SV *key|NULLOK SV *val\ @@ -1531,7 +1528,6 @@ sM |SV* |hv_delete_common|NULLOK HV *hv|NULLOK SV *keysv \ |NULLOK const char *key|STRLEN klen|int k_flags|I32 d_flags \ |U32 hash sM |void |clear_placeholders |NN HV *hv|U32 items -sM |SV * |refcounted_he_value |NN const struct refcounted_he *he #endif #if defined(PERL_IN_MG_C) @@ -66,8 +66,6 @@ #define ck_warner Perl_ck_warner #define ck_warner_d Perl_ck_warner_d #endif -#define cop_hints_2hv(a) Perl_cop_hints_2hv(aTHX_ a) -#define cop_hints_fetchpvn(a,b,c,d,e) Perl_cop_hints_fetchpvn(aTHX_ a,b,c,d,e) #ifndef PERL_IMPLICIT_CONTEXT #define croak Perl_croak #endif @@ -1443,6 +1441,15 @@ #define pp_wantarray() Perl_pp_wantarray(aTHX) #define pp_warn() Perl_pp_warn(aTHX) #define pp_xor() Perl_pp_xor(aTHX) +#define refcounted_he_chain_2hv(a,b) Perl_refcounted_he_chain_2hv(aTHX_ a,b) +#define refcounted_he_fetch_pv(a,b,c,d) Perl_refcounted_he_fetch_pv(aTHX_ a,b,c,d) +#define refcounted_he_fetch_pvn(a,b,c,d,e) Perl_refcounted_he_fetch_pvn(aTHX_ a,b,c,d,e) +#define refcounted_he_fetch_sv(a,b,c,d) Perl_refcounted_he_fetch_sv(aTHX_ a,b,c,d) +#define refcounted_he_free(a) Perl_refcounted_he_free(aTHX_ a) +#define refcounted_he_inc(a) Perl_refcounted_he_inc(aTHX_ a) +#define refcounted_he_new_pv(a,b,c,d,e) Perl_refcounted_he_new_pv(aTHX_ a,b,c,d,e) +#define refcounted_he_new_pvn(a,b,c,d,e,f) Perl_refcounted_he_new_pvn(aTHX_ a,b,c,d,e,f) +#define refcounted_he_new_sv(a,b,c,d,e) Perl_refcounted_he_new_sv(aTHX_ a,b,c,d,e) #define report_evil_fh(a,b,c) Perl_report_evil_fh(aTHX_ a,b,c) #define rpeep(a) Perl_rpeep(aTHX_ a) #define rsignal_restore(a,b) Perl_rsignal_restore(aTHX_ a,b) @@ -1602,7 +1609,6 @@ #define hv_magic_check S_hv_magic_check #define hv_notallowed(a,b,c,d) S_hv_notallowed(aTHX_ a,b,c,d) #define new_he() S_new_he(aTHX) -#define refcounted_he_new_common(a,b,c,d,e,f,g) S_refcounted_he_new_common(aTHX_ a,b,c,d,e,f,g) #define refcounted_he_value(a) S_refcounted_he_value(aTHX_ a) #define save_hek_flags S_save_hek_flags #define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d) diff --git a/ext/B/B.xs b/ext/B/B.xs index 2b6fb8d3db..3d51969407 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1274,7 +1274,7 @@ B::RHE COP_hints_hash(o) B::COP o CODE: - RETVAL = o->cop_hints_hash; + RETVAL = CopHINTHASH_get(o); OUTPUT: RETVAL @@ -2046,7 +2046,7 @@ SV* RHE_HASH(h) B::RHE h CODE: - RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) ); + RETVAL = newRV( (SV*)cophh_2hv(h, 0) ); OUTPUT: RETVAL diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 632b9f6a47..55aa1de74d 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1125,9 +1125,7 @@ refcounted_he_exists(key, level=0) if (level) { croak("level must be zero, not %"IVdf, level); } - RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, - key, NULL, 0, 0, 0) - != &PL_sv_placeholder); + RETVAL = (cop_hints_fetch_sv(PL_curcop, key, 0, 0) != &PL_sv_placeholder); OUTPUT: RETVAL @@ -1139,8 +1137,7 @@ refcounted_he_fetch(key, level=0) if (level) { croak("level must be zero, not %"IVdf, level); } - RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key, - NULL, 0, 0, 0); + RETVAL = cop_hints_fetch_sv(PL_curcop, key, 0, 0); SvREFCNT_inc(RETVAL); OUTPUT: RETVAL @@ -1589,12 +1586,12 @@ my_caller(level) gv = CvGV(dbcx->blk_sub.cv); ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef; - ST(4) = cop_hints_fetchpvs(cx->blk_oldcop, "foo"); - ST(5) = cop_hints_fetchpvn(cx->blk_oldcop, "foo", 3, 0, 0); - ST(6) = cop_hints_fetchsv(cx->blk_oldcop, - sv_2mortal(newSVpvn("foo", 3)), 0); + ST(4) = cop_hints_fetch_pvs(cx->blk_oldcop, "foo", 0); + ST(5) = cop_hints_fetch_pvn(cx->blk_oldcop, "foo", 3, 0, 0); + ST(6) = cop_hints_fetch_sv(cx->blk_oldcop, + sv_2mortal(newSVpvn("foo", 3)), 0, 0); - hv = cop_hints_2hv(cx->blk_oldcop); + hv = cop_hints_2hv(cx->blk_oldcop, 0); ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef; XSRETURN(8); @@ -1897,6 +1894,118 @@ cv_set_call_checker_multi_sum(CV *cv) cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef); void +test_cophh() + PREINIT: + COPHH *a, *b; + CODE: +#define check_ph(EXPR) \ + do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0) +#define check_iv(EXPR, EXPECT) \ + do { if(SvIV(EXPR) != (EXPECT)) croak("fail"); } while(0) +#define msvpvs(STR) sv_2mortal(newSVpvs(STR)) +#define msviv(VALUE) sv_2mortal(newSViv(VALUE)) + a = cophh_new_empty(); + check_ph(cophh_fetch_pvn(a, "foo_1", 5, 0, 0)); + check_ph(cophh_fetch_pvs(a, "foo_1", 0)); + check_ph(cophh_fetch_pv(a, "foo_1", 0, 0)); + check_ph(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0)); + a = cophh_store_pvn(a, "foo_1abc", 5, 0, msviv(111), 0); + a = cophh_store_pvs(a, "foo_2", msviv(222), 0); + a = cophh_store_pv(a, "foo_3", 0, msviv(333), 0); + a = cophh_store_sv(a, msvpvs("foo_4"), 0, msviv(444), 0); + check_iv(cophh_fetch_pvn(a, "foo_1xyz", 5, 0, 0), 111); + check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111); + check_iv(cophh_fetch_pv(a, "foo_1", 0, 0), 111); + check_iv(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0), 111); + check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222); + check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333); + check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444); + check_ph(cophh_fetch_pvs(a, "foo_5", 0)); + b = cophh_copy(a); + b = cophh_store_pvs(b, "foo_1", msviv(1111), 0); + check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111); + check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222); + check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333); + check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444); + check_ph(cophh_fetch_pvs(a, "foo_5", 0)); + check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111); + check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222); + check_iv(cophh_fetch_pvs(b, "foo_3", 0), 333); + check_iv(cophh_fetch_pvs(b, "foo_4", 0), 444); + check_ph(cophh_fetch_pvs(b, "foo_5", 0)); + a = cophh_delete_pvn(a, "foo_1abc", 5, 0, 0); + a = cophh_delete_pvs(a, "foo_2", 0); + b = cophh_delete_pv(b, "foo_3", 0, 0); + b = cophh_delete_sv(b, msvpvs("foo_4"), 0, 0); + check_ph(cophh_fetch_pvs(a, "foo_1", 0)); + check_ph(cophh_fetch_pvs(a, "foo_2", 0)); + check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333); + check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444); + check_ph(cophh_fetch_pvs(a, "foo_5", 0)); + check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111); + check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222); + check_ph(cophh_fetch_pvs(b, "foo_3", 0)); + check_ph(cophh_fetch_pvs(b, "foo_4", 0)); + check_ph(cophh_fetch_pvs(b, "foo_5", 0)); + b = cophh_delete_pvs(b, "foo_3", 0); + b = cophh_delete_pvs(b, "foo_5", 0); + check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111); + check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222); + check_ph(cophh_fetch_pvs(b, "foo_3", 0)); + check_ph(cophh_fetch_pvs(b, "foo_4", 0)); + check_ph(cophh_fetch_pvs(b, "foo_5", 0)); + cophh_free(b); + check_ph(cophh_fetch_pvs(a, "foo_1", 0)); + check_ph(cophh_fetch_pvs(a, "foo_2", 0)); + check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333); + check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444); + check_ph(cophh_fetch_pvs(a, "foo_5", 0)); + a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8); + a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0); + a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8); + a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8); + a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8); + check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111); + check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111); + check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123); + check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123); + check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0)); + check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456); + check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456); + check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0)); + check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789); + check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789); + check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0)); + check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666); + check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0)); + cophh_free(a); +#undef check_ph +#undef check_iv +#undef msvpvs +#undef msviv + +HV * +example_cophh_2hv() + PREINIT: + COPHH *a; + CODE: +#define msviv(VALUE) sv_2mortal(newSViv(VALUE)) + a = cophh_new_empty(); + a = cophh_store_pvs(a, "foo_0", msviv(999), 0); + a = cophh_store_pvs(a, "foo_1", msviv(111), 0); + a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0); + a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8); + a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8); + a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8); + a = cophh_delete_pvs(a, "foo_0", 0); + a = cophh_delete_pvs(a, "foo_2", 0); + RETVAL = cophh_2hv(a, 0); + cophh_free(a); +#undef msviv + OUTPUT: + RETVAL + +void test_savehints() PREINIT: SV **svp, *sv; @@ -1906,7 +2015,7 @@ test_savehints() #define hint_ok(KEY, EXPECT) \ ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \ (sv = *svp) && SvIV(sv) == (EXPECT) && \ - (sv = cop_hints_fetchpvs(&PL_compiling, KEY)) && \ + (sv = cop_hints_fetch_pvs(&PL_compiling, KEY, 0)) && \ SvIV(sv) == (EXPECT)) #define check_hint(KEY, EXPECT) \ do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0) @@ -1953,15 +2062,18 @@ test_copyhints() ENTER; SAVEHINTS(); sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123); - if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak_fail(); + if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123) + croak_fail(); a = newHVhv(GvHV(PL_hintgv)); sv_2mortal((SV*)a); sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456); - if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak_fail(); + if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123) + croak_fail(); b = hv_copy_hints_hv(a); sv_2mortal((SV*)b); sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789); - if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 789) croak_fail(); + if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 789) + croak_fail(); LEAVE; void diff --git a/ext/XS-APItest/t/cophh.t b/ext/XS-APItest/t/cophh.t new file mode 100644 index 0000000000..a3fe49bb9d --- /dev/null +++ b/ext/XS-APItest/t/cophh.t @@ -0,0 +1,18 @@ +use warnings; +use strict; +use Test::More tests => 2; + +use XS::APItest; + +XS::APItest::test_cophh(); +ok 1; + +is_deeply XS::APItest::example_cophh_2hv(), { + "foo_1" => 111, + "foo_\x{aa}" => 123, + "foo_\x{bb}" => 456, + "foo_\x{cc}" => 789, + "foo_\x{666}" => 666, +}; + +1; diff --git a/global.sym b/global.sym index b0ac7a69a4..a5319b5f7c 100644 --- a/global.sym +++ b/global.sym @@ -61,8 +61,6 @@ Perl_ck_warner Perl_ck_warner_d Perl_ckwarn Perl_ckwarn_d -Perl_cop_hints_2hv -Perl_cop_hints_fetchpvn Perl_croak Perl_croak_no_modify Perl_croak_sv @@ -457,8 +455,14 @@ Perl_re_intuit_string Perl_realloc Perl_ref Perl_refcounted_he_chain_2hv -Perl_refcounted_he_fetch -Perl_refcounted_he_new +Perl_refcounted_he_fetch_pv +Perl_refcounted_he_fetch_pvn +Perl_refcounted_he_fetch_sv +Perl_refcounted_he_free +Perl_refcounted_he_inc +Perl_refcounted_he_new_pv +Perl_refcounted_he_new_pvn +Perl_refcounted_he_new_sv Perl_reg_named_buff Perl_reg_named_buff_all Perl_reg_named_buff_exists @@ -2021,8 +2021,7 @@ 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 ) { - SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, - 0, "overloading", 11, 0, 0); + SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0); if ( !lex_mask || !SvOK(lex_mask) ) /* overloading lexically disabled */ @@ -2627,93 +2627,44 @@ S_refcounted_he_value(pTHX_ const struct refcounted_he *he) SvUTF8_on(value); break; default: - Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x", - he->refcounted_he_data[0]); + Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf, + (UV)he->refcounted_he_data[0]); } return value; } /* -=for apidoc cop_hints_2hv +=for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags -Generates and returns a C<HV *> from the hinthash in the provided -C<COP>. Returns C<NULL> if there isn't one there. +Generates and returns a C<HV *> representing the content of a +C<refcounted_he> chain. +I<flags> is currently unused and must be zero. =cut */ HV * -Perl_cop_hints_2hv(pTHX_ const COP *cop) +Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags) { - PERL_ARGS_ASSERT_COP_HINTS_2HV; - - if (!cop->cop_hints_hash) - return NULL; - - return Perl_refcounted_he_chain_2hv(aTHX_ cop->cop_hints_hash); -} - -/* -=for apidoc cop_hints_fetchsv - -Fetches an entry from the hinthash in the provided C<COP>. Returns NULL -if the entry isn't there. - -=for apidoc cop_hints_fetchpvn - -See L</cop_hints_fetchsv>. If C<flags> includes C<HVhek_UTF8>, C<key> is -in UTF-8. - -=for apidoc cop_hints_fetchpv - -See L</cop_hints_fetchsv>. If C<flags> includes C<HVhek_UTF8>, C<key> is -in UTF-8. - -=for apidoc cop_hints_fetchpvs - -See L</cop_hints_fetchpvn>. This is a macro that takes a constant string -for its argument, which is assumed to be ASCII (rather than UTF-8). - -=cut -*/ -SV * -Perl_cop_hints_fetchpvn(pTHX_ const COP *cop, const char *key, STRLEN klen, - int flags, U32 hash) -{ - PERL_ARGS_ASSERT_COP_HINTS_FETCHPVN; - - /* refcounted_he_fetch takes more flags than we do. Make sure - * noone's depending on being able to pass them here. */ - flags &= ~HVhek_UTF8; - - return Perl_refcounted_he_fetch(aTHX_ cop->cop_hints_hash, NULL, - key, klen, flags, hash); -} - -/* -=for apidoc refcounted_he_chain_2hv + dVAR; + HV *hv; + U32 placeholders, max; -Generates and returns a C<HV *> by walking up the tree starting at the passed -in C<struct refcounted_he *>. + if (flags) + Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf, + (UV)flags); -=cut -*/ -HV * -Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) -{ - dVAR; - HV *hv = newHV(); - U32 placeholders = 0; /* We could chase the chain once to get an idea of the number of keys, and call ksplit. But for now we'll make a potentially inefficient hash with only 8 entries in its array. */ - const U32 max = HvMAX(hv); - + hv = newHV(); + max = HvMAX(hv); if (!HvARRAY(hv)) { char *array; Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char); HvARRAY(hv) = (HE**)array; } + placeholders = 0; while (chain) { #ifdef USE_ITHREADS U32 hash = chain->refcounted_he_hash; @@ -2790,190 +2741,316 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) return hv; } +/* +=for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags + +Search along a C<refcounted_he> chain for an entry with the key specified +by I<keypv> and I<keylen>. If I<flags> has the C<REFCOUNTED_HE_KEY_UTF8> +bit set, the key octets are interpreted as UTF-8, otherwise they +are interpreted as Latin-1. I<hash> is a precomputed hash of the key +string, or zero if it has not been precomputed. Returns a mortal scalar +representing the value associated with the key, or C<&PL_sv_placeholder> +if there is no value associated with the key. + +=cut +*/ + SV * -Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, - const char *key, STRLEN klen, int flags, U32 hash) +Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain, + const char *keypv, STRLEN keylen, U32 hash, U32 flags) { dVAR; - /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness - of your key has to exactly match that which is stored. */ - SV *value = &PL_sv_placeholder; + U8 utf8_flag; + PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN; - if (chain) { - /* No point in doing any of this if there's nothing to find. */ - bool is_utf8; - - if (keysv) { - if (flags & HVhek_FREEKEY) - Safefree(key); - key = SvPV_const(keysv, klen); - flags = 0; - is_utf8 = (SvUTF8(keysv) != 0); - } else { - is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE); + if (flags & ~REFCOUNTED_HE_KEY_UTF8) + Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf, + (UV)flags); + if (!chain) + return &PL_sv_placeholder; + if (flags & REFCOUNTED_HE_KEY_UTF8) { + /* For searching purposes, canonicalise to Latin-1 where possible. */ + const char *keyend = keypv + keylen, *p; + STRLEN nonascii_count = 0; + for (p = keypv; p != keyend; p++) { + U8 c = (U8)*p; + if (c & 0x80) { + if (!((c & 0xfe) == 0xc2 && ++p != keyend && + (((U8)*p) & 0xc0) == 0x80)) + goto canonicalised_key; + nonascii_count++; + } } - - if (!hash) { - if (keysv && (SvIsCOW_shared_hash(keysv))) { - hash = SvSHARED_HASH(keysv); - } else { - PERL_HASH(hash, key, klen); + if (nonascii_count) { + char *q; + const char *p = keypv, *keyend = keypv + keylen; + keylen -= nonascii_count; + Newx(q, keylen, char); + SAVEFREEPV(q); + keypv = q; + for (; p != keyend; p++, q++) { + U8 c = (U8)*p; + *q = (char) + ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c); } } + flags &= ~REFCOUNTED_HE_KEY_UTF8; + canonicalised_key: ; + } + utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0; + if (!hash) + PERL_HASH(hash, keypv, keylen); - for (; chain; chain = chain->refcounted_he_next) { + for (; chain; chain = chain->refcounted_he_next) { + if ( #ifdef USE_ITHREADS - if (hash != chain->refcounted_he_hash) - continue; - if (klen != chain->refcounted_he_keylen) - continue; - if (memNE(REF_HE_KEY(chain),key,klen)) - continue; - if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8)) - continue; + hash == chain->refcounted_he_hash && + keylen == chain->refcounted_he_keylen && + memEQ(REF_HE_KEY(chain), keypv, keylen) && + utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8) #else - if (hash != HEK_HASH(chain->refcounted_he_hek)) - continue; - if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek)) - continue; - if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen)) - continue; - if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek)) - continue; + hash == HEK_HASH(chain->refcounted_he_hek) && + keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) && + memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) && + utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8) #endif - - value = sv_2mortal(refcounted_he_value(chain)); - break; - } + ) + return sv_2mortal(refcounted_he_value(chain)); } + return &PL_sv_placeholder; +} - if (flags & HVhek_FREEKEY) - Safefree(key); +/* +=for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags - return value; +Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string +instead of a string/length pair. + +=cut +*/ + +SV * +Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain, + const char *key, U32 hash, U32 flags) +{ + PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV; + return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags); } /* -=for apidoc refcounted_he_new +=for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags + +Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a +string/length pair. + +=cut +*/ -Creates a new C<struct refcounted_he>. As S<key> is copied, and value is -stored in a compact form, all references remain the property of the caller. -The C<struct refcounted_he> is returned with a reference count of 1. +SV * +Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain, + SV *key, U32 hash, U32 flags) +{ + const char *keypv; + STRLEN keylen; + PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV; + if (flags & REFCOUNTED_HE_KEY_UTF8) + Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf, + (UV)flags); + keypv = SvPV_const(key, keylen); + if (SvUTF8(key)) + flags |= REFCOUNTED_HE_KEY_UTF8; + if (!hash && SvIsCOW_shared_hash(key)) + hash = SvSHARED_HASH(key); + return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags); +} + +/* +=for apidoc m|struct refcounted_he *|refcounted_he_new_pvn|struct refcounted_he *parent|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags + +Creates a new C<refcounted_he>. This consists of a single key/value +pair and a reference to an existing C<refcounted_he> chain (which may +be empty), and thus forms a longer chain. When using the longer chain, +the new key/value pair takes precedence over any entry for the same key +further along the chain. + +The new key is specified by I<keypv> and I<keylen>. If I<flags> has +the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted +as UTF-8, otherwise they are interpreted as Latin-1. I<hash> is +a precomputed hash of the key string, or zero if it has not been +precomputed. + +I<value> is the scalar value to store for this key. I<value> is copied +by this function, which thus does not take ownership of any reference +to it, and later changes to the scalar will not be reflected in the +value visible in the C<refcounted_he>. Complex types of scalar will not +be stored with referential integrity, but will be coerced to strings. +I<value> may be either null or C<&PL_sv_placeholder> to indicate that no +value is to be associated with the key; this, as with any non-null value, +takes precedence over the existence of a value for the key further along +the chain. + +I<parent> points to the rest of the C<refcounted_he> chain to be +attached to the new C<refcounted_he>. This function takes ownership +of one reference to I<parent>, and returns one reference to the new +C<refcounted_he>. =cut */ struct refcounted_he * -Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, - SV *const key, SV *const value) { +Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent, + const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags) +{ dVAR; - STRLEN key_len; - const char *key_p = SvPV_const(key, key_len); STRLEN value_len = 0; const char *value_p = NULL; + bool is_pv; char value_type; - char flags; - bool is_utf8 = SvUTF8(key) ? TRUE : FALSE; + char hekflags; + STRLEN key_offset = 1; + struct refcounted_he *he; + PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN; - if (SvPOK(value)) { + if (!value || value == &PL_sv_placeholder) { + value_type = HVrhek_delete; + } else if (SvPOK(value)) { value_type = HVrhek_PV; } else if (SvIOK(value)) { value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV; - } else if (value == &PL_sv_placeholder) { - value_type = HVrhek_delete; } else if (!SvOK(value)) { value_type = HVrhek_undef; } else { value_type = HVrhek_PV; } - - if (value_type == HVrhek_PV) { + is_pv = value_type == HVrhek_PV; + if (is_pv) { /* Do it this way so that the SvUTF8() test is after the SvPV, in case the value is overloaded, and doesn't yet have the UTF-8flag set. */ value_p = SvPV_const(value, value_len); if (SvUTF8(value)) value_type = HVrhek_PV_UTF8; + key_offset = value_len + 2; + } + hekflags = value_type; + + if (flags & REFCOUNTED_HE_KEY_UTF8) { + /* Canonicalise to Latin-1 where possible. */ + const char *keyend = keypv + keylen, *p; + STRLEN nonascii_count = 0; + for (p = keypv; p != keyend; p++) { + U8 c = (U8)*p; + if (c & 0x80) { + if (!((c & 0xfe) == 0xc2 && ++p != keyend && + (((U8)*p) & 0xc0) == 0x80)) + goto canonicalised_key; + nonascii_count++; + } + } + if (nonascii_count) { + char *q; + const char *p = keypv, *keyend = keypv + keylen; + keylen -= nonascii_count; + Newx(q, keylen, char); + SAVEFREEPV(q); + keypv = q; + for (; p != keyend; p++, q++) { + U8 c = (U8)*p; + *q = (char) + ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c); + } + } + flags &= ~REFCOUNTED_HE_KEY_UTF8; + canonicalised_key: ; } - flags = value_type; - - if (is_utf8) { - /* Hash keys are always stored normalised to (yes) ISO-8859-1. - As we're going to be building hash keys from this value in future, - normalise it now. */ - key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8); - flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8; - } - - return refcounted_he_new_common(parent, key_p, key_len, flags, value_type, - ((value_type == HVrhek_PV - || value_type == HVrhek_PV_UTF8) ? - (void *)value_p : (void *)value), - value_len); -} - -static struct refcounted_he * -S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent, - const char *const key_p, const STRLEN key_len, - const char flags, char value_type, - const void *value, const STRLEN value_len) { - dVAR; - struct refcounted_he *he; - U32 hash; - const bool is_pv = value_type == HVrhek_PV || value_type == HVrhek_PV_UTF8; - STRLEN key_offset = is_pv ? value_len + 2 : 1; + if (flags & REFCOUNTED_HE_KEY_UTF8) + hekflags |= HVhek_UTF8; + if (!hash) + PERL_HASH(hash, keypv, keylen); - PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON; - -#ifdef USE_ITHREADS - he = (struct refcounted_he*) - PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 - + key_len - + key_offset); -#else he = (struct refcounted_he*) PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 - + key_offset); +#ifdef USE_ITHREADS + + keylen #endif + + key_offset); he->refcounted_he_next = parent; if (is_pv) { - Copy((char *)value, he->refcounted_he_data + 1, value_len + 1, char); + Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char); he->refcounted_he_val.refcounted_he_u_len = value_len; } else if (value_type == HVrhek_IV) { - he->refcounted_he_val.refcounted_he_u_iv = SvIVX((const SV *)value); + he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value); } else if (value_type == HVrhek_UV) { - he->refcounted_he_val.refcounted_he_u_uv = SvUVX((const SV *)value); + he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value); } - PERL_HASH(hash, key_p, key_len); - #ifdef USE_ITHREADS he->refcounted_he_hash = hash; - he->refcounted_he_keylen = key_len; - Copy(key_p, he->refcounted_he_data + key_offset, key_len, char); + he->refcounted_he_keylen = keylen; + Copy(keypv, he->refcounted_he_data + key_offset, keylen, char); #else - he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags); + he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags); #endif - if (flags & HVhek_WASUTF8) { - /* If it was downgraded from UTF-8, then the pointer returned from - bytes_from_utf8 is an allocated pointer that we must free. */ - Safefree(key_p); - } - - he->refcounted_he_data[0] = flags; + he->refcounted_he_data[0] = hekflags; he->refcounted_he_refcnt = 1; return he; } /* -=for apidoc refcounted_he_free +=for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags -Decrements the reference count of the passed in C<struct refcounted_he *> -by one. If the reference count reaches zero the structure's memory is freed, -and C<refcounted_he_free> iterates onto the parent node. +Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead +of a string/length pair. + +=cut +*/ + +struct refcounted_he * +Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent, + const char *key, U32 hash, SV *value, U32 flags) +{ + PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV; + return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags); +} + +/* +=for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags + +Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a +string/length pair. + +=cut +*/ + +struct refcounted_he * +Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent, + SV *key, U32 hash, SV *value, U32 flags) +{ + const char *keypv; + STRLEN keylen; + PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV; + if (flags & REFCOUNTED_HE_KEY_UTF8) + Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf, + (UV)flags); + keypv = SvPV_const(key, keylen); + if (SvUTF8(key)) + flags |= REFCOUNTED_HE_KEY_UTF8; + if (!hash && SvIsCOW_shared_hash(key)) + hash = SvSHARED_HASH(key); + return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags); +} + +/* +=for apidoc m|void|refcounted_he_free|struct refcounted_he *he + +Decrements the reference count of a C<refcounted_he> by one. If the +reference count reaches zero the structure's memory is freed, which +(recursively) causes a reduction of its parent C<refcounted_he>'s +reference count. It is safe to pass a null pointer to this function: +no action occurs in this case. =cut */ @@ -3004,6 +3081,27 @@ Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) { } } +/* +=for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he + +Increment the reference count of a C<refcounted_he>. The pointer to the +C<refcounted_he> is also returned. It is safe to pass a null pointer +to this function: no action occurs and a null pointer is returned. + +=cut +*/ + +struct refcounted_he * +Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he) +{ + if (he) { + HINTS_REFCNT_LOCK; + he->refcounted_he_refcnt++; + HINTS_REFCNT_UNLOCK; + } + return he; +} + /* pp_entereval is aware that labels are stored with a key ':' at the top of the linked list. */ const char * @@ -3044,16 +3142,17 @@ void Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len, U32 flags) { + SV *labelsv; PERL_ARGS_ASSERT_STORE_COP_LABEL; if (flags & ~(SVf_UTF8)) Perl_croak(aTHX_ "panic: store_cop_label illegal flag bits 0x%" UVxf, (UV)flags); - + labelsv = sv_2mortal(newSVpvn(label, len)); + if (flags & SVf_UTF8) + SvUTF8_on(labelsv); cop->cop_hints_hash - = refcounted_he_new_common(cop->cop_hints_hash, ":", 1, HVrhek_PV, - flags & SVf_UTF8 ? HVrhek_PV_UTF8 : HVrhek_PV, - label, len); + = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0); } /* @@ -451,18 +451,11 @@ C<SV*>. between threads (because it hangs from OPs, which are shared), hence the alternate definition and mutex. */ -#define cop_hints_fetchsv(cop, keysv, hash) \ - Perl_cop_hints_fetchpvn(aTHX_ (cop), SvPV_nolen(keysv), SvCUR(keysv), \ - (SvUTF8(keysv) ? HVhek_UTF8 : 0), (hash)) - -#define cop_hints_fetchpv(cop, key, flags, hash) \ - Perl_cop_hints_fetchpvn(aTHX_ (cop), key, strlen(key), (flags), (hash)) - -#define cop_hints_fetchpvs(cop, key) \ - Perl_cop_hints_fetchpvn(aTHX_ (cop), STR_WITH_LEN(key), 0, 0) - struct refcounted_he; +/* flags for the refcounted_he API */ +#define REFCOUNTED_HE_KEY_UTF8 0x00000001 + #ifdef PERL_CORE /* Gosh. This really isn't a good name any longer. */ @@ -486,6 +479,30 @@ struct refcounted_he { char refcounted_he_data[1]; }; +/* +=for apidoc m|SV *|refcounted_he_fetch_pvs|const struct refcounted_he *chain|const char *key|U32 flags + +Like L</refcounted_he_fetch_pvn>, but takes a literal string instead of +a string/length pair, and no precomputed hash. + +=cut +*/ + +#define refcounted_he_fetch_pvs(chain, key, flags) \ + Perl_refcounted_he_fetch_pvn(aTHX_ chain, STR_WITH_LEN(key), 0, flags) + +/* +=for apidoc m|struct refcounted_he *|refcounted_he_new_pvs|struct refcounted_he *parent|const char *key|SV *value|U32 flags + +Like L</refcounted_he_new_pvn>, but takes a literal string instead of +a string/length pair, and no precomputed hash. + +=cut +*/ + +#define refcounted_he_new_pvs(parent, key, value, flags) \ + Perl_refcounted_he_new_pvn(aTHX_ parent, STR_WITH_LEN(key), 0, value, flags) + /* Flag bits are HVhek_UTF8, HVhek_WASUTF8, then */ #define HVrhek_undef 0x00 /* Value is undef. */ #define HVrhek_delete 0x10 /* Value is placeholder - signifies delete. */ @@ -781,17 +781,13 @@ Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) sv_setpvs(sv, ""); SvUTF8_off(sv); if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) { - SV *const value = Perl_refcounted_he_fetch(aTHX_ - c->cop_hints_hash, - 0, "open<", 5, 0, 0); + SV *const value = cop_hints_fetch_pvs(c, "open<", 0); assert(value); sv_catsv(sv, value); } sv_catpvs(sv, "\0"); if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) { - SV *const value = Perl_refcounted_he_fetch(aTHX_ - c->cop_hints_hash, - 0, "open>", 5, 0, 0); + SV *const value = cop_hints_fetch_pvs(c, "open>", 0); assert(value); sv_catsv(sv, value); } @@ -3170,8 +3166,8 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) Doing this here saves a lot of doing it manually in perl code (and forgetting to do it, and consequent subtle errors. */ PL_hints |= HINT_LOCALIZE_HH; - PL_compiling.cop_hints_hash - = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv); + CopHINTHASH_set(&PL_compiling, + cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0)); return 0; } @@ -3196,9 +3192,9 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(sv); PL_hints |= HINT_LOCALIZE_HH; - PL_compiling.cop_hints_hash - = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, - MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder); + CopHINTHASH_set(&PL_compiling, + cophh_delete_sv(CopHINTHASH_get(&PL_compiling), + MUTABLE_SV(mg->mg_ptr), 0, 0)); return 0; } @@ -3215,10 +3211,8 @@ Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_CLEARHINTS; PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg); - if (PL_compiling.cop_hints_hash) { - Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); - PL_compiling.cop_hints_hash = NULL; - } + cophh_free(CopHINTHASH_get(&PL_compiling)); + CopHINTHASH_set(&PL_compiling, cophh_new_empty()); return 0; } @@ -717,7 +717,7 @@ S_cop_free(pTHX_ COP* cop) CopSTASH_free(cop); if (! specialWARN(cop->cop_warnings)) PerlMemShared_free(cop->cop_warnings); - Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash); + cophh_free(CopHINTHASH_get(cop)); } STATIC void @@ -3735,12 +3735,12 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) pmop->op_pmflags |= RXf_PMf_UNICODE; } if (PL_hints & HINT_RE_FLAGS) { - SV *reflags = Perl_refcounted_he_fetch(aTHX_ - PL_compiling.cop_hints_hash, 0, STR_WITH_LEN("reflags"), 0, 0 + SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_ + PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0 ); if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags); - reflags = Perl_refcounted_he_fetch(aTHX_ - PL_compiling.cop_hints_hash, 0, STR_WITH_LEN("reflags_dul"), 0, 0 + reflags = Perl_refcounted_he_fetch_pvn(aTHX_ + PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_dul"), 0, 0 ); if (reflags && SvOK(reflags)) { pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE); @@ -4798,12 +4798,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) CopHINTS and a possible value in cop_hints_hash, so no need to copy it. */ cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); - cop->cop_hints_hash = PL_curcop->cop_hints_hash; - if (cop->cop_hints_hash) { - HINTS_REFCNT_LOCK; - cop->cop_hints_hash->refcounted_he_refcnt++; - HINTS_REFCNT_UNLOCK; - } + CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop))); if (label) { Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0); @@ -1026,8 +1026,8 @@ perl_destruct(pTHXx) if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = NULL; - Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); - PL_compiling.cop_hints_hash = NULL; + cophh_free(CopHINTHASH_get(&PL_compiling)); + CopHINTHASH_set(&PL_compiling, cophh_new_empty()); CopFILE_free(&PL_compiling); CopSTASH_free(&PL_compiling); @@ -5232,8 +5232,7 @@ Perl_PerlIO_context_layers(pTHX_ const char *mode) if (!direction) return NULL; - layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, - 0, direction, 5, 0, 0); + layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0); assert(layers); return SvOK(layers) ? SvPV_nolen_const(layers) : NULL; @@ -194,8 +194,7 @@ PP(pp_regcomp) PM_SETRE(pm, NULL); /* crucial if regcomp aborts */ #endif } else if (PL_curcop->cop_hints_hash) { - SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0, - "regcomp", 7, 0, 0); + SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0); if (ptr && SvIOK(ptr) && SvIV(ptr)) eng = INT2PTR(regexp_engine*,SvIV(ptr)); } @@ -1915,9 +1914,7 @@ PP(pp_caller) } PUSHs(cx->blk_oldcop->cop_hints_hash ? - sv_2mortal(newRV_noinc( - MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_ - cx->blk_oldcop->cop_hints_hash)))) + sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0)))) : &PL_sv_undef); RETURN; } @@ -3892,25 +3889,18 @@ PP(pp_entereval) } SAVECOMPILEWARNINGS(); PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); - if (PL_compiling.cop_hints_hash) { - Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); - } + cophh_free(CopHINTHASH_get(&PL_compiling)); if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) { /* The label, if present, is the first entry on the chain. So rather than writing a blank label in front of it (which involves an allocation), just use the next entry in the chain. */ PL_compiling.cop_hints_hash - = PL_curcop->cop_hints_hash->refcounted_he_next; + = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next); /* Check the assumption that this removed the label. */ assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); } else - PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash; - if (PL_compiling.cop_hints_hash) { - HINTS_REFCNT_LOCK; - PL_compiling.cop_hints_hash->refcounted_he_refcnt++; - HINTS_REFCNT_UNLOCK; - } + PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash); /* special case: an eval '' executed within the DB package gets lexically * placed in the first non-DB CV rather than the current CV - this * allows the debugger to execute code, find lexicals etc, in the @@ -532,29 +532,6 @@ PERL_CALLCONV bool Perl_ckwarn_d(pTHX_ U32 w); PERL_CALLCONV OP* Perl_convert(pTHX_ I32 optype, I32 flags, OP* o) __attribute__warn_unused_result__; -PERL_CALLCONV HV* Perl_cop_hints_2hv(pTHX_ const COP *cop) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_COP_HINTS_2HV \ - assert(cop) - -/* PERL_CALLCONV SV* cop_hints_fetchpv(pTHX_ const COP *cop, const char *const key, int flags, U32 hash) - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); */ - -PERL_CALLCONV SV* Perl_cop_hints_fetchpvn(pTHX_ const COP *cop, const char *key, STRLEN klen, int flags, U32 hash) - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); -#define PERL_ARGS_ASSERT_COP_HINTS_FETCHPVN \ - assert(cop); assert(key) - -/* PERL_CALLCONV SV* cop_hints_fetchpvs(pTHX_ const COP *cop, const char *const key) - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); */ - -/* PERL_CALLCONV SV* cop_hints_fetchsv(pTHX_ const COP *cop, SV *keysv, U32 hash) - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); */ - PERL_CALLCONV PERL_CONTEXT* Perl_create_eval_scope(pTHX_ U32 flags); PERL_CALLCONV void Perl_croak(pTHX_ const char* pat, ...) __attribute__noreturn__ @@ -3292,10 +3269,39 @@ PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes) __attribute__warn_unused_result__; /* PERL_CALLCONV OP* Perl_ref(pTHX_ OP* o, I32 type); */ -PERL_CALLCONV HV * Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *c); -PERL_CALLCONV SV * Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, const char *key, STRLEN klen, int flags, U32 hash); +PERL_CALLCONV HV * Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *c, U32 flags); +PERL_CALLCONV SV * Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain, const char *key, U32 hash, U32 flags) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV \ + assert(key) + +PERL_CALLCONV SV * Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain, const char *keypv, STRLEN keylen, U32 hash, U32 flags) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN \ + assert(keypv) + +PERL_CALLCONV SV * Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain, SV *key, U32 hash, U32 flags) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV \ + assert(key) + PERL_CALLCONV void Perl_refcounted_he_free(pTHX_ struct refcounted_he *he); -PERL_CALLCONV struct refcounted_he * Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, SV *const key, SV *const value); +PERL_CALLCONV struct refcounted_he * Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he); +PERL_CALLCONV struct refcounted_he * Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent, const char *key, U32 hash, SV *value, U32 flags) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV \ + assert(key) + +PERL_CALLCONV struct refcounted_he * Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent, const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN \ + assert(keypv) + +PERL_CALLCONV struct refcounted_he * Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent, SV *key, U32 hash, SV *value, U32 flags) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV \ + assert(key) + PERL_CALLCONV SV* Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REG_NAMED_BUFF \ @@ -5553,12 +5559,6 @@ STATIC HE* S_new_he(pTHX) __attribute__malloc__ __attribute__warn_unused_result__; -STATIC struct refcounted_he * S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent, const char *const key_p, const STRLEN key_len, const char flags, char value_type, const void *value, const STRLEN value_len) - __attribute__nonnull__(pTHX_2) - __attribute__nonnull__(pTHX_6); -#define PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON \ - assert(key_p); assert(value) - STATIC SV * S_refcounted_he_value(pTHX_ const struct refcounted_he *he) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE \ @@ -598,17 +598,12 @@ void Perl_save_hints(pTHX) { dVAR; - if (PL_compiling.cop_hints_hash) { - HINTS_REFCNT_LOCK; - PL_compiling.cop_hints_hash->refcounted_he_refcnt++; - HINTS_REFCNT_UNLOCK; - } + COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling)); if (PL_hints & HINT_LOCALIZE_HH) { - save_pushptri32ptr(GvHV(PL_hintgv), PL_hints, - PL_compiling.cop_hints_hash, SAVEt_HINTS); + save_pushptri32ptr(GvHV(PL_hintgv), PL_hints, save_cophh, SAVEt_HINTS); GvHV(PL_hintgv) = hv_copy_hints_hv(GvHV(PL_hintgv)); } else { - save_pushi32ptr(PL_hints, PL_compiling.cop_hints_hash, SAVEt_HINTS); + save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS); } } @@ -1019,8 +1014,8 @@ Perl_leave_scope(pTHX_ I32 base) SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv))); GvHV(PL_hintgv) = NULL; } - Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); - PL_compiling.cop_hints_hash = (struct refcounted_he *) SSPOPPTR; + cophh_free(CopHINTHASH_get(&PL_compiling)); + CopHINTHASH_set(&PL_compiling, (COPHH*)SSPOPPTR); *(I32*)&PL_hints = (I32)SSPOPINT; if (PL_hints & HINT_LOCALIZE_HH) { SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv))); @@ -12230,11 +12230,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) break; case SAVEt_HINTS: ptr = POPPTR(ss,ix); - if (ptr) { - HINTS_REFCNT_LOCK; - ((struct refcounted_he *)ptr)->refcounted_he_refcnt++; - HINTS_REFCNT_UNLOCK; - } + ptr = cophh_copy((COPHH*)ptr); TOPPTR(nss,ix) = ptr; i = POPINT(ss,ix); TOPINT(nss,ix) = i; @@ -12587,11 +12583,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); - if (PL_compiling.cop_hints_hash) { - HINTS_REFCNT_LOCK; - PL_compiling.cop_hints_hash->refcounted_he_refcnt++; - HINTS_REFCNT_UNLOCK; - } + CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling))); PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl); #ifdef PERL_DEBUG_READONLY_OPS PL_slabs = NULL; |