# define Newx(v, n, c) New(0, v, n, c)
#endif
+#ifndef NewOp
+# define NewOp(m, var, c, type) Newz(m, var, c, type)
+#endif
+
#ifndef SvMAGIC_set
# define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
#endif
# define PERL_MAGIC_ext '~'
#endif
+#ifndef PERL_MAGIC_tied
+# define PERL_MAGIC_tied 'P'
+#endif
+
#ifndef MGf_COPY
# define MGf_COPY 0
#endif
MAGIC *mg = NULL, *moremagic = NULL;
MGWIZ *w;
SV *data;
+ U32 oldgmg = SvGMAGICAL(sv);
w = SV2MGWIZ(wiz);
mg->mg_flags |= MGf_LOCAL;
#endif /* MGf_LOCAL */
+ if (SvTYPE(sv) < SVt_PVHV)
+ goto done;
+
+ /* The GMAGICAL flag only says that a hash is tied or has uvar magic - get
+ * magic is actually never called for them. If the GMAGICAL flag was off before
+ * calling sv_magicext(), the hash isn't tied and has no uvar magic. If it's
+ * now on, then this wizard has get magic. Hence we can work around the
+ * get/clear shortcoming by turning the GMAGICAL flag off. If the current magic
+ * has uvar callbacks, it will be turned back on later. */
+ if (!oldgmg && SvGMAGICAL(sv))
+ SvGMAGICAL_off(sv);
+
#if VMG_UVAR
- if (w->uvar && SvTYPE(sv) >= SVt_PVHV) {
+ if (w->uvar) {
MAGIC *prevmagic;
- int add_uvar = 1;
struct ufuncs uf[2];
uf[0].uf_val = vmg_svt_val;
if (mg) { /* Found another uvar magic. */
struct ufuncs *olduf = (struct ufuncs *) mg->mg_ptr;
if (olduf->uf_val == vmg_svt_val) {
- /* It's our uvar magic, nothing to do. */
- add_uvar = 0;
+ /* It's our uvar magic, nothing to do. oldgmg was true. */
+ goto done;
} else {
/* It's another uvar magic, backup it and replace it by ours. */
uf[1] = *olduf;
}
}
- if (add_uvar) {
- vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf));
- }
-
+ vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf));
+ /* Our hash now carries uvar magic. The uvar/clear shortcoming has to be
+ * handled by our uvar callback. */
}
#endif /* VMG_UVAR */
+done:
return 1;
}
U32 ret;
dSP;
- int count;
has_array = SvTYPE(sv) == SVt_PVAV;
}
PUTBACK;
- count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR);
+ call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR);
SPAGAIN;
svr = POPs;
#endif /* MGf_LOCAL */
#if VMG_UVAR
+STATIC OP *vmg_pp_resetuvar(pTHX) {
+ SvRMAGICAL_on(cSVOP_sv);
+ return NORMAL;
+}
+
STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
struct ufuncs *uf;
MAGIC *mg, *umg;
SV *key = NULL, *newkey = NULL;
+ int tied = 0;
umg = mg_find(sv, PERL_MAGIC_uvar);
/* umg can't be NULL or we wouldn't be there. */
action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
MGWIZ *w;
- if ((mg->mg_type != PERL_MAGIC_ext)
- || (mg->mg_private < SIG_MIN)
- || (mg->mg_private > SIG_MAX)) { continue; }
+ switch (mg->mg_type) {
+ case PERL_MAGIC_ext:
+ break;
+ case PERL_MAGIC_tied:
+ ++tied;
+ continue;
+ default:
+ continue;
+ }
+ if (mg->mg_private < SIG_MIN || mg->mg_private > SIG_MAX)
+ continue;
w = SV2MGWIZ(mg->mg_ptr);
switch (w->uvar) {
case 0:
}
}
+ if (SvRMAGICAL(sv) && !tied) {
+ /* Temporarily hide the RMAGICAL flag of the hash so it isn't wrongly
+ * mistaken for a tied hash by the rest of hv_common. It will be reset by
+ * the op_ppaddr of a new fake op injected between the current and the next
+ * one. */
+ OP *o = PL_op;
+ if (!o->op_next || o->op_next->op_ppaddr != vmg_pp_resetuvar) {
+ SVOP *svop;
+ NewOp(1101, svop, 1, SVOP);
+ svop->op_type = OP_STUB;
+ svop->op_ppaddr = vmg_pp_resetuvar;
+ svop->op_next = o->op_next;
+ svop->op_flags = 0;
+ svop->op_sv = sv;
+ o->op_next = (OP *) svop;
+ }
+ SvRMAGICAL_off(sv);
+ }
+
return 0;
}
#endif /* VMG_UVAR */