From: Vincent Pit <vince@profvince.com>
Date: Sun, 29 Jun 2008 16:24:44 +0000 (+0200)
Subject: Importing Variable-Magic-0.11.tar.gz
X-Git-Tag: v0.11
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=refs%2Ftags%2Fv0.11;hp=fee1a480bc5d827590dc7394e0a77741bad86dc3;p=perl%2Fmodules%2FVariable-Magic.git

Importing Variable-Magic-0.11.tar.gz
---

diff --git a/Changes b/Changes
index 0d52bc6..0d1b8c2 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,15 @@
 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.
diff --git a/META.yml b/META.yml
index 799f882..1312412 100644
--- a/META.yml
+++ b/META.yml
@@ -1,6 +1,6 @@
 --- #YAML:1.0
 name:                Variable-Magic
-version:             0.10
+version:             0.11
 abstract:            Associate user-defined magic to variables from Perl.
 license:             perl
 author:              
diff --git a/Magic.xs b/Magic.xs
index 2df5bb4..936e8cd 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -20,6 +20,14 @@
 
 #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
@@ -60,25 +68,19 @@
 # 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 */
@@ -420,7 +422,7 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data) {
  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;
@@ -453,7 +455,43 @@ STATIC int vmg_cb_call2(pTHX_ SV *cb, SV *sv, SV *data, SV *sv2) {
 
  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);
@@ -513,8 +551,23 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
 }
 
 #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 */
 
@@ -700,8 +753,6 @@ BOOT:
                     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(...)
diff --git a/Makefile.PL b/Makefile.PL
index f76dda4..ebe7a50 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -4,6 +4,23 @@ use strict;
 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>',
@@ -11,6 +28,7 @@ WriteMakefile(
     VERSION_FROM        => 'lib/Variable/Magic.pm',
     ABSTRACT_FROM       => 'lib/Variable/Magic.pm',
     PL_FILES            => {},
+    @DEFINES,
     PREREQ_PM => {
         'Carp'       => 0,
         'Exporter'   => 0,
diff --git a/README b/README
index c947b23..f31437c 100644
--- a/README
+++ b/README
@@ -2,7 +2,7 @@ NAME
     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/;
@@ -95,8 +95,8 @@ PERL MAGIC HISTORY
     *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
@@ -104,6 +104,11 @@ PERL MAGIC HISTORY
     *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.
@@ -134,10 +139,6 @@ CONSTANTS
   "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    => ...,
@@ -147,7 +148,7 @@ FUNCTIONS
                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) = @_; ... },
@@ -178,9 +179,11 @@ FUNCTIONS
         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" },
diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm
index 8025a40..6e767b9 100644
--- a/lib/Variable/Magic.pm
+++ b/lib/Variable/Magic.pm
@@ -13,13 +13,13 @@ Variable::Magic - Associate user-defined magic to variables from Perl.
 
 =head1 VERSION
 
-Version 0.10
+Version 0.11
 
 =cut
 
 our $VERSION;
 BEGIN {
- $VERSION = '0.10';
+ $VERSION = '0.11';
 }
 
 =head1 SYNOPSIS
@@ -117,7 +117,7 @@ The places where magic is invoked have changed a bit through perl history. Here'
 
 =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.
 
@@ -133,6 +133,10 @@ The places where magic is invoked have changed a bit through perl history. Here'
 
 =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>
@@ -171,10 +175,6 @@ True for perls that don't call 'len' magic when you push an element in a magical
 
 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
@@ -193,7 +193,7 @@ BEGIN {
            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) = @_; ... },
@@ -214,7 +214,7 @@ A code reference to a private data constructor. It is called each time this magi
 
 =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
 
@@ -294,7 +294,7 @@ 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 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 ];
diff --git a/t/01-import.t b/t/01-import.t
index cc4aebd..6b85849 100644
--- a/t/01-import.t
+++ b/t/01-import.t
@@ -3,11 +3,11 @@
 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 ' . $_);
 }
diff --git a/t/32-hash.t b/t/32-hash.t
index 7f1669a..572f5e6 100644
--- a/t/32-hash.t
+++ b/t/32-hash.t
@@ -5,7 +5,7 @@ use warnings;
 
 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;
@@ -56,13 +56,13 @@ ok(check(), 'hash : slice');
 
 %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');