← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:48 2015

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