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