1 /* This file is part of the Variable::Magic Perl module.
2 * See http://search.cpan.org/dist/Variable-Magic/ */
4 #include <stdio.h> /* sprintf() */
6 #define PERL_NO_GET_CONTEXT
11 #define __PACKAGE__ "Variable::Magic"
13 #define R(S) fprintf(stderr, "R(" #S ") = %d\n", SvREFCNT(S))
15 #define PERL_VERSION_LE(R, V, S) (PERL_REVISION < (R) || (PERL_REVISION == (R) && (PERL_VERSION < (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION <= (S))))))
17 #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))))))
19 /* --- Compatibility ------------------------------------------------------- */
22 # define Newx(v, n, c) New(0, v, n, c)
26 # define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
30 # define MY_CXT vmg_globaldata
32 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
36 #ifndef PERL_MAGIC_ext
37 # define PERL_MAGIC_ext '~'
42 #endif /* !MGf_COPY */
50 #endif /* !MGf_LOCAL */
52 /* --- Our sv_magicext ----------------------------------------------------- */
55 STATIC MAGIC *vmg_sv_magicext(pTHX_ SV *sv, SV *obj, MGVTBL *vtbl, SV *obj2, I32 flag) {
56 return sv_magicext(sv, obj, PERL_MAGIC_ext, vtbl, (const char *) obj2, flag);
58 #else /* Stub inspired from 5.7.3's sv_magicext */
59 STATIC MAGIC *vmg_sv_magicext(pTHX_ SV *sv, SV *obj, MGVTBL *vtbl, SV *obj2, I32 flag) {
62 if (SvTYPE(sv) < SVt_PVMG) {
63 SvUPGRADE(sv, SVt_PVMG);
66 mg->mg_moremagic = SvMAGIC(sv);
69 if (!obj || obj == sv ||
70 (SvTYPE(obj) == SVt_PVGV &&
71 (GvSV(obj) == sv || GvHV(obj) == (HV *) sv || GvAV(obj) == (AV *) sv ||
72 GvCV(obj) == (CV *) sv || GvIOp(obj) == (IO *) sv ||
73 GvFORM(obj) == (CV *) sv))) {
76 mg->mg_obj = SvREFCNT_inc(obj);
77 mg->mg_flags |= MGf_REFCOUNTED;
80 mg->mg_type = PERL_MAGIC_ext;
83 if (flag == HEf_SVKEY) {
84 mg->mg_ptr = (char *) SvREFCNT_inc((SV *) obj2);
86 mg->mg_ptr = (char *) obj2;
89 mg->mg_virtual = vtbl;
93 SvFLAGS(sv) &= ~(SVf_IOK | SVf_NOK | SVf_POK);
99 #define vmg_sv_magicext(S, O, V, OO, F) vmg_sv_magicext(aTHX_ (S), (O), (V), (OO), (F))
101 /* --- Context-safe global data -------------------------------------------- */
103 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
112 /* --- Signatures ---------------------------------------------------------- */
114 #define SIG_MIN ((U16) (1u << 8))
115 #define SIG_MAX ((U16) (1u << 16 - 1))
116 #define SIG_NBR (SIG_MAX - SIG_MIN + 1)
117 #define SIG_WIZ ((U16) (1u << 8 - 1))
119 /* ... Generate signatures ................................................. */
121 STATIC U16 vmg_gensig(pTHX) {
122 #define vmg_gensig() vmg_gensig(aTHX)
128 sig = SIG_NBR * Drand01() + SIG_MIN;
129 } while (hv_exists(MY_CXT.wizz, buf, sprintf(buf, "%u", sig)));
134 /* --- MGWIZ structure ----------------------------------------------------- */
139 SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free;
142 #endif /* MGf_COPY */
148 #endif /* MGf_LOCAL */
152 #define MGWIZ2SV(W) (newSVuv(PTR2UV(W)))
153 #define SV2MGWIZ(S) (INT2PTR(MGWIZ*, SvUVX((SV *) (S))))
155 /* ... Construct private data .............................................. */
157 STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) {
158 #define vmg_data_new(C, S, A) vmg_data_new(aTHX_ (C), (S), (A))
168 XPUSHs(sv_2mortal(newRV_inc(sv)));
170 I32 i, alen = av_len(args);
171 for (i = 0; i < alen; ++i) { XPUSHs(*av_fetch(args, i, 0)); }
175 count = call_sv(ctor, G_SCALAR);
179 if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
181 #if PERL_VERSION_LE(5, 8, 2)
182 nsv = sv_newref(nsv); /* Workaround some bug in SvREFCNT_inc() */
184 SvREFCNT_inc(nsv); /* Or it will be destroyed in FREETMPS */
195 STATIC SV *vmg_data_get(SV *sv, U16 sig) {
196 MAGIC *mg, *moremagic;
199 if (SvTYPE(sv) >= SVt_PVMG) {
200 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
201 moremagic = mg->mg_moremagic;
202 if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == sig)) { break; }
204 if (mg) { return mg->mg_obj; }
210 /* ... Magic cast/dispell .................................................. */
212 STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
213 #define vmg_cast(S, W, A) vmg_cast(aTHX_ (S), (W), (A))
214 MAGIC *mg = NULL, *moremagic = NULL;
220 if (SvTYPE(sv) >= SVt_PVMG) {
221 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
222 moremagic = mg->mg_moremagic;
223 if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == w->sig)) { break; }
225 if (mg) { return 1; }
228 data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args) : NULL;
229 mg = vmg_sv_magicext(sv, data, w->vtbl, wiz, HEf_SVKEY);
230 mg->mg_private = w->sig;
231 mg->mg_flags = mg->mg_flags
234 #endif /* MGf_COPY */
240 #endif /* MGf_LOCAL */
246 STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
247 #define vmg_dispell(S, Z) vmg_dispell(aTHX_ (S), (Z))
248 MAGIC *mg, *prevmagic, *moremagic = NULL;
251 if (SvTYPE(sv) < SVt_PVMG) { return 0; }
253 for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
254 moremagic = mg->mg_moremagic;
255 if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == sig)) { break; }
257 if (!mg) { return 0; }
260 prevmagic->mg_moremagic = moremagic;
262 SvMAGIC_set(sv, moremagic);
264 mg->mg_moremagic = NULL;
266 if (mg->mg_obj != sv) { SvREFCNT_dec(mg->mg_obj); } /* Destroy private data */
267 SvREFCNT_dec((SV *) mg->mg_ptr); /* Unreference the wizard */
273 /* ... svt callbacks ....................................................... */
275 STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data) {
276 #define vmg_cb_call(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D))
286 XPUSHs(sv_2mortal(newRV_inc(sv)));
287 if (data) { XPUSHs(data); }
290 count = call_sv(cb, G_SCALAR);
294 if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
305 STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
306 return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj);
309 STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) {
310 return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_set, sv, mg->mg_obj);
313 STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
323 XPUSHs(sv_2mortal(newRV_inc(sv)));
324 XPUSHs((mg->mg_obj) ? (mg->mg_obj) : &PL_sv_undef);
325 if (SvTYPE(sv) == SVt_PVAV) {
326 XPUSHs(sv_2mortal(newSViv(av_len((AV *) sv) + 1)));
330 count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR);
334 if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
345 STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
346 return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_clear, sv, mg->mg_obj);
349 STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
350 /* So that it can survive tmp cleanup in vmg_cb_call */
352 /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and
353 * mg->mg_ptr reference count */
354 return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj);
358 STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *name, int namelen) {
368 XPUSHs(sv_2mortal(newRV_inc(sv)));
369 XPUSHs((mg->mg_obj) ? (mg->mg_obj) : &PL_sv_undef);
370 XPUSHs(sv_mortalcopy(nsv));
373 count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_copy, G_SCALAR);
377 if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
387 #endif /* MGf_COPY */
390 STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *p) {
396 STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
397 return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_local, nsv, mg->mg_obj);
399 #endif /* MGf_LOCAL */
401 /* ... Wizard destructor ................................................... */
403 STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) {
410 SvREFCNT_inc(wiz); /* Fake survival - it's gonna be deleted anyway */
411 #if PERL_API_VERSION_GE(5, 9, 5)
412 SvREFCNT_inc(wiz); /* One more push */
414 if (hv_delete(MY_CXT.wizz, buf, sprintf(buf, "%u", w->sig), 0)) {
418 if (w->cb_get != NULL) { SvREFCNT_dec(SvRV(w->cb_get)); }
419 if (w->cb_set != NULL) { SvREFCNT_dec(SvRV(w->cb_set)); }
420 if (w->cb_len != NULL) { SvREFCNT_dec(SvRV(w->cb_len)); }
421 if (w->cb_clear != NULL) { SvREFCNT_dec(SvRV(w->cb_clear)); }
422 if (w->cb_free != NULL) { SvREFCNT_dec(SvRV(w->cb_free)); }
424 if (w->cb_copy != NULL) { SvREFCNT_dec(SvRV(w->cb_copy)); }
425 #endif /* MGf_COPY */
427 if (w->cb_dup != NULL) { SvREFCNT_dec(SvRV(w->cb_dup)); }
430 if (w->cb_local != NULL) { SvREFCNT_dec(SvRV(w->cb_local)); }
431 #endif /* MGf_LOCAL */
432 if (w->cb_data != NULL) { SvREFCNT_dec(SvRV(w->cb_data)); }
439 STATIC MGVTBL vmg_wizard_vtbl = {
444 vmg_wizard_free, /* free */
447 #endif /* MGf_COPY */
453 #endif /* MGf_LOCAL */
456 /* --- Error messages and misc helpers ------------------------------------- */
458 STATIC const char vmg__wizard_args[] = "_wizard() called with a wrong number of arguments - use wizard() instead";
459 STATIC const char vmg_invalid_wiz[] = "Invalid wizard object";
460 STATIC const char vmg_invalid_sv[] = "Invalid variable";
461 STATIC const char vmg_invalid_sig[] = "Invalid numeric signature";
462 STATIC const char vmg_toomanysigs[] = "Too many magic signatures used";
463 STATIC const char vmg_argstorefailed[] = "Error while storing arguments";
465 STATIC U16 vmg_sv2sig(pTHX_ SV *sv) {
466 #define vmg_sv2sig(S) vmg_sv2sig(aTHX_ (S))
471 } else if (SvNOK(sv)) {
473 } else if ((SvPOK(sv) && grok_number(SvPVX(sv), SvCUR(sv), NULL))) {
476 croak(vmg_invalid_sig);
478 if (sig < SIG_MIN) { sig += SIG_MIN; }
479 if (sig > SIG_MAX) { sig %= SIG_MAX + 1; }
484 #define VMG_SET_CB(T, V, M, CB) \
487 (V)->svt_##T = vmg_svt_##T; (M)->cb_##T = newRV_inc(SvRV(cb)); \
489 (V)->svt_##T = NULL; (M)->cb_##T = NULL; \
492 /* --- XS ------------------------------------------------------------------ */
494 MODULE = Variable::Magic PACKAGE = Variable::Magic
502 MY_CXT.wizz = newHV();
504 stash = gv_stashpv(__PACKAGE__, 1);
505 newCONSTSUB(stash, "SIG_MIN", newSVuv(SIG_MIN));
506 newCONSTSUB(stash, "SIG_MAX", newSVuv(SIG_MAX));
507 newCONSTSUB(stash, "SIG_NBR", newSVuv(SIG_NBR));
508 newCONSTSUB(stash, "MGf_COPY", newSVuv(MGf_COPY));
509 newCONSTSUB(stash, "MGf_DUP", newSVuv(MGf_DUP));
510 newCONSTSUB(stash, "MGf_LOCAL", newSVuv(MGf_LOCAL));
513 SV *_wizard(SV *svsig, ...)
529 #endif /* MGf_COPY */
535 #endif /* MGf_LOCAL */
536 ) { croak(vmg__wizard_args); }
540 sig = vmg_sv2sig(svsig);
541 if (old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) {
542 ST(0) = sv_2mortal(newRV_inc(*old));
546 if (MY_CXT.count >= SIG_NBR) { croak(vmg_toomanysigs); }
555 cb = ST(1); w->cb_data = SvROK(cb) ? newRV_inc(SvRV(cb)) : NULL;
556 VMG_SET_CB(get, t, w, ST(2));
557 VMG_SET_CB(set, t, w, ST(3));
558 VMG_SET_CB(len, t, w, ST(4));
559 VMG_SET_CB(clear, t, w, ST(5));
560 VMG_SET_CB(free, t, w, ST(6));
562 VMG_SET_CB(copy, t, w, ST(7));
563 #endif /* MGf_COPY */
565 VMG_SET_CB(dup, t, w, ST(8));
568 VMG_SET_CB(local, t, w, ST(9));
569 #endif /* MGf_LOCAL */
572 mg = vmg_sv_magicext(sv, NULL, &vmg_wizard_vtbl, NULL, -1);
573 mg->mg_private = SIG_WIZ;
575 if (t->svt_copy) { mg->mg_flags |= MGf_COPY; }
576 #endif /* MGf_COPY */
578 if (t->svt_dup) { mg->mg_flags |= MGf_DUP; }
581 if (t->svt_local) { mg->mg_flags |= MGf_LOCAL; }
582 #endif /* MGf_LOCAL */
584 hv_store(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), sv, 0);
587 RETVAL = newRV_noinc(sv);
595 if (MY_CXT.count >= SIG_NBR) { croak(vmg_toomanysigs); }
596 RETVAL = newSVuv(vmg_gensig());
603 if (!SvROK(wiz)) { croak(vmg_invalid_wiz); }
604 RETVAL = newSVuv(SV2MGWIZ(SvRV(wiz))->sig);
608 SV *cast(SV *sv, SV *wiz, ...)
609 PROTOTYPE: \[$@%&*]$@
617 } else if (SvOK(wiz)) {
620 U16 sig = vmg_sv2sig(wiz);
621 if (old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) {
627 croak(vmg_invalid_sig);
632 av_fill(args, items - 2);
633 for (i = 2; i < items; ++i) {
636 if (av_store(args, i - 2, arg) == NULL) { croak(vmg_argstorefailed); }
639 ret = newSVuv(vmg_cast(SvRV(sv), wiz, args));
645 SV *getdata(SV *sv, SV *wiz)
653 sig = SV2MGWIZ(SvRV(wiz))->sig;
654 } else if (SvOK(wiz)) {
656 sig = vmg_sv2sig(wiz);
657 if (!hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) {
661 croak(vmg_invalid_wiz);
663 data = vmg_data_get(SvRV(sv), sig);
664 if (!data) { XSRETURN_UNDEF; }
665 ST(0) = newSVsv(data);
668 SV *dispell(SV *sv, SV *wiz)
675 sig = SV2MGWIZ(SvRV(wiz))->sig;
676 } else if (SvOK(wiz)) {
678 sig = vmg_sv2sig(wiz);
679 if (!hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) {
683 croak(vmg_invalid_wiz);
685 RETVAL = newSVuv(vmg_dispell(SvRV(sv), sig));