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     is($copy_gv_size, $real_gv_size + $incremental_gv_size - $gp_size,
  65       'GV copies point back to the real GV');
  66 }
  67
  68 sub gv_grew {
  69     my ($sub, $glob, $code, $type) = @_;
  70     # unthreaded, this gives us a way of getting to sv_size() from one of the
  71     # other *_size() functions, with a GV that has nothing allocated from its
  72     # GP:
  73     eval "sub $sub { *$glob }; 1" or die $@;
  74     # Assigning to IoFMT_GV() also provides this, threaded and unthreaded:
  75     $~ = $glob;
  76
  77     is(do {no strict 'refs'; *{$glob}{$type}}, undef, "No reference for $type")
  78         unless $type eq 'SCALAR';
  79     my $cv_was_size = size(do {no strict 'refs'; \&$sub});
  80     my $gv_was_size = size(do {no strict 'refs'; *$glob});
  81     my $gv_was_total_size = total_size(do {no strict 'refs'; *$glob});
  82     my $io_was_size = size(*STDOUT{IO});
  83
  84     eval $code or die "For $type, can't execute q{$code}: $@";
  85
  86     my $new_thing = do {no strict 'refs'; *{$glob}{$type}};
  87     my $new_thing_size = size($new_thing);
  88
  89     my $cv_now_size = size(do {no strict 'refs'; \&$sub});
  90     my $gv_now_size = size(do {no strict 'refs'; *$glob});
  91     my $gv_now_total_size = total_size(do {no strict 'refs'; *$glob});
  92     my $io_now_size = size(*STDOUT{IO});
  93
  94     # These run string evals with the source file synthesised based on caller
  95     # source name, which means that %:: changes, which then peturbs sizes of
  96     # anything that can reach them. So calculate and record the sizes before
  97     # testing anything.
  98     isnt($new_thing, undef, "Created a reference for $type");
  99     cmp_ok($new_thing_size, '>', 0, "For $type, new item has a size");
 100
 101     is($cv_now_size, $cv_was_size,
 102        "Under ithreads, the optree doesn't directly close onto a GV, so CVs won't change size")
 103             if $Config{useithreads};
 104     if ($] < 5.010 && $type eq 'SCALAR') {
 105         is($cv_now_size, $cv_was_size, "CV doesn't grow as GV has SCALAR")
 106             unless $Config{useithreads};
 107         is($io_now_size, $io_was_size, "IO doesn't grow as GV has SCALAR");
 108         is($gv_now_size, $gv_was_size, 'GV size unchanged as GV has SCALAR');
 109         is($gv_now_total_size, $gv_was_total_size,
 110            'GV total size unchanged as GV has SCALAR');
 111     } elsif ($type eq 'CODE' || $type eq 'FORMAT') {
 112         # CV like things (effectively) close back over their typeglob, so its
 113         # hard to just get the size of the CV.
 114         cmp_ok($cv_now_size, '>', $cv_was_size, "CV grew for $type")
 115             unless $Config{useithreads};
 116         cmp_ok($io_now_size, '>', $io_was_size, "IO grew for $type");
 117         # Assigning CVs and FORMATs to typeglobs causes the typeglob to get
 118         # weak reference magic
 119         cmp_ok($gv_now_size, '>', $gv_was_size, "GV size grew for $type");
 120         cmp_ok($gv_now_total_size, '>', $gv_was_total_size,
 121                "GV total size grew for $type");
 122     } else {
 123         is($cv_now_size, $cv_was_size + $new_thing_size,
 124            "CV grew by expected amount for $type")
 125                     unless $Config{useithreads};
 126         is($io_now_size, $io_was_size + $new_thing_size,
 127            "IO total_size grew by expected amount for $type");
 128         is($gv_now_size, $gv_was_size + $new_thing_size,
 129            "GV size grew by expected amount for $type");
 130         is($gv_now_total_size, $gv_was_total_size + $new_thing_size,
 131            "GV total_size grew by expected amount for $type");
 132     }
 133 }
 134
 135 gv_grew('glipp', 'zok', 'no strict "vars"; $zok = undef; 1', 'SCALAR');
 136 gv_grew('bang', 'boff', 'no strict "vars"; @boff = (); 1', 'ARRAY');
 137 gv_grew('clange', 'sock', 'no strict "vars"; %sock = (); 1', 'HASH');
 138 {
 139     local $Devel::Size::warn = 0;
 140     gv_grew('biff', 'zapeth', "format zapeth =\n.\n1", 'FORMAT');
 141 }
 142 gv_grew('crunch_eth', 'awkkkkkk', 'sub awkkkkkk {}; 1', 'CODE');
 143
 144 # Devel::Size isn't even tracking PVIOs from GVs (yet)
 145 # gv_grew('kapow', 'thwape', 'opendir *thwape, "."', 'IO');
 146
 147 is($warn_count, undef, 'No warnings emitted');