t/globs.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Test::More tests => 44;
   5 use Devel::Size ':all';
   6 use Config;
   7
   8 my $warn_count;
   9
  10 $SIG{__WARN__} = sub {
  11     return if $_[0] eq "Devel::Size: Can't size up perlio layers yet\n";
  12     ++$warn_count;
  13     warn @_;
  14 };
  15
  16 {
  17     my @array = (\undef, \undef, \undef);
  18     my $array_overhead = total_size(\@array);
  19     cmp_ok($array_overhead, '>', 0, 'Array has a positive size');
  20
  21     my $real_gv_size = total_size(*PFLAP);
  22     cmp_ok($real_gv_size, '>', 0, 'GVs have a positive size');
  23
  24     # Eventually DonMartin gives up enough same-length names:
  25     $array[0] = \*PFLAP;
  26
  27     my $with_one = total_size(\@array);
  28     is($with_one, $array_overhead + $real_gv_size,
  29        'agregate size is overhead plus GV');
  30
  31     $array[1] = \*CHOMP;
  32
  33     my $with_two = total_size(\@array);
  34     cmp_ok($with_two, '>', $with_one, 'agregate size for 2 GVs is larger');
  35     # GvFILE may well be shared:
  36     cmp_ok($with_two, '<=', $with_one + $real_gv_size,
  37            'agregate size for 2 GVs is not larger than overhead plus 2 GVs');
  38
  39     my $incremental_gv_size = $with_two - $with_one;
  40     my $gv_shared = $real_gv_size - $incremental_gv_size;
  41
  42     $array[2] = \*KSSSH;
  43
  44     is(total_size(\@array), $with_one + 2 * $incremental_gv_size,
  45        "linear growth for 1, 2 and 3 GVs - $gv_shared bytes are shared");
  46
  47     $array[2] = \undef;
  48     *CHOMP = \*PFLAP;
  49
  50     my $two_aliased = total_size(\@array);
  51     cmp_ok($two_aliased, '<', $with_two, 'Aliased typeglobs are smaller');
  52
  53     my $gp_size = $with_two - $two_aliased;
  54
  55     $array[2] = \*KSSSH;
  56     *KSSSH = \*PFLAP;
  57     is(total_size(\@array), $with_one + 2 * $incremental_gv_size - 2 * $gp_size,
  58        "3 aliased typeglobs are smaller, shared GP size is $gp_size");
  59
  60     my $copy = *PFLAP;
  61     my $copy_gv_size = total_size($copy);
  62     # GV copies point back to the real GV through GvEGV. They share the same GP
  63     # and GvFILE
  64     local $TODO = 'EGV is double counted. GV - GP == '
  65         . ($incremental_gv_size - $gp_size);
  66     is($copy_gv_size, $real_gv_size + $incremental_gv_size - $gp_size,
  67       'GV copies point back to the real GV');
  68 }
  69
  70 sub gv_grew {
  71     my ($sub, $glob, $code, $type) = @_;
  72     # unthreaded, this gives us a way of getting to sv_size() from one of the
  73     # other *_size() functions, with a GV that has nothing allocated from its
  74     # GP:
  75     eval "sub $sub { *$glob }; 1" or die $@;
  76     # Assigning to IoFMT_GV() also provides this, threaded and unthreaded:
  77     $~ = $glob;
  78
  79     is(do {no strict 'refs'; *{$glob}{$type}}, undef, "No reference for $type")
  80         unless $type eq 'SCALAR';
  81     my $cv_was_size = size(do {no strict 'refs'; \&$sub});
  82     my $gv_was_size = size(do {no strict 'refs'; *$glob});
  83     my $gv_was_total_size = total_size(do {no strict 'refs'; *$glob});
  84     my $io_was_size = size(*STDOUT{IO});
  85
  86     eval $code or die "For $type, can't execute q{$code}: $@";
  87
  88     my $new_thing = do {no strict 'refs'; *{$glob}{$type}};
  89     my $new_thing_size = size($new_thing);
  90
  91     my $cv_now_size = size(do {no strict 'refs'; \&$sub});
  92     my $gv_now_size = size(do {no strict 'refs'; *$glob});
  93     my $gv_now_total_size = total_size(do {no strict 'refs'; *$glob});
  94     my $io_now_size = size(*STDOUT{IO});
  95
  96     # These run string evals with the source file synthesised based on caller
  97     # source name, which means that %:: changes, which then peturbs sizes of
  98     # anything that can reach them. So calculate and record the sizes before
  99     # testing anything.
 100     isnt($new_thing, undef, "Created a reference for $type");
 101     cmp_ok($new_thing_size, '>', 0, "For $type, new item has a size");
 102
 103     is($cv_now_size, $cv_was_size,
 104        "Under multiplicity, the optree doesn't directly close onto a GV, so CVs won't change size")
 105             if $Config{usemultiplicity};
 106     if ($] < 5.010 && $type eq 'SCALAR') {
 107         is($cv_now_size, $cv_was_size, "CV doesn't grow as GV has SCALAR")
 108             unless $Config{usemultiplicity};
 109         is($io_now_size, $io_was_size, "IO doesn't grow as GV has SCALAR");
 110         is($gv_now_size, $gv_was_size, 'GV size unchanged as GV has SCALAR');
 111         local $TODO = 'total_size double counts GP entries';
 112         is($gv_now_total_size, $gv_was_total_size,
 113            'GV total size unchanged as GV has SCALAR');
 114     } elsif ($type eq 'CODE' || $type eq 'FORMAT') {
 115         # CV like things (effectively) close back over their typeglob, so its
 116         # hard to just get the size of the CV.
 117         cmp_ok($cv_now_size, '>', $cv_was_size, "CV grew for $type")
 118             unless $Config{usemultiplicity};
 119         cmp_ok($io_now_size, '>', $io_was_size, "IO grew for $type");
 120         # Assigning CVs and FORMATs to typeglobs causes the typeglob to get
 121         # weak reference magic
 122         cmp_ok($gv_now_size, '>', $gv_was_size, "GV size grew for $type");
 123         cmp_ok($gv_now_total_size, '>', $gv_was_total_size,
 124                "GV total size grew for $type");
 125     } else {
 126         is($cv_now_size, $cv_was_size + $new_thing_size,
 127            "CV grew by expected amount for $type")
 128                     unless $Config{usemultiplicity};
 129         is($io_now_size, $io_was_size + $new_thing_size,
 130            "IO total_size grew by expected amount for $type");
 131         is($gv_now_size, $gv_was_size + $new_thing_size,
 132            "GV size grew by expected amount for $type");
 133         local $TODO = 'total_size double counts GP entries';
 134         is($gv_now_total_size, $gv_was_total_size + $new_thing_size,
 135            "GV total_size grew by expected amount for $type");
 136     }
 137 }
 138
 139 gv_grew('glipp', 'zok', 'no strict "vars"; $zok = undef; 1', 'SCALAR');
 140 gv_grew('bang', 'boff', 'no strict "vars"; @boff = (); 1', 'ARRAY');
 141 gv_grew('clange', 'sock', 'no strict "vars"; %sock = (); 1', 'HASH');
 142 {
 143     local $Devel::Size::warn = 0;
 144     gv_grew('biff', 'zapeth', "format zapeth =\n.\n1", 'FORMAT');
 145 }
 146 gv_grew('crunch_eth', 'awkkkkkk', 'sub awkkkkkk {}; 1', 'CODE');
 147
 148 # Devel::Size isn't even tracking PVIOs from GVs (yet)
 149 # gv_grew('kapow', 'thwape', 'opendir *thwape, "."', 'IO');
 150
 151 is($warn_count, undef, 'No warnings emitted');