Filename | /usr/share/perl5/Readonly.pm |
Statements | Executed 53 statements in 1.99ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 39µs | 39µs | BEGIN@100 | Readonly::Array::
1 | 1 | 1 | 38µs | 38µs | BEGIN@13 | boolean::
2 | 2 | 1 | 24µs | 36µs | Scalar | Readonly::
1 | 1 | 1 | 9µs | 27µs | BEGIN@170 | Readonly::
1 | 1 | 1 | 8µs | 32µs | BEGIN@32 | Readonly::
1 | 1 | 1 | 8µs | 11µs | BEGIN@14.11 | boolean::
2 | 1 | 1 | 7µs | 8µs | _is_badtype | Readonly::
1 | 1 | 1 | 6µs | 51µs | BEGIN@171 | Readonly::
1 | 1 | 1 | 6µs | 38µs | BEGIN@35 | Readonly::
2 | 1 | 1 | 900ns | 900ns | CORE:subst (opcode) | Readonly::
0 | 0 | 0 | 0s | 0s | Array | Readonly::
0 | 0 | 0 | 0s | 0s | Array1 | Readonly::
0 | 0 | 0 | 0s | 0s | FETCH | Readonly::Array::
0 | 0 | 0 | 0s | 0s | FETCHSIZE | Readonly::Array::
0 | 0 | 0 | 0s | 0s | TIEARRAY | Readonly::Array::
0 | 0 | 0 | 0s | 0s | __ANON__[:112] | Readonly::Array::
0 | 0 | 0 | 0s | 0s | Hash | Readonly::
0 | 0 | 0 | 0s | 0s | Hash1 | Readonly::
0 | 0 | 0 | 0s | 0s | EXISTS | Readonly::Hash::
0 | 0 | 0 | 0s | 0s | FETCH | Readonly::Hash::
0 | 0 | 0 | 0s | 0s | FIRSTKEY | Readonly::Hash::
0 | 0 | 0 | 0s | 0s | NEXTKEY | Readonly::Hash::
0 | 0 | 0 | 0s | 0s | TIEHASH | Readonly::Hash::
0 | 0 | 0 | 0s | 0s | __ANON__[:162] | Readonly::Hash::
0 | 0 | 0 | 0s | 0s | Scalar1 | Readonly::
0 | 0 | 0 | 0s | 0s | FETCH | Readonly::Scalar::
0 | 0 | 0 | 0s | 0s | TIESCALAR | Readonly::Scalar::
0 | 0 | 0 | 0s | 0s | __ANON__[:69] | Readonly::Scalar::
0 | 0 | 0 | 0s | 0s | croak | Readonly::
0 | 0 | 0 | 0s | 0s | is_sv_readonly | Readonly::
0 | 0 | 0 | 0s | 0s | make_sv_readonly | Readonly::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | =head1 NAME | ||||
2 | |||||
3 | Readonly - Facility for creating read-only scalars, arrays, hashes. | ||||
4 | |||||
5 | =head1 VERSION | ||||
6 | |||||
7 | This documentation describes version 1.03 of Readonly.pm, April 20, 2004. | ||||
8 | |||||
9 | =cut | ||||
10 | |||||
11 | # Rest of documentation is after __END__. | ||||
12 | |||||
13 | 2 | 63µs | 1 | 38µs | # spent 38µs within boolean::BEGIN@13 which was called:
# once (38µs+0s) by boolean::BEGIN@31 at line 13 # spent 38µs making 1 call to boolean::BEGIN@13 |
14 | 2 | 80µs | 2 | 14µs | # spent 11µs (8+3) within boolean::BEGIN@14.11 which was called:
# once (8µs+3µs) by boolean::BEGIN@31 at line 14 # spent 11µs making 1 call to boolean::BEGIN@14.11
# spent 3µs making 1 call to strict::import |
15 | #use warnings; | ||||
16 | #no warnings 'uninitialized'; | ||||
17 | |||||
18 | package Readonly; | ||||
19 | 1 | 700ns | $Readonly::VERSION = '1.03'; # Also change in the documentation! | ||
20 | |||||
21 | # Autocroak (Thanks, MJD) | ||||
22 | # Only load Carp.pm if module is croaking. | ||||
23 | sub croak | ||||
24 | { | ||||
25 | require Carp; | ||||
26 | goto &Carp::croak; | ||||
27 | } | ||||
28 | |||||
29 | # These functions may be overridden by Readonly::XS, if installed. | ||||
30 | sub is_sv_readonly ($) { 0 } | ||||
31 | sub make_sv_readonly ($) { die "make_sv_readonly called but not overridden" } | ||||
32 | 2 | 31µs | 2 | 55µs | # spent 32µs (8+24) within Readonly::BEGIN@32 which was called:
# once (8µs+24µs) by boolean::BEGIN@31 at line 32 # spent 32µs making 1 call to Readonly::BEGIN@32
# spent 24µs making 1 call to vars::import |
33 | |||||
34 | # Common error messages, or portions thereof | ||||
35 | 2 | 310µs | 2 | 71µs | # spent 38µs (6+32) within Readonly::BEGIN@35 which was called:
# once (6µs+32µs) by boolean::BEGIN@31 at line 35 # spent 38µs making 1 call to Readonly::BEGIN@35
# spent 32µs making 1 call to vars::import |
36 | 1 | 400ns | $MODIFY = 'Modification of a read-only value attempted'; | ||
37 | 1 | 200ns | $REASSIGN = 'Attempt to reassign a readonly'; | ||
38 | 1 | 300ns | $ODDHASH = 'May not store an odd number of values in a hash'; | ||
39 | |||||
40 | # See if we can use the XS stuff. | ||||
41 | 1 | 200ns | $Readonly::XS::MAGIC_COOKIE = "Do NOT use or require Readonly::XS unless you're me."; | ||
42 | 1 | 28µs | eval 'use Readonly::XS'; # spent 78µs executing statements in string eval # includes 297µs spent executing 1 call to 1 sub defined therein. | ||
43 | |||||
44 | |||||
45 | # ---------------- | ||||
46 | # Read-only scalars | ||||
47 | # ---------------- | ||||
48 | package Readonly::Scalar; | ||||
49 | |||||
50 | sub TIESCALAR | ||||
51 | { | ||||
52 | my $whence = (caller 2)[3]; # Check if naughty user is trying to tie directly. | ||||
53 | Readonly::croak "Invalid tie" unless $whence && $whence =~ /^Readonly::(?:Scalar1?|Readonly)$/; | ||||
54 | my $class = shift; | ||||
55 | Readonly::croak "No value specified for readonly scalar" unless @_; | ||||
56 | Readonly::croak "Too many values specified for readonly scalar" unless @_ == 1; | ||||
57 | |||||
58 | my $value = shift; | ||||
59 | return bless \$value, $class; | ||||
60 | } | ||||
61 | |||||
62 | sub FETCH | ||||
63 | { | ||||
64 | my $self = shift; | ||||
65 | return $$self; | ||||
66 | } | ||||
67 | |||||
68 | *STORE = *UNTIE = | ||||
69 | 1 | 3µs | sub {Readonly::croak $Readonly::MODIFY}; | ||
70 | |||||
71 | |||||
72 | # ---------------- | ||||
73 | # Read-only arrays | ||||
74 | # ---------------- | ||||
75 | package Readonly::Array; | ||||
76 | |||||
77 | sub TIEARRAY | ||||
78 | { | ||||
79 | my $whence = (caller 1)[3]; # Check if naughty user is trying to tie directly. | ||||
80 | Readonly::croak "Invalid tie" unless $whence =~ /^Readonly::Array1?$/; | ||||
81 | my $class = shift; | ||||
82 | my @self = @_; | ||||
83 | |||||
84 | return bless \@self, $class; | ||||
85 | } | ||||
86 | |||||
87 | sub FETCH | ||||
88 | { | ||||
89 | my $self = shift; | ||||
90 | my $index = shift; | ||||
91 | return $self->[$index]; | ||||
92 | } | ||||
93 | |||||
94 | sub FETCHSIZE | ||||
95 | { | ||||
96 | my $self = shift; | ||||
97 | return scalar @$self; | ||||
98 | } | ||||
99 | |||||
100 | # spent 39µs within Readonly::Array::BEGIN@100 which was called:
# once (39µs+0s) by boolean::BEGIN@31 at line 109 | ||||
101 | 1 | 40µs | eval q{ | ||
102 | sub EXISTS | ||||
103 | { | ||||
104 | my $self = shift; | ||||
105 | my $index = shift; | ||||
106 | return exists $self->[$index]; | ||||
107 | } | ||||
108 | } if $] >= 5.006; # couldn't do "exists" on arrays before then | ||||
109 | 1 | 246µs | 1 | 39µs | } # spent 39µs making 1 call to Readonly::Array::BEGIN@100 |
110 | |||||
111 | *STORE = *STORESIZE = *EXTEND = *PUSH = *POP = *UNSHIFT = *SHIFT = *SPLICE = *CLEAR = *UNTIE = | ||||
112 | 1 | 3µs | sub {Readonly::croak $Readonly::MODIFY}; | ||
113 | |||||
114 | |||||
115 | # ---------------- | ||||
116 | # Read-only hashes | ||||
117 | # ---------------- | ||||
118 | package Readonly::Hash; | ||||
119 | |||||
120 | sub TIEHASH | ||||
121 | { | ||||
122 | my $whence = (caller 1)[3]; # Check if naughty user is trying to tie directly. | ||||
123 | Readonly::croak "Invalid tie" unless $whence =~ /^Readonly::Hash1?$/; | ||||
124 | |||||
125 | my $class = shift; | ||||
126 | # must have an even number of values | ||||
127 | Readonly::croak $Readonly::ODDHASH unless (@_ %2 == 0); | ||||
128 | |||||
129 | my %self = @_; | ||||
130 | return bless \%self, $class; | ||||
131 | } | ||||
132 | |||||
133 | sub FETCH | ||||
134 | { | ||||
135 | my $self = shift; | ||||
136 | my $key = shift; | ||||
137 | |||||
138 | return $self->{$key}; | ||||
139 | } | ||||
140 | |||||
141 | sub EXISTS | ||||
142 | { | ||||
143 | my $self = shift; | ||||
144 | my $key = shift; | ||||
145 | return exists $self->{$key}; | ||||
146 | } | ||||
147 | |||||
148 | sub FIRSTKEY | ||||
149 | { | ||||
150 | my $self = shift; | ||||
151 | my $dummy = keys %$self; | ||||
152 | return scalar each %$self; | ||||
153 | } | ||||
154 | |||||
155 | sub NEXTKEY | ||||
156 | { | ||||
157 | my $self = shift; | ||||
158 | return scalar each %$self; | ||||
159 | } | ||||
160 | |||||
161 | *STORE = *DELETE = *CLEAR = *UNTIE = | ||||
162 | 1 | 2µs | sub {Readonly::croak $Readonly::MODIFY}; | ||
163 | |||||
164 | |||||
165 | # ---------------------------------------------------------------- | ||||
166 | # Main package, containing convenience functions (so callers won't | ||||
167 | # have to explicitly tie the variables themselves). | ||||
168 | # ---------------------------------------------------------------- | ||||
169 | package Readonly; | ||||
170 | 2 | 29µs | 2 | 45µs | # spent 27µs (9+18) within Readonly::BEGIN@170 which was called:
# once (9µs+18µs) by boolean::BEGIN@31 at line 170 # spent 27µs making 1 call to Readonly::BEGIN@170
# spent 18µs making 1 call to Exporter::import |
171 | 2 | 885µs | 2 | 97µs | # spent 51µs (6+45) within Readonly::BEGIN@171 which was called:
# once (6µs+45µs) by boolean::BEGIN@31 at line 171 # spent 51µs making 1 call to Readonly::BEGIN@171
# spent 45µs making 1 call to vars::import |
172 | 1 | 4µs | push @ISA, 'Exporter'; | ||
173 | 1 | 400ns | push @EXPORT, qw/Readonly/; | ||
174 | 1 | 1µs | push @EXPORT_OK, qw/Scalar Array Hash Scalar1 Array1 Hash1/; | ||
175 | |||||
176 | # Predeclare the following, so we can use them recursively | ||||
177 | sub Scalar ($$); | ||||
178 | sub Array (\@;@); | ||||
179 | sub Hash (\%;@); | ||||
180 | |||||
181 | # Returns true if a string begins with "Readonly::" | ||||
182 | # Used to prevent reassignment of Readonly variables. | ||||
183 | sub _is_badtype | ||||
184 | # spent 8µs (7+900ns) within Readonly::_is_badtype which was called 2 times, avg 4µs/call:
# 2 times (7µs+900ns) by Readonly::Scalar at line 249, avg 4µs/call | ||||
185 | 6 | 10µs | my $type = $_[0]; | ||
186 | 2 | 900ns | return lc $type if $type =~ s/^Readonly:://; # spent 900ns making 2 calls to Readonly::CORE:subst, avg 450ns/call | ||
187 | return; | ||||
188 | } | ||||
189 | |||||
190 | # Shallow Readonly scalar | ||||
191 | sub Scalar1 ($$) | ||||
192 | { | ||||
193 | croak "$REASSIGN scalar" if is_sv_readonly $_[0]; | ||||
194 | my $badtype = _is_badtype (ref tied $_[0]); | ||||
195 | croak "$REASSIGN $badtype" if $badtype; | ||||
196 | |||||
197 | # xs method: flag scalar as readonly | ||||
198 | if ($XSokay) | ||||
199 | { | ||||
200 | $_[0] = $_[1]; | ||||
201 | make_sv_readonly $_[0]; | ||||
202 | return; | ||||
203 | } | ||||
204 | |||||
205 | # pure-perl method: tied scalar | ||||
206 | my $tieobj = eval {tie $_[0], 'Readonly::Scalar', $_[1]}; | ||||
207 | if ($@) | ||||
208 | { | ||||
209 | croak "$REASSIGN scalar" if substr($@,0,43) eq $MODIFY; | ||||
210 | die $@; # some other error? | ||||
211 | } | ||||
212 | return $tieobj; | ||||
213 | } | ||||
214 | |||||
215 | # Shallow Readonly array | ||||
216 | sub Array1 (\@;@) | ||||
217 | { | ||||
218 | my $badtype = _is_badtype (ref tied $_[0]); | ||||
219 | croak "$REASSIGN $badtype" if $badtype; | ||||
220 | |||||
221 | my $aref = shift; | ||||
222 | return tie @$aref, 'Readonly::Array', @_; | ||||
223 | } | ||||
224 | |||||
225 | # Shallow Readonly hash | ||||
226 | sub Hash1 (\%;@) | ||||
227 | { | ||||
228 | my $badtype = _is_badtype (ref tied $_[0]); | ||||
229 | croak "$REASSIGN $badtype" if $badtype; | ||||
230 | |||||
231 | my $href = shift; | ||||
232 | |||||
233 | # If only one value, and it's a hashref, expand it | ||||
234 | if (@_ == 1 && ref $_[0] eq 'HASH') | ||||
235 | { | ||||
236 | return tie %$href, 'Readonly::Hash', %{$_[0]}; | ||||
237 | } | ||||
238 | |||||
239 | # otherwise, must have an even number of values | ||||
240 | croak $ODDHASH unless (@_%2 == 0); | ||||
241 | |||||
242 | return tie %$href, 'Readonly::Hash', @_; | ||||
243 | } | ||||
244 | |||||
245 | # Deep Readonly scalar | ||||
246 | sub Scalar ($$) | ||||
247 | # spent 36µs (24+12) within Readonly::Scalar which was called 2 times, avg 18µs/call:
# once (17µs+9µs) by boolean::BEGIN@31 at line 40 of boolean.pm
# once (7µs+3µs) by boolean::BEGIN@31 at line 41 of boolean.pm | ||||
248 | 20 | 28µs | 2 | 3µs | croak "$REASSIGN scalar" if is_sv_readonly $_[0]; # spent 3µs making 2 calls to Readonly::XS::is_sv_readonly, avg 1µs/call |
249 | 2 | 8µs | my $badtype = _is_badtype (ref tied $_[0]); # spent 8µs making 2 calls to Readonly::_is_badtype, avg 4µs/call | ||
250 | croak "$REASSIGN $badtype" if $badtype; | ||||
251 | |||||
252 | my $value = $_[1]; | ||||
253 | |||||
254 | # Recursively check passed element for references; if any, make them Readonly | ||||
255 | foreach ($value) | ||||
256 | { | ||||
257 | if (ref eq 'SCALAR') {Scalar my $v => $$_; $_ = \$v} | ||||
258 | elsif (ref eq 'ARRAY') {Array my @v => @$_; $_ = \@v} | ||||
259 | elsif (ref eq 'HASH') {Hash my %v => $_; $_ = \%v} | ||||
260 | } | ||||
261 | |||||
262 | # xs method: flag scalar as readonly | ||||
263 | if ($XSokay) | ||||
264 | { | ||||
265 | $_[0] = $value; | ||||
266 | 2 | 1µs | make_sv_readonly $_[0]; # spent 1µs making 2 calls to Readonly::XS::make_sv_readonly, avg 650ns/call | ||
267 | return; | ||||
268 | } | ||||
269 | |||||
270 | # pure-perl method: tied scalar | ||||
271 | my $tieobj = eval {tie $_[0], 'Readonly::Scalar', $value}; | ||||
272 | if ($@) | ||||
273 | { | ||||
274 | croak "$REASSIGN scalar" if substr($@,0,43) eq $MODIFY; | ||||
275 | die $@; # some other error? | ||||
276 | } | ||||
277 | return $tieobj; | ||||
278 | } | ||||
279 | |||||
280 | # Deep Readonly array | ||||
281 | sub Array (\@;@) | ||||
282 | { | ||||
283 | my $badtype = _is_badtype (ref tied @{$_[0]}); | ||||
284 | croak "$REASSIGN $badtype" if $badtype; | ||||
285 | |||||
286 | my $aref = shift; | ||||
287 | my @values = @_; | ||||
288 | |||||
289 | # Recursively check passed elements for references; if any, make them Readonly | ||||
290 | foreach (@values) | ||||
291 | { | ||||
292 | if (ref eq 'SCALAR') {Scalar my $v => $$_; $_ = \$v} | ||||
293 | elsif (ref eq 'ARRAY') {Array my @v => @$_; $_ = \@v} | ||||
294 | elsif (ref eq 'HASH') {Hash my %v => $_; $_ = \%v} | ||||
295 | } | ||||
296 | # Lastly, tie the passed reference | ||||
297 | return tie @$aref, 'Readonly::Array', @values; | ||||
298 | } | ||||
299 | |||||
300 | # Deep Readonly hash | ||||
301 | sub Hash (\%;@) | ||||
302 | { | ||||
303 | my $badtype = _is_badtype (ref tied %{$_[0]}); | ||||
304 | croak "$REASSIGN $badtype" if $badtype; | ||||
305 | |||||
306 | my $href = shift; | ||||
307 | my @values = @_; | ||||
308 | |||||
309 | # If only one value, and it's a hashref, expand it | ||||
310 | if (@_ == 1 && ref $_[0] eq 'HASH') | ||||
311 | { | ||||
312 | @values = %{$_[0]}; | ||||
313 | } | ||||
314 | |||||
315 | # otherwise, must have an even number of values | ||||
316 | croak $ODDHASH unless (@values %2 == 0); | ||||
317 | |||||
318 | # Recursively check passed elements for references; if any, make them Readonly | ||||
319 | foreach (@values) | ||||
320 | { | ||||
321 | if (ref eq 'SCALAR') {Scalar my $v => $$_; $_ = \$v} | ||||
322 | elsif (ref eq 'ARRAY') {Array my @v => @$_; $_ = \@v} | ||||
323 | elsif (ref eq 'HASH') {Hash my %v => $_; $_ = \%v} | ||||
324 | } | ||||
325 | |||||
326 | return tie %$href, 'Readonly::Hash', @values; | ||||
327 | } | ||||
328 | |||||
329 | |||||
330 | # Common entry-point for all supported data types | ||||
331 | 1 | 214µs | eval q{sub Readonly} . ( $] < 5.008 ? '' : '(\[$@%]@)' ) . <<'SUB_READONLY'; | ||
332 | { | ||||
333 | if (ref $_[0] eq 'SCALAR') | ||||
334 | { | ||||
335 | croak $MODIFY if is_sv_readonly ${$_[0]}; | ||||
336 | my $badtype = _is_badtype (ref tied ${$_[0]}); | ||||
337 | croak "$REASSIGN $badtype" if $badtype; | ||||
338 | croak "Readonly scalar must have only one value" if @_ > 2; | ||||
339 | |||||
340 | my $tieobj = eval {tie ${$_[0]}, 'Readonly::Scalar', $_[1]}; | ||||
341 | # Tie may have failed because user tried to tie a constant, or we screwed up somehow. | ||||
342 | if ($@) | ||||
343 | { | ||||
344 | croak $MODIFY if $@ =~ /^$MODIFY at/; # Point the finger at the user. | ||||
345 | die "$@\n"; # Not a modify read-only message; must be our fault. | ||||
346 | } | ||||
347 | return $tieobj; | ||||
348 | } | ||||
349 | elsif (ref $_[0] eq 'ARRAY') | ||||
350 | { | ||||
351 | my $aref = shift; | ||||
352 | return Array @$aref, @_; | ||||
353 | } | ||||
354 | elsif (ref $_[0] eq 'HASH') | ||||
355 | { | ||||
356 | my $href = shift; | ||||
357 | croak $ODDHASH if @_%2 != 0 && !(@_ == 1 && ref $_[0] eq 'HASH'); | ||||
358 | return Hash %$href, @_; | ||||
359 | } | ||||
360 | elsif (ref $_[0]) | ||||
361 | { | ||||
362 | croak "Readonly only supports scalar, array, and hash variables."; | ||||
363 | } | ||||
364 | else | ||||
365 | { | ||||
366 | croak "First argument to Readonly must be a reference."; | ||||
367 | } | ||||
368 | } | ||||
369 | SUB_READONLY | ||||
370 | |||||
371 | |||||
372 | 1 | 9µs | 1; | ||
373 | __END__ | ||||
# spent 900ns within Readonly::CORE:subst which was called 2 times, avg 450ns/call:
# 2 times (900ns+0s) by Readonly::_is_badtype at line 186, avg 450ns/call |