← Index
NYTProf Performance Profile   « block view • line view • sub view »
For t/app_dpath.t
  Run on Tue Jun 5 15:25:28 2012
Reported on Tue Jun 5 15:26:12 2012

Filename/home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/x86_64-linux-thread-multi/Storable.pm
StatementsExecuted 22 statements in 9.89ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111216µs216µsStorable::::BEGIN@26Storable::BEGIN@26
11156µs533µsStorable::::BEGIN@51Storable::BEGIN@51
11150µs220µsStorable::::BEGIN@22Storable::BEGIN@22
0000s0sStorable::::BIN_VERSION_NVStorable::BIN_VERSION_NV
0000s0sStorable::::BIN_WRITE_VERSION_NVStorable::BIN_WRITE_VERSION_NV
0000s0sStorable::::CAN_FLOCKStorable::CAN_FLOCK
0000s0sStorable::::CLONEStorable::CLONE
0000s0sStorable::::__ANON__[:39]Storable::__ANON__[:39]
0000s0sStorable::::__ANON__[:43]Storable::__ANON__[:43]
0000s0sStorable::::_freezeStorable::_freeze
0000s0sStorable::::_retrieveStorable::_retrieve
0000s0sStorable::::_storeStorable::_store
0000s0sStorable::::_store_fdStorable::_store_fd
0000s0sStorable::::fd_retrieveStorable::fd_retrieve
0000s0sStorable::::file_magicStorable::file_magic
0000s0sStorable::::freezeStorable::freeze
0000s0sStorable::::lock_nstoreStorable::lock_nstore
0000s0sStorable::::lock_retrieveStorable::lock_retrieve
0000s0sStorable::::lock_storeStorable::lock_store
0000s0sStorable::::nfreezeStorable::nfreeze
0000s0sStorable::::nstoreStorable::nstore
0000s0sStorable::::nstore_fdStorable::nstore_fd
0000s0sStorable::::read_magicStorable::read_magic
0000s0sStorable::::retrieveStorable::retrieve
0000s0sStorable::::retrieve_fdStorable::retrieve_fd
0000s0sStorable::::show_file_magicStorable::show_file_magic
0000s0sStorable::::storeStorable::store
0000s0sStorable::::store_fdStorable::store_fd
0000s0sStorable::::thawStorable::thaw
Call graph for these subroutines as a Graphviz dot language file.
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
813µsrequire XSLoader;
912µsrequire Exporter;
10134µspackage Storable; @ISA = qw(Exporter);
11
1214µs@EXPORT = qw(store retrieve);
1318µ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
222599µs2389µ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
use vars qw($canonical $forgive_me $VERSION);
# spent 220µs making 1 call to Storable::BEGIN@22 # spent 170µs making 1 call to vars::import
23
2412µ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
BEGIN {
273204µ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 {
3512µs require Carp;
36
37 *logcroak = sub {
38 Carp::croak(@_);
39117µs };
40
41 *logcarp = sub {
42 Carp::carp(@_);
43113µs };
44 }
451243µs1216µ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
BEGIN {
52335µs1477µ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 }
6017.77ms1533µs}
# spent 533µs making 1 call to Storable::BEGIN@51
61
62sub CLONE {
63 # clone context under threads
64 Storable::init_perinterp();
65}
66
67# By default restricted hashes are downgraded on earlier perls.
68
6912µs$Storable::downgrade_restricted = 1;
701800ns$Storable::accept_future_minor = 1;
71
721907µs1866µsXSLoader::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
7812µssub 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
87sub 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#
940 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
1000 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)
106EOM
107}
108
109sub 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
124sub 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
184sub BIN_VERSION_NV {
185 sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR();
186}
187
188sub 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#
200sub store {
201 return _store(\&pstore, @_, 0);
202}
203
204#
205# nstore
206#
207# Same as store, but in network order.
208#
209sub 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#
218sub 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#
227sub lock_nstore {
228 return _store(\&net_pstore, @_, 1);
229}
230
231# Internal store to file routine
232sub _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#
277sub store_fd {
278 return _store_fd(\&pstore, @_);
279}
280
281#
282# nstore_fd
283#
284# Same as store_fd, but in network order.
285#
286sub nstore_fd {
287 my ($self, $file) = @_;
288 return _store_fd(\&net_pstore, @_);
289}
290
291# Internal store routine on opened file descriptor
292sub _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#
316sub freeze {
317 _freeze(\&mstore, @_);
318}
319
320#
321# nfreeze
322#
323# Same as freeze but in network order.
324#
325sub nfreeze {
326 _freeze(\&net_mstore, @_);
327}
328
329# Internal freeze routine
330sub _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#
350sub retrieve {
351 _retrieve($_[0], 0);
352}
353
354#
355# lock_retrieve
356#
357# Same as retrieve, but with advisory locking.
358#
359sub lock_retrieve {
360 _retrieve($_[0], 1);
361}
362
363# Internal retrieve routine
364sub _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#
391sub 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
403sub 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#
411sub 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
422143µs1;
423__END__