Commit | Line | Data |
ae12fecd |
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 |
638a265a |
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'); |
ae12fecd |
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, |
ce5e7c21 |
111 | "Under ithreads, the optree doesn't directly close onto a GV, so CVs won't change size") |
112 | if $Config{useithreads}; |
ae12fecd |
113 | if ($] < 5.010 && $type eq 'SCALAR') { |
114 | is($cv_now_size, $cv_was_size, "CV doesn't grow as GV has SCALAR") |
ce5e7c21 |
115 | unless $Config{useithreads}; |
ae12fecd |
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'); |
ae12fecd |
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") |
ce5e7c21 |
124 | unless $Config{useithreads}; |
ae12fecd |
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") |
ce5e7c21 |
134 | unless $Config{useithreads}; |
ae12fecd |
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"); |
ae12fecd |
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'); |
d6158a76 |
147 | SKIP: { |
148 | skip("Can't create FORMAT references prior to 5.8.0", 7) if $] < 5.008; |
ae12fecd |
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'); |