From: Vincent Pit Date: Sun, 29 Jun 2008 16:24:20 +0000 (+0200) Subject: Importing Variable-Magic-0.03.tar.gz X-Git-Tag: v0.03^0 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;ds=sidebyside;h=8556481280524737222300317146a23b801f6be0;p=perl%2Fmodules%2FVariable-Magic.git Importing Variable-Magic-0.03.tar.gz --- diff --git a/Changes b/Changes index bcd60be..9bc0f25 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,20 @@ Revision history for Variable-Magic +0.03 2007-08-01 17:20 UTC + + Add : Passing the signature of an already defined magic to wizard() + now returns the corresponding magic object. + + Add : You can pass the numeric signature as the wizard argument of + cast(), dispell() and getdata(). + + Add : Any argument specified after the wizard (or the signature) in a + call to cast() is now passed to the private data constructor in + $_[1] and after. + + Chg : $_[0] is now always a reference to the magic variable in all + callbacks. The reason for changing from the previous behaviour + is that one may want to apply the same magic to a plain scalar + and to a scalar reference, and needs a way to distinguish + between them in the callback (say, ref()). + + Fix : Wizard object destruction used not to free the signature. + 0.02 2007-07-27 13:50 UTC + Fix : In response to test report 548152 : Newx() and SvMAGIC_set() not present on older perls. diff --git a/MANIFEST b/MANIFEST index f07ba3e..398b805 100644 --- a/MANIFEST +++ b/MANIFEST @@ -11,6 +11,7 @@ t/01-import.t t/10-simple.t t/11-multiple.t t/12-data.t +t/13-sig.t t/20-get.t t/21-set.t t/22-len.t diff --git a/META.yml b/META.yml index afc6683..012aebd 100644 --- a/META.yml +++ b/META.yml @@ -1,13 +1,12 @@ --- #YAML:1.0 name: Variable-Magic -version: 0.02 +version: 0.03 abstract: Associate user-defined magic to variables from Perl. license: perl generated_by: ExtUtils::MakeMaker version 6.36 distribution_type: module requires: Carp: 0 - constant: 0 Test::More: 0 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.2.html diff --git a/Magic.xs b/Magic.xs index be5e8f8..14874e1 100644 --- a/Magic.xs +++ b/Magic.xs @@ -1,8 +1,18 @@ +/* This file is part of the Variable::Magic Perl module. + * See http://search.cpan.org/dist/Variable-Magic/ */ + +#include /* rand(), RAND_MAX */ +#include /* sprintf() */ + #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#define __PACKAGE__ "Variable::Magic" + +#define R(S) fprintf(stderr, "R(" #S ") = %d\n", SvREFCNT(S)) + /* --- Compatibility ------------------------------------------------------- */ #ifndef Newx @@ -13,9 +23,48 @@ # define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val)) #endif +#ifndef dMY_CXT +# define MY_CXT vmg_globaldata +# define dMY_CXT +# define START_MY_CXT STATIC my_cxt_t MY_CXT; +# define MY_CXT_INIT +#endif + +/* --- Context-safe global data -------------------------------------------- */ + +#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION + +typedef struct { + HV *wizz; + U16 count; +} my_cxt_t; + +START_MY_CXT + +/* --- Signatures ---------------------------------------------------------- */ + +#define SIG_MIN ((U16) (1u << 8)) +#define SIG_MAX ((U16) (1u << 16 - 1)) +#define SIG_NBR (SIG_MAX - SIG_MIN + 1) #define SIG_WIZ ((U16) (1u << 8 - 1)) -#define R(S) fprintf(stderr, "R(" #S ") = %d\n", SvREFCNT(sv)) +/* ... Generate signatures ................................................. */ + +STATIC U16 vmg_gensig(pTHX) { +#define vmg_gensig() vmg_gensig(aTHX) + U16 sig; + char buf[8]; + dMY_CXT; + + do { + double u = rand() / (RAND_MAX + 1.0); + sig = SIG_NBR * u + SIG_MIN; + } while (hv_exists(MY_CXT.wizz, buf, sprintf(buf, "%u", sig))); + + return sig; +} + +/* --- MGWIZ structure ----------------------------------------------------- */ typedef struct { MGVTBL *vtbl; @@ -28,8 +77,8 @@ typedef struct { /* ... Construct private data .............................................. */ -STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv) { -#define vmg_data_new(C, S) vmg_data_new(aTHX_ (C), (S)) +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; dSP; @@ -39,7 +88,11 @@ STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv) { SAVETMPS; PUSHMARK(SP); - XPUSHs(sv); + 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)); } + } PUTBACK; count = call_sv(ctor, G_SCALAR); @@ -75,8 +128,8 @@ STATIC SV *vmg_data_get(SV *sv, U16 sig) { /* ... Magic cast/dispell .................................................. */ -STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz) { -#define vmg_cast(S, W) vmg_cast(aTHX_ (S), (W)) +STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) { +#define vmg_cast(S, W, A) vmg_cast(aTHX_ (S), (W), (A)) MAGIC *mg = NULL, *moremagic = NULL; MGWIZ *w; SV *data; @@ -91,7 +144,7 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz) { if (mg) { return 1; } } - data = (w->cb_data) ? vmg_data_new(w->cb_data, sv) : NULL; + 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; @@ -139,11 +192,7 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data) { SAVETMPS; PUSHMARK(SP); - switch (SvTYPE(sv)) { - case SVt_PVAV: - case SVt_PVHV: XPUSHs(sv_2mortal(newRV_inc(sv))); break; - default: XPUSHs(sv); - } + XPUSHs(sv_2mortal(newRV_inc(sv))); if (data) { XPUSHs(data); } PUTBACK; @@ -180,11 +229,7 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { SAVETMPS; PUSHMARK(SP); - switch (SvTYPE(sv)) { - case SVt_PVAV: - case SVt_PVHV: XPUSHs(sv_2mortal(newRV_inc(sv))); break; - default: XPUSHs(sv); - } + XPUSHs(sv_2mortal(newRV_inc(sv))); XPUSHs((mg->mg_obj) ? (mg->mg_obj) : &PL_sv_undef); if (SvTYPE(sv) == SVt_PVAV) { XPUSHs(sv_2mortal(newSViv(av_len((AV *) sv) + 1))); @@ -212,7 +257,7 @@ STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) { STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { /* So that it can survive tmp cleanup in vmg_cb_call */ - if (SvREFCNT(sv) <= 0) { SvREFCNT_inc(sv); } + 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); @@ -221,7 +266,19 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { /* ... Wizard destructor ................................................... */ STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) { - MGWIZ *w = SV2MGWIZ(wiz); + char buf[8]; + MGWIZ *w; + dMY_CXT; + + w = SV2MGWIZ(wiz); + + SvREFCNT_inc(wiz); /* Fake survival - it's gonna be deleted anyway */ +#if PERL_API_REVISION >= 5 && PERL_API_VERSION >= 9 && PERL_API_SUBVERSION >= 5 + SvREFCNT_inc(wiz); /* One more push */ +#endif + if (hv_delete(MY_CXT.wizz, buf, sprintf(buf, "%u", w->sig), 0)) { + --MY_CXT.count; + } if (w->cb_get != NULL) { SvREFCNT_dec(SvRV(w->cb_get)); } if (w->cb_set != NULL) { SvREFCNT_dec(SvRV(w->cb_set)); } @@ -249,9 +306,30 @@ STATIC MGVTBL vmg_wizard_vtbl = { #endif /* MGf_DUP */ }; -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_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_toomanysigs[] = "Too many magic signatures used"; +STATIC const char vmg_argstorefailed[] = "Error while storing arguments"; + +STATIC U16 vmg_sv2sig(pTHX_ SV *sv) { +#define vmg_sv2sig(S) vmg_sv2sig(aTHX_ (S)) + U16 sig; + + if (SvIOK(sv)) { + sig = SvUVX(sv); + } else if (SvNOK(sv)) { + sig = SvNVX(sv); + } else if ((SvPOK(sv) && grok_number(SvPVX(sv), SvCUR(sv), NULL))) { + sig = SvUV(sv); + } else { + croak(vmg_invalid_sig); + } + if (sig < SIG_MIN) { sig += SIG_MIN; } + if (sig > SIG_MAX) { sig %= SIG_MAX + 1; } + + return sig; +} /* --- XS ------------------------------------------------------------------ */ @@ -259,15 +337,44 @@ MODULE = Variable::Magic PACKAGE = Variable::Magic PROTOTYPES: ENABLE -SV *_wizard(SV *sig, SV *cb_get, SV *cb_set, SV *cb_len, SV *cb_clear, SV *cb_free, SV *cb_data) -PROTOTYPE: $&&&&& +BOOT: +{ + HV *stash; + MY_CXT_INIT; + MY_CXT.wizz = newHV(); + MY_CXT.count = 0; + stash = gv_stashpv(__PACKAGE__, 1); + newCONSTSUB(stash, "SIG_MIN", newSVuv(SIG_MIN)); + newCONSTSUB(stash, "SIG_MAX", newSVuv(SIG_MAX)); + newCONSTSUB(stash, "SIG_NBR", newSVuv(SIG_NBR)); +/* + newCONSTSUB(stash, "MGf_COPY", newSVuv(MGf_COPY)); + newCONSTSUB(stash, "MGf_DUP", newSVuv(MGf_DUP)); +*/ +} + +SV *_wizard(SV *svsig, SV *cb_get, SV *cb_set, SV *cb_len, SV *cb_clear, SV *cb_free, SV *cb_data) +PROTOTYPE: $&&&&&& PREINIT: + U16 sig; + char buf[8]; MGWIZ *w; MGVTBL *t; MAGIC *mg; SV *sv; CODE: - if (!SvIOK(sig)) { croak(vmg_invalid_sig); } + dMY_CXT; + if (SvOK(svsig)) { + SV **old; + sig = vmg_sv2sig(svsig); + if (old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) { + ST(0) = sv_2mortal(newRV_inc(*old)); + XSRETURN(1); + } + } else { + if (MY_CXT.count >= SIG_NBR) { croak(vmg_toomanysigs); } + sig = vmg_gensig(); + } Newx(t, 1, MGVTBL); t->svt_get = (SvOK(cb_get)) ? vmg_svt_get : NULL; @@ -284,7 +391,7 @@ CODE: Newx(w, 1, MGWIZ); w->vtbl = t; - w->sig = SvUVX(sig); + w->sig = sig; w->cb_get = (SvROK(cb_get)) ? newRV_inc(SvRV(cb_get)) : NULL; w->cb_set = (SvROK(cb_set)) ? newRV_inc(SvRV(cb_set)) : NULL; w->cb_len = (SvROK(cb_len)) ? newRV_inc(SvRV(cb_len)) : NULL; @@ -296,10 +403,22 @@ CODE: mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, -1); mg->mg_private = SIG_WIZ; + hv_store(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), sv, 0); + ++MY_CXT.count; + RETVAL = newRV_noinc(sv); OUTPUT: RETVAL +SV *gensig() +PROTOTYPE: +CODE: + dMY_CXT; + if (MY_CXT.count >= SIG_NBR) { croak(vmg_toomanysigs); } + RETVAL = newSVuv(vmg_gensig()); +OUTPUT: + RETVAL + SV *getsig(SV *wiz) PROTOTYPE: $ CODE: @@ -308,11 +427,40 @@ CODE: OUTPUT: RETVAL -SV *cast(SV *sv, SV *wiz) -PROTOTYPE: \[$@%&*]$ +SV *cast(SV *sv, SV *wiz, ...) +PROTOTYPE: \[$@%&*]$@ +PREINIT: + AV *args = NULL; + SV *ret; CODE: - if (!SvROK(wiz)) { croak(vmg_invalid_wiz); } - RETVAL = newSVuv(vmg_cast(SvRV(sv), SvRV(wiz))); + dMY_CXT; + if (SvROK(wiz)) { + wiz = SvRV(wiz); + } else if (SvOK(wiz)) { + char buf[8]; + SV **old; + U16 sig = vmg_sv2sig(wiz); + if (old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) { + wiz = *old; + } else { + XSRETURN_UNDEF; + } + } else { + croak(vmg_invalid_sig); + } + if (items > 2) { + I32 i; + args = newAV(); + av_fill(args, items - 2); + for (i = 2; i < items; ++i) { + SV *arg = ST(i); + SvREFCNT_inc(arg); + if (av_store(args, i - 2, arg) == NULL) { croak(vmg_argstorefailed); } + } + } + ret = newSVuv(vmg_cast(SvRV(sv), wiz, args)); + SvREFCNT_dec(args); + RETVAL = ret; OUTPUT: RETVAL @@ -320,9 +468,21 @@ SV *getdata(SV *sv, SV *wiz) PROTOTYPE: \[$@%&*]$ PREINIT: SV *data; + U16 sig; CODE: - if (!SvROK(wiz)) { croak(vmg_invalid_wiz); } - data = vmg_data_get(SvRV(sv), SV2MGWIZ(SvRV(wiz))->sig); + dMY_CXT; + if (SvROK(wiz)) { + sig = SV2MGWIZ(SvRV(wiz))->sig; + } else if (SvOK(wiz)) { + char buf[8]; + sig = vmg_sv2sig(wiz); + if (!hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) { + XSRETURN_UNDEF; + } + } else { + croak(vmg_invalid_wiz); + } + data = vmg_data_get(SvRV(sv), sig); if (!data) { XSRETURN_UNDEF; } ST(0) = newSVsv(data); XSRETURN(1); @@ -332,10 +492,15 @@ PROTOTYPE: \[$@%&*]$ PREINIT: U16 sig; CODE: + dMY_CXT; if (SvROK(wiz)) { sig = SV2MGWIZ(SvRV(wiz))->sig; - } else if (SvIOK(wiz)) { - sig = SvUVX(wiz); + } else if (SvOK(wiz)) { + char buf[8]; + sig = vmg_sv2sig(wiz); + if (!hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) { + XSRETURN_UNDEF; + } } else { croak(vmg_invalid_wiz); } diff --git a/Makefile.PL b/Makefile.PL index 21d7518..d754ae3 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -11,8 +11,7 @@ WriteMakefile( PL_FILES => {}, PREREQ_PM => { 'Carp' => 0, - 'Test::More' => 0, - 'constant' => 0 + 'Test::More' => 0 }, dist => { PREOP => 'pod2text lib/Variable/Magic.pm > $(DISTVNAME)/README', diff --git a/README b/README index c7ce74e..6f8f6b0 100644 --- a/README +++ b/README @@ -2,12 +2,12 @@ NAME Variable::Magic - Associate user-defined magic to variables from Perl. VERSION - Version 0.02 + Version 0.03 SYNOPSIS use Variable::Magic qw/wizard cast dispell/; - my $wiz = wizard set => sub { print STDERR "now set to $_[0]!\n" }; + my $wiz = wizard set => sub { print STDERR "now set to ${$_[0]}!\n" }; my $a = 1; cast $a, $wiz; $a = 2; # "now set to 2!" @@ -55,6 +55,9 @@ DESCRIPTION each set of callbacks for magic operations). 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. + 5.9.3 'len' magic is no longer called when pushing an element into a magic array. @@ -83,26 +86,29 @@ FUNCTIONS 'sig' The numerical signature. If not specified or undefined, a random - signature is generated. + signature is generated. If the signature matches an already defined + magic, then the existant magic object is returned. 'data' - A code reference to a private data constructor. It will be called - each time this magic is cast on a variable, and the scalar returned - will be used as private data storage for it. + 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' 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. When the magic variable is an array or a - hash, $_[0] is a reference to it, but directly references it - otherwise. $_[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 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. # A simple scalar tracer - my $wiz = wizard get => sub { print STDERR "got $_[0]\n" }, - set => sub { print STDERR "set to $_[0]\n" }, - free => sub { print STDERR "$_[0] was deleted\n" } + my $wiz = wizard get => sub { print STDERR "got ${$_[0]}\n" }, + set => sub { print STDERR "set to ${$_[0]}\n" }, + free => sub { print STDERR "${$_[0]} was deleted\n" } "gensig" With this tool, you can manually generate random magic signature between @@ -121,32 +127,41 @@ FUNCTIONS my $sig = getsig $wiz; "cast" - cast [$@%&*]var, $wiz + cast [$@%&*]var, [$wiz|$sig], ... This function associates $wiz magic to the variable supplied, without - overwriting any other kind of magic. It returns true on success or when - $wiz magic is already present, and false on error. - - # Casts $wiz to $x + overwriting any other kind of magic. You can also supply the numeric + signature $sig instead of $wiz. It returns true on success or when $wiz + magic is already present, 0 on error, and "undef" when no magic + corresponds to the given signature (in case $sig was supplied). All + extra arguments specified after $wiz are passed to the private data + constructor. + + # Casts $wiz onto $x. If $wiz isn't a signature, undef can't be returned. my $x; die 'error' unless cast $x, $wiz; "getdata" - getdata [$@%&*]var, $wiz + getdata [$@%&*]var, [$wiz|$sig] - This accessor fetches the private data associated with the magic $wiz in - the variable. "undef" is returned when no such magic or data is found. + This accessor fetches the private data associated with the magic $wiz + (or the signature $sig) in the variable. "undef" is returned when no + such magic or data is found, or when $sig does not represent a current + valid magic object. + + # Get the attached data. + my $data = getdata $x, $wiz or die 'no such magic or magic has no data'; "dispell" - dispell [$@%&*]variable, $wiz - dispell [$@%&*]variable, $sig + dispell [$@%&*]variable, [$wiz|$sig] The exact opposite of "cast" : it dissociates $wiz magic from the - variable. You can also pass the magic signature as the second argument. - True is returned on success, and false on error or when no magic - represented by $wiz could be found in the variable. + variable. You can also pass the magic signature $sig as the second + argument. True is returned on success, 0 on error or when no magic + represented by $wiz could be found in the variable, and "undef" when no + magic corresponds to the given signature (in case $sig was supplied). - # Dispell now + # Dispell now. If $wiz isn't a signature, undef can't be returned. die 'no such magic or error' unless dispell $x, $wiz; EXPORT @@ -168,6 +183,8 @@ SEE ALSO AUTHOR Vincent Pit, "" + You can contact me by mail or on #perl @ FreeNode (Prof_Vince). + BUGS Please report any bugs or feature requests to "bug-variable-magic at rt.cpan.org", or through the web interface at diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm index 07fa6f5..74baa34 100644 --- a/lib/Variable/Magic.pm +++ b/lib/Variable/Magic.pm @@ -11,17 +11,17 @@ Variable::Magic - Associate user-defined magic to variables from Perl. =head1 VERSION -Version 0.02 +Version 0.03 =cut -our $VERSION = '0.02'; +our $VERSION = '0.03'; =head1 SYNOPSIS use Variable::Magic qw/wizard cast dispell/; - my $wiz = wizard set => sub { print STDERR "now set to $_[0]!\n" }; + my $wiz = wizard set => sub { print STDERR "now set to ${$_[0]}!\n" }; my $a = 1; cast $a, $wiz; $a = 2; # "now set to 2!" @@ -62,6 +62,8 @@ To prevent any clash between different magics defined with this module, an uniqu =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.9.3> =over 4 @@ -84,26 +86,14 @@ To prevent any clash between different magics defined with this module, an uniqu The minimum integer used as a signature for user-defined magic. -=cut - -use constant SIG_MIN => 2 ** 8; - =head2 C The maximum integer used as a signature for user-defined magic. -=cut - -use constant SIG_MAX => 2 ** 16 - 1; - =head2 C SIG_NBR = SIG_MAX - SIG_MIN + 1 -=cut - -use constant SIG_NBR => SIG_MAX - SIG_MIN + 1; - =head1 FUNCTIONS =cut @@ -112,8 +102,6 @@ require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); -my %wizz; - =head2 C wizard sig => .., data => ..., get => .., set => .., len => .., clear => .., free => .. @@ -124,37 +112,29 @@ This function creates a 'wizard', an opaque type that holds the magic informatio =item C<'sig'> -The numerical signature. If not specified or undefined, a random signature is generated. +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'> -A code reference to a private data constructor. It will be called each time this magic is cast on a variable, and the scalar returned will be used as private data storage for it. +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. =item C<'get'>, C<'set'>, C<'len'>, C<'clear'> and C<'free'> -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. When the magic variable is an array or a hash, C<$_[0]> is a reference to it, but directly references it otherwise. C<$_[1]> is the private data (or C when no private data constructor was supplied). In the special case of C 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 a reference to the magic object and C<$_[1]> is the private data (or C when no private data constructor was supplied). In the special case of C magic and when the variable is an array, C<$_[2]> contains its normal length. =back # A simple scalar tracer - my $wiz = wizard get => sub { print STDERR "got $_[0]\n" }, - set => sub { print STDERR "set to $_[0]\n" }, - free => sub { print STDERR "$_[0] was deleted\n" } + my $wiz = wizard get => sub { print STDERR "got ${$_[0]}\n" }, + set => sub { print STDERR "set to ${$_[0]}\n" }, + free => sub { print STDERR "${$_[0]} was deleted\n" } =cut sub wizard { croak 'Wrong number of arguments for wizard()' if @_ % 2; my %opts = @_; - my $sig; - if (defined $opts{sig}) { - $sig = int $opts{sig}; - $sig += SIG_MIN if $sig < SIG_MIN; - $sig %= SIG_MAX + 1 if $sig > SIG_MAX; - } else { - $sig = gensig(); - } - return _wizard($sig, map { $opts{$_} } qw/get set len clear free data/); + return _wizard(map { $opts{$_} } qw/sig get set len clear free data/); } =head2 C @@ -164,16 +144,6 @@ With this tool, you can manually generate random magic signature between SIG_MIN # Generate a signature my $sig = gensig; -=cut - -sub gensig { - my $sig; - my $used = ~~keys %wizz; - croak 'Too many magic signatures used' if $used == SIG_NBR; - do { $sig = SIG_MIN + int(rand(SIG_NBR)) } while $wizz{$sig}; - return $sig; -} - =head2 C getsig $wiz @@ -185,28 +155,30 @@ This accessor returns the magic signature of this wizard. =head2 C - cast [$@%&*]var, $wiz + cast [$@%&*]var, [$wiz|$sig], ... -This function associates C<$wiz> magic to the variable supplied, without overwriting any other kind of magic. It returns true on success or when C<$wiz> magic is already present, and false on error. +This function associates C<$wiz> magic to the variable supplied, without overwriting any other kind of magic. You can also supply the numeric signature C<$sig> instead of C<$wiz>. It returns true on success or when C<$wiz> magic is already present, C<0> on error, and C when no magic corresponds to the given signature (in case C<$sig> was supplied). All extra arguments specified after C<$wiz> are passed to the private data constructor. - # Casts $wiz to $x + # Casts $wiz onto $x. If $wiz isn't a signature, undef can't be returned. my $x; die 'error' unless cast $x, $wiz; =head2 C - getdata [$@%&*]var, $wiz + getdata [$@%&*]var, [$wiz|$sig] -This accessor fetches the private data associated with the magic C<$wiz> in the variable. C is returned when no such magic or data is found. +This accessor fetches the private data associated with the magic C<$wiz> (or the signature C<$sig>) in the variable. C is returned when no such magic or data is found, or when C<$sig> does not represent a current valid magic object. + + # Get the attached data. + my $data = getdata $x, $wiz or die 'no such magic or magic has no data'; =head2 C - dispell [$@%&*]variable, $wiz - dispell [$@%&*]variable, $sig + dispell [$@%&*]variable, [$wiz|$sig] -The exact opposite of L : it dissociates C<$wiz> magic from the variable. You can also pass the magic signature as the second argument. True is returned on success, and false on error or when no magic represented by C<$wiz> could be found in the variable. +The exact opposite of L : it dissociates C<$wiz> magic from the variable. You can also pass the magic signature C<$sig> as the second argument. True is returned on success, C<0> on error or when no magic represented by C<$wiz> could be found in the variable, and C when no magic corresponds to the given signature (in case C<$sig> was supplied). - # Dispell now + # Dispell now. If $wiz isn't a signature, undef can't be returned. die 'no such magic or error' unless dispell $x, $wiz; =head1 EXPORT @@ -241,6 +213,8 @@ L and L for internal information about magic. Vincent Pit, C<< >> +You can contact me by mail or on #perl @ FreeNode (Prof_Vince). + =head1 BUGS Please report any bugs or feature requests to diff --git a/samples/magic.pl b/samples/magic.pl index b176599..1439e2d 100755 --- a/samples/magic.pl +++ b/samples/magic.pl @@ -6,8 +6,8 @@ use warnings; use lib qw{blib/arch blib/lib}; use Variable::Magic qw/wizard getsig cast dispell/; -sub foo { print STDERR "got $_[0]!\n" } -my $bar = sub { ++$_[0]; print STDERR "now set to $_[0]!\n"; }; +sub foo { print STDERR "got ${$_[0]}!\n" } +my $bar = sub { ++${$_[0]}; print STDERR "now set to ${$_[0]}!\n"; }; my $a = 1; my $sig; @@ -17,13 +17,13 @@ my $sig; free => sub { print STDERR "deleted!\n"; }; $sig = getsig $wiz; print "my sig is $sig\n"; - cast $a, $wiz; + cast $a, $wiz, qw/a b c/; ++$a; # "got 1!", "now set to 3!" dispell $a, $wiz; cast $a, $wiz; my $b = 123; cast $b, $wiz; -} # "got 123!", "deleted!" +} # "deleted!" my $b = $a; # "got 3!" $a = 3; # "now set to 4!" $b = 3; # (nothing) diff --git a/t/10-simple.t b/t/10-simple.t index becb24f..37d348e 100644 --- a/t/10-simple.t +++ b/t/10-simple.t @@ -1,6 +1,6 @@ #!perl -T -use Test::More tests => 12; +use Test::More tests => 14; use Variable::Magic qw/wizard gensig getsig cast dispell/; @@ -12,20 +12,30 @@ ok(defined $wiz, 'wizard is defined'); ok(ref $wiz eq 'SCALAR', 'wizard is a scalar ref'); ok($sig == getsig $wiz, 'wizard signature is correct'); -my $a = 0; +my $a = 1; my $res = eval { cast $a, $wiz }; -ok(!$@, "cast error 1 ($@)"); -ok($res, 'cast error 2'); +ok(!$@, "cast croaks ($@)"); +ok($res, 'cast invalid'); $res = eval { dispell $a, $wiz }; -ok(!$@, "dispell from wizard error 1 ($@)"); -ok($res, 'dispell from wizard error 2'); +ok(!$@, "dispell from wizard croaks ($@)"); +ok($res, 'dispell from wizard invalid'); $res = eval { cast $a, $wiz }; -ok(!$@, "re-cast error 1 ($@)"); -ok($res, 're-cast error 2'); - -$res = eval { dispell $a, $sig }; -ok(!$@, "dispell from signature error 1 ($@)"); -ok($res, 'dispell from signature error 2'); +ok(!$@, "re-cast croaks ($@)"); +ok($res, 're-cast invalid'); +$res = eval { dispell $a, $wiz }; +ok(!$@, "re-dispell croaks ($@)"); +ok($res, 're-dispell invalid'); + +$sig = gensig; +{ + my $wiz = wizard sig => $sig; + my $b = 2; + my $res = cast $b, $wiz; +} +my $c = 3; +$res = eval { cast $c, $sig }; +ok(!$@, "cast from obsolete signature croaks ($@)"); +ok(!defined($res), 'cast from obsolete signature returns undef'); diff --git a/t/11-multiple.t b/t/11-multiple.t index 9ca0679..c77dece 100644 --- a/t/11-multiple.t +++ b/t/11-multiple.t @@ -37,8 +37,8 @@ multi sub { cast $a, $w[$i]; }, sub { my ($res, $err) = @_; - ok(!$err, "cast magic $i error 1 ($err)"); - ok($res, "cast magic $i error 2"); + ok(!$err, "cast magic $i croaks ($err)"); + ok($res, "cast magic $i invalid"); }; my $b = $a; @@ -48,8 +48,8 @@ $a = 1; for (0 .. $n - 1) { ok($c[$_] == 0, "set magic $_"); } my $res = eval { dispell $a, $w[1] }; -ok(!$@, "dispell magic 1 error 1 ($@)"); -ok($res, 'dispell magic 1 error 2'); +ok(!$@, "dispell magic 1 croaks ($@)"); +ok($res, 'dispell magic 1 invalid'); $b = $a; for (0, 2) { ok($c[$_] == 1, "get magic $_ after dispelled 1"); } @@ -58,8 +58,8 @@ $a = 2; for (0, 2) { ok($c[$_] == 0, "set magic $_ after dispelled 1"); } $res = eval { dispell $a, $w[0] }; -ok(!$@, "dispell magic 0 error 1 ($@)"); -ok($res, 'dispell magic 0 error 2'); +ok(!$@, "dispell magic 0 croaks ($@)"); +ok($res, 'dispell magic 0 invalid'); $b = $a; ok($c[2] == 1, 'get magic 2 after dispelled 1 & 0'); @@ -68,5 +68,5 @@ $a = 3; ok($c[2] == 0, 'set magic 2 after dispelled 1 & 0'); $res = eval { dispell $a, $w[2] }; -ok(!$@, "dispell magic 2 error 1 ($@)"); -ok($res, 'dispell magic 2 error 2'); +ok(!$@, "dispell magic 2 croaks ($@)"); +ok($res, 'dispell magic 2 invalid'); diff --git a/t/12-data.t b/t/12-data.t index b80fc89..7e640b3 100644 --- a/t/12-data.t +++ b/t/12-data.t @@ -1,13 +1,13 @@ #!perl -T -use Test::More tests => 14; +use Test::More tests => 19; use Variable::Magic qw/wizard getdata cast dispell/; my $c = 1; my $wiz = eval { - wizard data => sub { return { foo => 12, bar => 27 } }, + wizard data => sub { return { foo => $_[1] || 12, bar => $_[3] || 27 } }, get => sub { $c += $_[1]->{foo}; $_[1]->{foo} = $c }, set => sub { $c += $_[1]->{bar}; $_[1]->{bar} = $c } }; @@ -17,15 +17,15 @@ ok(ref $wiz eq 'SCALAR', 'wizard is a scalar ref'); my $a = 75; my $res = eval { cast $a, $wiz }; -ok(!$@, "cast error 1 ($@)"); -ok($res, 'cast error 2'); +ok(!$@, "cast croaks ($@)"); +ok($res, 'cast invalid'); my $data = eval { getdata $a, $wiz }; -ok(!$@, "getdata error 1 ($@)"); -ok($res, 'getdata error 2'); +ok(!$@, "getdata croaks ($@)"); +ok($res, 'getdata invalid'); ok($data && ref($data) eq 'HASH' - && exists $data->{foo} && $data->{foo} eq 12 - && exists $data->{bar} && $data->{bar} eq 27, + && exists $data->{foo} && $data->{foo} == 12 + && exists $data->{bar} && $data->{bar} == 27, 'private data creation ok'); my $b = $a; @@ -37,5 +37,17 @@ ok($c == 40, 'set magic : pass data'); ok($data->{bar} == 40, 'set magic : pass data'); $res = eval { dispell $a, $wiz }; -ok(!$@, "dispell error 1 ($@)"); -ok($res, 'dispell error 2'); +ok(!$@, "dispell croaks ($@)"); +ok($res, 'dispell invalid'); + +$res = eval { cast $a, $wiz, qw/z j t/ }; +ok(!$@, "cast with arguments croaks ($@)"); +ok($res, 'cast with arguments invalid'); + +$data = eval { getdata $a, $wiz }; +ok(!$@, "getdata croaks ($@)"); +ok($res, 'getdata invalid'); +ok($data && ref($data) eq 'HASH' + && exists $data->{foo} && $data->{foo} eq 'z' + && exists $data->{bar} && $data->{bar} eq 't', + 'private data creation with arguments ok'); diff --git a/t/13-sig.t b/t/13-sig.t new file mode 100644 index 0000000..c7b9f49 --- /dev/null +++ b/t/13-sig.t @@ -0,0 +1,57 @@ +#!perl -T + +use Test::More tests => 24; + +use Variable::Magic qw/wizard getsig cast dispell SIG_MIN/; + +my $sig = 300; + +my ($a, $b, $c, $d) = 1 .. 4; + +{ + my $wiz = eval { wizard sig => $sig }; + ok(!$@, "wizard creation error ($@)"); + ok(defined $wiz, 'wizard is defined'); + ok(ref $wiz eq 'SCALAR', 'wizard is a scalar ref'); + ok($sig == getsig $wiz, 'wizard signature is correct'); + + my $wiz2 = eval { wizard sig => $sig }; + ok(!$@, "wizard retrieve error ($@)"); + ok(defined $wiz2, 'retrieved wizard is defined'); + ok(ref $wiz2 eq 'SCALAR', 'retrieved wizard is a scalar ref'); + ok($sig == getsig $wiz2, 'retrieved wizard signature is correct'); + + my $a = 1; + my $res = eval { cast $a, $wiz }; + ok(!$@, "cast from wizard croaks ($@)"); + ok($res, 'cast from wizard invalid'); + + $res = eval { dispell $a, $wiz2 }; + ok(!$@, "dispell from retrieved wizard croaks ($@)"); + ok($res, 'dispell from retrieved wizard invalid'); + + $res = eval { cast $b, $sig }; + ok(!$@, "cast from integer croaks ($@)"); + ok($res, 'cast from integer invalid'); +} + +my $res = eval { cast $c, $sig + 0.1 }; +ok(!$@, "cast from float croaks ($@)"); +ok($res, 'cast from float invalid'); + +$res = eval { cast $d, sprintf "%u", $sig }; +ok(!$@, "cast from string croaks ($@)"); +ok($res, 'cast from string invalid'); + +$res = eval { dispell $b, $sig }; +ok(!$@, "dispell from integer croaks ($@)"); +ok($res, 'dispell from integer invalid'); + +$res = eval { dispell $c, $sig + 0.1 }; +ok(!$@, "dispell from float croaks ($@)"); +ok($res, 'dispell from float invalid'); + +$res = eval { dispell $d, sprintf "%u", $sig }; +ok(!$@, "dispell from string croaks ($@)"); +ok($res, 'dispell from string invalid'); +