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