t/80-leaks.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Variable::Magic qw<wizard cast getdata dispell MGf_LOCAL VMG_UVAR>;
   7
   8 use Test::More;
   9
  10 BEGIN {
  11  my $tests = 11;
  12  $tests += 3 * (4 + (MGf_LOCAL ? 1 : 0) + (VMG_UVAR ? 4 : 0));
  13  plan tests => $tests;
  14 }
  15
  16 our $destroyed;
  17
  18 {
  19  package Variable::Magic::TestDestructor;
  20
  21  sub new { bless { }, shift }
  22
  23  sub DESTROY { ++$::destroyed }
  24 }
  25
  26 sub D () { 'Variable::Magic::TestDestructor' }
  27
  28 {
  29  local $destroyed = 0;
  30
  31  my $w = wizard data => sub { $_[1] };
  32
  33  {
  34   my $obj = D->new;
  35
  36   {
  37    my $x = 1;
  38    cast $x, $w, $obj;
  39    is $destroyed, 0;
  40   }
  41
  42   is $destroyed, 0;
  43  }
  44
  45  is $destroyed, 1;
  46 }
  47
  48 {
  49  local $destroyed = 0;
  50
  51  my $w = wizard data => sub { $_[1] };
  52
  53  {
  54   my $copy;
  55
  56   {
  57    my $obj = D->new;
  58
  59    {
  60     my $x = 1;
  61     cast $x, $w, $obj;
  62     is $destroyed, 0;
  63     $copy = getdata $x, $w;
  64    }
  65
  66    is $destroyed, 0;
  67   }
  68
  69   is $destroyed, 0;
  70  }
  71
  72  is $destroyed, 1;
  73 }
  74
  75 {
  76  local $destroyed = 0;
  77
  78  {
  79   my $obj = D->new;
  80
  81   {
  82    my $w  = wizard set => $obj;
  83
  84    {
  85     my $x = 1;
  86     cast $x, $w;
  87     is $destroyed, 0;
  88    }
  89
  90    is $destroyed, 0;
  91   }
  92
  93   is $destroyed, 0;
  94  }
  95
  96  is $destroyed, 1;
  97 }
  98
  99 # Test destruction of returned values
 100
 101 my @methods = qw<get set clear free>;
 102 push @methods, 'local' if MGf_LOCAL;
 103 push @methods, qw<fetch store exists delete> if VMG_UVAR;
 104
 105 my %init = (
 106  scalar_lexical => 'my $x = 1; cast $x, $w',
 107  scalar_global  => 'our $X; local $X = 1; cast $X, $w',
 108  array          => 'my @a = (1); cast @a, $w',
 109  hash           => 'my %h = (a => 1); cast %h, $w',
 110 );
 111
 112 my %type;
 113 $type{$_} = 'scalar_lexical' for qw<get set free>;
 114 $type{$_} = 'scalar_global'  for qw<local>;
 115 $type{$_} = 'array'          for qw<clear>;
 116 $type{$_} = 'hash'           for qw<fetch store exists delete>;
 117
 118 my %trigger = (
 119  get    => 'my $y = $x',
 120  set    => '$x = 2',
 121  clear  => '@a = ()',
 122  free   => '',
 123  local  => 'local $X = 2',
 124  fetch  => 'my $v = $h{a}',
 125  store  => '$h{a} = 2',
 126  exists => 'my $e = exists $h{a}',
 127  delete => 'my $d = delete $h{a}',
 128 );
 129
 130 for my $meth (@methods) {
 131  local $destroyed = 0;
 132
 133  {
 134   my $w = wizard $meth => sub { return D->new };
 135
 136   my $init    = $init{$type{$meth}};
 137   my $trigger = $trigger{$meth};
 138
 139   if ($meth eq 'free') {
 140    $init    = "{\n$init";
 141    $trigger = '}';
 142   }
 143
 144   my $code = join ";\n", grep length, (
 145    $init,
 146    'is $destroyed, 0, "return from $meth, before trigger"',
 147    $trigger,
 148    'is $destroyed, 1, "return from $meth, after trigger"',
 149   );
 150
 151   {
 152    local $@;
 153    eval $code;
 154    die $@ if $@;
 155   }
 156
 157   is $destroyed, 1, "return from $meth, end";
 158  }
 159 }