Allow editing the key SV in uvar callbacks by passing a new option 'copy_key'

diff --git a/Magic.xs b/Magic.xs
index c0c4297b82177cb431e9d548c2da6b3d91736b0a..44d6c88202bc9e33377153cbdb6260953d0126f2 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -638,13 +638,13 @@ STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
 #if VMG_UVAR
 STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
  struct ufuncs *uf;
- MAGIC *mg;
- SV *key = NULL;
+ MAGIC *mg, *umg;
+ SV *key = NULL, *newkey = 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;
+ umg = mg_find(sv, PERL_MAGIC_uvar);
+ /* umg can't be NULL or we wouldn't be there. */
+ key = umg->mg_obj;
+ uf  = (struct ufuncs *) umg->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); }
@@ -656,7 +656,13 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
    || (mg->mg_private < SIG_MIN)
    || (mg->mg_private > SIG_MAX)) { continue; }
   w = SV2MGWIZ(mg->mg_ptr);
-  if (!w->uvar) { continue; }
+  switch (w->uvar) {
+   case 0:
+    continue;
+   case 2:
+    if (!newkey)
+     newkey = key = umg->mg_obj = sv_2mortal(newSVsv(umg->mg_obj));
+  }
   switch (action) {
    case 0:
     if (w->cb_fetch)  { vmg_cb_call2(w->cb_fetch,  sv, mg->mg_obj, key); }
@@ -970,7 +976,7 @@ CODE:
               + 1
 #endif /* MGf_LOCAL */
 #if VMG_UVAR
-              + 4
+              + 5
 #endif /* VMG_UVAR */
               ) { croak(vmg_wrongargnum); }
 
@@ -1013,16 +1019,17 @@ CODE:
  VMG_SET_CB(ST(i++), store);
  VMG_SET_CB(ST(i++), exists);
  VMG_SET_CB(ST(i++), delete);
+ cb = ST(i++);
+ if (w->cb_fetch || w->cb_store || w->cb_exists || w->cb_delete)
+  w->uvar = SvTRUE(cb) ? 2 : 1;
+ else
+  w->uvar = 0;
 #endif /* VMG_UVAR */
 #if VMG_MULTIPLICITY
  w->owner = aTHX;
 #endif /* VMG_MULTIPLICITY */
-
- 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 */
+ w->vtbl  = t;
+ w->sig   = sig;
 
  sv = MGWIZ2SV(w);
  mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);

diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm
index 52425fb565e5fa04f8da3fa9ec9c20560d14e99f..5f268a44b951fd6f5c2d280c536e4a9fe9438971 100644 (file)
--- a/lib/Variable/Magic.pm
+++ b/lib/Variable/Magic.pm
@@ -339,12 +339,12 @@ However, only the return value of the C<len> callback currently holds a meaning.
 sub wizard {
  croak 'Wrong number of arguments for wizard()' if @_ % 2;
  my %opts = @_;
- 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;
- my $ret = eval { _wizard(map $opts{$_}, @cbs) };
+ my @keys  = qw/sig data get set len clear free/;
+ push @keys, 'copy'  if MGf_COPY;
+ push @keys, 'dup'   if MGf_DUP;
+ push @keys, 'local' if MGf_LOCAL;
+ push @keys, qw/fetch store exists delete copy_key/ if VMG_UVAR;
+ my $ret = eval { _wizard(map $opts{$_}, @keys) };
  if (my $err = $@) {
   $err =~ s/\sat\s+.*?\n//;
   croak $err;

diff --git a/t/10-simple.t b/t/10-simple.t
index 7921facab3a3af8047fc70761ab9298c84d96765..1fdefcd61aa3e8b418e9863eecf5cd38b0b2b229 100644 (file)
--- a/t/10-simple.t
+++ b/t/10-simple.t
@@ -11,7 +11,7 @@ my $args = 7;
 ++$args if MGf_COPY;
 ++$args if MGf_DUP;
 ++$args if MGf_LOCAL;
-$args += 4 if VMG_UVAR;
+$args += 5 if VMG_UVAR;
 for (0 .. 20) {
  next if $_ == $args;
  eval { Variable::Magic::_wizard(('hlagh') x $_) };

diff --git a/t/28-uvar.t b/t/28-uvar.t
index 4906e72f1a867ce0bf8fd8ccea04c491fb0046a3..30d7f525e20b5d4e9651d88759d3148bd4067af4 100644 (file)
--- a/t/28-uvar.t
+++ b/t/28-uvar.t
@@ -3,14 +3,12 @@
 use strict;
 use warnings;
 
-use Config qw/%Config/;
-
 use Test::More;
 
 use Variable::Magic qw/wizard cast dispell VMG_UVAR/;
 
 if (VMG_UVAR) {
- plan tests => 2 * 9 + 7 + 12 + 1;
+ plan tests => 2 * 10 + 8 + 14 + 1;
 } else {
  plan skip_all => 'No nice uvar magic for this perl';
 }
@@ -47,7 +45,13 @@ is $x, 5, 'uvar: delete existing key correctly';
 check { $x = delete $h{z} } { delete => 1 }, 'delete non-existing key';
 ok !defined $x, 'uvar: delete non-existing key correctly';
 
-my $wiz2 = wizard fetch => sub { 0 };
+my $wiz2 = wizard get => sub { 0 };
+cast %h, $wiz2;
+
+check { $x = $h{a} } { fetch => 1 }, 'fetch directly with also non uvar magic';
+is $x, 1, 'uvar: fetch directly with also non uvar magic correctly';
+
+$wiz2 = wizard fetch => sub { 0 };
 my %h2 = (a => 37, b => 2, c => 3);
 cast %h2, $wiz2;
 
@@ -65,31 +69,22 @@ eval {
 is $@, '',     'uvar: store with incomplete magic doesn\'t croak';
 is $h2{a}, 73, 'uvar: store with incomplete magic correctly';
 
-my $wiz3 = wizard store => sub { ++$_[2]; 0 };
+my $wiz3 = wizard store => sub { ++$_[2]; 0 }, copy_key => 1;
 my %h3 = (a => 3);
 cast %h3, $wiz3;
 
 for my $i (1 .. 2) {
- eval { my $key = 'a'; $h3{$key} = 3 + $i };
+ my $key = 'a';
+ eval { $h3{$key} = 3 + $i };
  is        $@,   '',  "uvar: change key in store doesn't croak ($i)";
+ is        $key, 'a', "uvar: change key didn't clobber \$key ($i)";
  is_deeply \%h3, { a => 3, b => 3 + $i },
                       "uvar: change key in store correcty ($i)";
 }
 
-my $ro_bare_hk = $] >= 5.010 && $Config{useithreads};
-diag 'This perl has readonly bare hash keys' if $ro_bare_hk;
-
 for my $i (1 .. 2) {
  eval { $h3{b} = 5 + $i };
- if ($ro_bare_hk) {
-  like $@, qr/Modification\s+of\s+a\s+read-only\s+value/,
-                               "uvar: change readonly key in store croaks ($i)";
-  is_deeply \%h3, { a => 3, b => 5 },
-                             "uvar: change readonly key in store correcty ($i)";
- } else {
-  is $@, '',                   "uvar: change readonly key in store croaks ($i)";
-  is_deeply \%h3, { a => 3, b => 5, c => 6, (d => 7) x ($i >= 2) },
+ is $@, '',                    "uvar: change readonly key in store croaks ($i)";
+ is_deeply \%h3, { a => 3, b => 5, c => 5 + $i },
                              "uvar: change readonly key in store correcty ($i)";
- }
 }
-