/* This file is part of the Variable::Magic Perl module.
* See http://search.cpan.org/dist/Variable-Magic/ */
+#include <stdarg.h> /* <va_list>, va_{start,arg,end}, ... */
+
#include <stdio.h> /* sprintf() */
#define PERL_NO_GET_CONTEXT
# define MGf_COPY 0
#endif
-#undef MGf_DUP /* Disable it for now. */
#ifndef MGf_DUP
# define MGf_DUP 0
#endif
# define VMG_UVAR 0
#endif
-#if (VMG_PERL_PATCHLEVEL >= 25854) || PERL_VERSION_GE(5, 9, 3)
+#if (VMG_PERL_PATCHLEVEL >= 25854) || (!VMG_PERL_PATCHLEVEL && PERL_VERSION_GE(5, 9, 3))
# define VMG_COMPAT_ARRAY_PUSH_NOLEN 1
#else
# define VMG_COMPAT_ARRAY_PUSH_NOLEN 0
#endif
/* since 5.9.5 - see #43357 */
-#if (VMG_PERL_PATCHLEVEL >= 31473) || PERL_VERSION_GE(5, 9, 5)
+#if (VMG_PERL_PATCHLEVEL >= 31473) || (!VMG_PERL_PATCHLEVEL && PERL_VERSION_GE(5, 9, 5))
# define VMG_COMPAT_ARRAY_UNDEF_CLEAR 1
#else
# define VMG_COMPAT_ARRAY_UNDEF_CLEAR 0
#endif
+#if (VMG_PERL_PATCHLEVEL >= 32969) || (!VMG_PERL_PATCHLEVEL && PERL_VERSION_GE(5, 11, 0))
+# define VMG_COMPAT_SCALAR_LENGTH_NOLEN 1
+#else
+# define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0
+#endif
+
#if VMG_UVAR
-/* Bug-free mg_magical - see http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html */
-STATIC void vmg_mg_magical(pTHX_ SV *sv) {
-#define vmg_mg_magical(S) vmg_mg_magical(aTHX_ (S))
+/* Bug-free mg_magical - see http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html, but specialized to our needs. */
+STATIC void vmg_sv_magicuvar(pTHX_ SV *sv, const char *uf, I32 len) {
+#define vmg_sv_magicuvar(S, U, L) vmg_sv_magicuvar(aTHX_ (S), (U), (L))
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 {
const MGVTBL* const vtbl = mg->mg_virtual;
if (vtbl) {
+/*
if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
SvGMAGICAL_on(sv);
if (vtbl->svt_set)
SvSMAGICAL_on(sv);
- if (vtbl->svt_clear)
+*/
+ if (vtbl->svt_clear) {
SvRMAGICAL_on(sv);
+ break;
+ }
}
} while ((mg = mg->mg_moremagic));
+/*
if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
SvRMAGICAL_on(sv);
+*/
}
}
/* ... Magic cast/dispell .................................................. */
+#if VMG_UVAR
STATIC I32 vmg_svt_val(pTHX_ IV, SV *);
STATIC void vmg_uvar_del(SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic) {
Safefree(mg->mg_ptr);
Safefree(mg);
}
+#endif /* VMG_UVAR */
STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
#define vmg_cast(S, W, A) vmg_cast(aTHX_ (S), (W), (A))
}
if (add_uvar) {
- sv_magic(sv, NULL, PERL_MAGIC_uvar, (const char *) &uf, sizeof(uf));
- vmg_mg_magical(sv);
+ vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf));
}
}
/* Revert the original uvar magic. */
uf[0] = uf[1];
Renew(uf, 1, struct ufuncs);
+ mg->mg_ptr = (char *) uf;
mg->mg_len = sizeof(struct ufuncs);
} else {
/* Remove the uvar magic. */
/* ... svt callbacks ....................................................... */
-STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data) {
-#define vmg_cb_call(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D))
+STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int args, ...) {
+ va_list ap;
SV *svr;
int ret;
+ unsigned int i;
dSP;
int count;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newRV_inc(sv)));
- if (data) { XPUSHs(data); }
- PUTBACK;
-
- count = call_sv(cb, G_SCALAR);
-
- SPAGAIN;
-
- if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
- svr = POPs;
- ret = SvOK(svr) ? SvIV(svr) : 0;
-
- PUTBACK;
-
- FREETMPS;
- LEAVE;
-
- return ret;
-}
-
-#if VMG_UVAR
-STATIC int vmg_cb_call2(pTHX_ SV *cb, SV *sv, SV *data, SV *sv2) {
-#define vmg_cb_call2(I, S, D, S2) vmg_cb_call2(aTHX_ (I), (S), (D), (S2))
- SV *svr;
- int ret;
-
- dSP;
- int count;
-
- ENTER;
- SAVETMPS;
-
- PUSHMARK(SP);
- XPUSHs(sv_2mortal(newRV_inc(sv)));
- XPUSHs(data ? data : &PL_sv_undef);
- if (sv2) { XPUSHs(sv2); }
+ EXTEND(SP, args + 2);
+ PUSHs(sv_2mortal(newRV_inc(sv)));
+ PUSHs(data ? data : &PL_sv_undef);
+ va_start(ap, args);
+ 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);
return ret;
}
-#endif /* VMG_UVAR */
-
-#if MGf_COPY
-STATIC int vmg_cb_call3(pTHX_ SV *cb, SV *sv, SV *data, SV *sv2, SV *sv3) {
-#define vmg_cb_call3(I, S, D, S2, S3) vmg_cb_call3(aTHX_ (I), (S), (D), (S2), (S3))
- SV *svr;
- int ret;
- dSP;
- int count;
-
- ENTER;
- SAVETMPS;
-
- PUSHMARK(SP);
- XPUSHs(sv_2mortal(newRV_inc(sv)));
- XPUSHs(data ? data : &PL_sv_undef);
- XPUSHs(sv2 ? sv2 : &PL_sv_undef);
- if (sv3) { XPUSHs(sv3); }
- PUTBACK;
-
- count = call_sv(cb, G_SCALAR);
-
- SPAGAIN;
-
- if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
- svr = POPs;
- ret = SvOK(svr) ? SvIV(svr) : 0;
-
- PUTBACK;
-
- FREETMPS;
- LEAVE;
-
- return ret;
-}
-#endif /* MGf_COPY */
+#define vmg_cb_call1(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D), 0)
+#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 int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
- return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj);
+ return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj);
}
STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) {
- return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_set, sv, mg->mg_obj);
+ return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_set, sv, mg->mg_obj);
}
STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newRV_inc(sv)));
- XPUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
+ EXTEND(SP, 3);
+ PUSHs(sv_2mortal(newRV_inc(sv)));
+ PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
if (SvTYPE(sv) == SVt_PVAV) {
len = av_len((AV *) sv) + 1;
- XPUSHs(sv_2mortal(newSViv(len)));
+ mPUSHi(len);
+ } else {
+ len = 1;
+ PUSHs(&PL_sv_undef);
}
PUTBACK;
if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
svr = POPs;
- ret = SvOK(svr) ? SvUV(svr)
- : ((SvTYPE(sv) == SVt_PVAV) ? len : 1);
+ ret = SvOK(svr) ? SvUV(svr) : len;
PUTBACK;
}
STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
- return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_clear, sv, mg->mg_obj);
+ return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_clear, sv, mg->mg_obj);
}
STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
SvREFCNT_inc(sv);
/* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and
* mg->mg_ptr reference count */
- return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj);
+ return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj);
}
#if MGf_COPY
-STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, int keylen) {
+STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key,
+# if (VMG_PERL_PATCHLEVEL >= 33256) || (!VMG_PERL_PATCHLEVEL && PERL_API_VERSION_GE(5, 11, 0))
+ I32 keylen
+# else
+ int keylen
+# endif
+ ) {
SV *keysv;
int ret;
}
#endif /* MGf_COPY */
-#if MGf_DUP
+#if 0 /* MGf_DUP */
STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
return 0;
}
#if MGf_LOCAL
STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
- return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_local, nsv, mg->mg_obj);
+ return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_local, nsv, mg->mg_obj);
}
#endif /* MGf_LOCAL */
if (!w->uvar) { continue; }
switch (action) {
case 0:
- if (w->cb_fetch) { vmg_cb_call2(w->cb_fetch, sv, mg->mg_obj, key); }
+ if (w->cb_fetch) { vmg_cb_call2(w->cb_fetch, sv, mg->mg_obj, key); }
break;
case HV_FETCH_ISSTORE:
case HV_FETCH_LVALUE:
case (HV_FETCH_ISSTORE|HV_FETCH_LVALUE):
- if (w->cb_store) { vmg_cb_call2(w->cb_store, sv, mg->mg_obj, key); }
+ if (w->cb_store) { vmg_cb_call2(w->cb_store, sv, mg->mg_obj, key); }
break;
case HV_FETCH_ISEXISTS:
if (w->cb_exists) { vmg_cb_call2(w->cb_exists, sv, mg->mg_obj, key); }
newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN));
newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNDEF_CLEAR",
newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR));
+ newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN",
+ newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
}
SV *_wizard(...)
VMG_SET_SVT_CB(ST(i++), copy);
#endif /* MGf_COPY */
#if MGf_DUP
- VMG_SET_SVT_CB(ST(i++), dup);
+ /* VMG_SET_SVT_CB(ST(i++), dup); */
+ i++;
+ t->svt_dup = NULL;
+ w->cb_dup = NULL;
#endif /* MGf_DUP */
#if MGf_LOCAL
VMG_SET_SVT_CB(ST(i++), local);
projects / perl / modules / Variable-Magic.git / blobdiff