# define MGf_LOCAL 0
#endif
-/* uvar magic and Hash::Util::FieldHash were commited with p28419 */
+#ifndef IN_PERL_COMPILETIME
+# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
+#endif
+
+#if VMG_HAS_PERL(5, 10, 0) || defined(PL_parser)
+# ifndef PL_error_count
+# define PL_error_count PL_parser->error_count
+# endif
+#else
+# ifndef PL_error_count
+# define PL_error_count PL_Ierror_count
+# endif
+#endif
+
+/* uvar magic and Hash::Util::FieldHash were commited with 28419 */
#if VMG_HAS_PERL_MAINT(5, 9, 4, 28419) || VMG_HAS_PERL(5, 10, 0)
# define VMG_UVAR 1
#else
# define VMG_UVAR 0
#endif
-#if !defined(VMG_COMPAT_ARRAY_PUSH_NOLEN) && (VMG_HAS_PERL_BRANCH(5, 8, 9) || VMG_HAS_PERL_MAINT(5, 9, 3, 25854) || VMG_HAS_PERL(5, 10, 0))
-# define VMG_COMPAT_ARRAY_PUSH_NOLEN 1
+/* Applied to dev-5.9 as 25854, integrated to maint-5.8 as 28160 */
+#ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN
+# if VMG_HAS_PERL_MAINT(5, 8, 9, 28160) || VMG_HAS_PERL_MAINT(5, 9, 3, 25854) || VMG_HAS_PERL(5, 10, 0)
+# define VMG_COMPAT_ARRAY_PUSH_NOLEN 1
+# else
+# define VMG_COMPAT_ARRAY_PUSH_NOLEN 0
+# endif
+#endif
+
+/* Applied to dev-5.11 as 34908 */
+#if VMG_HAS_PERL_MAINT(5, 11, 0, 34908)
+# define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 1
#else
-# define VMG_COMPAT_ARRAY_PUSH_NOLEN 0
+# define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 0
#endif
-/* since 5.9.5 - see #43357 */
-#if VMG_HAS_PERL_BRANCH(5, 8, 9) || VMG_HAS_PERL_MAINT(5, 9, 5, 31473) || VMG_HAS_PERL(5, 10, 0)
+/* Applied to dev-5.9 as 31473 (see #43357), integrated to maint-5.8 as 32542 */
+#if VMG_HAS_PERL_MAINT(5, 8, 9, 32542) || VMG_HAS_PERL_MAINT(5, 9, 5, 31473) || VMG_HAS_PERL(5, 10, 0)
# define VMG_COMPAT_ARRAY_UNDEF_CLEAR 1
#else
# define VMG_COMPAT_ARRAY_UNDEF_CLEAR 0
const MAGIC* mg;
sv_magic(sv, NULL, PERL_MAGIC_uvar, uf, len);
/* uvar magic has set and get magic, hence this has set SVs_GMG and SVs_SMG. */
- PERL_UNUSED_CONTEXT;
if ((mg = SvMAGIC(sv))) {
SvRMAGICAL_off(sv);
do {
I32 i, alen = (args == NULL) ? 0 : av_len(args);
dSP;
- int count;
ENTER;
SAVETMPS;
PUSHs(*av_fetch(args, i, 0));
PUTBACK;
- count = call_sv(ctor, G_SCALAR);
+ call_sv(ctor, G_SCALAR);
SPAGAIN;
-
- if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
nsv = POPs;
#if VMG_HAS_PERL(5, 8, 3)
SvREFCNT_inc(nsv); /* Or it will be destroyed in FREETMPS */
#else
nsv = sv_newref(nsv); /* Workaround some bug in SvREFCNT_inc() */
#endif
-
PUTBACK;
FREETMPS;
/* ... svt callbacks ....................................................... */
-STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int args, ...) {
+#define VMG_CB_CALL_ARGS_MASK 15
+#define VMG_CB_CALL_EVAL 16
+
+STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
va_list ap;
SV *svr;
int ret;
unsigned int i;
+ unsigned int args = flags & VMG_CB_CALL_ARGS_MASK;
+ unsigned int eval = flags & VMG_CB_CALL_EVAL ? G_EVAL : 0;
dSP;
- int count;
ENTER;
SAVETMPS;
EXTEND(SP, args + 2);
PUSHs(sv_2mortal(newRV_inc(sv)));
PUSHs(data ? data : &PL_sv_undef);
- va_start(ap, args);
+ va_start(ap, flags);
for (i = 0; i < args; ++i) {
SV *sva = va_arg(ap, SV *);
PUSHs(sva ? sva : &PL_sv_undef);
va_end(ap);
PUTBACK;
- count = call_sv(cb, G_SCALAR);
+ call_sv(cb, G_SCALAR | eval);
SPAGAIN;
-
- if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
+ if (eval && IN_PERL_COMPILETIME && SvTRUE(ERRSV))
+ ++PL_error_count;
svr = POPs;
ret = SvOK(svr) ? SvIV(svr) : 0;
-
PUTBACK;
FREETMPS;
}
#define vmg_cb_call1(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D), 0)
+#define vmg_cb_call1e(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D), VMG_CB_CALL_EVAL)
#define vmg_cb_call2(I, S, D, S2) vmg_cb_call(aTHX_ (I), (S), (D), 1, (S2))
#define vmg_cb_call3(I, S, D, S2, S3) vmg_cb_call(aTHX_ (I), (S), (D), 2, (S2), (S3))
STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
SV *svr;
- I32 len;
+ I32 len, has_array;
U32 ret;
dSP;
int count;
+ has_array = SvTYPE(sv) == SVt_PVAV;
+
ENTER;
SAVETMPS;
EXTEND(SP, 3);
PUSHs(sv_2mortal(newRV_inc(sv)));
PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
- if (SvTYPE(sv) == SVt_PVAV) {
+ if (has_array) {
len = av_len((AV *) sv) + 1;
mPUSHi(len);
} else {
- len = 1;
+ len = 0;
PUSHs(&PL_sv_undef);
}
PUTBACK;
count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR);
SPAGAIN;
-
- if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
svr = POPs;
ret = SvOK(svr) ? SvUV(svr) : len;
-
PUTBACK;
FREETMPS;
LEAVE;
- return ret - 1;
+ return has_array ? ret - 1 : ret;
}
STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
#endif
/* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and
* mg->mg_ptr reference count */
- return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj);
+ return vmg_cb_call1e(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj);
}
#if MGf_COPY
};
STATIC const char vmg_invalid_wiz[] = "Invalid wizard object";
-STATIC const char vmg_invalid_sv[] = "Invalid variable";
STATIC const char vmg_invalid_sig[] = "Invalid numeric signature";
STATIC const char vmg_wrongargnum[] = "Wrong number of arguments";
STATIC const char vmg_toomanysigs[] = "Too many magic signatures used";
#if VMG_THREADSAFE
#define VMG_CLONE_CB(N) \
- z->cb_ ## N = (w->cb_ ## N) ? newRV_noinc(vmg_clone(SvRV(w->cb_ ## N), \
- w->owner)) \
+ z->cb_ ## N = (w->cb_ ## N) ? newRV_inc(vmg_clone(SvRV(w->cb_ ## N), \
+ w->owner)) \
: NULL;
STATIC MGWIZ *vmg_wizard_clone(pTHX_ const MGWIZ *w) {
newCONSTSUB(stash, "VMG_UVAR", newSVuv(VMG_UVAR));
newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN",
newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN));
+ newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID",
+ newSVuv(VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID));
newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNDEF_CLEAR",
newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR));
newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN",