Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/x86_64-linux-thread-multi/Storable.pm |
Statements | Executed 22 statements in 9.89ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 216µs | 216µs | BEGIN@26 | Storable::
1 | 1 | 1 | 56µs | 533µs | BEGIN@51 | Storable::
1 | 1 | 1 | 50µs | 220µs | BEGIN@22 | Storable::
0 | 0 | 0 | 0s | 0s | BIN_VERSION_NV | Storable::
0 | 0 | 0 | 0s | 0s | BIN_WRITE_VERSION_NV | Storable::
0 | 0 | 0 | 0s | 0s | CAN_FLOCK | Storable::
0 | 0 | 0 | 0s | 0s | CLONE | Storable::
0 | 0 | 0 | 0s | 0s | __ANON__[:39] | Storable::
0 | 0 | 0 | 0s | 0s | __ANON__[:43] | Storable::
0 | 0 | 0 | 0s | 0s | _freeze | Storable::
0 | 0 | 0 | 0s | 0s | _retrieve | Storable::
0 | 0 | 0 | 0s | 0s | _store | Storable::
0 | 0 | 0 | 0s | 0s | _store_fd | Storable::
0 | 0 | 0 | 0s | 0s | fd_retrieve | Storable::
0 | 0 | 0 | 0s | 0s | file_magic | Storable::
0 | 0 | 0 | 0s | 0s | freeze | Storable::
0 | 0 | 0 | 0s | 0s | lock_nstore | Storable::
0 | 0 | 0 | 0s | 0s | lock_retrieve | Storable::
0 | 0 | 0 | 0s | 0s | lock_store | Storable::
0 | 0 | 0 | 0s | 0s | nfreeze | Storable::
0 | 0 | 0 | 0s | 0s | nstore | Storable::
0 | 0 | 0 | 0s | 0s | nstore_fd | Storable::
0 | 0 | 0 | 0s | 0s | read_magic | Storable::
0 | 0 | 0 | 0s | 0s | retrieve | Storable::
0 | 0 | 0 | 0s | 0s | retrieve_fd | Storable::
0 | 0 | 0 | 0s | 0s | show_file_magic | Storable::
0 | 0 | 0 | 0s | 0s | store | Storable::
0 | 0 | 0 | 0s | 0s | store_fd | Storable::
0 | 0 | 0 | 0s | 0s | thaw | Storable::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # | ||||
2 | # Copyright (c) 1995-2000, Raphael Manfredi | ||||
3 | # | ||||
4 | # You may redistribute only under the same terms as Perl 5, as specified | ||||
5 | # in the README file that comes with the distribution. | ||||
6 | # | ||||
7 | |||||
8 | 1 | 3µs | require XSLoader; | ||
9 | 1 | 2µs | require Exporter; | ||
10 | 1 | 34µs | package Storable; @ISA = qw(Exporter); | ||
11 | |||||
12 | 1 | 4µs | @EXPORT = qw(store retrieve); | ||
13 | 1 | 8µs | @EXPORT_OK = qw( | ||
14 | nstore store_fd nstore_fd fd_retrieve | ||||
15 | freeze nfreeze thaw | ||||
16 | dclone | ||||
17 | retrieve_fd | ||||
18 | lock_store lock_nstore lock_retrieve | ||||
19 | file_magic read_magic | ||||
20 | ); | ||||
21 | |||||
22 | 2 | 599µs | 2 | 389µs | # spent 220µs (50+170) within Storable::BEGIN@22 which was called:
# once (50µs+170µs) by Data::Structure::Util::BEGIN@8 at line 22 # spent 220µs making 1 call to Storable::BEGIN@22
# spent 170µs making 1 call to vars::import |
23 | |||||
24 | 1 | 2µs | $VERSION = '2.30'; | ||
25 | |||||
26 | # spent 216µs within Storable::BEGIN@26 which was called:
# once (216µs+0s) by Data::Structure::Util::BEGIN@8 at line 45 | ||||
27 | 3 | 204µs | if (eval { local $SIG{__DIE__}; require Log::Agent; 1 }) { | ||
28 | Log::Agent->import; | ||||
29 | } | ||||
30 | # | ||||
31 | # Use of Log::Agent is optional. If it hasn't imported these subs then | ||||
32 | # provide a fallback implementation. | ||||
33 | # | ||||
34 | else { | ||||
35 | 1 | 2µs | require Carp; | ||
36 | |||||
37 | *logcroak = sub { | ||||
38 | Carp::croak(@_); | ||||
39 | 1 | 17µs | }; | ||
40 | |||||
41 | *logcarp = sub { | ||||
42 | Carp::carp(@_); | ||||
43 | 1 | 13µs | }; | ||
44 | } | ||||
45 | 1 | 243µs | 1 | 216µs | } # spent 216µs making 1 call to Storable::BEGIN@26 |
46 | |||||
47 | # | ||||
48 | # They might miss :flock in Fcntl | ||||
49 | # | ||||
50 | |||||
51 | # spent 533µs (56+477) within Storable::BEGIN@51 which was called:
# once (56µs+477µs) by Data::Structure::Util::BEGIN@8 at line 60 | ||||
52 | 3 | 35µs | 1 | 477µs | if (eval { require Fcntl; 1 } && exists $Fcntl::EXPORT_TAGS{'flock'}) { # spent 477µs making 1 call to Exporter::import |
53 | Fcntl->import(':flock'); | ||||
54 | } else { | ||||
55 | eval q{ | ||||
56 | sub LOCK_SH () {1} | ||||
57 | sub LOCK_EX () {2} | ||||
58 | }; | ||||
59 | } | ||||
60 | 1 | 7.77ms | 1 | 533µs | } # spent 533µs making 1 call to Storable::BEGIN@51 |
61 | |||||
62 | sub CLONE { | ||||
63 | # clone context under threads | ||||
64 | Storable::init_perinterp(); | ||||
65 | } | ||||
66 | |||||
67 | # By default restricted hashes are downgraded on earlier perls. | ||||
68 | |||||
69 | 1 | 2µs | $Storable::downgrade_restricted = 1; | ||
70 | 1 | 800ns | $Storable::accept_future_minor = 1; | ||
71 | |||||
72 | 1 | 907µs | 1 | 866µs | XSLoader::load 'Storable', $Storable::VERSION; # spent 866µs making 1 call to XSLoader::load |
73 | |||||
74 | # | ||||
75 | # Determine whether locking is possible, but only when needed. | ||||
76 | # | ||||
77 | |||||
78 | 1 | 2µs | sub CAN_FLOCK; my $CAN_FLOCK; sub CAN_FLOCK { | ||
79 | return $CAN_FLOCK if defined $CAN_FLOCK; | ||||
80 | require Config; import Config; | ||||
81 | return $CAN_FLOCK = | ||||
82 | $Config{'d_flock'} || | ||||
83 | $Config{'d_fcntl_can_lock'} || | ||||
84 | $Config{'d_lockf'}; | ||||
85 | } | ||||
86 | |||||
87 | sub show_file_magic { | ||||
88 | print <<EOM; | ||||
89 | # | ||||
90 | # To recognize the data files of the Perl module Storable, | ||||
91 | # the following lines need to be added to the local magic(5) file, | ||||
92 | # usually either /usr/share/misc/magic or /etc/magic. | ||||
93 | # | ||||
94 | 0 string perl-store perl Storable(v0.6) data | ||||
95 | >4 byte >0 (net-order %d) | ||||
96 | >>4 byte &01 (network-ordered) | ||||
97 | >>4 byte =3 (major 1) | ||||
98 | >>4 byte =2 (major 1) | ||||
99 | |||||
100 | 0 string pst0 perl Storable(v0.7) data | ||||
101 | >4 byte >0 | ||||
102 | >>4 byte &01 (network-ordered) | ||||
103 | >>4 byte =5 (major 2) | ||||
104 | >>4 byte =4 (major 2) | ||||
105 | >>5 byte >0 (minor %d) | ||||
106 | EOM | ||||
107 | } | ||||
108 | |||||
109 | sub file_magic { | ||||
110 | require IO::File; | ||||
111 | |||||
112 | my $file = shift; | ||||
113 | my $fh = IO::File->new; | ||||
114 | open($fh, "<". $file) || die "Can't open '$file': $!"; | ||||
115 | binmode($fh); | ||||
116 | defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!"; | ||||
117 | close($fh); | ||||
118 | |||||
119 | $file = "./$file" unless $file; # ensure TRUE value | ||||
120 | |||||
121 | return read_magic($buf, $file); | ||||
122 | } | ||||
123 | |||||
124 | sub read_magic { | ||||
125 | my($buf, $file) = @_; | ||||
126 | my %info; | ||||
127 | |||||
128 | my $buflen = length($buf); | ||||
129 | my $magic; | ||||
130 | if ($buf =~ s/^(pst0|perl-store)//) { | ||||
131 | $magic = $1; | ||||
132 | $info{file} = $file || 1; | ||||
133 | } | ||||
134 | else { | ||||
135 | return undef if $file; | ||||
136 | $magic = ""; | ||||
137 | } | ||||
138 | |||||
139 | return undef unless length($buf); | ||||
140 | |||||
141 | my $net_order; | ||||
142 | if ($magic eq "perl-store" && ord(substr($buf, 0, 1)) > 1) { | ||||
143 | $info{version} = -1; | ||||
144 | $net_order = 0; | ||||
145 | } | ||||
146 | else { | ||||
147 | $buf =~ s/(.)//s; | ||||
148 | my $major = (ord $1) >> 1; | ||||
149 | return undef if $major > 4; # sanity (assuming we never go that high) | ||||
150 | $info{major} = $major; | ||||
151 | $net_order = (ord $1) & 0x01; | ||||
152 | if ($major > 1) { | ||||
153 | return undef unless $buf =~ s/(.)//s; | ||||
154 | my $minor = ord $1; | ||||
155 | $info{minor} = $minor; | ||||
156 | $info{version} = "$major.$minor"; | ||||
157 | $info{version_nv} = sprintf "%d.%03d", $major, $minor; | ||||
158 | } | ||||
159 | else { | ||||
160 | $info{version} = $major; | ||||
161 | } | ||||
162 | } | ||||
163 | $info{version_nv} ||= $info{version}; | ||||
164 | $info{netorder} = $net_order; | ||||
165 | |||||
166 | unless ($net_order) { | ||||
167 | return undef unless $buf =~ s/(.)//s; | ||||
168 | my $len = ord $1; | ||||
169 | return undef unless length($buf) >= $len; | ||||
170 | return undef unless $len == 4 || $len == 8; # sanity | ||||
171 | @info{qw(byteorder intsize longsize ptrsize)} | ||||
172 | = unpack "a${len}CCC", $buf; | ||||
173 | (substr $buf, 0, $len + 3) = ''; | ||||
174 | if ($info{version_nv} >= 2.002) { | ||||
175 | return undef unless $buf =~ s/(.)//s; | ||||
176 | $info{nvsize} = ord $1; | ||||
177 | } | ||||
178 | } | ||||
179 | $info{hdrsize} = $buflen - length($buf); | ||||
180 | |||||
181 | return \%info; | ||||
182 | } | ||||
183 | |||||
184 | sub BIN_VERSION_NV { | ||||
185 | sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR(); | ||||
186 | } | ||||
187 | |||||
188 | sub BIN_WRITE_VERSION_NV { | ||||
189 | sprintf "%d.%03d", BIN_MAJOR(), BIN_WRITE_MINOR(); | ||||
190 | } | ||||
191 | |||||
192 | # | ||||
193 | # store | ||||
194 | # | ||||
195 | # Store target object hierarchy, identified by a reference to its root. | ||||
196 | # The stored object tree may later be retrieved to memory via retrieve. | ||||
197 | # Returns undef if an I/O error occurred, in which case the file is | ||||
198 | # removed. | ||||
199 | # | ||||
200 | sub store { | ||||
201 | return _store(\&pstore, @_, 0); | ||||
202 | } | ||||
203 | |||||
204 | # | ||||
205 | # nstore | ||||
206 | # | ||||
207 | # Same as store, but in network order. | ||||
208 | # | ||||
209 | sub nstore { | ||||
210 | return _store(\&net_pstore, @_, 0); | ||||
211 | } | ||||
212 | |||||
213 | # | ||||
214 | # lock_store | ||||
215 | # | ||||
216 | # Same as store, but flock the file first (advisory locking). | ||||
217 | # | ||||
218 | sub lock_store { | ||||
219 | return _store(\&pstore, @_, 1); | ||||
220 | } | ||||
221 | |||||
222 | # | ||||
223 | # lock_nstore | ||||
224 | # | ||||
225 | # Same as nstore, but flock the file first (advisory locking). | ||||
226 | # | ||||
227 | sub lock_nstore { | ||||
228 | return _store(\&net_pstore, @_, 1); | ||||
229 | } | ||||
230 | |||||
231 | # Internal store to file routine | ||||
232 | sub _store { | ||||
233 | my $xsptr = shift; | ||||
234 | my $self = shift; | ||||
235 | my ($file, $use_locking) = @_; | ||||
236 | logcroak "not a reference" unless ref($self); | ||||
237 | logcroak "wrong argument number" unless @_ == 2; # No @foo in arglist | ||||
238 | local *FILE; | ||||
239 | if ($use_locking) { | ||||
240 | open(FILE, ">>$file") || logcroak "can't write into $file: $!"; | ||||
241 | unless (&CAN_FLOCK) { | ||||
242 | logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O"; | ||||
243 | return undef; | ||||
244 | } | ||||
245 | flock(FILE, LOCK_EX) || | ||||
246 | logcroak "can't get exclusive lock on $file: $!"; | ||||
247 | truncate FILE, 0; | ||||
248 | # Unlocking will happen when FILE is closed | ||||
249 | } else { | ||||
250 | open(FILE, ">$file") || logcroak "can't create $file: $!"; | ||||
251 | } | ||||
252 | binmode FILE; # Archaic systems... | ||||
253 | my $da = $@; # Don't mess if called from exception handler | ||||
254 | my $ret; | ||||
255 | # Call C routine nstore or pstore, depending on network order | ||||
256 | eval { $ret = &$xsptr(*FILE, $self) }; | ||||
257 | # close will return true on success, so the or short-circuits, the () | ||||
258 | # expression is true, and for that case the block will only be entered | ||||
259 | # if $@ is true (ie eval failed) | ||||
260 | # if close fails, it returns false, $ret is altered, *that* is (also) | ||||
261 | # false, so the () expression is false, !() is true, and the block is | ||||
262 | # entered. | ||||
263 | if (!(close(FILE) or undef $ret) || $@) { | ||||
264 | unlink($file) or warn "Can't unlink $file: $!\n"; | ||||
265 | } | ||||
266 | logcroak $@ if $@ =~ s/\.?\n$/,/; | ||||
267 | $@ = $da; | ||||
268 | return $ret; | ||||
269 | } | ||||
270 | |||||
271 | # | ||||
272 | # store_fd | ||||
273 | # | ||||
274 | # Same as store, but perform on an already opened file descriptor instead. | ||||
275 | # Returns undef if an I/O error occurred. | ||||
276 | # | ||||
277 | sub store_fd { | ||||
278 | return _store_fd(\&pstore, @_); | ||||
279 | } | ||||
280 | |||||
281 | # | ||||
282 | # nstore_fd | ||||
283 | # | ||||
284 | # Same as store_fd, but in network order. | ||||
285 | # | ||||
286 | sub nstore_fd { | ||||
287 | my ($self, $file) = @_; | ||||
288 | return _store_fd(\&net_pstore, @_); | ||||
289 | } | ||||
290 | |||||
291 | # Internal store routine on opened file descriptor | ||||
292 | sub _store_fd { | ||||
293 | my $xsptr = shift; | ||||
294 | my $self = shift; | ||||
295 | my ($file) = @_; | ||||
296 | logcroak "not a reference" unless ref($self); | ||||
297 | logcroak "too many arguments" unless @_ == 1; # No @foo in arglist | ||||
298 | my $fd = fileno($file); | ||||
299 | logcroak "not a valid file descriptor" unless defined $fd; | ||||
300 | my $da = $@; # Don't mess if called from exception handler | ||||
301 | my $ret; | ||||
302 | # Call C routine nstore or pstore, depending on network order | ||||
303 | eval { $ret = &$xsptr($file, $self) }; | ||||
304 | logcroak $@ if $@ =~ s/\.?\n$/,/; | ||||
305 | local $\; print $file ''; # Autoflush the file if wanted | ||||
306 | $@ = $da; | ||||
307 | return $ret; | ||||
308 | } | ||||
309 | |||||
310 | # | ||||
311 | # freeze | ||||
312 | # | ||||
313 | # Store oject and its hierarchy in memory and return a scalar | ||||
314 | # containing the result. | ||||
315 | # | ||||
316 | sub freeze { | ||||
317 | _freeze(\&mstore, @_); | ||||
318 | } | ||||
319 | |||||
320 | # | ||||
321 | # nfreeze | ||||
322 | # | ||||
323 | # Same as freeze but in network order. | ||||
324 | # | ||||
325 | sub nfreeze { | ||||
326 | _freeze(\&net_mstore, @_); | ||||
327 | } | ||||
328 | |||||
329 | # Internal freeze routine | ||||
330 | sub _freeze { | ||||
331 | my $xsptr = shift; | ||||
332 | my $self = shift; | ||||
333 | logcroak "not a reference" unless ref($self); | ||||
334 | logcroak "too many arguments" unless @_ == 0; # No @foo in arglist | ||||
335 | my $da = $@; # Don't mess if called from exception handler | ||||
336 | my $ret; | ||||
337 | # Call C routine mstore or net_mstore, depending on network order | ||||
338 | eval { $ret = &$xsptr($self) }; | ||||
339 | logcroak $@ if $@ =~ s/\.?\n$/,/; | ||||
340 | $@ = $da; | ||||
341 | return $ret ? $ret : undef; | ||||
342 | } | ||||
343 | |||||
344 | # | ||||
345 | # retrieve | ||||
346 | # | ||||
347 | # Retrieve object hierarchy from disk, returning a reference to the root | ||||
348 | # object of that tree. | ||||
349 | # | ||||
350 | sub retrieve { | ||||
351 | _retrieve($_[0], 0); | ||||
352 | } | ||||
353 | |||||
354 | # | ||||
355 | # lock_retrieve | ||||
356 | # | ||||
357 | # Same as retrieve, but with advisory locking. | ||||
358 | # | ||||
359 | sub lock_retrieve { | ||||
360 | _retrieve($_[0], 1); | ||||
361 | } | ||||
362 | |||||
363 | # Internal retrieve routine | ||||
364 | sub _retrieve { | ||||
365 | my ($file, $use_locking) = @_; | ||||
366 | local *FILE; | ||||
367 | open(FILE, $file) || logcroak "can't open $file: $!"; | ||||
368 | binmode FILE; # Archaic systems... | ||||
369 | my $self; | ||||
370 | my $da = $@; # Could be from exception handler | ||||
371 | if ($use_locking) { | ||||
372 | unless (&CAN_FLOCK) { | ||||
373 | logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O"; | ||||
374 | return undef; | ||||
375 | } | ||||
376 | flock(FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!"; | ||||
377 | # Unlocking will happen when FILE is closed | ||||
378 | } | ||||
379 | eval { $self = pretrieve(*FILE) }; # Call C routine | ||||
380 | close(FILE); | ||||
381 | logcroak $@ if $@ =~ s/\.?\n$/,/; | ||||
382 | $@ = $da; | ||||
383 | return $self; | ||||
384 | } | ||||
385 | |||||
386 | # | ||||
387 | # fd_retrieve | ||||
388 | # | ||||
389 | # Same as retrieve, but perform from an already opened file descriptor instead. | ||||
390 | # | ||||
391 | sub fd_retrieve { | ||||
392 | my ($file) = @_; | ||||
393 | my $fd = fileno($file); | ||||
394 | logcroak "not a valid file descriptor" unless defined $fd; | ||||
395 | my $self; | ||||
396 | my $da = $@; # Could be from exception handler | ||||
397 | eval { $self = pretrieve($file) }; # Call C routine | ||||
398 | logcroak $@ if $@ =~ s/\.?\n$/,/; | ||||
399 | $@ = $da; | ||||
400 | return $self; | ||||
401 | } | ||||
402 | |||||
403 | sub retrieve_fd { &fd_retrieve } # Backward compatibility | ||||
404 | |||||
405 | # | ||||
406 | # thaw | ||||
407 | # | ||||
408 | # Recreate objects in memory from an existing frozen image created | ||||
409 | # by freeze. If the frozen image passed is undef, return undef. | ||||
410 | # | ||||
411 | sub thaw { | ||||
412 | my ($frozen) = @_; | ||||
413 | return undef unless defined $frozen; | ||||
414 | my $self; | ||||
415 | my $da = $@; # Could be from exception handler | ||||
416 | eval { $self = mretrieve($frozen) }; # Call C routine | ||||
417 | logcroak $@ if $@ =~ s/\.?\n$/,/; | ||||
418 | $@ = $da; | ||||
419 | return $self; | ||||
420 | } | ||||
421 | |||||
422 | 1 | 43µs | 1; | ||
423 | __END__ |