Delay destruction of reference return values till the current statement end

diff --git a/MANIFEST b/MANIFEST
index e474b4b1b82fba83faf5f71f205810710fdb81d4..c05275672437875e97828758b12ccf4fd3ac5eb7 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -39,6 +39,7 @@ t/34-glob.t
 t/35-stash.t
 t/40-threads.t
 t/41-clone.t
 t/35-stash.t
 t/40-threads.t
 t/41-clone.t

+t/50-return.t

 t/80-leaks.t
 t/lib/Test/Leaner.pm
 t/lib/VPIT/TestHelpers.pm
 t/80-leaks.t
 t/lib/Test/Leaner.pm
 t/lib/VPIT/TestHelpers.pm

diff --git a/Magic.xs b/Magic.xs
index 9eda482e03a65e3652c7732e63b921a0386b47da..b810d91f9db40a63c90e9a75711a8861a809967f 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -1246,11 +1246,18 @@ static int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
  svr = POPs;
  if (SvOK(svr))
   ret = (int) SvIV(svr);
  svr = POPs;
  if (SvOK(svr))
   ret = (int) SvIV(svr);

+ if (SvROK(svr))
+  SvREFCNT_inc(svr);
+ else
+  svr = NULL;

  PUTBACK;
 
  FREETMPS;
  LEAVE;
 
  PUTBACK;
 
  FREETMPS;
  LEAVE;
 

