LOCK_SV_MUTEX;
if (!*root)
S_more_he(aTHX);
- he = *root;
+ he = (HE*) *root;
assert(he);
*root = HeNEXT(he);
UNLOCK_SV_MUTEX;
return NULL;
if (keysv) {
+ if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
+ keysv = hv_magic_uvar_xkey(hv, keysv, action);
if (flags & HVhek_FREEKEY)
Safefree(key);
key = SvPV_const(keysv, klen);
xhv = (XPVHV*)SvANY(hv);
if (SvMAGICAL(hv)) {
if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
- if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
- sv = sv_newmortal();
+ MAGIC *regdata = NULL;
+ if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)
+ || (regdata = mg_find((SV*)hv, PERL_MAGIC_regdata_names))) {
/* XXX should be able to skimp on the HE/HEK here when
HV_FETCH_JUST_SV is true. */
-
if (!keysv) {
keysv = newSVpvn(key, klen);
if (is_utf8) {
} else {
keysv = newSVsv(keysv);
}
- mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
+ if (regdata) {
+ sv = Perl_reg_named_buff_sv(aTHX_ keysv);
+ if (!sv) {
+ SvREFCNT_dec(keysv);
+ return 0;
+ }
+ } else {
+ sv = sv_newmortal();
+ mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
+ }
/* grab a fake HE/HEK pair from the pool or make a new one */
entry = PL_hv_fetch_ent_mh;
return NULL;
if (keysv) {
+ if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
+ keysv = hv_magic_uvar_xkey(hv, keysv, -1);
if (k_flags & HVhek_FREEKEY)
Safefree(key);
key = SvPV_const(keysv, klen);
} else {
hv_auxinit(hv);
}
-
+ if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
+ MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_regdata_names);
+ if ( mg ) {
+ if (PL_curpm) {
+ const REGEXP * const rx = PM_GETRE(PL_curpm);
+ if (rx && rx->paren_names) {
+ (void)hv_iterinit(rx->paren_names);
+ }
+ }
+ }
+ }
/* used to be xhv->xhv_fill before 5.004_65 */
return HvTOTALKEYS(hv);
}
if (!hv)
Perl_croak(aTHX_ "Bad hash");
+
xhv = (XPVHV*)SvANY(hv);
if (!SvOOK(hv)) {
iter = HvAUX(hv);
oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
+ if (SvMAGICAL(hv) && SvRMAGICAL(hv) &&
+ (mg = mg_find((SV*)hv, PERL_MAGIC_regdata_names)))
+ {
+ SV * key;
+ SV *val = NULL;
+ REGEXP * rx;
+ if (!PL_curpm)
+ return NULL;
+ rx = PM_GETRE(PL_curpm);
+ if (rx && rx->paren_names) {
+ hv = rx->paren_names;
+ } else {
+ return NULL;
+ }
- if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
+ key = sv_newmortal();
+ if (entry) {
+ sv_setsv(key, HeSVKEY_force(entry));
+ SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
+ }
+ else {
+ char *k;
+ HEK *hek;
+
+ /* one HE per MAGICAL hash */
+ iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
+ Zero(entry, 1, HE);
+ Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
+ hek = (HEK*)k;
+ HeKEY_hek(entry) = hek;
+ HeKLEN(entry) = HEf_SVKEY;
+ }
+ {
+ while (!val) {
+ HE *temphe = hv_iternext_flags(hv,flags);
+ if (temphe) {
+ IV i;
+ IV parno = 0;
+ SV* sv_dat = HeVAL(temphe);
+ I32 *nums = (I32*)SvPVX(sv_dat);
+ for ( i = 0; i < SvIVX(sv_dat); i++ ) {
+ if ((I32)(rx->lastcloseparen) >= nums[i] &&
+ rx->startp[nums[i]] != -1 &&
+ rx->endp[nums[i]] != -1)
+ {
+ parno = nums[i];
+ break;
+ }
+ }
+ if (parno) {
+ GV *gv_paren;
+ STRLEN len;
+ SV *sv = sv_newmortal();
+ const char* pvkey = HePV(temphe, len);
+
+ Perl_sv_setpvf(aTHX_ sv, "%"IVdf,(IV)parno);
+ gv_paren = Perl_gv_fetchsv(aTHX_ sv, GV_ADD, SVt_PVGV);
+ Perl_sv_setpvn(aTHX_ key, pvkey, len);
+ val = GvSVn(gv_paren);
+ }
+ } else {
+ break;
+ }
+ }
+ }
+ if (val && SvOK(key)) {
+ /* force key to stay around until next time */
+ HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
+ HeVAL(entry) = SvREFCNT_inc_simple_NN(val);
+ return entry; /* beware, hent_val is not set */
+ }
+ if (HeVAL(entry))
+ SvREFCNT_dec(HeVAL(entry));
+ Safefree(HeKEY_hek(entry));
+ del_HE(entry);
+ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
+ return NULL;
+
+ } else if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
SV * const key = sv_newmortal();
if (entry) {
sv_setsv(key, HeSVKEY_force(entry));
return HeKEY_hek(entry);
}
+STATIC SV *
+S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, 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;
+ mg->mg_obj = keysv; /* pass key */
+ uf->uf_index = action; /* pass action */
+ magic_getuvar((SV*)hv, mg);
+ keysv = mg->mg_obj; /* may have changed */
+ mg->mg_obj = obj;
+ }
+ }
+ return keysv;
+}
+
I32 *
Perl_hv_placeholders_p(pTHX_ HV *hv)
{
/* else we don't need to add magic to record 0 placeholders. */
}
+SV *
+S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
+{
+ dVAR;
+ SV *value;
+ switch(he->refcounted_he_data[0] & HVrhek_typemask) {
+ case HVrhek_undef:
+ value = newSV(0);
+ break;
+ case HVrhek_delete:
+ value = &PL_sv_placeholder;
+ break;
+ case HVrhek_IV:
+ value = (he->refcounted_he_data[0] & HVrhek_UV)
+ ? newSVuv(he->refcounted_he_val.refcounted_he_u_iv)
+ : newSViv(he->refcounted_he_val.refcounted_he_u_uv);
+ break;
+ case HVrhek_PV:
+ /* Create a string SV that directly points to the bytes in our
+ structure. */
+ value = newSV(0);
+ sv_upgrade(value, SVt_PV);
+ SvPV_set(value, (char *) he->refcounted_he_data + 1);
+ SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
+ /* This stops anything trying to free it */
+ SvLEN_set(value, 0);
+ SvPOK_on(value);
+ SvREADONLY_on(value);
+ if (he->refcounted_he_data[0] & HVrhek_UTF8)
+ SvUTF8_on(value);
+ break;
+ default:
+ Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
+ he->refcounted_he_data[0]);
+ }
+ return value;
+}
+
+#ifdef USE_ITHREADS
+/* A big expression to find the key offset */
+#define REF_HE_KEY(chain) \
+ ((((chain->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV) \
+ ? chain->refcounted_he_val.refcounted_he_u_len + 1 : 0) \
+ + 1 + chain->refcounted_he_data)
+#endif
+
/*
=for apidoc refcounted_he_chain_2hv
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) == hash) {
- goto next_please;
+ /* We might have a duplicate key here. If so, entry is older
+ than the key we've already put in the hash, so if they are
+ the same, skip adding entry. */
+#ifdef USE_ITHREADS
+ const STRLEN klen = HeKLEN(entry);
+ const char *const key = HeKEY(entry);
+ if (klen == chain->refcounted_he_keylen
+ && (!!HeKUTF8(entry)
+ == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
+ && memEQ(key, REF_HE_KEY(chain), klen))
+ goto next_please;
+#else
+ if (HeKEY_hek(entry) == chain->refcounted_he_hek)
+ goto next_please;
+ if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
+ && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
+ && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
+ HeKLEN(entry)))
+ goto next_please;
+#endif
}
}
assert (!entry);
#ifdef USE_ITHREADS
HeKEY_hek(entry)
- = share_hek_flags(/* A big expression to find the key offset */
- (((chain->refcounted_he_data[0]
- & HVrhek_typemask) == HVrhek_PV)
- ? chain->refcounted_he_val.refcounted_he_u_len
- + 1 : 0) + 1 + chain->refcounted_he_data,
+ = share_hek_flags(REF_HE_KEY(chain),
chain->refcounted_he_keylen,
chain->refcounted_he_hash,
(chain->refcounted_he_data[0]
#else
HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
#endif
-
- switch(chain->refcounted_he_data[0] & HVrhek_typemask) {
- case HVrhek_undef:
- value = newSV(0);
- break;
- case HVrhek_delete:
- value = &PL_sv_placeholder;
+ value = refcounted_he_value(chain);
+ if (value == &PL_sv_placeholder)
placeholders++;
- break;
- case HVrhek_IV:
- value = (chain->refcounted_he_data[0] & HVrhek_UV)
- ? newSVuv(chain->refcounted_he_val.refcounted_he_u_iv)
- : newSViv(chain->refcounted_he_val.refcounted_he_u_uv);
- break;
- case HVrhek_PV:
- /* Create a string SV that directly points to the bytes in our
- structure. */
- value = newSV(0);
- sv_upgrade(value, SVt_PV);
- SvPV_set(value, (char *) chain->refcounted_he_data + 1);
- SvCUR_set(value, chain->refcounted_he_val.refcounted_he_u_len);
- /* This stops anything trying to free it */
- SvLEN_set(value, 0);
- SvPOK_on(value);
- SvREADONLY_on(value);
- if (chain->refcounted_he_data[0] & HVrhek_UTF8)
- SvUTF8_on(value);
- break;
- default:
- Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %x",
- chain->refcounted_he_data[0]);
- }
HeVAL(entry) = value;
/* Link it into the chain. */
return hv;
}
+SV *
+Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
+ const char *key, STRLEN klen, int flags, U32 hash)
+{
+ 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;
+ 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 (!hash) {
+ if (keysv && (SvIsCOW_shared_hash(keysv))) {
+ hash = SvSHARED_HASH(keysv);
+ } else {
+ PERL_HASH(hash, key, klen);
+ }
+ }
+
+ for (; chain; chain = chain->refcounted_he_next) {
+#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;
+#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;
+#endif
+
+ value = sv_2mortal(refcounted_he_value(chain));
+ break;
+ }
+
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
+
+ return value;
+}
+
/*
=for apidoc refcounted_he_new
-Creates a new C<struct refcounted_he>. Assumes ownership of one reference
-to I<value>. As S<key> is copied into a shared hash key, all references remain
-the property of the caller. The C<struct refcounted_he> is returned with a
-reference count of 1.
+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.
=cut
*/
char flags;
STRLEN key_offset;
U32 hash;
- bool is_utf8 = SvUTF8(key);
+ bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
if (SvPOK(value)) {
value_type = HVrhek_PV;
flags = value_type;
#ifdef USE_ITHREADS
- he = PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
- + key_len
- + key_offset);
+ he = (struct refcounted_he*)
+ PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
+ + key_len
+ + key_offset);
#else
- he = PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
- + key_offset);
+ he = (struct refcounted_he*)
+ PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
+ + key_offset);
#endif
https://perl5.git.perl.org / perl5.git / blobdiff