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