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 (( regdata = mg_find((SV*)hv, PERL_MAGIC_regdata_names)) ||
+ mg_find((SV*)hv, PERL_MAGIC_tied) ||
+ SvGMAGICAL((SV*)hv))
+ {
/* 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)
+ sv = sv_newmortal();
+ } 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 ( 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)) {
+ if ( ( 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))) {
- SV * const 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;
- }
- magic_nextpack((SV*) hv,mg,key);
- if (SvOK(key)) {
- /* force key to stay around until next time */
- HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
- 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;
+ 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 = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) {
+ SV * const 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;
+ }
+ magic_nextpack((SV*) hv,mg,key);
+ if (SvOK(key)) {
+ /* force key to stay around until next time */
+ HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
+ 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;
+ }
}
#if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */
if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
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 *
+STATIC 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:
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;
#else
if (hash != HEK_HASH(chain->refcounted_he_hek))
continue;
- if (klen != HEK_LEN(chain->refcounted_he_hek))
+ if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
continue;
if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
continue;
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
projects / p5sagit/p5-mst-13.2.git / blobdiff