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 # As of blead commit b50b20584a1bbc1a, Implement new 'use 5.xxx' plan,
  78 # use strict; will write to %^H. In turn, this causes the eval $code below
  79 # to have compile with a pp_hintseval with a private copy of %^H in the
  80 # optree. In turn, this private value is copied on op execution and put on
  81 # the stack. The act of copying requires a hash iterator, and the *first*
  82 # time the op is encountered its private HV doesn't have space for one, so
  83 # it's expanded to hold one. Which happens after $cv_was_size is assigned to.
  84 # Which matters, because it means that the total size of anything that can
  85 # reach \&gv_grew will include this extra size. In this case, this means that
  86 # if the code for generate_glob() is within gv_grew() [as it used to be],
  87 # then the generated subroutine's CvOUTSIDE points to an anon sub whose
  88 # CvOUTSIDE points to gv_grew(). Which means that the generated subroutine
  89 # gets "bigger" simply as a side effect of the eval executing.
  90
  91 # The solution is to put the eval that creates the subroutine into a different
  92 # scope, so that its outside pointer chain doesn't include gv_grew(). Hence
  93 # it's now broken out into generate_glob():
  94
  95 sub generate_glob {
  96     my ($sub, $glob) = @_;
  97     # unthreaded, this gives us a way of getting to sv_size() from one of the
  98     # other *_size() functions, with a GV that has nothing allocated from its
  99     # GP:
 100     eval "sub $sub { *$glob }; 1" or die $@;
 101 }
 102
 103 sub gv_grew {
 104     my ($sub, $glob, $code, $type) = @_;
 105     generate_glob($sub, $glob);
 106     # Assigning to IoFMT_GV() also provides this, threaded and unthreaded:
 107     $~ = $glob;
 108
 109     is(do {no strict 'refs'; *{$glob}{$type}}, undef, "No reference for $type")
 110         unless $type eq 'SCALAR';
 111     my $cv_was_size = size(do {no strict 'refs'; \&$sub});
 112     my $gv_was_size = size(do {no strict 'refs'; *$glob});
 113     my $gv_was_total_size = total_size(do {no strict 'refs'; *$glob});
 114     my $io_was_size = size(*STDOUT{IO});
 115
 116     eval $code or die "For $type, can't execute q{$code}: $@";
 117
 118     my $new_thing = do {no strict 'refs'; *{$glob}{$type}};
 119     my $new_thing_size = size($new_thing);
 120
 121     my $cv_now_size = size(do {no strict 'refs'; \&$sub});
 122     my $gv_now_size = size(do {no strict 'refs'; *$glob});
 123     my $gv_now_total_size = total_size(do {no strict 'refs'; *$glob});
 124     my $io_now_size = size(*STDOUT{IO});
 125
 126     # These run string evals with the source file synthesised based on caller
 127     # source name, which means that %:: changes, which then peturbs sizes of
 128     # anything that can reach them. So calculate and record the sizes before
 129     # testing anything.
 130     isnt($new_thing, undef, "Created a reference for $type");
 131     cmp_ok($new_thing_size, '>', 0, "For $type, new item has a size");
 132
 133     is($cv_now_size, $cv_was_size,
 134        "Under ithreads, the optree doesn't directly close onto a GV, so CVs won't change size")
 135             if $Config{useithreads};
 136     if ($] < 5.010 && $type eq 'SCALAR') {
 137         is($cv_now_size, $cv_was_size, "CV doesn't grow as GV has SCALAR")
 138             unless $Config{useithreads};
 139         is($io_now_size, $io_was_size, "IO doesn't grow as GV has SCALAR");
 140         is($gv_now_size, $gv_was_size, 'GV size unchanged as GV has SCALAR');
 141         is($gv_now_total_size, $gv_was_total_size,
 142            'GV total size unchanged as GV has SCALAR');
 143     } elsif ($type eq 'CODE' || $type eq 'FORMAT') {
 144         # CV like things (effectively) close back over their typeglob, so its
 145         # hard to just get the size of the CV.
 146         cmp_ok($cv_now_size, '>', $cv_was_size, "CV grew for $type")
 147             unless $Config{useithreads};
 148         cmp_ok($io_now_size, '>', $io_was_size, "IO grew for $type");
 149         # Assigning CVs and FORMATs to typeglobs causes the typeglob to get
 150         # weak reference magic
 151         cmp_ok($gv_now_size, '>', $gv_was_size, "GV size grew for $type");
 152         cmp_ok($gv_now_total_size, '>', $gv_was_total_size,
 153                "GV total size grew for $type");
 154     } else {
 155         is($cv_now_size, $cv_was_size + $new_thing_size,
 156            "CV grew by expected amount for $type")
 157                     unless $Config{useithreads};
 158         is($io_now_size, $io_was_size + $new_thing_size,
 159            "IO total_size grew by expected amount for $type");
 160         is($gv_now_size, $gv_was_size + $new_thing_size,
 161            "GV size grew by expected amount for $type");
 162         is($gv_now_total_size, $gv_was_total_size + $new_thing_size,
 163            "GV total_size grew by expected amount for $type");
 164     }
 165 }
 166
 167 gv_grew('glipp', 'zok', 'no strict "vars"; $zok = undef; 1', 'SCALAR');
 168 gv_grew('bang', 'boff', 'no strict "vars"; @boff = (); 1', 'ARRAY');
 169 gv_grew('clange', 'sock', 'no strict "vars"; %sock = (); 1', 'HASH');
 170 SKIP: {
 171     skip("Can't create FORMAT references prior to 5.8.0", 7) if $] < 5.008;
 172     local $Devel::Size::warn = 0;
 173     gv_grew('biff', 'zapeth', "format zapeth =\n.\n1", 'FORMAT');
 174 }
 175 gv_grew('crunch_eth', 'awkkkkkk', 'sub awkkkkkk {}; 1', 'CODE');
 176
 177 # Devel::Size isn't even tracking PVIOs from GVs (yet)
 178 # gv_grew('kapow', 'thwape', 'opendir *thwape, "."', 'IO');
 179
 180 is($warn_count, undef, 'No warnings emitted');