#define PERL_VERSION_LE(R, V, S) (PERL_REVISION < (R) || (PERL_REVISION == (R) && (PERL_VERSION < (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION <= (S))))))
-#define PERL_API_VERSION_GE(R, V, S) (PERL_API_REVISION > (R) || (PERL_API_REVISION == (R) && (PERL_API_VERSION > (V) || (PERL_API_VERSION == (V) && (PERL_API_SUBVERSION >= (S))))))
-
-#define PERL_API_VERSION_LE(R, V, S) (PERL_API_REVISION < (R) || (PERL_API_REVISION == (R) && (PERL_API_VERSION < (V) || (PERL_API_VERSION == (V) && (PERL_API_SUBVERSION <= (S))))))
-
#ifndef VMG_PERL_PATCHLEVEL
# ifdef PERL_PATCHNUM
# define VMG_PERL_PATCHLEVEL PERL_PATCHNUM
# endif
#endif
+#define VMG_HAS_PERL_OR(P, R, V, S) ((VMG_PERL_PATCHLEVEL >= (P)) || (!VMG_PERL_PATCHLEVEL && PERL_VERSION_GE((R), (V), (S))))
+
+#define VMG_HAS_PERL_AND(P, R, V, S) (PERL_VERSION_GE((R), (V), (S)) && (!VMG_PERL_PATCHLEVEL || (VMG_PERL_PATCHLEVEL >= (P))))
+
/* --- Compatibility ------------------------------------------------------- */
#ifndef Newx
# define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
#endif
+#ifndef mPUSHi
+# define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
+#endif
+
#ifndef dMY_CXT
-# define MY_CXT vmg_globaldata
# define dMY_CXT
+# undef MY_CXT
+# define MY_CXT vmg_globaldata
+# undef START_MY_CXT
# define START_MY_CXT STATIC my_cxt_t MY_CXT;
+# undef MY_CXT_INIT
# define MY_CXT_INIT
+# undef MY_CXT_CLONE
+# undef aMY_CXT
+# undef pMY_CXT
+# define VMG_THREADSAFE 0
+#else
+# define VMG_THREADSAFE 1
#endif
#ifndef PERL_MAGIC_ext
# define MGf_LOCAL 0
#endif
-#if PERL_API_VERSION_GE(5, 10, 0)
+/* uvar magic and Hash::Util::FieldHash were commited with p28419 */
+#if VMG_HAS_PERL_AND(28419, 5, 9, 4)
# define VMG_UVAR 1
#else
# define VMG_UVAR 0
#endif
-#if (VMG_PERL_PATCHLEVEL >= 25854) || (!VMG_PERL_PATCHLEVEL && PERL_VERSION_GE(5, 9, 3))
+#if !defined(VMG_COMPAT_ARRAY_PUSH_NOLEN) && VMG_HAS_PERL_OR(25854, 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) || (!VMG_PERL_PATCHLEVEL && PERL_VERSION_GE(5, 9, 5))
+#if VMG_HAS_PERL_OR(31473, 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))
+#if VMG_HAS_PERL_OR(32969, 5, 11, 0)
# define VMG_COMPAT_SCALAR_LENGTH_NOLEN 1
#else
# define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0
#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);
}
}
START_MY_CXT
+STATIC void vmg_cxt_init
+#if defined(pMY_CXT) && defined(aMY_CXT)
+ (pTHX_ pMY_CXT) {
+# define vmg_cxt_init() vmg_cxt_init(aTHX_ aMY_CXT)
+#else
+ (pTHX) {
+ dMY_CXT;
+# define vmg_cxt_init() vmg_cxt_init(aTHX)
+#endif
+ MY_CXT.wizz = newHV();
+#ifdef USE_ITHREADS
+ HvSHAREKEYS_off(MY_CXT.wizz);
+#endif
+ MY_CXT.count = 0;
+ return;
+}
+
/* --- Signatures ---------------------------------------------------------- */
#define SIG_MIN ((U16) (1u << 8))
STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) {
#define vmg_data_new(C, S, A) vmg_data_new(aTHX_ (C), (S), (A))
SV *nsv;
+ I32 i, alen = (args == NULL) ? 0 : av_len(args);
dSP;
int count;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newRV_inc(sv)));
- if (args != NULL) {
- I32 i, alen = av_len(args);
- for (i = 0; i < alen; ++i) { XPUSHs(*av_fetch(args, i, 0)); }
- }
+ EXTEND(SP, alen + 1);
+ PUSHs(sv_2mortal(newRV_inc(sv)));
+ for (i = 0; i < alen; ++i)
+ PUSHs(*av_fetch(args, i, 0));
PUTBACK;
count = call_sv(ctor, G_SCALAR);
data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args) : NULL;
mg = sv_magicext(sv, data, PERL_MAGIC_ext, w->vtbl, (const char *) wiz, HEf_SVKEY);
mg->mg_private = w->sig;
- mg->mg_flags = mg->mg_flags
#if MGf_COPY
- | MGf_COPY
+ if (w->cb_copy)
+ mg->mg_flags |= MGf_COPY;
#endif /* MGf_COPY */
#if MGf_DUP
- | MGf_DUP
+ if (w->cb_dup)
+ mg->mg_flags |= MGf_DUP;
#endif /* MGf_DUP */
#if MGf_LOCAL
- | MGf_LOCAL
+ if (w->cb_local)
+ mg->mg_flags |= MGf_LOCAL;
#endif /* MGf_LOCAL */
- ;
#if VMG_UVAR
if (w->uvar && SvTYPE(sv) >= SVt_PVHV) {
}
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));
}
}
PUSHs(data ? data : &PL_sv_undef);
va_start(ap, args);
for (i = 0; i < args; ++i) {
- SV *sv = va_arg(ap, SV *);
- PUSHs(sv ? sv : &PL_sv_undef);
+ SV *sva = va_arg(ap, SV *);
+ PUSHs(sva ? sva : &PL_sv_undef);
}
va_end(ap);
PUTBACK;
PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
if (SvTYPE(sv) == SVt_PVAV) {
len = av_len((AV *) sv) + 1;
- PUSHs(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;
#if MGf_COPY
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))
+# if VMG_HAS_PERL_AND(33256, 5, 11, 0)
I32 keylen
# else
int keylen
w = SV2MGWIZ(wiz);
- SvREFCNT_inc(wiz); /* Fake survival - it's gonna be deleted anyway */
-#if PERL_API_VERSION_GE(5, 9, 5)
- SvREFCNT_inc(wiz); /* One more push */
-#endif
if (hv_delete(MY_CXT.wizz, buf, sprintf(buf, "%u", w->sig), 0)) {
--MY_CXT.count;
}
+ SvFLAGS(wiz) |= SVf_BREAK;
+ FREETMPS;
if (w->cb_data != NULL) { SvREFCNT_dec(SvRV(w->cb_data)); }
if (w->cb_get != NULL) { SvREFCNT_dec(SvRV(w->cb_get)); }
{
HV *stash;
MY_CXT_INIT;
- MY_CXT.wizz = newHV();
- MY_CXT.count = 0;
+ vmg_cxt_init();
stash = gv_stashpv(__PACKAGE__, 1);
newCONSTSUB(stash, "SIG_MIN", newSVuv(SIG_MIN));
newCONSTSUB(stash, "SIG_MAX", newSVuv(SIG_MAX));
newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR));
newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN",
newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
+ newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL));
+ newCONSTSUB(stash, "VMG_THREADSAFE", newSVuv(VMG_THREADSAFE));
}
+void
+CLONE(...)
+PROTOTYPE: DISABLE
+CODE:
+#ifdef MY_CXT_CLONE
+ MY_CXT_CLONE;
+ vmg_cxt_init();
+#endif
+
SV *_wizard(...)
PROTOTYPE: DISABLE
PREINIT:
hv_store(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), sv, 0);
++MY_CXT.count;
-
+
RETVAL = newRV_noinc(sv);
OUTPUT:
RETVAL
projects / perl / modules / Variable-Magic.git / blobdiff