Commit | Line | Data |
0430b7f7 |
1 | #!/usr/bin/perl -w |
e98cedbf |
2 | |
0430b7f7 |
3 | use strict; |
0a45c998 |
4 | |
5 | # I'm not sure if this is "too hacky to live". |
6 | # It seems that for some newer versions of Test::More on older perls, if the |
7 | # test for total_size(1 == 1) is *after* the load of test more, then the test |
8 | # fails. I infer that something in Test::More is also ending up with PL_sv_yes |
9 | # in a pad temp somewhere, and whatever gets compiled first gets to keep the |
10 | # real one, and everyone afterwards gets forced to have a copy. (For ithreads). |
11 | # And I'm not even sure if this is a bug that was fixed (in the constant code) |
12 | # or a necessary evil that survives, and it's pure chance when it hits. |
13 | sub specials { |
14 | # Must call direct - avoid all copying: |
15 | foreach(['undef', total_size(undef)], |
16 | ['no', total_size(1 == 0)], |
17 | ['yes', total_size(1 == 1)], |
18 | ) { |
19 | my ($name, $size) = @$_; |
20 | is($size, 0, |
21 | "PL_sv_$name is interpeter wide, so not counted as part of the structure's size"); |
22 | } |
23 | } |
24 | |
25 | use Test::More tests => 30; |
6c3d85e7 |
26 | use Devel::Size qw(size total_size); |
e98cedbf |
27 | |
0430b7f7 |
28 | can_ok ('Devel::Size', qw/ |
29 | size |
30 | total_size |
31 | /); |
e98cedbf |
32 | |
5a83b7cf |
33 | die ("Uhoh, test uses an outdated version of Devel::Size") |
cd06d5d8 |
34 | unless is ($Devel::Size::VERSION, '0.81', 'VERSION MATCHES'); |
0430b7f7 |
35 | |
36 | ############################################################################# |
37 | # some basic checks: |
e98cedbf |
38 | |
5073b933 |
39 | use vars qw($foo @foo %foo); |
40 | $foo = "12"; |
41 | @foo = (1,2,3); |
42 | %foo = (a => 1, b => 2); |
b98fcdb9 |
43 | |
44 | my $x = "A string"; |
9fc9ab86 |
45 | my $y = "A much much longer string"; # need to be at least 7 bytes longer for 64 bit |
1c566e6a |
46 | cmp_ok(size($x), '<', size($y), 'size() of strings'); |
47 | cmp_ok(total_size($x), '<', total_size($y), 'total_size() of strings'); |
b98fcdb9 |
48 | |
49 | my @x = (1..4); |
0430b7f7 |
50 | my @y = (1..200); |
51 | |
52 | my $size_1 = total_size(\@x); |
53 | my $size_2 = total_size(\@y); |
54 | |
1c566e6a |
55 | cmp_ok($size_1, '<', $size_2, 'size() of array refs'); |
0430b7f7 |
56 | |
50f7a785 |
57 | # the arrays alone shouldn't be the same size |
0430b7f7 |
58 | $size_1 = size(\@x); |
59 | $size_2 = size(\@y); |
60 | |
50f7a785 |
61 | isnt ( $size_1, $size_2, 'size() of array refs'); |
0430b7f7 |
62 | |
63 | ############################################################################# |
64 | # IV vs IV+PV (bug #17586) |
b98fcdb9 |
65 | |
0430b7f7 |
66 | $x = 12; |
67 | $y = 12; $y .= ''; |
b98fcdb9 |
68 | |
0430b7f7 |
69 | $size_1 = size($x); |
70 | $size_2 = size($y); |
b98fcdb9 |
71 | |
1c566e6a |
72 | cmp_ok($size_1, '<', $size_2, ' ."" makes string longer'); |
0430b7f7 |
73 | |
74 | ############################################################################# |
78dfb4e7 |
75 | # check that the tracking_hash is working |
76 | |
77 | my($a,$b) = (1,2); |
78 | my @ary1 = (\$a, \$a); |
79 | my @ary2 = (\$a, \$b); |
80 | |
cf1d079f |
81 | cmp_ok(total_size(\@ary1), '<', total_size(\@ary2), |
82 | 'the tracking hash is working'); |
78dfb4e7 |
83 | |
0430b7f7 |
84 | ############################################################################# |
78dfb4e7 |
85 | # check that circular references don't mess things up |
86 | |
87 | my($c1,$c2); $c2 = \$c1; $c1 = \$c2; |
88 | |
0430b7f7 |
89 | is (total_size($c1), total_size($c2), 'circular references'); |
90 | |
9fc9ab86 |
91 | ########################################################## |
92 | # RT#14849 (& RT#26781 and possibly RT#29238?) |
cf1d079f |
93 | cmp_ok( total_size( sub{ do{ my $t=0 }; } ), '>', 0, |
94 | 'total_size( sub{ my $t=0 } ) > 0' ); |
87372f42 |
95 | |
96 | # CPAN RT #58484 and #58485 |
cf1d079f |
97 | cmp_ok(total_size(\&total_size), '>', 0, 'total_size(\&total_size) > 0'); |
87372f42 |
98 | |
66f50dda |
99 | use constant LARGE => 'N' x 8192; |
87372f42 |
100 | |
66f50dda |
101 | cmp_ok (total_size(\&LARGE), '>', 8192, |
102 | 'total_size for a constant includes the constant'); |
2640cff1 |
103 | |
104 | { |
105 | my $a = []; |
106 | my $b = \$a; |
d6158a76 |
107 | # Scalar::Util isn't in the core before 5.7.something. |
108 | # The test isn't really testing anything without the weaken(), but it |
109 | # isn't counter-productive or harmful to run it anyway. |
110 | unless (eval { |
111 | require Scalar::Util; |
112 | # making a weakref upgrades the target to PVMG and adds magic |
113 | Scalar::Util::weaken($b); |
114 | 1; |
115 | }) { |
116 | die $@ if $] >= 5.008; |
117 | } |
118 | |
8c394e12 |
119 | is(total_size($a), total_size([]), |
120 | 'Any intial reference is dereferenced and discarded'); |
2640cff1 |
121 | } |
a52ceccd |
122 | |
0a45c998 |
123 | specials(); |
95dc1714 |
124 | |
125 | { |
126 | # SvOOK stuff |
127 | my $uurk = "Perl Rules"; |
128 | # This may upgrade the scalar: |
129 | $uurk =~ s/Perl//; |
130 | $uurk =~ s/^/Perl/; |
131 | my $before_size = total_size($uurk); |
132 | my $before_length = length $uurk; |
133 | cmp_ok($before_size, '>', $before_length, 'Size before is sane'); |
00a70dfa |
134 | # As of 5.20.0, s/// doesn't trigger COW. |
135 | # Seems that formline is about the the only thing left that reliably calls |
136 | # sv_chop. See CPAN #95493, perl #122322 |
137 | formline '^<<<<~', $uurk; |
95dc1714 |
138 | is(total_size($uurk), $before_size, |
139 | "Size doesn't change because OOK is used"); |
140 | cmp_ok(length $uurk, '<', $before_size, 'but string is shorter'); |
141 | } |
924d9c4e |
142 | |
143 | sub shared_hash_keys { |
144 | my %h = @_; |
145 | my $one = total_size([keys %h]); |
146 | cmp_ok($one, '>', 0, 'Size of one entry is sane'); |
147 | my $two = total_size([keys %h, keys %h]); |
148 | cmp_ok($two, '>', $one, 'Two take more space than one'); |
149 | my $increment = $two - $one; |
150 | is(total_size([keys %h, keys %h, keys %h]), $one + 2 * $increment, |
151 | 'Linear size increase for three'); |
152 | return $increment; |
153 | } |
154 | |
155 | { |
156 | my $small = shared_hash_keys(Perl => 'Rules'); |
157 | my $big = shared_hash_keys('x' x 1024, ''); |
158 | SKIP: { |
159 | skip("[keys %h] doesn't copy as shared hash key scalars prior to 5.10.0", |
160 | 1) if $] < 5.010; |
161 | is ($small, $big, 'The "shared" part of shared hash keys is spotted'); |
162 | } |
163 | } |
78037efb |
164 | |
165 | { |
166 | use vars '%DANG_DANG_DANG_DANG_DANG_DANG_DANG_DANG_DANG'; |
167 | my $hash_size = total_size(\%DANG_DANG_DANG_DANG_DANG_DANG_DANG_DANG_DANG); |
168 | cmp_ok($hash_size, '>', 0, 'Hash size is sane'); |
169 | my $stash_size |
170 | = total_size(\%DANG_DANG_DANG_DANG_DANG_DANG_DANG_DANG_DANG::); |
171 | cmp_ok($stash_size, '>', |
172 | $hash_size + length 'DANG_DANG_DANG_DANG_DANG_DANG_DANG_DANG_DANG', |
173 | 'Stash size is larger than hash size plus length of the name'); |
174 | } |
175 | |
176 | { |
177 | my %h = (Perl => 'Rules'); |
178 | my $hash_size = total_size(\%h); |
179 | cmp_ok($hash_size, '>', 0, 'Hash size is sane'); |
180 | my $a = keys %h; |
181 | if ($] < 5.010) { |
182 | is(total_size(\%h), $hash_size, |
183 | "Creating iteration state doesn't need to allocate storage"); |
184 | # because all hashes carry the overhead of this storage from creation |
185 | } else { |
186 | cmp_ok(total_size(\%h), '>', $hash_size, |
187 | 'Creating iteration state allocates storage'); |
188 | } |
189 | } |