+ if (svr && !SvTEMP(svr))
+  sv_2mortal(svr);
+

  if (chain) {
   vmg_dispell_guard_new(*chain);
   *chain = NULL;
  if (chain) {
   vmg_dispell_guard_new(*chain);
   *chain = NULL;

diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm
index 12af5b595c3cac25c8ae90716e5275a03eb60aa2..7c866494233c59ffdd7729ad8f6a124d396282ef 100644 (file)
--- a/lib/Variable/Magic.pm
+++ b/lib/Variable/Magic.pm
@@ -309,8 +309,12 @@ C<$_[-1]> is the C<B::OP> object for the current op.
 
 Both result in a small performance hit, but just getting the name is lighter than getting the op object.
 
 
 Both result in a small performance hit, but just getting the name is lighter than getting the op object.
 

-These callbacks are executed in scalar context and are expected to return an integer, which is then passed straight to the perl magic API.
-However, only the return value of the I<len> magic callback currently holds a meaning.
+These callbacks are always executed in scalar context.
+The returned value is coerced into a signed integer, which is then passed straight to the perl magic API.
+However, note that perl currently only cares about the return value of the I<len> magic callback and ignores all the others.
+Starting with Variable::Magic 0.58, a reference returned from a non-I<len> magic callback will not be destroyed immediately but will be allowed to survive until the end of the statement that triggered the magic.
+This lets you use this return value as a token for triggering a destructor after the original magic action takes place.
+You can see an example of this technique in the L<cookbook|/COOKBOOK>.

 
 =back
 
 
 =back
 


@@ -577,6 +581,44 @@ When C<%h> goes out of scope, this prints something among the lines of :
 
 Of course, this example does nothing with the values that are added after the C<cast>.
 
 
 Of course, this example does nothing with the values that are added after the C<cast>.
 

+=head2 Delayed magic actions
+
+Starting with Variable::Magic 0.58, the return value of the magic callbacks can be used to delay the action until after the original action takes place :
+
+    my $delayed;
+    my $delayed_aux = wizard(
+     data => sub { $_[1] },
+     free => sub {
+      my ($target) = $_[1];
+      my $target_data = &getdata($target, $delayed);
+      local $target_data->{guard} = 1;
+      if (ref $target eq 'SCALAR') {
+       my $orig = $$target;
+       $$target = $target_data->{mangler}->($orig);
+      }
+      return;
+     },
+    );
+    $delayed = wizard(
+     data => sub {
+      return +{ guard => 0, mangler => $_[1] };
+     },
+     set  => sub {
+      return if $_[1]->{guard};
+      my $token;
+      cast $token, $delayed_aux, $_[0];
+      return \$token;
+     },
+    );
+    my $x = 1;
+    cast $x, $delayed => sub { $_[0] * 2 };
+    $x = 2;
+    # $x is now 4
+    # But note that the delayed action only takes place at the end of the
+    # current statement :
+    my @y = ($x = 5, $x);
+    # $x is now 10, but @y is (5, 5)
+

 =head1 PERL MAGIC HISTORY
 
 The places where magic is invoked have changed a bit through perl history.
 =head1 PERL MAGIC HISTORY
 
 The places where magic is invoked have changed a bit through perl history.

diff --git a/t/50-return.t b/t/50-return.t
new file mode 100644 (file)
index 0000000..a52d768
--- /dev/null
+++ b/t/50-return.t
@@ -0,0 +1,195 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Variable::Magic qw<wizard cast dispell getdata>;
+
+use Test::More tests => 3 * 11;
+
+our $destroyed;
+
+my $destructor = wizard free => sub { ++$destroyed; return };
+
+{
+ my $increment;
+
+ my $increment_aux = wizard(
+  data => sub { $_[1] },
+  free => sub {
+   my ($target) = $_[1];
+   my $target_data = &getdata($target, $increment);
+   local $target_data->{guard} = 1;
+   ++$$target;
+   return;
+  },
+ );
+
+ $increment = wizard(
+  data => sub {
+   return +{ guard => 0 };
+  },
+  set  => sub {
+   return if $_[1]->{guard};
+   my $token;
+   cast $token, $increment_aux, $_[0];
+   return \$token;
+  },
+ );
+
+ local $destroyed = 0;
+
+ {
+  my $x = 0;
+
+  cast $x, $destructor;
+
+  {
+   cast $x, $increment;
+   is $x, 0;
+   $x = 1;
+   is $x, 2;
+   $x = 123;
+   is $x, 124;
+   $x = -5;
+   is $x, -4;
+   $x = 27, is($x, 27);
+   is $x, 28;
+   my @y = ($x = -13, $x);
+   is $x, -12;
+   is "@y", '-13 -13';
+  }
+
+  dispell $x, $increment;
+
+  $x = 456;
+  is $x, 456;
+
+  is $destroyed, 0;
+ }
+
+ is $destroyed, 1;
+}
+
+{
+ my $locker;
+
+ my $locker_aux = wizard(
+  data => sub { $_[1] },
+  free => sub {
+   my ($target) = $_[1];
+   my $target_data = &getdata($target, $locker);
+   local $target_data->{guard} = 1;
+   $$target = $target_data->{value};
+   return;
+  },
+ );
+
+ $locker = wizard(
+  data => sub {
+   return +{ guard => 0, value => $_[1] };
+  },
+  set  => sub {
+   return if $_[1]->{guard};
+   my $token;
+   cast $token, $locker_aux, $_[0];
+   return \$token;
+  },
+ );
+
+ local $destroyed = 0;
+
+ {
+  my $x = 0;
+
+  cast $x, $destructor;
+
+  {
+   cast $x, $locker, 999;
+   is $x, 0;
+   $x = 1;
+   is $x, 999;
+   $x = 123;
+   is $x, 999;
+   $x = -5;
+   is $x, 999;
+   $x = 27, is($x, 27);
+   is $x, 999;
+   my @y = ($x = -13, $x);
+   is $x, 999;
+   is "@y", '-13 -13';
+  }
+
+  dispell $x, $locker;
+
+  $x = 456;
+  is $x, 456;
+
+  is $destroyed, 0;
+ }
+
+ is $destroyed, 1;
+}
+
+{
+ my $delayed;
+
+ my $delayed_aux = wizard(
+  data => sub { $_[1] },
+  free => sub {
+   my ($target) = $_[1];
+   my $target_data = &getdata($target, $delayed);
+   local $target_data->{guard} = 1;
+   if (ref $target eq 'SCALAR') {
+    my $orig = $$target;
+    $$target = $target_data->{mangler}->($orig);
+   }
+   return;
+  },
+ );
+
+ $delayed = wizard(
+  data => sub {
+   return +{ guard => 0, mangler => $_[1] };
+  },
+  set  => sub {
+   return if $_[1]->{guard};
+   my $token;
+   cast $token, $delayed_aux, $_[0];
+   return \$token;
+  },
+ );
+
+ local $destroyed = 0;
+
+ {
+  my $x = 0;
+
+  cast $x, $destructor;
+
+  {
+   cast $x, $delayed => sub { $_[0] * 2 };
+   is $x, 0;
+   $x = 1;
+   is $x, 2;
+   $x = 123;
+   is $x, 246;
+   $x = -5;
+   is $x, -10;
+   $x = 27, is($x, 27);
+   is $x, 54;
+   my @y = ($x = -13, $x);
+   is $x, -26;
+   is "@y", '-13 -13';
+  }
+
+  dispell $x, $delayed;
+
+  $x = 456;
+  is $x, 456;
+
+  is $destroyed, 0;
+ }
+
+ is $destroyed, 1;
+}

diff --git a/t/80-leaks.t b/t/80-leaks.t
index 6916936327e0ad0c2c3c2e626c791296eefc22ce..9ccc1a38429e3ca787c176eab238491d189781ba 100644 (file)
--- a/t/80-leaks.t
+++ b/t/80-leaks.t
@@ -9,7 +9,7 @@ use Test::More;
 
 BEGIN {
  my $tests = 11;
 
 BEGIN {
  my $tests = 11;

- $tests += 3 * (4 + (MGf_LOCAL ? 1 : 0) + (VMG_UVAR ? 4 : 0));
+ $tests += 4 * (4 + (MGf_LOCAL ? 1 : 0) + (VMG_UVAR ? 4 : 0));

  plan tests => $tests;
 }
 
  plan tests => $tests;
 }
 


@@ -115,11 +115,13 @@ $type{$_} = 'scalar_global'  for qw<local>;
 $type{$_} = 'array'          for qw<clear>;
 $type{$_} = 'hash'           for qw<fetch store exists delete>;
 
 $type{$_} = 'array'          for qw<clear>;
 $type{$_} = 'hash'           for qw<fetch store exists delete>;
 

+sub void { }
+

 my %trigger = (
  get    => 'my $y = $x',
  set    => '$x = 2',
  clear  => '@a = ()',
 my %trigger = (
  get    => 'my $y = $x',
  set    => '$x = 2',
  clear  => '@a = ()',

- free   => '',
+ free   => 'void()',

  local  => 'local $X = 2',
  fetch  => 'my $v = $h{a}',
  store  => '$h{a} = 2',
  local  => 'local $X = 2',
  fetch  => 'my $v = $h{a}',
  store  => '$h{a} = 2',


@@ -135,16 +137,18 @@ for my $meth (@methods) {
 
   my $init    = $init{$type{$meth}};
   my $trigger = $trigger{$meth};
 
   my $init    = $init{$type{$meth}};
   my $trigger = $trigger{$meth};

+  my $deinit  = '';

 
   if ($meth eq 'free') {
 
   if ($meth eq 'free') {

-   $init    = "{\n$init";
-   $trigger = '}';
+   $init   = "{\n$init";
+   $deinit = '}';

   }
 
   my $code = join ";\n", grep length, (
    $init,
    'is $destroyed, 0, "return from $meth, before trigger"',
   }
 
   my $code = join ";\n", grep length, (
    $init,
    'is $destroyed, 0, "return from $meth, before trigger"',

-   $trigger,
+   $trigger . ', is($destroyed, 0, "return from $meth, after trigger")',
+   $deinit,

    'is $destroyed, 1, "return from $meth, after trigger"',
   );
 
    'is $destroyed, 1, "return from $meth, after trigger"',
   );