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 |
63 | # and GvFILE |
ae12fecd |
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, |
ce5e7c21 |
102 | "Under ithreads, the optree doesn't directly close onto a GV, so CVs won't change size") |
103 | if $Config{useithreads}; |
ae12fecd |
104 | if ($] < 5.010 && $type eq 'SCALAR') { |
105 | is($cv_now_size, $cv_was_size, "CV doesn't grow as GV has SCALAR") |
ce5e7c21 |
106 | unless $Config{useithreads}; |
ae12fecd |
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'); |
ae12fecd |
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") |
ce5e7c21 |
115 | unless $Config{useithreads}; |
ae12fecd |
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") |
ce5e7c21 |
125 | unless $Config{useithreads}; |
ae12fecd |
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"); |
ae12fecd |
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'); |