From: Vincent Pit <vince@profvince.com>
Date: Mon, 20 Jul 2015 16:32:52 +0000 (-0300)
Subject: Test timely destruction of values returned from magic callbacks
X-Git-Tag: v0.58~9
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=2e52ce0819fd8c02f7b5c13dbea35d4e44568cde;p=perl%2Fmodules%2FVariable-Magic.git

Test timely destruction of values returned from magic callbacks
---

diff --git a/t/80-leaks.t b/t/80-leaks.t
index 7b2a3f0..6916936 100644
--- a/t/80-leaks.t
+++ b/t/80-leaks.t
@@ -3,9 +3,15 @@
 use strict;
 use warnings;
 
-use Test::More tests => 11;
+use Variable::Magic qw<wizard cast getdata dispell MGf_LOCAL VMG_UVAR>;
 
-use Variable::Magic qw<wizard cast getdata>;
+use Test::More;
+
+BEGIN {
+ my $tests = 11;
+ $tests += 3 * (4 + (MGf_LOCAL ? 1 : 0) + (VMG_UVAR ? 4 : 0));
+ plan tests => $tests;
+}
 
 our $destroyed;
 
@@ -89,3 +95,65 @@ sub D () { 'Variable::Magic::TestDestructor' }
 
  is $destroyed, 1;
 }
+
+# Test destruction of returned values
+
+my @methods = qw<get set clear free>;
+push @methods, 'local' if MGf_LOCAL;
+push @methods, qw<fetch store exists delete> if VMG_UVAR;
+
+my %init = (
+ scalar_lexical => 'my $x = 1; cast $x, $w',
+ scalar_global  => 'our $X; local $X = 1; cast $X, $w',
+ array          => 'my @a = (1); cast @a, $w',
+ hash           => 'my %h = (a => 1); cast %h, $w',
+);
+
+my %type;
+$type{$_} = 'scalar_lexical' for qw<get set free>;
+$type{$_} = 'scalar_global'  for qw<local>;
+$type{$_} = 'array'          for qw<clear>;
+$type{$_} = 'hash'           for qw<fetch store exists delete>;
+
+my %trigger = (
+ get    => 'my $y = $x',
+ set    => '$x = 2',
+ clear  => '@a = ()',
+ free   => '',
+ local  => 'local $X = 2',
+ fetch  => 'my $v = $h{a}',
+ store  => '$h{a} = 2',
+ exists => 'my $e = exists $h{a}',
+ delete => 'my $d = delete $h{a}',
+);
+
+for my $meth (@methods) {
+ local $destroyed = 0;
+
+ {
+  my $w = wizard $meth => sub { return D->new };
+
+  my $init    = $init{$type{$meth}};
+  my $trigger = $trigger{$meth};
+
+  if ($meth eq 'free') {
+   $init    = "{\n$init";
+   $trigger = '}';
+  }
+
+  my $code = join ";\n", grep length, (
+   $init,
+   'is $destroyed, 0, "return from $meth, before trigger"',
+   $trigger,
+   'is $destroyed, 1, "return from $meth, after trigger"',
+  );
+
+  {
+   local $@;
+   eval $code;
+   die $@ if $@;
+  }
+
+  is $destroyed, 1, "return from $meth, end";
+ }
+}