Revision history for Variable-Magic
+0.11 2008-02-07 17:55 UTC
+ + Add : Copy callbacks now receive the current key/index in $_[2].
+ The current value/element is now in $_[3].
+ + Chg : The trigger of copy magic on list assignment with perls greater
+ than 5.10.0 was caused by uvar magic. Hence,
+ VMG_COMPAT_HASH_LISTASSIGN_COPY was removed. Use VMG_UVAR
+ instead.
+ + Fix : Build failures on patched perls.
+ + Tst : Added missing exported symbols to 01-import.t.
+
0.10 2008-02-04 11:30 UTC
+ Add : New script : samples/vm_vs_tie.pl, that benchmarks our uvar
magic versus tied hashes.
--- #YAML:1.0
name: Variable-Magic
-version: 0.10
+version: 0.11
abstract: Associate user-defined magic to variables from Perl.
license: perl
author:
#define PERL_API_VERSION_LE(R, V, S) (PERL_API_REVISION < (R) || (PERL_API_REVISION == (R) && (PERL_API_VERSION < (V) || (PERL_API_VERSION == (V) && (PERL_API_SUBVERSION <= (S))))))
+#ifndef VMG_PERL_PATCHLEVEL
+# ifdef PERL_PATCHNUM
+# define VMG_PERL_PATCHLEVEL PERL_PATCHNUM
+# else
+# define VMG_PERL_PATCHLEVEL 0
+# endif
+#endif
+
/* --- Compatibility ------------------------------------------------------- */
#ifndef Newx
# define VMG_UVAR 0
#endif
-#if PERL_VERSION_GE(5, 9, 3)
+#if (VMG_PERL_PATCHLEVEL >= 25854) || PERL_VERSION_GE(5, 9, 3)
# define VMG_COMPAT_ARRAY_PUSH_NOLEN 1
#else
# define VMG_COMPAT_ARRAY_PUSH_NOLEN 0
#endif
/* since 5.9.5 - see #43357 */
-#if PERL_VERSION_GE(5, 9, 5)
+#if (VMG_PERL_PATCHLEVEL >= 31473) || PERL_VERSION_GE(5, 9, 5)
# define VMG_COMPAT_ARRAY_UNDEF_CLEAR 1
#else
# define VMG_COMPAT_ARRAY_UNDEF_CLEAR 0
#endif
-#if MGf_COPY && PERL_VERSION_GE(5, 9, 4)
-# define VMG_COMPAT_HASH_LISTASSIGN_COPY 1
-#else
-# define VMG_COMPAT_HASH_LISTASSIGN_COPY 0
-#endif
-
#if VMG_UVAR
/* Bug-free mg_magical - see http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html */
return ret;
}
-#if MGf_COPY || VMG_UVAR
+#if 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))
SV *svr;
return ret;
}
-#endif /* MGf_COPY || VMG_UVAR */
+#endif /* VMG_UVAR */
+
+#if MGf_COPY
+STATIC int vmg_cb_call3(pTHX_ SV *cb, SV *sv, SV *data, SV *sv2, SV *sv3) {
+#define vmg_cb_call3(I, S, D, S2, S3) vmg_cb_call3(aTHX_ (I), (S), (D), (S2), (S3))
+ SV *svr;
+ int ret;
+
+ dSP;
+ int count;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newRV_inc(sv)));
+ XPUSHs(data ? data : &PL_sv_undef);
+ XPUSHs(sv2 ? sv2 : &PL_sv_undef);
+ if (sv3) { XPUSHs(sv3); }
+ PUTBACK;
+
+ count = call_sv(cb, G_SCALAR);
+
+ SPAGAIN;
+
+ if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
+ svr = POPs;
+ ret = SvOK(svr) ? SvIV(svr) : 0;
+
+ PUTBACK;
+
+ FREETMPS;
+ LEAVE;
+
+ return ret;
+}
+#endif /* MGf_COPY */
STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj);
}
#if MGf_COPY
-STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *name, int namelen) {
- return vmg_cb_call2(SV2MGWIZ(mg->mg_ptr)->cb_copy, sv, mg->mg_obj, nsv);
+STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, int keylen) {
+ SV *keysv;
+ int ret;
+
+ if (keylen == HEf_SVKEY) {
+ keysv = (SV *) key;
+ } else {
+ keysv = newSVpvn(key, keylen);
+ }
+
+ ret = vmg_cb_call3(SV2MGWIZ(mg->mg_ptr)->cb_copy, sv, mg->mg_obj, keysv, nsv);
+
+ if (keylen != HEf_SVKEY) {
+ SvREFCNT_dec(keysv);
+ }
+
+ return ret;
}
#endif /* MGf_COPY */
newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN));
newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNDEF_CLEAR",
newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR));
- newCONSTSUB(stash, "VMG_COMPAT_HASH_LISTASSIGN_COPY",
- newSVuv(VMG_COMPAT_HASH_LISTASSIGN_COPY));
}
SV *_wizard(...)
use warnings;
use ExtUtils::MakeMaker;
+eval {
+ require Config;
+};
+die "OS unsupported" if $@;
+
+my @DEFINES;
+
+my $pl = $Config::Config{perl_patchlevel};
+print "Checking perl patchlevel... ";
+if (defined $pl && length $pl) {
+ $pl = int $pl;
+ push @DEFINES, DEFINE => '-DVMG_PERL_PATCHLEVEL=' . $pl;
+ print $pl, "\n";
+} else {
+ print "none\n";
+}
+
WriteMakefile(
NAME => 'Variable::Magic',
AUTHOR => 'Vincent Pit <perl@profvince.com>',
VERSION_FROM => 'lib/Variable/Magic.pm',
ABSTRACT_FROM => 'lib/Variable/Magic.pm',
PL_FILES => {},
+ @DEFINES,
PREREQ_PM => {
'Carp' => 0,
'Exporter' => 0,
Variable::Magic - Associate user-defined magic to variables from Perl.
VERSION
- Version 0.10
+ Version 0.11
SYNOPSIS
use Variable::Magic qw/wizard cast dispell/;
*p14416* : 'copy' and 'dup' magic.
5.9.3
- 'len' magic is no longer called when pushing an element into a magic
- array.
+ *p25854* : 'len' magic is no longer called when pushing an element into
+ a magic array.
*p26569* : 'local' magic.
5.9.5
*p31473* : 'clear' magic wasn't invoked when undefining an array. The
bug is fixed as of this version.
+ 5.10.0
+ Since "PERL_MAGIC_uvar" is uppercased, "hv_magic_check()" triggers
+ 'copy' magic on hash stores for (non-tied) hashes that also have 'uvar'
+ magic.
+
CONSTANTS
"SIG_MIN"
The minimum integer used as a signature for user-defined magic.
"VMG_COMPAT_ARRAY_UNDEF_CLEAR"
True for perls that call 'clear' magic when undefining magical arrays.
- "VMG_COMPAT_HASH_LISTASSIGN_COPY"
- True for perls that call 'copy' magic on list assignments. Implies that
- "MGf_COPY" is true.
-
FUNCTIONS
"wizard"
wizard sig => ...,
len => sub { my ($ref, $data, $len) = @_; ... ; return $newlen; },
clear => sub { my ($ref, $data) = @_; ... },
free => sub { my ($ref, $data) = @_, ... },
- copy => sub { my ($ref, $data, $elt) = @_; ... },
+ copy => sub { my ($ref, $data, $key, $elt) = @_; ... },
local => sub { my ($ref, $data) = @_; ... },
fetch => sub { my ($ref, $data, $key) = @_; ... },
store => sub { my ($ref, $data, $key) = @_; ... },
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.
+ contains its normal length. $_[2] is the current key in "copy",
+ "fetch", "store", "exists" and "delete" callbacks, although for
+ "copy" it may just be a copy of the actual key so it's useless to
+ (for example) cast magic on it. "copy" magic also receives the
+ current element (i.e. the value) in $_[3].
# A simple scalar tracer
my $wiz = wizard get => sub { print STDERR "got ${$_[0]}\n" },
=head1 VERSION
-Version 0.10
+Version 0.11
=cut
our $VERSION;
BEGIN {
- $VERSION = '0.10';
+ $VERSION = '0.11';
}
=head1 SYNOPSIS
=over 4
-=item 'len' magic is no longer called when pushing an element into a magic array.
+=item I<p25854> : 'len' magic is no longer called when pushing an element into a magic array.
=item I<p26569> : 'local' magic.
=back
+=head2 B<5.10.0>
+
+=item Since C<PERL_MAGIC_uvar> is uppercased, C<hv_magic_check()> triggers 'copy' magic on hash stores for (non-tied) hashes that also have 'uvar' magic.
+
=head1 CONSTANTS
=head2 C<SIG_MIN>
True for perls that call 'clear' magic when undefining magical arrays.
-=head2 C<VMG_COMPAT_HASH_LISTASSIGN_COPY>
-
-True for perls that call 'copy' magic on list assignments. Implies that C<MGf_COPY> is true.
-
=head1 FUNCTIONS
=cut
len => sub { my ($ref, $data, $len) = @_; ... ; return $newlen; },
clear => sub { my ($ref, $data) = @_; ... },
free => sub { my ($ref, $data) = @_, ... },
- copy => sub { my ($ref, $data, $elt) = @_; ... },
+ copy => sub { my ($ref, $data, $key, $elt) = @_; ... },
local => sub { my ($ref, $data) = @_; ... },
fetch => sub { my ($ref, $data, $key) = @_; ... },
store => sub { my ($ref, $data, $key) = @_; ... },
=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 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.
+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<$_[2]> is the current key in C<copy>, C<fetch>, C<store>, C<exists> and C<delete> callbacks, although for C<copy> it may just be a copy of the actual key so it's useless to (for example) cast magic on it. C<copy> magic also receives the current element (i.e. the value) in C<$_[3]>.
=back
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 VMG_UVAR/,
- qw/VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNDEF_CLEAR VMG_COMPAT_HASH_LISTASSIGN_COPY/ ]
+ qw/VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNDEF_CLEAR/ ]
);
our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More tests => 15;
require Variable::Magic;
-for (qw/wizard gensig getsig cast getdata dispell SIG_MIN SIG_MAX SIG_NBR/) {
+for (qw/wizard gensig getsig cast getdata dispell SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNDEF_CLEAR/) {
eval { Variable::Magic->import($_) };
ok(!$@, 'import ' . $_);
}
use Test::More tests => 18;
-use Variable::Magic qw/wizard cast dispell MGf_COPY VMG_UVAR VMG_COMPAT_HASH_LISTASSIGN_COPY/;
+use Variable::Magic qw/wizard cast dispell MGf_COPY VMG_UVAR/;
my @c = (0) x 12;
my @x = (0) x 12;
%a = (a => 1, d => 3);
++$x[3];
-$x[5] += 2 if VMG_COMPAT_HASH_LISTASSIGN_COPY;
+$x[5] += 2 if VMG_UVAR;
$x[9] += 2 if VMG_UVAR;
ok(check(), 'hash : assign from list');
%a = map { $_ => 1 } qw/a b d/;
++$x[3];
-$x[5] += 3 if VMG_COMPAT_HASH_LISTASSIGN_COPY;
+$x[5] += 3 if VMG_UVAR;
$x[9] += 3 if VMG_UVAR;
ok(check(), 'hash : assign from map');
projects / perl / modules / Variable-Magic.git / commitdiff