Revision history for Variable-Magic
-0.07 2007-12-27
- + Add : copy, dup & local magic.
+0.08 2008-02-01 16:55 UTC
+ + Add : copy magic for tied arrays/hashes.
+ + Add : local magic.
+ + Add : uvar magics : fetch, store, exists, delete for hashes.
+
+0.07_* 2008-01
+ Internal development versions.
0.06 2007-11-20 10:10 UTC
+ Chg : 5.7.3 is now officially required.
t/24-free.t
t/25-copy.t
t/27-local.t
+t/28-uvar.t
t/30-scalar.t
t/31-array.t
t/32-hash.t
--- #YAML:1.0
name: Variable-Magic
-version: 0.07_02
+version: 0.08
abstract: Associate user-defined magic to variables from Perl.
license: perl
author:
#ifndef MGf_COPY
# define MGf_COPY 0
-#endif /* !MGf_COPY */
+#endif
+#undef MGf_DUP /* Disable it for now. */
#ifndef MGf_DUP
# define MGf_DUP 0
-#endif /* !MGf_DUP */
+#endif
#ifndef MGf_LOCAL
# define MGf_LOCAL 0
-#endif /* !MGf_LOCAL */
+#endif
+
+#if PERL_API_VERSION_GE(5, 10, 0)
+# define VMG_UVAR 1
+#else
+# define VMG_UVAR 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))
+ const MAGIC* mg;
+ 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)
+ SvRMAGICAL_on(sv);
+ }
+ } while ((mg = mg->mg_moremagic));
+ if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
+ SvRMAGICAL_on(sv);
+ }
+}
+
+#endif /* VMG_UVAR */
/* --- Context-safe global data -------------------------------------------- */
typedef struct {
MGVTBL *vtbl;
U16 sig;
- int uvar;
+ U16 uvar;
SV *cb_data;
SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free;
#if MGf_COPY
#if MGf_LOCAL
SV *cb_local;
#endif /* MGf_LOCAL */
+#if VMG_UVAR
SV *cb_fetch, *cb_store, *cb_exists, *cb_delete;
+#endif /* VMG_UVAR */
} MGWIZ;
#define MGWIZ2SV(W) (newSVuv(PTR2UV(W)))
/* ... Magic cast/dispell .................................................. */
-STATIC I32 vmg_uf_val(pTHX_ IV idx, SV *sv);
+STATIC I32 vmg_svt_val(pTHX_ IV, SV *);
+
+STATIC void vmg_uvar_del(SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic) {
+ if (prevmagic) {
+ prevmagic->mg_moremagic = moremagic;
+ } else {
+ SvMAGIC_set(sv, moremagic);
+ }
+ mg->mg_moremagic = NULL;
+ Safefree(mg->mg_ptr);
+ Safefree(mg);
+}
STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
#define vmg_cast(S, W, A) vmg_cast(aTHX_ (S), (W), (A))
- int has_uvar = 0;
MAGIC *mg = NULL, *moremagic = NULL;
MGWIZ *w;
SV *data;
w = SV2MGWIZ(wiz);
- if ((SvTYPE(sv) >= SVt_PVMG) && (mg = SvMAGIC(sv))) {
- if (mg->mg_type == PERL_MAGIC_uvar) { has_uvar = 1; }
- do {
- if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == w->sig)) { break;}
- mg = mg->mg_moremagic;
- } while (mg);
+ if (SvTYPE(sv) >= SVt_PVMG) {
+ for (mg = SvMAGIC(sv); mg; mg = moremagic) {
+ moremagic = mg->mg_moremagic;
+ if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == w->sig)) { break; }
+ }
if (mg) { return 1; }
}
- if (w->uvar && (SvTYPE(sv) >= SVt_PVHV) && !has_uvar) {
- struct ufuncs uf;
- uf.uf_val = vmg_uf_val;
- uf.uf_set = NULL;
- uf.uf_index = 0;
- sv_magicext(sv, NULL, PERL_MAGIC_uvar, &PL_vtbl_uvar, (char *) &uf, sizeof(uf));
- }
-
data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args) : NULL;
- mg = sv_magicext(sv, data, PERL_MAGIC_ext, w->vtbl, (char *) wiz, HEf_SVKEY);
+ 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
#if MGf_LOCAL
| MGf_LOCAL
#endif /* MGf_LOCAL */
- ;
+ ;
+
+#if VMG_UVAR
+ if (w->uvar && SvTYPE(sv) >= SVt_PVHV) {
+ MAGIC *prevmagic;
+ int add_uvar = 1;
+ struct ufuncs uf[2];
+
+ uf[0].uf_val = vmg_svt_val;
+ uf[0].uf_set = NULL;
+ uf[0].uf_index = 0;
+ uf[1].uf_val = NULL;
+ uf[1].uf_set = NULL;
+ uf[1].uf_index = 0;
+
+ /* One uvar magic in the chain is enough. */
+ for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
+ moremagic = mg->mg_moremagic;
+ if (mg->mg_type == PERL_MAGIC_uvar) { break; }
+ }
+
+ if (mg) { /* Found another uvar magic. */
+ struct ufuncs *olduf = (struct ufuncs *) mg->mg_ptr;
+ if (olduf->uf_val == vmg_svt_val) {
+ /* It's our uvar magic, nothing to do. */
+ add_uvar = 0;
+ } else {
+ /* It's another uvar magic, backup it and replace it by ours. */
+ uf[1] = *olduf;
+ vmg_uvar_del(sv, prevmagic, mg, moremagic);
+ }
+ }
+
+ if (add_uvar) {
+ sv_magic(sv, NULL, PERL_MAGIC_uvar, (const char *) &uf, sizeof(uf));
+ vmg_mg_magical(sv);
+ }
+
+ }
+#endif /* VMG_UVAR */
return 1;
}
STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
#define vmg_dispell(S, Z) vmg_dispell(aTHX_ (S), (Z))
+#if VMG_UVAR
+ U32 uvars = 0;
+#endif /* VMG_UVAR */
MAGIC *mg, *prevmagic, *moremagic = NULL;
- MGWIZ *w;
if (SvTYPE(sv) < SVt_PVMG) { return 0; }
for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
moremagic = mg->mg_moremagic;
- if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == sig)) { break; }
+ if (mg->mg_type == PERL_MAGIC_ext) {
+#if VMG_UVAR
+ MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+ if (w->uvar) { ++uvars; }
+#endif /* VMG_UVAR */
+ if (mg->mg_private == sig) {
+#if VMG_UVAR
+ if (!w->uvar) { uvars = 0; } /* Short-circuit uvar deletion. */
+#endif /* VMG_UVAR */
+ break;
+ }
+ }
}
if (!mg) { return 0; }
SvREFCNT_dec((SV *) mg->mg_ptr); /* Unreference the wizard */
Safefree(mg);
+#if VMG_UVAR
+ if (uvars == 1 && SvTYPE(sv) >= SVt_PVHV) {
+ /* mg was the first ext magic in the chain that had uvar */
+
+ for (mg = moremagic; mg; mg = mg->mg_moremagic) {
+ if ((mg->mg_type == PERL_MAGIC_ext) && SV2MGWIZ(mg->mg_ptr)->uvar) {
+ ++uvars;
+ break;
+ }
+ }
+
+ if (uvars == 1) {
+ struct ufuncs *uf;
+ for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic){
+ moremagic = mg->mg_moremagic;
+ if (mg->mg_type == PERL_MAGIC_uvar) { break; }
+ }
+ /* assert(mg); */
+ uf = (struct ufuncs *) mg->mg_ptr;
+ /* assert(uf->uf_val == vmg_svt_val); */
+ if (uf[1].uf_val || uf[1].uf_set) {
+ /* Revert the original uvar magic. */
+ uf[0] = uf[1];
+ Renew(uf, 1, struct ufuncs);
+ mg->mg_len = sizeof(struct ufuncs);
+ } else {
+ /* Remove the uvar magic. */
+ vmg_uvar_del(sv, prevmagic, mg, moremagic);
+ }
+ }
+ }
+#endif /* VMG_UVAR */
+
return 1;
}
return ret;
}
-STATIC int vmg_cb_call2(pTHX_ SV *cb, SV *sv, SV *data, SV *extra) {
-#define vmg_cb_call2(I, S, D, E) vmg_cb_call2(aTHX_ (I), (S), (D), (E))
+#if MGf_COPY || 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))
int ret;
dSP;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc(sv)));
XPUSHs(data ? data : &PL_sv_undef);
- if (extra) { XPUSHs(extra); }
+ if (sv2) { XPUSHs(sv2); }
PUTBACK;
count = call_sv(cb, G_SCALAR);
return ret;
}
+#endif /* MGf_COPY || VMG_UVAR */
STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj);
PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc(sv)));
- XPUSHs((mg->mg_obj) ? (mg->mg_obj) : &PL_sv_undef);
+ XPUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
if (SvTYPE(sv) == SVt_PVAV) {
XPUSHs(sv_2mortal(newSViv(av_len((AV *) sv) + 1)));
}
#endif /* MGf_COPY */
#if MGf_DUP
-STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *p) {
+STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
return 0;
}
#endif /* MGf_DUP */
}
#endif /* MGf_LOCAL */
-STATIC I32 vmg_uf_val(pTHX_ IV idx, SV *sv) {
+#if VMG_UVAR
+STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
+ struct ufuncs *uf;
MAGIC *mg;
- SV *key;
- for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- if (mg->mg_type == PERL_MAGIC_uvar) { key = mg->mg_obj; break; }
- }
- if (!key) { return 0; }
+ SV *key = NULL;
+
+ mg = mg_find(sv, PERL_MAGIC_uvar);
+ /* mg can't be NULL or we wouldn't be there. */
+ key = mg->mg_obj;
+ uf = (struct ufuncs *) mg->mg_ptr;
+
+ if (uf[1].uf_val != NULL) { uf[1].uf_val(aTHX_ action, sv); }
+ if (uf[1].uf_set != NULL) { uf[1].uf_set(aTHX_ action, sv); }
+
+ action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
MGWIZ *w;
- if ((mg->mg_type != PERL_MAGIC_ext) ||
- (mg->mg_private < SIG_MIN) || (mg->mg_private > SIG_MAX)) { continue; }
+ if ((mg->mg_type != PERL_MAGIC_ext)
+ || (mg->mg_private < SIG_MIN)
+ || (mg->mg_private > SIG_MAX)) { continue; }
w = SV2MGWIZ(mg->mg_ptr);
- if (!w->uvar) { continue; }
- switch (idx & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS|HV_FETCH_LVALUE|HV_DELETE)){
+ switch (action) {
case 0:
- if (w->cb_fetch) { return vmg_cb_call2(w->cb_fetch, sv, mg->mg_obj, key); }
+ 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) { return vmg_cb_call2(w->cb_store, sv, mg->mg_obj, key); }
+ vmg_cb_call2(w->cb_store, sv, mg->mg_obj, key);
break;
case HV_FETCH_ISEXISTS:
- if (w->cb_exists) { return vmg_cb_call2(w->cb_exists, sv, mg->mg_obj, key);}
+ vmg_cb_call2(w->cb_exists, sv, mg->mg_obj, key);
break;
case HV_DELETE:
- if (w->cb_delete) { return vmg_cb_call2(w->cb_delete, sv, mg->mg_obj, key);}
+ vmg_cb_call2(w->cb_delete, sv, mg->mg_obj, key);
break;
}
}
+
return 0;
}
+#endif /* VMG_UVAR */
/* ... Wizard destructor ................................................... */
#endif /* MGf_COPY */
#if MGf_DUP
if (w->cb_dup != NULL) { SvREFCNT_dec(SvRV(w->cb_dup)); }
-#endif /* MGf_DUP */
+#endif /* MGf_COPY */
#if MGf_LOCAL
if (w->cb_local != NULL) { SvREFCNT_dec(SvRV(w->cb_local)); }
-#endif /* MGf_LOCAL */
- if (w->cb_fetch != NULL) { SvREFCNT_dec(SvRV(w->cb_fetch)); }
- if (w->cb_store != NULL) { SvREFCNT_dec(SvRV(w->cb_store)); }
+#endif /* MGf_COPY */
+#if VMG_UVAR
+ if (w->cb_fetch != NULL) { SvREFCNT_dec(SvRV(w->cb_fetch)); }
+ if (w->cb_store != NULL) { SvREFCNT_dec(SvRV(w->cb_store)); }
if (w->cb_exists != NULL) { SvREFCNT_dec(SvRV(w->cb_exists)); }
if (w->cb_delete != NULL) { SvREFCNT_dec(SvRV(w->cb_delete)); }
+#endif /* VMG_UVAR */
Safefree(w->vtbl);
Safefree(w);
#endif /* MGf_DUP */
#if MGf_LOCAL
NULL, /* local */
-#endif /* MGf_LOCAL */
+#endif /* MGf_DUP */
};
-/* --- Error messages and misc helpers ------------------------------------- */
-
-STATIC const char vmg__wizard_args[] = "_wizard() called with a wrong number of arguments - use wizard() instead";
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";
STATIC const char vmg_argstorefailed[] = "Error while storing arguments";
return sig;
}
-#define VMG_SET_CB(T, M, CB) \
- cb = (CB); \
- (M)->cb_##T = (SvROK(cb)) ? newRV_inc(SvRV(cb)) : NULL;
-
-#define VMG_SET_CB_SVT(T, V, M, CB) \
- cb = (CB); \
- if (SvROK(cb)) { \
- (V)->svt_##T = vmg_svt_##T; (M)->cb_##T = newRV_inc(SvRV(cb)); \
- } else { \
- (V)->svt_##T = NULL; (M)->cb_##T = NULL; \
+#define VMG_SET_CB(S, N) \
+ cb = (S); \
+ w->cb_ ## N = (SvOK(cb) && SvROK(cb)) ? newRV_inc(SvRV(cb)) : NULL;
+
+#define VMG_SET_SVT_CB(S, N) \
+ cb = (S); \
+ if (SvOK(cb) && SvROK(cb)) { \
+ t->svt_ ## N = vmg_svt_ ## N; \
+ w->cb_ ## N = newRV_inc(SvRV(cb)); \
+ } else { \
+ t->svt_ ## N = NULL; \
+ w->cb_ ## N = NULL; \
}
+
/* --- XS ------------------------------------------------------------------ */
MODULE = Variable::Magic PACKAGE = Variable::Magic
newCONSTSUB(stash, "MGf_COPY", newSVuv(MGf_COPY));
newCONSTSUB(stash, "MGf_DUP", newSVuv(MGf_DUP));
newCONSTSUB(stash, "MGf_LOCAL", newSVuv(MGf_LOCAL));
+ newCONSTSUB(stash, "VMG_UVAR", newSVuv(VMG_UVAR));
}
-SV *_wizard(SV *svsig, ...)
-PROTOTYPE: $@
+SV *_wizard(...)
+PROTOTYPE: DISABLE
PREINIT:
+ I32 i = 0;
U16 sig;
- I32 i;
char buf[8];
MGWIZ *w;
MGVTBL *t;
MAGIC *mg;
- SV *cb, *sv;
+ SV *sv;
+ SV *svsig;
+ SV *cb;
CODE:
dMY_CXT;
- if (items != 14) { croak(vmg__wizard_args); }
+ if (items != 7
+#if MGf_COPY
+ + 1
+#endif /* MGf_COPY */
+#if MGf_DUP
+ + 1
+#endif /* MGf_DUP */
+#if MGf_LOCAL
+ + 1
+#endif /* MGf_LOCAL */
+#if VMG_UVAR
+ + 4
+#endif /* VMG_UVAR */
+ ) { croak(vmg_wrongargnum); }
+ svsig = ST(i++);
if (SvOK(svsig)) {
SV **old;
sig = vmg_sv2sig(svsig);
if (MY_CXT.count >= SIG_NBR) { croak(vmg_toomanysigs); }
sig = vmg_gensig();
}
-
+
Newx(t, 1, MGVTBL);
Newx(w, 1, MGWIZ);
- w->vtbl = t;
- w->sig = sig;
- VMG_SET_CB(data, w, ST(1));
- VMG_SET_CB_SVT(get, t, w, ST(2));
- VMG_SET_CB_SVT(set, t, w, ST(3));
- VMG_SET_CB_SVT(len, t, w, ST(4));
- VMG_SET_CB_SVT(clear, t, w, ST(5));
- VMG_SET_CB_SVT(free, t, w, ST(6));
+ VMG_SET_CB(ST(i++), data);
+ VMG_SET_SVT_CB(ST(i++), get);
+ VMG_SET_SVT_CB(ST(i++), set);
+ VMG_SET_SVT_CB(ST(i++), len);
+ VMG_SET_SVT_CB(ST(i++), clear);
+ VMG_SET_SVT_CB(ST(i++), free);
#if MGf_COPY
- VMG_SET_CB_SVT(copy, t, w, ST(7));
+ VMG_SET_SVT_CB(ST(i++), copy);
#endif /* MGf_COPY */
#if MGf_DUP
- VMG_SET_CB_SVT(dup, t, w, ST(8));
+ VMG_SET_SVT_CB(ST(i++), dup);
#endif /* MGf_DUP */
#if MGf_LOCAL
- VMG_SET_CB_SVT(local, t, w, ST(9));
+ VMG_SET_SVT_CB(ST(i++), local);
#endif /* MGf_LOCAL */
- VMG_SET_CB(fetch, w, ST(10));
- VMG_SET_CB(store, w, ST(11));
- VMG_SET_CB(exists, w, ST(12));
- VMG_SET_CB(delete, w, ST(13));
+#if VMG_UVAR
+ VMG_SET_CB(ST(i++), fetch);
+ VMG_SET_CB(ST(i++), store);
+ VMG_SET_CB(ST(i++), exists);
+ VMG_SET_CB(ST(i++), delete);
+#endif /* VMG_UVAR */
+ w->vtbl = t;
+ w->sig = sig;
+#if VMG_UVAR
w->uvar = (w->cb_fetch || w->cb_store || w->cb_exists || w->cb_delete);
+#endif /* VMG_UVAR */
sv = MGWIZ2SV(w);
mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, -1);
mg->mg_private = SIG_WIZ;
-#if MGf_COPY
- if (t->svt_copy) { mg->mg_flags |= MGf_COPY; }
-#endif /* MGf_COPY */
-#if MGf_DUP
- if (t->svt_dup) { mg->mg_flags |= MGf_DUP; }
-#endif /* MGf_DUP */
-#if MGf_LOCAL
- if (t->svt_local) { mg->mg_flags |= MGf_LOCAL; }
-#endif /* MGf_LOCAL */
hv_store(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), sv, 0);
++MY_CXT.count;
Variable::Magic - Associate user-defined magic to variables from Perl.
VERSION
- Version 0.07_02
+ Version 0.08
SYNOPSIS
use Variable::Magic qw/wizard cast dispell/;
prevent it to work before perl 5.9.5 - see the history).
"free"
- This last one can be considered as an object destructor. It happens
- when the variable goes out of scope (with the exception of global
- scope), but not when it is undefined.
+ This one can be considered as an object destructor. It happens when
+ the variable goes out of scope (with the exception of global scope),
+ but not when it is undefined.
+
+ "copy"
+ This magic only applies to tied arrays and hashes. It fires when you
+ try to access or change their elements. It is available on your perl
+ iff "MGf_COPY" is true.
+
+ "dup"
+ Invoked when the variable is cloned across threads. Currently not
+ available.
+
+ "local"
+ When this magic is set on a variable, all subsequent localizations
+ of the variable will trigger the callback. It is available on your
+ perl iff "MGf_LOCAL" is true.
+
+ The following actions only applies to hashes and are available iff
+ "VMG_UVAR" is true. They are referred to as "uvar" magics.
+
+ "fetch"
+ This magic happens each time an element is fetched from the hash.
+
+ "store"
+ This one is called when an element is stored into the hash.
+
+ "exists"
+ This magic fires when a key is tested for existence in the hash.
+
+ "delete"
+ This last one triggers when a key is deleted in the hash, regardless
+ of whether the key actually exists in it.
+
+ You can refer to the tests to have more insight of where the different
+ magics are invoked.
To prevent any clash between different magics defined with this module,
an unique numerical signature is attached to each kind of magic (i.e.
The places where magic is invoked have changed a bit through perl
history. Here's a little list of the most recent ones.
+ 5.6.x
+ *p14416* : 'copy' and 'dup' magic.
+
5.9.3
'len' magic is no longer called when pushing an element into a magic
array.
+ *p26569* : 'local' magic.
5.9.5
- 'clear' magic wasn't invoked when undefining an array. The bug is fixed
- as of this version.
+ *p31064* : Meaningful 'uvar' magic.
+ *p31473* : 'clear' magic wasn't invoked when undefining an array. The
+ bug is fixed as of this version.
CONSTANTS
"SIG_MIN"
SIG_NBR = SIG_MAX - SIG_MIN + 1
"MGf_COPY"
- True iff the 'copy' magic is available.
+ Evaluates to true iff the 'copy' magic is available.
"MGf_DUP"
- True iff the 'dup' magic is available.
+ Evaluates to true iff the 'dup' magic is available.
"MGf_LOCAL"
- True iff the 'local' magic is available.
+ Evaluates to true iff the 'local' magic is available.
+
+ "VMG_UVAR"
+ When this constant is true, you can use the "fetch,store,exists,delete"
+ callbacks on hashes.
FUNCTIONS
"wizard"
- wizard sig => .., data => ..., get => .., set => .., len => .., clear => .., free => ..
+ wizard sig => ...,
+ data => sub { ... },
+ get => sub { my ($ref, $data) = @_; ... },
+ set => sub { my ($ref, $data) = @_; ... },
+ len => sub { my ($ref, $data, $len) = @_; ... ; return $newlen; },
+ clear => sub { my ($ref, $data) = @_; ... },
+ free => sub { my ($ref, $data) = @_, ... },
+ copy => sub { my ($ref, $data, $elt) = @_; ... },
+ local => sub { my ($ref, $data) = @_; ... },
+ fetch => sub { my ($ref, $data, $key) = @_; ... },
+ store => sub { my ($ref, $data, $key) = @_; ... },
+ exists => sub { my ($ref, $data, $key) = @_; ... },
+ delete => sub { my ($ref, $data, $key) = @_; ... }
This function creates a 'wizard', an opaque type that holds the magic
information. It takes a list of keys / values as argument, whose keys
can be :
- 'sig'
+ "sig"
The numerical signature. If not specified or undefined, a random
signature is generated. If the signature matches an already defined
magic, then the existant magic object is returned.
- 'data'
+ "data"
A code reference to a private data constructor. It is called each
time this magic is cast on a variable, and the scalar returned is
used as private data storage for it. $_[0] is a reference to the
magic object and @_[1 .. @_-1] are all extra arguments that were
passed to "cast".
- 'get', 'set', 'len', 'clear' and 'free'
+ "get", "set", "len", "clear", "free", "copy", "local", "fetch", "store",
+ "exists" and "delete"
Code references to corresponding magic callbacks. You don't have to
specify all of them : the magic associated with undefined entries
- simply won't be hooked. In those callbacks, $_[0] is a reference to
- the magic object and $_[1] is the private data (or "undef" when no
- private data constructor was supplied). In the special case of "len"
- magic and when the variable is an array, $_[2] contains its normal
- length.
+ simply won't be hooked. In those callbacks, $_[0] is always a
+ reference to the magic object and $_[1] is always the private data
+ (or "undef" when no private data constructor was supplied). In the
+ special case of "len" magic and when the variable is an array, $_[2]
+ contains its normal length. "copy" magic receives the current
+ element (i.e. the value) in $_[2]. $_[2] is also the current key in
+ "fetch", "store", "exists" and "delete" callbacks.
# A simple scalar tracer
my $wiz = wizard get => sub { print STDERR "got ${$_[0]}\n" },
"dispell" are only exported on request. All of them are exported by the
tags ':funcs' and ':all'.
- The constants "SIG_MIN", "SIG_MAX" and "SIG_NBR" are also only exported
- on request. They are all exported by the tags ':consts' and ':all'.
+ The constants "SIG_MIN", "SIG_MAX", "SIG_NBR", "MGf_COPY", "MGf_DUP",
+ "MGf_LOCAL" and "VMG_UVAR" are also only exported on request. They are
+ all exported by the tags ':consts' and ':all'.
DEPENDENCIES
perl 5.7.3.
Carp (standard since perl 5), XSLoader (standard since perl 5.006).
+ Copy tests need Tie::Array (standard since perl 5.005) and Tie::Hash
+ (since 5.002).
+
+ Some uvar tests need Hash::Util::FieldHash (standard since perl
+ 5.009004).
+
Glob tests need Symbol (standard since perl 5.002).
SEE ALSO
perlguts and perlapi for internal information about magic.
+ perltie and overload for other ways of enhancing objects.
+
AUTHOR
Vincent Pit, "<perl at profvince.com>"
perldoc Variable::Magic
COPYRIGHT & LICENSE
- Copyright 2007 Vincent Pit, all rights reserved.
+ Copyright 2007-2008 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=head1 VERSION
-Version 0.07_02
+Version 0.08
=cut
-use vars qw/$VERSION/;
-
+our $VERSION;
BEGIN {
- $VERSION = '0.07_02';
+ $VERSION = '0.08';
}
=head1 SYNOPSIS
=item C<free>
-This last one can be considered as an object destructor. It happens when the variable goes out of scope (with the exception of global scope), but not when it is undefined.
+This one can be considered as an object destructor. It happens when the variable goes out of scope (with the exception of global scope), but not when it is undefined.
+
+=item C<copy>
+
+This magic only applies to tied arrays and hashes. It fires when you try to access or change their elements. It is available on your perl iff C<MGf_COPY> is true.
+
+=item C<dup>
+
+Invoked when the variable is cloned across threads. Currently not available.
+
+=item C<local>
+
+When this magic is set on a variable, all subsequent localizations of the variable will trigger the callback. It is available on your perl iff C<MGf_LOCAL> is true.
=back
+The following actions only applies to hashes and are available iff C<VMG_UVAR> is true. They are referred to as C<uvar> magics.
+
+=over 4
+
+=item C<fetch>
+
+This magic happens each time an element is fetched from the hash.
+
+=item C<store>
+
+This one is called when an element is stored into the hash.
+
+=item C<exists>
+
+This magic fires when a key is tested for existence in the hash.
+
+=item C<delete>
+
+This last one triggers when a key is deleted in the hash, regardless of whether the key actually exists in it.
+
+=back
+
+You can refer to the tests to have more insight of where the different magics are invoked.
+
To prevent any clash between different magics defined with this module, an unique numerical signature is attached to each kind of magic (i.e. each set of callbacks for magic operations).
=head1 PERL MAGIC HISTORY
The places where magic is invoked have changed a bit through perl history. Here's a little list of the most recent ones.
+=head2 B<5.6.x>
+
+=over 4
+
+=item I<p14416> : 'copy' and 'dup' magic.
+
+=back
+
=head2 B<5.9.3>
=over 4
=item 'len' magic is no longer called when pushing an element into a magic array.
+=item I<p26569> : 'local' magic.
+
=back
=head2 B<5.9.5>
=over 4
-=item 'clear' magic wasn't invoked when undefining an array. The bug is fixed as of this version.
+=item I<p31064> : Meaningful 'uvar' magic.
+
+=item I<p31473> : 'clear' magic wasn't invoked when undefining an array. The bug is fixed as of this version.
=back
=head2 C<MGf_COPY>
-True iff the 'copy' magic is available.
+Evaluates to true iff the 'copy' magic is available.
=head2 C<MGf_DUP>
-True iff the 'dup' magic is available.
+Evaluates to true iff the 'dup' magic is available.
=head2 C<MGf_LOCAL>
-True iff the 'local' magic is available.
+Evaluates to true iff the 'local' magic is available.
+
+=head2 C<VMG_UVAR>
+
+When this constant is true, you can use the C<fetch,store,exists,delete> callbacks on hashes.
=head1 FUNCTIONS
=cut
-use XSLoader;
-
BEGIN {
- XSLoader::load __PACKAGE__, $VERSION;
+ require XSLoader;
+ XSLoader::load(__PACKAGE__, $VERSION);
}
=head2 C<wizard>
- wizard sig => .., data => ..., get => .., set => .., len => .., clear => .., free => ..
+ wizard sig => ...,
+ data => sub { ... },
+ get => sub { my ($ref, $data) = @_; ... },
+ set => sub { my ($ref, $data) = @_; ... },
+ len => sub { my ($ref, $data, $len) = @_; ... ; return $newlen; },
+ clear => sub { my ($ref, $data) = @_; ... },
+ free => sub { my ($ref, $data) = @_, ... },
+ copy => sub { my ($ref, $data, $elt) = @_; ... },
+ local => sub { my ($ref, $data) = @_; ... },
+ fetch => sub { my ($ref, $data, $key) = @_; ... },
+ store => sub { my ($ref, $data, $key) = @_; ... },
+ exists => sub { my ($ref, $data, $key) = @_; ... },
+ delete => sub { my ($ref, $data, $key) = @_; ... }
This function creates a 'wizard', an opaque type that holds the magic information. It takes a list of keys / values as argument, whose keys can be :
=over 4
-=item C<'sig'>
+=item C<sig>
The numerical signature. If not specified or undefined, a random signature is generated. If the signature matches an already defined magic, then the existant magic object is returned.
-=item C<'data'>
+=item C<data>
A code reference to a private data constructor. It is called each time this magic is cast on a variable, and the scalar returned is used as private data storage for it. C<$_[0]> is a reference to the magic object and C<@_[1 .. @_-1]> are all extra arguments that were passed to L</cast>.
-=item C<'get'>, C<'set'>, C<'len'>, C<'clear'> and C<'free'>
+=item C<get>, C<set>, C<len>, C<clear>, C<free>, C<copy>, C<local>, C<fetch>, C<store>, C<exists> and C<delete>
-Code references to corresponding magic callbacks. You don't have to specify all of them : the magic associated with undefined entries simply won't be hooked. In those callbacks, C<$_[0]> is a reference to the magic object and C<$_[1]> is the private data (or C<undef> when no private data constructor was supplied). In the special case of C<len> magic and when the variable is an array, C<$_[2]> contains its normal length.
+Code references to corresponding magic callbacks. You don't have to specify all of them : the magic associated with undefined entries simply won't be hooked. In those callbacks, C<$_[0]> is always a reference to the magic object and C<$_[1]> is always the private data (or C<undef> when no private data constructor was supplied). In the special case of C<len> magic and when the variable is an array, C<$_[2]> contains its normal length. C<copy> magic receives the current element (i.e. the value) in C<$_[2]>. C<$_[2]> is also the current key in C<fetch>, C<store>, C<exists> and C<delete> callbacks.
=back
sub wizard {
croak 'Wrong number of arguments for wizard()' if @_ % 2;
my %opts = @_;
- my $sig = $opts{sig};
- return _wizard($sig, map { $opts{$_} } qw/data get set len clear free copy dup local fetch store exists delete/);
+ my @cbs = qw/sig data get set len clear free/;
+ push @cbs, 'copy' if MGf_COPY;
+ push @cbs, 'dup' if MGf_DUP;
+ push @cbs, 'local' if MGf_LOCAL;
+ push @cbs, qw/fetch store exists delete/ if VMG_UVAR;
+ return _wizard(map $opts{$_}, @cbs);
}
=head2 C<gensig>
The functions L</wizard>, L</gensig>, L</getsig>, L</cast>, L</getdata> and L</dispell> are only exported on request. All of them are exported by the tags C<':funcs'> and C<':all'>.
-The constants L</SIG_MIN>, L</SIG_MAX> and L</SIG_NBR> are also only exported on request. They are all exported by the tags C<':consts'> and C<':all'>.
+The constants L</SIG_MIN>, L</SIG_MAX>, L</SIG_NBR>, L</MGf_COPY>, L</MGf_DUP>, L</MGf_LOCAL> and L</VMG_UVAR> are also only exported on request. They are all exported by the tags C<':consts'> and C<':all'>.
=cut
our @EXPORT = ();
our %EXPORT_TAGS = (
'funcs' => [ qw/wizard gensig getsig cast getdata dispell/ ],
- 'consts' => [ qw/SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL/ ]
+ 'consts' => [ qw/SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR/ ]
);
our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
-$EXPORT_TAGS{'all'} = \@EXPORT_OK;
+$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
=head1 DEPENDENCIES
L<Carp> (standard since perl 5), L<XSLoader> (standard since perl 5.006).
+Copy tests need L<Tie::Array> (standard since perl 5.005) and L<Tie::Hash> (since 5.002).
+
+Some uvar tests need L<Hash::Util::FieldHash> (standard since perl 5.009004).
+
Glob tests need L<Symbol> (standard since perl 5.002).
=head1 SEE ALSO
L<perlguts> and L<perlapi> for internal information about magic.
+L<perltie> and L<overload> for other ways of enhancing objects.
+
=head1 AUTHOR
Vincent Pit, C<< <perl at profvince.com> >>
=head1 COPYRIGHT & LICENSE
-Copyright 2007 Vincent Pit, all rights reserved.
+Copyright 2007-2008 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
-#!/usr/bin/env perl
-
-use lib qw{blib/arch blib/lib};
+#!/usr/bin/perl
use strict;
use warnings;
-use Variable::Magic qw/wizard cast/;
-
-my $w = wizard map {
- my $s = $_; $s => sub { print STDERR "$s $_[2]!\n" }
-} qw/fetch store exists delete/;
-my %h;
-cast %h, $w;
-$h{'foo'} = 1;
-print STDERR "#", $h{'foo'}, "#\n";
-my $y = exists $h{'foo'};
-delete $h{'foo'};
+use lib qw{blib/arch blib/lib};
+use Variable::Magic qw/wizard getsig cast dispell/;
+
+my $wiz = wizard
+ fetch => sub { print STDERR "$_[0] FETCH KEY $_[2]\n" },
+ store => sub { print STDERR "$_[0] STORE KEY $_[2]\n" },
+ 'exists' => sub { print STDERR "$_[0] EXISTS KEY $_[2]\n" },
+ 'delete' => sub { print STDERR "$_[0] DELETE KEY $_[2]\n" };
+
+my %h = (foo => 1, bar => 2);
+cast %h, $wiz;
+
+print STDERR "foo was $h{foo}\n";
+$h{foo} = 3;
+print STDERR "now foo is $h{foo}\n";
+
+print STDERR "foo exists!\n" if exists $h{foo};
+
+my $d = delete $h{foo};
+print STDERR "foo deleted, got $d\n";
+
+dispell %h, $wiz;
use strict;
use warnings;
-use Test::More tests => 33;
+use Test::More tests => 33 + 24 + 12;
-use Variable::Magic qw/wizard cast dispell/;
+use Variable::Magic qw/wizard cast dispell VMG_UVAR/;
my $n = 3;
my @w;
$res = eval { dispell $a, $w[2] };
ok(!$@, "dispell magic 2 croaks ($@)");
ok($res, 'dispell magic 2 invalid');
+
+SKIP: {
+ skip 'No nice uvar magic for this perl', 24 unless VMG_UVAR;
+
+ $n = 2;
+ @c = (0) x $n;
+
+ eval { $w[0] = wizard fetch => sub { ++$c[0] }, store => sub { --$c[0] } };
+ ok(!$@, "wizard with uvar 0 creation error ($@)");
+ eval { $w[1] = wizard fetch => sub { ++$c[1] }, store => sub { --$c[1] } };
+ ok(!$@, "wizard with uvar 1 creation error ($@)");
+
+ multi sub {
+ my ($i) = @_;
+ $w[$i]
+ }, sub {
+ my ($i, $res, $err) = @_;
+ ok(defined $res, "wizard with uvar $i is defined");
+ ok(ref($w[$i]) eq 'SCALAR', "wizard with uvar $i is a scalar ref");
+ };
+
+ my %h = (a => 1, b => 2);
+
+ multi sub {
+ my ($i) = @_;
+ cast %h, $w[$i];
+ }, sub {
+ my ($i, $res, $err) = @_;
+ ok(!$err, "cast uvar magic $i croaks ($err)");
+ ok($res, "cast uvar magic $i invalid");
+ };
+
+ my $s = $h{a};
+ ok($s == 1, 'fetch magic doesn\'t clobber');
+ for (0 .. $n - 1) { ok($c[$_] == 1, "fetch magic $_"); }
+
+ $h{a} = 3;
+ for (0 .. $n - 1) { ok($c[$_] == 0, "store magic $_"); }
+ ok($h{a} == 3, 'store magic doesn\'t clobber'); # $c[$_] == 1 for 0 .. 1
+
+ my $res = eval { dispell %h, $w[1] };
+ ok(!$@, "dispell uvar magic 1 croaks ($@)");
+ ok($res, 'dispell uvar magic 1 invalid');
+
+ $s = $h{b};
+ ok($s == 2, 'fetch magic after dispelled 1 doesn\'t clobber');
+ for (0) { ok($c[$_] == 2, "fetch magic $_ after dispelled 1"); }
+
+ $h{b} = 4;
+ for (0) { ok($c[$_] == 1, "store magic $_ after dispelled 1"); }
+ ok($h{b} == 4, 'store magic doesn\'t clobber'); # $c[$_] == 2 for 0
+
+ $res = eval { dispell %h, $w[0] };
+ ok(!$@, "dispell uvar magic 0 croaks ($@)");
+ ok($res, 'dispell uvar magic 0 invalid');
+}
+
+SKIP: {
+ eval "use Hash::Util::FieldHash qw/fieldhash/";
+ skip 'Hash::Util::FieldHash required for testing uvar interaction', 12
+ unless VMG_UVAR && !$@;
+
+ fieldhash(my %h);
+
+ bless \(my $obj = {}), 'Variable::Magic::Test::Mock';
+ $h{$obj} = 5;
+
+ my ($w, $c) = (undef, 0);
+
+ eval { $w = wizard fetch => sub { ++$c }, store => sub { --$c } };
+ ok(!$@, "wizard with uvar creation error ($@)");
+ ok(defined $w, 'wizard with uvar is defined');
+ ok(ref($w) eq 'SCALAR', 'wizard with uvar is a scalar ref');
+
+ my $res = eval { cast %h, $w };
+ ok(!$@, "cast uvar magic on fieldhash croaks ($@)");
+ ok($res, 'cast uvar magic on fieldhash invalid');
+
+ my $s = $h{$obj};
+ ok($s == 5, 'fetch magic on fieldhash doesn\'t clobber');
+ ok($c == 1, 'fetch magic on fieldhash');
+
+ $h{$obj} = 7;
+ ok($c == 0, 'store magic on fieldhash');
+ ok($h{$obj} == 7, 'store magic on fieldhash doesn\'t clobber'); # $c == 1
+
+ $res = eval { dispell %h, $w };
+ ok(!$@, "dispell uvar magic on fieldhash croaks ($@)");
+ ok($res, 'dispell uvar magic on fieldhash invalid');
+
+ $h{$obj} = 11;
+ $s = $h{$obj};
+ ok($s == 11, 'store/fetch on fieldhash after dispell still ok');
+}
use Variable::Magic qw/wizard cast MGf_COPY/;
-if (!MGf_COPY) {
- plan skip_all => "this perl doesn't handle copy magic";
+if (MGf_COPY) {
+ plan tests => 1 + 8 + 14;
} else {
- plan tests => 16;
+ plan skip_all => 'No copy magic for this perl' if !MGf_COPY;
}
my $c = 0;
-my $wiz = wizard copy => sub { ++$c };
+my $wiz = wizard 'copy' => sub { ++$c };
ok($c == 0, 'copy : create wizard');
-use Tie::Array;
+SKIP: {
+ eval "use Tie::Array";
+ skip 'Tie::Array required to test copy magic on arrays', 8 if $@;
-tie my @a, 'Tie::StdArray';
-cast @a, $wiz;
-ok($c == 0, 'copy (array) : cast');
+ tie my @a, 'Tie::StdArray';
+ @a = (1 .. 10);
-my $n = time;
-$a[0] = $n;
-ok($c == 1, 'copy (array) : store element');
+ my $res = cast @a, $wiz;
+ ok($res, 'copy : cast on array succeeded');
+ ok($c == 0, 'copy : cast on array didn\'t triggered the callback');
-my $e = exists $a[0];
-ok($c == 2, 'copy (array) : exists element');
-ok($e, 'copy (array) : exists element, really');
+ $a[3] = 13;
+ ok($c == 1, 'copy : callback triggers on array store');
-my $b = $a[0];
-ok($c == 3, 'copy (array) : fetch element');
-ok($b == $n, 'copy (array) : fetch element correctly');
+ my $s = $a[3];
+ ok($c == 2, 'copy : callback triggers on array fetch');
+ ok($s == 13, 'copy : array fetch is correct');
-use Tie::Hash;
+ $s = exists $a[3];
+ ok($c == 3, 'copy : callback triggers on array exists');
+ ok($s, 'copy : array exists is correct');
-$c = 0;
+ undef @a;
+ ok($c == 3, 'copy : callback doesn\'t trigger on array undef');
+}
+
+SKIP: {
+ eval "use Tie::Has";
+ skip 'Tie::Hash required to test copy magic on hashes', 14 if $@;
+
+ tie my %h, 'Tie::StdHash';
+ %h = (a => 1, b => 2, c => 3);
+
+ $c = 0;
+ my $res = cast %h, $wiz;
+ ok($res, 'copy : cast on hash succeeded');
+ ok($c == 0, 'copy : cast on hash didn\'t triggered the callback');
-tie my %h, 'Tie::StdHash';
-cast %h, $wiz;
-ok($c == 0, 'copy (hash) : cast');
+ $h{b} = 7;
+ ok($c == 1, 'copy : callback triggers on hash store');
-my ($k, $v) = (time, int rand time);
-$h{$k} = $v;
-ok($c == 1, 'copy (hash) : store element');
+ my $s = $h{c};
+ ok($c == 2, 'copy : callback triggers on hash fetch');
+ ok($s == 3, 'copy : hash fetch is correct');
-$e = exists $h{$k};
-ok($c == 2, 'copy (hash) : exists element');
-ok($e, 'copy (hash) : exists element, really');
+ $s = exists $h{a};
+ ok($c == 3, 'copy : callback triggers on hash exists');
+ ok($s, 'copy : hash exists is correct');
-my $w = $h{$k};
-ok($c == 3, 'copy (hash) : fetch element');
-ok($w == $v, 'copy (hash) : fetch element correctly');
+ $s = delete $h{b};
+ ok($c == 4, 'copy : callback triggers on hash delete');
+ ok($s == 7, 'copy : hash delete is correct');
-my ($K, $V) = each %h;
-ok($c == 4, 'copy (hash) : iterate');
-ok($k == $K && $v == $V, 'copy (hash) : iterate correctly');
+ my ($k, $v) = each %h;
+ ok($c == 5, 'copy : callback triggers on hash each');
-delete $h{$k};
-ok($c == 5, 'copy (hash) : delete');
+ my @k = keys %h;
+ ok($c == 5, 'copy : callback doesn\'t trigger on hash keys');
+
+ my @v = values %h;
+ ok(@v == 2, 'copy : two values in the hash');
+ ok($c == 7, 'copy : callback triggers on hash values');
+
+ undef %h;
+ ok($c == 7, 'copy : callback doesn\'t trigger on hash undef');
+}
use Test::More;
-use Variable::Magic qw/wizard cast dispell MGf_LOCAL/;
+use Variable::Magic qw/wizard cast MGf_LOCAL/;
-if (!MGf_LOCAL) {
- plan skip_all => "this perl doesn't handle local magic";
-} else {
+if (MGf_LOCAL) {
plan tests => 5;
+} else {
+ plan skip_all => 'No local magic for this perl';
}
my $c = 0;
my $wiz = wizard 'local' => sub { ++$c };
ok($c == 0, 'local : create wizard');
-my $n = int rand 1000;
-local $a = $n;
-
-cast $a, $wiz;
-ok($c == 0, 'local : cast');
+local $a = int rand 1000;
+my $res = cast $a, $wiz;
+ok($res, 'local : cast succeeded');
+ok($c == 0, 'local : cast didn\'t triggered the callback');
{
local $a;
- ok($c == 1, 'local : localize casted variable');
+ ok($c == 1, 'local : localized');
}
-
-dispell $a, $wiz;
-ok($c == 1, 'local : dispell');
-
-{
- local $a;
- ok($c == 1, 'local : localize dispelled variable');
-}
-
+ok($c == 1, 'local : end of local scope');
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use Variable::Magic qw/wizard cast dispell VMG_UVAR/;
+
+if (VMG_UVAR) {
+ plan tests => 16;
+} else {
+ plan skip_all => 'No nice uvar magic for this perl';
+}
+
+my @c = (0) x 4;
+my @x = (0) x 4;
+
+sub check {
+ for (0 .. 3) { return 0 unless $c[$_] == $x[$_]; }
+ return 1;
+}
+
+my $wiz = wizard 'fetch' => sub { ++$c[0] },
+ 'store' => sub { ++$c[1] },
+ 'exists' => sub { ++$c[2] },
+ 'delete' => sub { ++$c[3] };
+ok(check(), 'uvar : create wizard');
+
+my %h = (a => 1, b => 2, c => 3);
+my $res = cast %h, $wiz;
+
+ok($res, 'uvar : cast succeeded');
+ok(check(), 'uvar : cast didn\'t triggered the callback');
+
+my $x = $h{a};
+++$x[0];
+ok(check(), 'uvar : fetch directly');
+ok($x, 'uvar : fetch directly correctly');
+
+$x = "$h{b}";
+++$x[0];
+ok(check(), 'uvar : fetch by interpolation');
+ok($x == 2, 'uvar : fetch by interpolation correctly');
+
+$h{c} = 4;
+++$x[1];
+ok(check(), 'uvar : store directly');
+
+$x = $h{c} = 5;
+++$x[1];
+ok(check(), 'uvar : fetch and store');
+ok($x == 5, 'uvar : fetch and store correctly');
+
+$x = exists $h{c};
+++$x[2];
+ok(check(), 'uvar : exists');
+ok($x, 'uvar : exists correctly');
+
+$x = delete $h{c};
+++$x[3];
+ok(check(), 'uvar : delete existing key');
+ok($x == 5, 'uvar : delete existing key correctly');
+
+$x = delete $h{z};
+++$x[3];
+ok(check(), 'uvar : delete non-existing key');
+ok(!defined $x, 'uvar : delete non-existing key correctly');
+
use Variable::Magic qw/wizard cast dispell/;
-my @c = (0) x 5;
-my @x = (0) x 5;
+my @c = (0) x 12;
+my @x = (0) x 12;
sub check {
- for (0 .. 4) { return 0 unless $c[$_] == $x[$_]; }
+ for (0 .. 11) { return 0 unless $c[$_] == $x[$_]; }
return 1;
}
set => sub { ++$c[1] },
len => sub { ++$c[2] },
clear => sub { ++$c[3] },
- free => sub { ++$c[4] };
+ free => sub { ++$c[4] },
+ copy => sub { ++$c[5] },
+ dup => sub { ++$c[6] },
+ local => sub { ++$c[7] },
+ fetch => sub { ++$c[8] },
+ store => sub { ++$c[9] },
+ 'exists' => sub { ++$c[10] },
+ 'delete' => sub { ++$c[11] };
ok(check(), 'scalar : create wizard');
my $n = int rand 1000;
use Variable::Magic qw/wizard cast dispell/;
-my @c = (0) x 5;
-my @x = (0) x 5;
+my @c = (0) x 12;
+my @x = (0) x 12;
sub check {
- for (0 .. 4) { return 0 unless $c[$_] == $x[$_]; }
+ for (0 .. 11) { return 0 unless $c[$_] == $x[$_]; }
return 1;
}
set => sub { ++$c[1] },
len => sub { ++$c[2]; $_[2] },
clear => sub { ++$c[3] },
- free => sub { ++$c[4] };
+ free => sub { ++$c[4] },
+ copy => sub { ++$c[5] },
+ dup => sub { ++$c[6] },
+ local => sub { ++$c[7] },
+ fetch => sub { ++$c[8] },
+ store => sub { ++$c[9] },
+ 'exists' => sub { ++$c[10] },
+ 'delete' => sub { ++$c[11] };
ok(check(), 'array : create wizard');
my @n = map { int rand 1000 } 1 .. 5;
use Test::More tests => 17;
-use Variable::Magic qw/wizard cast dispell/;
+use Variable::Magic qw/wizard cast dispell MGf_COPY VMG_UVAR/;
-my @c = (0) x 5;
-my @x = (0) x 5;
+my @c = (0) x 12;
+my @x = (0) x 12;
sub check {
- for (0 .. 4) { return 0 unless $c[$_] == $x[$_]; }
+ for (0 .. 11) { return 0 unless $c[$_] == $x[$_]; }
return 1;
}
set => sub { ++$c[1] },
len => sub { ++$c[2]; $_[2] },
clear => sub { ++$c[3] },
- free => sub { ++$c[4] };
+ free => sub { ++$c[4] },
+ copy => sub { ++$c[5] },
+ dup => sub { ++$c[6] },
+ local => sub { ++$c[7] },
+ fetch => sub { ++$c[8] },
+ store => sub { ++$c[9] },
+ 'exists' => sub { ++$c[10] },
+ 'delete' => sub { ++$c[11] };
ok(check(), 'hash : create wizard');
my %n = map { $_ => int rand 1000 } qw/foo bar baz qux/;
ok(check(), 'hash : cast');
my $b = $a{foo};
+++$x[5] if MGf_COPY;
+++$x[8] if VMG_UVAR;
ok(check(), 'hash : assign element to');
my %b = %a;
ok(check(), 'hash : reference');
my @b = @a{qw/bar qux/};
+$x[5] += 2 if MGf_COPY;
+$x[8] += 2 if VMG_UVAR;
ok(check(), 'hash : slice');
%a = map { $_ => 1 } qw/a b d/;
++$x[3];
+$x[5] += 3 if MGf_COPY && $^V && $^V gt 5.9.3;
+$x[9] += 3 if VMG_UVAR;
ok(check(), 'hash : assign');
$a{d} = 2;
+++$x[5] if MGf_COPY;
+++$x[9] if VMG_UVAR;
ok(check(), 'hash : assign old element');
$a{c} = 3;
+++$x[5] if MGf_COPY;
+++$x[9] if VMG_UVAR;
ok(check(), 'hash : assign new element');
$b = %a;
use Variable::Magic qw/wizard cast dispell/;
-my @c = (0) x 5;
-my @x = (0) x 5;
+my @c = (0) x 12;
+my @x = (0) x 12;
sub check {
- for (0 .. 4) { return 0 unless $c[$_] == $x[$_]; }
+ for (0 .. 11) { return 0 unless $c[$_] == $x[$_]; }
return 1;
}
set => sub { ++$c[1] },
len => sub { ++$c[2] },
clear => sub { ++$c[3] },
- free => sub { ++$c[4] };
+ free => sub { ++$c[4] },
+ copy => sub { ++$c[5] },
+ dup => sub { ++$c[6] },
+ local => sub { ++$c[7] },
+ fetch => sub { ++$c[8] },
+ store => sub { ++$c[9] },
+ 'exists' => sub { ++$c[10] },
+ 'delete' => sub { ++$c[11] };
ok(check(), 'code : create wizard');
my $x = 0;
use Variable::Magic qw/wizard cast dispell/;
-my @c = (0) x 5;
-my @x = (0) x 5;
+my @c = (0) x 12;
+my @x = (0) x 12;
sub check {
- for (0 .. 4) { return 0 unless $c[$_] == $x[$_]; }
+ for (0 .. 11) { return 0 unless $c[$_] == $x[$_]; }
return 1;
}
set => sub { ++$c[1] },
len => sub { ++$c[2] },
clear => sub { ++$c[3] },
- free => sub { ++$c[4] };
+ free => sub { ++$c[4] },
+ copy => sub { ++$c[5] },
+ dup => sub { ++$c[6] },
+ local => sub { ++$c[7] },
+ fetch => sub { ++$c[8] },
+ store => sub { ++$c[9] },
+ 'exists' => sub { ++$c[10] },
+ 'delete' => sub { ++$c[11] };
ok(check(), 'glob : create wizard');
local *a = gensym();
projects / perl / modules / Variable-Magic.git / commitdiff