From: Vincent Pit Date: Sun, 29 Jun 2008 16:24:27 +0000 (+0200) Subject: Importing Variable-Magic-0.07_01.tar.gz X-Git-Tag: v0.07_01^0 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=183e73e0590b46550dfa6fdd4b6cf3280c1a5877;p=perl%2Fmodules%2FVariable-Magic.git Importing Variable-Magic-0.07_01.tar.gz --- diff --git a/Changes b/Changes index 9e840ed..5fa00d2 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ Revision history for Variable-Magic +0.07 2007-12-27 + + Add : copy, dup & local magic. + 0.06 2007-11-20 10:10 UTC + Chg : 5.7.3 is now officially required. + Fix : "data" test failures on 5.8.{0,2}. diff --git a/MANIFEST b/MANIFEST index 398b805..559408b 100644 --- a/MANIFEST +++ b/MANIFEST @@ -17,6 +17,8 @@ t/21-set.t t/22-len.t t/23-clear.t t/24-free.t +t/25-copy.t +t/27-local.t t/30-scalar.t t/31-array.t t/32-hash.t diff --git a/META.yml b/META.yml index 46168a1..c4bb419 100644 --- a/META.yml +++ b/META.yml @@ -1,17 +1,14 @@ ---- #YAML:1.0 -name: Variable-Magic -version: 0.06 -abstract: Associate user-defined magic to variables from Perl. -license: perl -generated_by: ExtUtils::MakeMaker version 6.36_01 -distribution_type: module -requires: +# http://module-build.sourceforge.net/META-spec.html +#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# +name: Variable-Magic +version: 0.07_01 +version_from: lib/Variable/Magic.pm +installdirs: site +requires: Carp: 0 Exporter: 0 Test::More: 0 XSLoader: 0 -meta-spec: - url: http://module-build.sourceforge.net/META-spec-v1.2.html - version: 1.2 -author: - - Vincent Pit + +distribution_type: module +generated_by: ExtUtils::MakeMaker version 6.30 diff --git a/Magic.xs b/Magic.xs index a2387f1..fd22ffa 100644 --- a/Magic.xs +++ b/Magic.xs @@ -37,6 +37,18 @@ # define PERL_MAGIC_ext '~' #endif +#ifndef MGf_COPY +# define MGf_COPY 0 +#endif /* !MGf_COPY */ + +#ifndef MGf_DUP +# define MGf_DUP 0 +#endif /* !MGf_DUP */ + +#ifndef MGf_LOCAL +# define MGf_LOCAL 0 +#endif /* !MGf_LOCAL */ + /* --- Our sv_magicext ----------------------------------------------------- */ #ifdef sv_magicext @@ -124,7 +136,17 @@ STATIC U16 vmg_gensig(pTHX) { typedef struct { MGVTBL *vtbl; U16 sig; - SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free, *cb_data; + SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free; +#if MGf_COPY + SV *cb_copy; +#endif /* MGf_COPY */ +#if MGf_DUP + SV *cb_dup; +#endif /* MGf_DUP */ +#if MGf_LOCAL + SV *cb_local; +#endif /* MGf_LOCAL */ + SV *cb_data; } MGWIZ; #define MGWIZ2SV(W) (newSVuv(PTR2UV(W))) @@ -206,6 +228,17 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) { data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args) : NULL; mg = vmg_sv_magicext(sv, data, w->vtbl, wiz, HEf_SVKEY); mg->mg_private = w->sig; + mg->mg_flags = mg->mg_flags +#if MGf_COPY + | MGf_COPY +#endif /* MGf_COPY */ +#if MGf_DUP + | MGf_DUP +#endif /* MGf_DUP */ +#if MGf_LOCAL + | MGf_LOCAL +#endif /* MGf_LOCAL */ + ; return 1; } @@ -321,6 +354,50 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj); } +#if MGf_COPY +STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *name, int namelen) { + int ret; + + dSP; + int count; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(sv_2mortal(newRV_inc(sv))); + XPUSHs((mg->mg_obj) ? (mg->mg_obj) : &PL_sv_undef); + XPUSHs(sv_mortalcopy(nsv)); + PUTBACK; + + count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_copy, G_SCALAR); + + SPAGAIN; + + if (count != 1) { croak("Callback needs to return 1 scalar\n"); } + ret = POPi; + + PUTBACK; + + FREETMPS; + LEAVE; + + return ret; +} +#endif /* MGf_COPY */ + +#if MGf_DUP +STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *p) { + return 0; +} +#endif /* MGf_DUP */ + +#if MGf_LOCAL +STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) { + return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_local, nsv, mg->mg_obj); +} +#endif /* MGf_LOCAL */ + /* ... Wizard destructor ................................................... */ STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) { @@ -343,6 +420,15 @@ STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) { if (w->cb_len != NULL) { SvREFCNT_dec(SvRV(w->cb_len)); } if (w->cb_clear != NULL) { SvREFCNT_dec(SvRV(w->cb_clear)); } if (w->cb_free != NULL) { SvREFCNT_dec(SvRV(w->cb_free)); } +#if MGf_COPY + if (w->cb_copy != NULL) { SvREFCNT_dec(SvRV(w->cb_copy)); } +#endif /* MGf_COPY */ +#if MGf_DUP + if (w->cb_dup != NULL) { SvREFCNT_dec(SvRV(w->cb_dup)); } +#endif /* MGf_DUP */ +#if MGf_LOCAL + if (w->cb_local != NULL) { SvREFCNT_dec(SvRV(w->cb_local)); } +#endif /* MGf_LOCAL */ if (w->cb_data != NULL) { SvREFCNT_dec(SvRV(w->cb_data)); } Safefree(w->vtbl); Safefree(w); @@ -356,14 +442,20 @@ STATIC MGVTBL vmg_wizard_vtbl = { NULL, /* len */ NULL, /* clear */ vmg_wizard_free, /* free */ -#ifdef MGf_COPY +#if MGf_COPY NULL, /* copy */ #endif /* MGf_COPY */ -#ifdef MGf_DUP +#if MGf_DUP NULL, /* dup */ #endif /* MGf_DUP */ +#if MGf_LOCAL + NULL, /* local */ +#endif /* MGf_LOCAL */ }; +/* --- 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"; @@ -389,6 +481,14 @@ STATIC U16 vmg_sv2sig(pTHX_ SV *sv) { return sig; } +#define VMG_SET_CB(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; \ + } + /* --- XS ------------------------------------------------------------------ */ MODULE = Variable::Magic PACKAGE = Variable::Magic @@ -402,26 +502,39 @@ BOOT: 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)); -*/ + 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)); + newCONSTSUB(stash, "MGf_LOCAL", newSVuv(MGf_LOCAL)); } -SV *_wizard(SV *svsig, SV *cb_get, SV *cb_set, SV *cb_len, SV *cb_clear, SV *cb_free, SV *cb_data) -PROTOTYPE: $&&&&&& +SV *_wizard(SV *svsig, ...) +PROTOTYPE: $@ PREINIT: U16 sig; + I32 i; char buf[8]; MGWIZ *w; MGVTBL *t; MAGIC *mg; - SV *sv; + SV *cb, *sv; CODE: dMY_CXT; + + if (items != 7 +#if MGf_COPY + + 1 +#endif /* MGf_COPY */ +#if MGf_DUP + + 1 +#endif /* MGf_DUP */ +#if MGf_LOCAL + + 1 +#endif /* MGf_LOCAL */ + ) { croak(vmg__wizard_args); } + if (SvOK(svsig)) { SV **old; sig = vmg_sv2sig(svsig); @@ -433,33 +546,40 @@ CODE: 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; - t->svt_set = (SvOK(cb_set)) ? vmg_svt_set : NULL; - t->svt_len = (SvOK(cb_len)) ? vmg_svt_len : NULL; - t->svt_clear = (SvOK(cb_clear)) ? vmg_svt_clear : NULL; - t->svt_free = (SvOK(cb_free)) ? vmg_svt_free : NULL; -#ifdef MGf_COPY - t->svt_copy = NULL; -#endif /* MGf_COPY */ -#ifdef MGf_DUP - t->svt_dup = NULL; -#endif /* MGf_DUP */ + Newx(t, 1, MGVTBL); Newx(w, 1, MGWIZ); w->vtbl = t; 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; - w->cb_clear = (SvROK(cb_clear)) ? newRV_inc(SvRV(cb_clear)) : NULL; - w->cb_free = (SvROK(cb_free)) ? newRV_inc(SvRV(cb_free)) : NULL; - w->cb_data = (SvROK(cb_data)) ? newRV_inc(SvRV(cb_data)) : NULL; + + cb = ST(1); w->cb_data = SvROK(cb) ? newRV_inc(SvRV(cb)) : NULL; + VMG_SET_CB(get, t, w, ST(2)); + VMG_SET_CB(set, t, w, ST(3)); + VMG_SET_CB(len, t, w, ST(4)); + VMG_SET_CB(clear, t, w, ST(5)); + VMG_SET_CB(free, t, w, ST(6)); +#if MGf_COPY + VMG_SET_CB(copy, t, w, ST(7)); +#endif /* MGf_COPY */ +#if MGf_DUP + VMG_SET_CB(dup, t, w, ST(8)); +#endif /* MGf_DUP */ +#if MGf_LOCAL + VMG_SET_CB(local, t, w, ST(9)); +#endif /* MGf_LOCAL */ sv = MGWIZ2SV(w); mg = vmg_sv_magicext(sv, NULL, &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; diff --git a/README b/README index 4b92a15..a626da0 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ NAME Variable::Magic - Associate user-defined magic to variables from Perl. VERSION - Version 0.06 + Version 0.07_01 SYNOPSIS use Variable::Magic qw/wizard cast dispell/; @@ -76,6 +76,15 @@ CONSTANTS "SIG_NBR" SIG_NBR = SIG_MAX - SIG_MIN + 1 + "MGf_COPY" + True iff the 'copy' magic is available. + + "MGf_DUP" + True iff the 'dup' magic is available. + + "MGf_LOCAL" + True iff the 'local' magic is available. + FUNCTIONS "wizard" wizard sig => .., data => ..., get => .., set => .., len => .., clear => .., free => .. diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm index ff6ec4a..f605649 100644 --- a/lib/Variable/Magic.pm +++ b/lib/Variable/Magic.pm @@ -13,11 +13,15 @@ Variable::Magic - Associate user-defined magic to variables from Perl. =head1 VERSION -Version 0.06 +Version 0.07_01 =cut -our $VERSION = '0.06'; +use vars qw/$VERSION/; + +BEGIN { + $VERSION = '0.07_01'; +} =head1 SYNOPSIS @@ -96,13 +100,27 @@ The maximum integer used as a signature for user-defined magic. SIG_NBR = SIG_MAX - SIG_MIN + 1 +=head2 C + +True iff the 'copy' magic is available. + +=head2 C + +True iff the 'dup' magic is available. + +=head2 C + +True iff the 'local' magic is available. + =head1 FUNCTIONS =cut use XSLoader; -XSLoader::load __PACKAGE__, $VERSION; +BEGIN { + XSLoader::load __PACKAGE__, $VERSION; +} =head2 C @@ -136,7 +154,13 @@ Code references to corresponding magic callbacks. You don't have to specify all sub wizard { croak 'Wrong number of arguments for wizard()' if @_ % 2; my %opts = @_; - return _wizard(map { $opts{$_} } qw/sig get set len clear free data/); + my $sig = $opts{sig}; + my @types = qw/data get set len clear free/; + push @types, 'copy' if MGf_COPY; + push @types, 'dup' if MGf_DUP; + delete $opts{dup}; # don't use it for now + push @types, 'local' if MGf_LOCAL; + return _wizard($sig, map { $opts{$_} } @types); } =head2 C @@ -196,7 +220,7 @@ use base qw/Exporter/; our @EXPORT = (); our %EXPORT_TAGS = ( 'funcs' => [ qw/wizard gensig getsig cast getdata dispell/ ], - 'consts' => [ qw/SIG_MIN SIG_MAX SIG_NBR/ ] + 'consts' => [ qw/SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL/ ] ); our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS; $EXPORT_TAGS{'all'} = \@EXPORT_OK; diff --git a/t/25-copy.t b/t/25-copy.t new file mode 100644 index 0000000..58cf8e9 --- /dev/null +++ b/t/25-copy.t @@ -0,0 +1,63 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +use Variable::Magic qw/wizard cast MGf_COPY/; + +if (!MGf_COPY) { + plan skip_all => "this perl doesn't handle copy magic"; +} else { + plan tests => 16; +} + +my $c = 0; +my $wiz = wizard copy => sub { ++$c }; +ok($c == 0, 'copy : create wizard'); + +use Tie::Array; + +tie my @a, 'Tie::StdArray'; +cast @a, $wiz; +ok($c == 0, 'copy (array) : cast'); + +my $n = time; +$a[0] = $n; +ok($c == 1, 'copy (array) : store element'); + +my $e = exists $a[0]; +ok($c == 2, 'copy (array) : exists element'); +ok($e, 'copy (array) : exists element, really'); + +my $b = $a[0]; +ok($c == 3, 'copy (array) : fetch element'); +ok($b == $n, 'copy (array) : fetch element correctly'); + +use Tie::Hash; + +$c = 0; + +tie my %h, 'Tie::StdHash'; +cast %h, $wiz; +ok($c == 0, 'copy (hash) : cast'); + +my ($k, $v) = (time, int rand time); +$h{$k} = $v; +ok($c == 1, 'copy (hash) : store element'); + +$e = exists $h{$k}; +ok($c == 2, 'copy (hash) : exists element'); +ok($e, 'copy (hash) : exists element, really'); + +my $w = $h{$k}; +ok($c == 3, 'copy (hash) : fetch element'); +ok($w == $v, 'copy (hash) : fetch element correctly'); + +my ($K, $V) = each %h; +ok($c == 4, 'copy (hash) : iterate'); +ok($k == $K && $v == $V, 'copy (hash) : iterate correctly'); + +delete $h{$k}; +ok($c == 5, 'copy (hash) : delete'); diff --git a/t/27-local.t b/t/27-local.t new file mode 100644 index 0000000..7d5f88b --- /dev/null +++ b/t/27-local.t @@ -0,0 +1,38 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +use Variable::Magic qw/wizard cast dispell MGf_LOCAL/; + +if (!MGf_LOCAL) { + plan skip_all => "this perl doesn't handle local magic"; +} else { + plan tests => 5; +} + +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; + ok($c == 1, 'local : localize casted variable'); +} + +dispell $a, $wiz; +ok($c == 1, 'local : dispell'); + +{ + local $a; + ok($c == 1, 'local : localize dispelled variable'); +} +