xt/release/21-leaks-debug.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use lib 't/lib';
   5 use Test::More;
   6 use Test::Fatal;
   7 use Test::Requires 'Test::LeakTrace';
   8
   9 BEGIN { $^P |= 0x210 } # PERLDBf_SUBLINE
  10
  11 use Package::Stash;
  12 use Symbol;
  13
  14 {
  15     package Bar;
  16 }
  17
  18 {
  19     package Baz;
  20     our $foo;
  21     sub bar { }
  22     use constant baz => 1;
  23     our %quux = (a => 'b');
  24 }
  25
  26 {
  27     no_leaks_ok {
  28         Package::Stash->new('Foo');
  29     } "object construction doesn't leak";
  30 }
  31
  32 {
  33     no_leaks_ok {
  34         Package::Stash->new('Bar');
  35     } "object construction doesn't leak, with an existing package";
  36 }
  37
  38 {
  39     no_leaks_ok {
  40         Package::Stash->new('Baz');
  41     } "object construction doesn't leak, with an existing package with things in it";
  42 }
  43
  44 {
  45     my $foo = Package::Stash->new('Foo');
  46     no_leaks_ok {
  47         $foo->name;
  48         $foo->namespace;
  49     } "accessors don't leak";
  50 }
  51
  52 {
  53     my $foo = Package::Stash->new('Foo');
  54     no_leaks_ok {
  55         $foo->add_symbol('$scalar');
  56         $foo->add_symbol('@array');
  57         $foo->add_symbol('%hash');
  58         $foo->add_symbol('io');
  59     } "add_symbol doesn't leak";
  60 }
  61
  62 {
  63     my $foo = Package::Stash->new('Foo');
  64     { local $TODO = $Package::Stash::IMPLEMENTATION eq 'PP'
  65         ? "the pure perl implementation leaks here somehow"
  66         : undef;
  67     no_leaks_ok {
  68         $foo->add_symbol('$scalar_init' => 1);
  69         $foo->add_symbol('@array_init' => []);
  70         $foo->add_symbol('%hash_init' => {});
  71         $foo->add_symbol('&code_init' => sub { "foo" });
  72         $foo->add_symbol('io_init' => Symbol::geniosym);
  73     } "add_symbol doesn't leak";
  74     }
  75     is(exception {
  76         is(Foo->code_init, 'foo', "sub installed correctly")
  77     }, undef, "code_init exists");
  78 }
  79
  80 {
  81     my $foo = Package::Stash->new('Foo');
  82     no_leaks_ok {
  83         $foo->remove_symbol('$scalar_init');
  84         $foo->remove_symbol('@array_init');
  85         $foo->remove_symbol('%hash_init');
  86         $foo->remove_symbol('&code_init');
  87         $foo->remove_symbol('io_init');
  88     } "remove_symbol doesn't leak";
  89 }
  90
  91 {
  92     my $foo = Package::Stash->new('Foo');
  93     $foo->add_symbol("${_}glob") for ('$', '@', '%', '&', '');
  94     no_leaks_ok {
  95         $foo->remove_glob('glob');
  96     } "remove_glob doesn't leak";
  97 }
  98
  99 {
 100     my $foo = Package::Stash->new('Foo');
 101     no_leaks_ok {
 102         $foo->has_symbol('io');
 103         $foo->has_symbol('%hash');
 104         $foo->has_symbol('@array_init');
 105         $foo->has_symbol('$glob');
 106         $foo->has_symbol('&something_else');
 107     } "has_symbol doesn't leak";
 108 }
 109
 110 {
 111     my $foo = Package::Stash->new('Foo');
 112     no_leaks_ok {
 113         $foo->get_symbol('io');
 114         $foo->get_symbol('%hash');
 115         $foo->get_symbol('@array_init');
 116         $foo->get_symbol('$glob');
 117         $foo->get_symbol('&something_else');
 118     } "get_symbol doesn't leak";
 119 }
 120
 121 {
 122     my $foo = Package::Stash->new('Foo');
 123     ok(!$foo->has_symbol('$glob'));
 124     ok(!$foo->has_symbol('@array_init'));
 125     no_leaks_ok {
 126         $foo->get_or_add_symbol('io');
 127         $foo->get_or_add_symbol('%hash');
 128         my @super = ('Exporter');
 129         @{$foo->get_or_add_symbol('@ISA')} = @super;
 130         $foo->get_or_add_symbol('$glob');
 131     } "get_or_add_symbol doesn't leak";
 132     { local $TODO = ($] < 5.010 || $Package::Stash::IMPLEMENTATION eq 'PP')
 133         ? "undef scalars aren't visible on 5.8, or from pure perl at all"
 134         : undef;
 135     ok($foo->has_symbol('$glob'));
 136     }
 137     is(ref($foo->get_symbol('$glob')), 'SCALAR');
 138     ok($foo->has_symbol('@ISA'));
 139     is(ref($foo->get_symbol('@ISA')), 'ARRAY');
 140     is_deeply($foo->get_symbol('@ISA'), ['Exporter']);
 141     isa_ok('Foo', 'Exporter');
 142 }
 143
 144 {
 145     my $foo = Package::Stash->new('Foo');
 146     my $baz = Package::Stash->new('Baz');
 147     no_leaks_ok {
 148         $foo->list_all_symbols;
 149         $foo->list_all_symbols('SCALAR');
 150         $foo->list_all_symbols('CODE');
 151         $baz->list_all_symbols('CODE');
 152     } "list_all_symbols doesn't leak";
 153 }
 154
 155 {
 156     package Blah;
 157     use constant 'baz';
 158 }
 159
 160 {
 161     my $foo = Package::Stash->new('Foo');
 162     my $blah = Package::Stash->new('Blah');
 163     no_leaks_ok {
 164         $foo->get_all_symbols;
 165         $foo->get_all_symbols('SCALAR');
 166         $foo->get_all_symbols('CODE');
 167         $blah->get_all_symbols('CODE');
 168     } "get_all_symbols doesn't leak";
 169 }
 170
 171 # mimic CMOP::create_anon_class
 172 {
 173     local $TODO = $] < 5.010 ? "deleting stashes is inherently leaky on 5.8"
 174                              : undef;
 175     my $i = 0;
 176     no_leaks_ok {
 177         $i++;
 178         eval "package Quux$i; 1;";
 179         my $quux = Package::Stash->new("Quux$i");
 180         $quux->get_or_add_symbol('@ISA');
 181         delete $::{'Quux' . $i . '::'};
 182     } "get_symbol doesn't leak during glob expansion";
 183 }
 184
 185 {
 186     local $TODO = ($Package::Stash::IMPLEMENTATION eq 'PP'
 187                 && $Carp::VERSION ge '1.17')
 188         ? "Carp is leaky on 5.12.2 apparently?"
 189         : undef;
 190     my $foo = Package::Stash->new('Foo');
 191     no_leaks_ok {
 192         eval { $foo->get_or_add_symbol('&blorg') };
 193     } "doesn't leak on errors";
 194 }
 195
 196 done_testing;