xt/author/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::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     no_leaks_ok {
  65         $foo->add_symbol('$scalar_init' => 1);
  66     } "add_symbol scalar doesn't leak";
  67     no_leaks_ok {
  68         $foo->add_symbol('@array_init' => []);
  69     } "add_symbol array doesn't leak";
  70     no_leaks_ok {
  71         $foo->add_symbol('%hash_init' => {});
  72     } "add_symbol hash doesn't leak";
  73     no_leaks_ok {
  74         $foo->add_symbol('&code_init' => sub { "foo" });
  75     } "add_symbol code doesn't leak";
  76     { local $TODO = "the pure perl implementation leaks here somehow";
  77     no_leaks_ok {
  78         $foo->add_symbol('io_init' => Symbol::geniosym);
  79     } "add_symbol io doesn't leak";
  80     }
  81     is(exception {
  82         is(Foo->code_init, 'foo', "sub installed correctly")
  83     }, undef, "code_init exists");
  84 }
  85
  86 {
  87     my $foo = Package::Stash->new('Foo');
  88     no_leaks_ok {
  89         $foo->remove_symbol('$scalar_init');
  90         $foo->remove_symbol('@array_init');
  91         $foo->remove_symbol('%hash_init');
  92         $foo->remove_symbol('&code_init');
  93         $foo->remove_symbol('io_init');
  94     } "remove_symbol doesn't leak";
  95 }
  96
  97 {
  98     my $foo = Package::Stash->new('Foo');
  99     $foo->add_symbol("${_}glob") for ('$', '@', '%', '&', '');
 100     no_leaks_ok {
 101         $foo->remove_glob('glob');
 102     } "remove_glob doesn't leak";
 103 }
 104
 105 {
 106     my $foo = Package::Stash->new('Foo');
 107     no_leaks_ok {
 108         $foo->has_symbol('io');
 109         $foo->has_symbol('%hash');
 110         $foo->has_symbol('@array_init');
 111         $foo->has_symbol('$glob');
 112         $foo->has_symbol('&something_else');
 113     } "has_symbol doesn't leak";
 114 }
 115
 116 {
 117     my $foo = Package::Stash->new('Foo');
 118     no_leaks_ok {
 119         $foo->get_symbol('io');
 120         $foo->get_symbol('%hash');
 121         $foo->get_symbol('@array_init');
 122         $foo->get_symbol('$glob');
 123         $foo->get_symbol('&something_else');
 124     } "get_symbol doesn't leak";
 125 }
 126
 127 {
 128     my $foo = Package::Stash->new('Foo');
 129     ok(!$foo->has_symbol('$glob'));
 130     ok(!$foo->has_symbol('@array_init'));
 131     no_leaks_ok {
 132         $foo->get_or_add_symbol('io');
 133         $foo->get_or_add_symbol('%hash');
 134         my @super = ('Exporter');
 135         @{$foo->get_or_add_symbol('@ISA')} = @super;
 136         $foo->get_or_add_symbol('$glob');
 137     } "get_or_add_symbol doesn't leak";
 138     { local $TODO = $] < 5.010
 139         ? "undef scalars aren't visible on 5.8"
 140         : undef;
 141     ok($foo->has_symbol('$glob'));
 142     }
 143     is(ref($foo->get_symbol('$glob')), 'SCALAR');
 144     ok($foo->has_symbol('@ISA'));
 145     is(ref($foo->get_symbol('@ISA')), 'ARRAY');
 146     is_deeply($foo->get_symbol('@ISA'), ['Exporter']);
 147     isa_ok('Foo', 'Exporter');
 148 }
 149
 150 {
 151     my $foo = Package::Stash->new('Foo');
 152     my $baz = Package::Stash->new('Baz');
 153     no_leaks_ok {
 154         $foo->list_all_symbols;
 155         $foo->list_all_symbols('SCALAR');
 156         $foo->list_all_symbols('CODE');
 157         $baz->list_all_symbols('CODE');
 158     } "list_all_symbols doesn't leak";
 159 }
 160
 161 {
 162     package Blah;
 163     use constant 'baz';
 164 }
 165
 166 {
 167     my $foo = Package::Stash->new('Foo');
 168     my $blah = Package::Stash->new('Blah');
 169     no_leaks_ok {
 170         $foo->get_all_symbols;
 171         $foo->get_all_symbols('SCALAR');
 172         $foo->get_all_symbols('CODE');
 173         $blah->get_all_symbols('CODE');
 174     } "get_all_symbols doesn't leak";
 175 }
 176
 177 # mimic CMOP::create_anon_class
 178 {
 179     local $TODO = $] < 5.010 ? "deleting stashes is inherently leaky on 5.8"
 180                              : undef;
 181     my $i = 0;
 182     no_leaks_ok {
 183         $i++;
 184         eval "package Quux$i; 1;";
 185         my $quux = Package::Stash->new("Quux$i");
 186         $quux->get_or_add_symbol('@ISA');
 187         delete $::{'Quux' . $i . '::'};
 188     } "get_symbol doesn't leak during glob expansion";
 189 }
 190
 191 {
 192     local $TODO = ($Package::Stash::IMPLEMENTATION eq 'PP'
 193                 && $Carp::VERSION ge '1.17')
 194         ? "Carp is leaky on 5.12.2 apparently?"
 195         : undef;
 196     my $foo = Package::Stash->new('Foo');
 197     no_leaks_ok {
 198         eval { $foo->get_or_add_symbol('&blorg') };
 199     } "doesn't leak on errors";
 200 }
 201
 202 done_testing;