# define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
#endif
-#ifndef mPUSHu
-# define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U)))
+#ifndef SvRV_const
+# define SvRV_const(sv) SvRV((SV *) sv)
#endif
-#ifndef SvPV_const
-# define SvPV_const SvPV
+#ifndef SvREFCNT_inc_simple_void
+# define SvREFCNT_inc_simple_void(sv) SvREFCNT_inc(sv)
+#endif
+
+#ifndef mPUSHu
+# define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U)))
#endif
#ifndef PERL_MAGIC_ext
# endif
#endif
-/* uvar magic and Hash::Util::FieldHash were commited with 28419, but only
- * enable it on 5.10 */
+/* uvar magic and Hash::Util::FieldHash were commited with 28419, but we only
+ * enable them on 5.10 */
#if VMG_HAS_PERL(5, 10, 0)
# define VMG_UVAR 1
#else
#endif
/* Applied to dev-5.11 as 34908 */
-#if VMG_HAS_PERL_MAINT(5, 11, 0, 34908)
+#if VMG_HAS_PERL_MAINT(5, 11, 0, 34908) || VMG_HAS_PERL(5, 12, 0)
# define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 1
#else
# define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 0
# define VMG_COMPAT_ARRAY_UNDEF_CLEAR 0
#endif
-#if VMG_HAS_PERL_MAINT(5, 11, 0, 32969)
+#if VMG_HAS_PERL_MAINT(5, 11, 0, 32969) || VMG_HAS_PERL(5, 12, 0)
# define VMG_COMPAT_SCALAR_LENGTH_NOLEN 1
#else
# define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0
typedef struct {
MGVTBL *vtbl;
- U8 uvar;
U8 opinfo;
+ U8 uvar;
SV *cb_data;
SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free;
STATIC const SV *vmg_wizard_validate(pTHX_ const SV *wiz) {
#define vmg_wizard_validate(W) vmg_wizard_validate(aTHX_ (W))
if (SvROK(wiz)) {
- wiz = SvRV(wiz);
+ wiz = SvRV_const(wiz);
if (SvIOK(wiz))
return wiz;
}
STATIC const MAGIC *vmg_find(const SV *sv, const SV *wiz) {
const MAGIC *mg, *moremagic;
- UV wid;
+ IV wid;
if (SvTYPE(sv) < SVt_PVMG)
return NULL;
for (mg = SvMAGIC(sv); mg; mg = moremagic) {
moremagic = mg->mg_moremagic;
if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
- UV zid = vmg_wizard_id(mg->mg_ptr);
+ IV zid = vmg_wizard_id(mg->mg_ptr);
if (zid == wid)
return mg;
}
SPAGAIN;
nsv = POPs;
#if VMG_HAS_PERL(5, 8, 3)
- SvREFCNT_inc(nsv); /* Or it will be destroyed in FREETMPS */
+ SvREFCNT_inc_simple_void(nsv); /* Or it will be destroyed in FREETMPS */
#else
- nsv = sv_newref(nsv); /* Workaround some bug in SvREFCNT_inc() */
+ nsv = sv_newref(nsv); /* Workaround some bug in SvREFCNT_inc() */
#endif
PUTBACK;
U32 uvars = 0;
#endif /* VMG_UVAR */
MAGIC *mg, *prevmagic, *moremagic = NULL;
- UV wid = vmg_wizard_id(wiz);
+ IV wid = vmg_wizard_id(wiz);
if (SvTYPE(sv) < SVt_PVMG)
return 0;
moremagic = mg->mg_moremagic;
if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
const MGWIZ *z = vmg_wizard_mgwiz(mg->mg_ptr);
- UV zid = vmg_wizard_id(mg->mg_ptr);
+ IV zid = vmg_wizard_id(mg->mg_ptr);
if (zid == wid) {
#if VMG_UVAR
/* If the current has no uvar, short-circuit uvar deletion. */
/* ... svt callbacks ....................................................... */
-#define VMG_CB_CALL_SET_RET(D) \
- { \
- SV *svr; \
- SPAGAIN; \
- svr = POPs; \
- ret = SvOK(svr) ? SvIV(svr) : (D); \
- PUTBACK; \
- }
-
#define VMG_CB_CALL_ARGS_MASK 15
#define VMG_CB_CALL_ARGS_SHIFT 4
#define VMG_CB_CALL_OPINFO (VMG_OP_INFO_NAME|VMG_OP_INFO_OBJECT)
STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
va_list ap;
- int ret;
+ int ret = 0;
unsigned int i, args, opinfo;
+ SV *svr;
dSP;
call_sv(cb, G_SCALAR);
- VMG_CB_CALL_SET_RET(0);
+ SPAGAIN;
+ svr = POPs;
+ if (SvOK(svr))
+ ret = (int) SvIV(svr);
+ PUTBACK;
FREETMPS;
LEAVE;
return ret;
}
-#define vmg_cb_call1(I, F, S, A1) \
- vmg_cb_call(aTHX_ (I), (((F) << VMG_CB_CALL_ARGS_SHIFT) | 1), (S), (A1))
-#define vmg_cb_call2(I, F, S, A1, A2) \
- vmg_cb_call(aTHX_ (I), (((F) << VMG_CB_CALL_ARGS_SHIFT) | 2), (S), (A1), (A2))
-#define vmg_cb_call3(I, F, S, A1, A2, A3) \
- vmg_cb_call(aTHX_ (I), (((F) << VMG_CB_CALL_ARGS_SHIFT) | 3), (S), (A1), (A2), (A3))
+#define VMG_CB_FLAGS(OI, A) \
+ ((((unsigned int) (OI)) << VMG_CB_CALL_ARGS_SHIFT) | (A))
+
+#define vmg_cb_call1(I, OI, S, A1) \
+ vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 1), (S), (A1))
+#define vmg_cb_call2(I, OI, S, A1, A2) \
+ vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 2), (S), (A1), (A2))
+#define vmg_cb_call3(I, OI, S, A1, A2, A3) \
+ vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 3), (S), (A1), (A2), (A3))
STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
const MGWIZ *w = vmg_wizard_mgwiz(mg->mg_ptr);
const MGWIZ *w = vmg_wizard_mgwiz(mg->mg_ptr);
unsigned int opinfo = w->opinfo;
U32 len, ret;
+ SV *svr;
svtype t = SvTYPE(sv);
dSP;
PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
if (t < SVt_PVAV) {
STRLEN l;
- const U8 *s = (const U8 *) SvPV_const(sv, l);
+#if VMG_HAS_PERL(5, 9, 3)
+ const U8 *s = SvPV_const(sv, l);
+#else
+ U8 *s = SvPV(sv, l);
+#endif
if (DO_UTF8(sv))
len = utf8_length(s, s + l);
else
call_sv(w->cb_len, G_SCALAR);
- VMG_CB_CALL_SET_RET(len);
+ SPAGAIN;
+ svr = POPs;
+ ret = SvOK(svr) ? (U32) SvUV(svr) : len;
+ if (t == SVt_PVAV)
+ --ret;
+ PUTBACK;
FREETMPS;
LEAVE;
- return t == SVt_PVAV ? ret - 1 : ret;
+ return ret;
}
STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
PERL_CONTEXT saved_cx;
I32 cxix;
#endif
- unsigned int had_err, has_err, flags = G_SCALAR | G_EVAL;
+ I32 had_err, has_err, flags = G_SCALAR | G_EVAL;
int ret = 0;
+ SV *svr;
dSP;
w = vmg_wizard_mgwiz(mg->mg_ptr);
/* So that it survives the temp cleanup below */
- SvREFCNT_inc(sv);
+ SvREFCNT_inc_simple_void(sv);
-#if !VMG_HAS_PERL_MAINT(5, 11, 0, 32686)
+#if !(VMG_HAS_PERL_MAINT(5, 11, 0, 32686) || VMG_HAS_PERL(5, 12, 0))
/* The previous magic tokens were freed but the magic chain wasn't updated, so
* if you access the sv from the callback the old deleted magics will trigger
* and cause memory misreads. Change 32686 solved it that way : */
#endif
has_err = SvTRUE(ERRSV);
- if (IN_PERL_COMPILETIME && !had_err && has_err)
- ++PL_error_count;
+ if (IN_PERL_COMPILETIME && !had_err && has_err) {
+ if (PL_errors)
+ sv_catsv(PL_errors, ERRSV);
+ else
+ Perl_warn(aTHX_ "%s", SvPV_nolen(ERRSV));
+#ifdef PL_parser
+ if (PL_parser)
+#endif
+ ++PL_error_count;
+ }
- VMG_CB_CALL_SET_RET(0);
+ SPAGAIN;
+ svr = POPs;
+ if (SvOK(svr))
+ ret = (int) SvIV(svr);
+ PUTBACK;
FREETMPS;
LEAVE;
#if MGf_COPY
STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key,
-# if VMG_HAS_PERL_MAINT(5, 11, 0, 33256)
+# if VMG_HAS_PERL_MAINT(5, 11, 0, 33256) || VMG_HAS_PERL(5, 12, 0)
I32 keylen
# else
int keylen
PROTOTYPE: DISABLE
PREINIT:
I32 i = 0;
+ UV opinfo;
MGWIZ *w;
MGVTBL *t;
SV *cb;
Newx(w, 1, MGWIZ);
VMG_SET_CB(ST(i++), data);
+
cb = ST(i++);
- w->opinfo = SvOK(cb) ? SvUV(cb) : 0;
+ opinfo = SvOK(cb) ? SvUV(cb) : 0;
+ w->opinfo = (U8) ((opinfo < 255) ? opinfo : 255);
if (w->opinfo)
vmg_op_info_init(w->opinfo);
+
VMG_SET_SVT_CB(ST(i++), get);
VMG_SET_SVT_CB(ST(i++), set);
VMG_SET_SVT_CB(ST(i++), len);
PREINIT:
SV **args = NULL;
I32 i = 0;
- SV *ret;
CODE:
if (items > 2) {
i = items - 2;
args = &ST(2);
}
- ret = newSVuv(vmg_cast(SvRV(sv), vmg_wizard_validate(wiz), args, i));
- SvREFCNT_dec(args);
- RETVAL = ret;
+ RETVAL = newSVuv(vmg_cast(SvRV(sv), vmg_wizard_validate(wiz), args, i));
OUTPUT:
RETVAL