t/21-leaks-debug.t

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