← Index
NYTProf Performance Profile   « line view »
For rbm/rbm
  Run on Wed Feb 12 20:36:06 2020
Reported on Wed Feb 12 21:42:25 2020

Filename/usr/lib/x86_64-linux-gnu/perl/5.28/Storable.pm
StatementsExecuted 31 statements in 2.39ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111378µs2.53msStorable::::BEGIN@72Storable::BEGIN@72
11160µs60µsStorable::::BEGIN@40Storable::BEGIN@40
11115µs18µsStorable::::BEGIN@478Storable::BEGIN@478
1113µs3µsStorable::::CORE:qrStorable::CORE:qr (opcode)
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__[:58]Storable::__ANON__[:58]
0000s0sStorable::::__ANON__[:64]Storable::__ANON__[:64]
0000s0sStorable::::_freezeStorable::_freeze
0000s0sStorable::::_make_reStorable::_make_re
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-2014 by the Perl 5 Porters
4# Copyright (c) 2015-2016 cPanel Inc
5# Copyright (c) 2017 Reini Urban
6#
7# You may redistribute only under the same terms as Perl 5, as specified
8# in the README file that comes with the distribution.
9#
10
111500nsrequire XSLoader;
121200nsrequire Exporter;
13package Storable;
14
1518µsour @ISA = qw(Exporter);
161700nsour @EXPORT = qw(store retrieve);
1714µsour @EXPORT_OK = qw(
18 nstore store_fd nstore_fd fd_retrieve
19 freeze nfreeze thaw
20 dclone
21 retrieve_fd
22 lock_store lock_nstore lock_retrieve
23 file_magic read_magic
24 BLESS_OK TIE_OK FLAGS_COMPAT
25 stack_depth stack_depth_hash
26);
27
28our ($canonical, $forgive_me);
29
301200nsour $VERSION = '3.08';
31
32our $recursion_limit;
33our $recursion_limit_hash;
34
351300ns$recursion_limit = 512
36 unless defined $recursion_limit;
371200ns$recursion_limit_hash = 256
38 unless defined $recursion_limit_hash;
39
40
# spent 60µs within Storable::BEGIN@40 which was called: # once (60µs+0s) by Encode::BEGIN@55 at line 66
BEGIN {
411200ns if (eval {
4212µs local $SIG{__DIE__};
4312µs local @INC = @INC;
441400ns pop @INC if $INC[-1] eq '.';
45142µs require Log::Agent;
46 1;
47 }) {
48 Log::Agent->import;
49 }
50 #
51 # Use of Log::Agent is optional. If it hasn't imported these subs then
52 # provide a fallback implementation.
53 #
5411µs unless ($Storable::{logcroak} && *{$Storable::{logcroak}}{CODE}) {
551500ns require Carp;
56 *logcroak = sub {
57 Carp::croak(@_);
5813µs };
59 }
6014µs unless ($Storable::{logcarp} && *{$Storable::{logcarp}}{CODE}) {
611100ns require Carp;
62 *logcarp = sub {
63 Carp::carp(@_);
641900ns };
65 }
66156µs160µs}
# spent 60µs making 1 call to Storable::BEGIN@40
67
68#
69# They might miss :flock in Fcntl
70#
71
72
# spent 2.53ms (378µs+2.15) within Storable::BEGIN@72 which was called: # once (378µs+2.15ms) by Encode::BEGIN@55 at line 81
BEGIN {
73383µs11.92ms if (eval { require Fcntl; 1 } && exists $Fcntl::EXPORT_TAGS{'flock'}) {
# spent 1.92ms making 1 call to Exporter::import
74 Fcntl->import(':flock');
75 } else {
76 eval q{
77 sub LOCK_SH () { 1 }
78 sub LOCK_EX () { 2 }
79 };
80 }
8111.85ms12.53ms}
# spent 2.53ms making 1 call to Storable::BEGIN@72
82
83sub CLONE {
84 # clone context under threads
85 Storable::init_perinterp();
86}
87
88sub BLESS_OK () { 2 }
89sub TIE_OK () { 4 }
90sub FLAGS_COMPAT () { BLESS_OK | TIE_OK }
91
92# By default restricted hashes are downgraded on earlier perls.
93
941100ns$Storable::flags = FLAGS_COMPAT;
951100ns$Storable::downgrade_restricted = 1;
961100ns$Storable::accept_future_minor = 1;
97
981179µs1172µsXSLoader::load('Storable');
# spent 172µs making 1 call to XSLoader::load
99
100#
101# Determine whether locking is possible, but only when needed.
102#
103
104sub CAN_FLOCK { 1 } # computed by Storable.pm.PL
105
106sub show_file_magic {
107 print <<EOM;
108#
109# To recognize the data files of the Perl module Storable,
110# the following lines need to be added to the local magic(5) file,
111# usually either /usr/share/misc/magic or /etc/magic.
112#
1130 string perl-store perl Storable(v0.6) data
114>4 byte >0 (net-order %d)
115>>4 byte &01 (network-ordered)
116>>4 byte =3 (major 1)
117>>4 byte =2 (major 1)
118
1190 string pst0 perl Storable(v0.7) data
120>4 byte >0
121>>4 byte &01 (network-ordered)
122>>4 byte =5 (major 2)
123>>4 byte =4 (major 2)
124>>5 byte >0 (minor %d)
125EOM
126}
127
128sub file_magic {
129 require IO::File;
130
131 my $file = shift;
132 my $fh = IO::File->new;
133 open($fh, "<", $file) || die "Can't open '$file': $!";
134 binmode($fh);
135 defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!";
136 close($fh);
137
138 $file = "./$file" unless $file; # ensure TRUE value
139
140 return read_magic($buf, $file);
141}
142
143sub read_magic {
144 my($buf, $file) = @_;
145 my %info;
146
147 my $buflen = length($buf);
148 my $magic;
149 if ($buf =~ s/^(pst0|perl-store)//) {
150 $magic = $1;
151 $info{file} = $file || 1;
152 }
153 else {
154 return undef if $file;
155 $magic = "";
156 }
157
158 return undef unless length($buf);
159
160 my $net_order;
161 if ($magic eq "perl-store" && ord(substr($buf, 0, 1)) > 1) {
162 $info{version} = -1;
163 $net_order = 0;
164 }
165 else {
166 $buf =~ s/(.)//s;
167 my $major = (ord $1) >> 1;
168 return undef if $major > 4; # sanity (assuming we never go that high)
169 $info{major} = $major;
170 $net_order = (ord $1) & 0x01;
171 if ($major > 1) {
172 return undef unless $buf =~ s/(.)//s;
173 my $minor = ord $1;
174 $info{minor} = $minor;
175 $info{version} = "$major.$minor";
176 $info{version_nv} = sprintf "%d.%03d", $major, $minor;
177 }
178 else {
179 $info{version} = $major;
180 }
181 }
182 $info{version_nv} ||= $info{version};
183 $info{netorder} = $net_order;
184
185 unless ($net_order) {
186 return undef unless $buf =~ s/(.)//s;
187 my $len = ord $1;
188 return undef unless length($buf) >= $len;
189 return undef unless $len == 4 || $len == 8; # sanity
190 @info{qw(byteorder intsize longsize ptrsize)}
191 = unpack "a${len}CCC", $buf;
192 (substr $buf, 0, $len + 3) = '';
193 if ($info{version_nv} >= 2.002) {
194 return undef unless $buf =~ s/(.)//s;
195 $info{nvsize} = ord $1;
196 }
197 }
198 $info{hdrsize} = $buflen - length($buf);
199
200 return \%info;
201}
202
203sub BIN_VERSION_NV {
204 sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR();
205}
206
207sub BIN_WRITE_VERSION_NV {
208 sprintf "%d.%03d", BIN_MAJOR(), BIN_WRITE_MINOR();
209}
210
211#
212# store
213#
214# Store target object hierarchy, identified by a reference to its root.
215# The stored object tree may later be retrieved to memory via retrieve.
216# Returns undef if an I/O error occurred, in which case the file is
217# removed.
218#
219sub store {
220 return _store(\&pstore, @_, 0);
221}
222
223#
224# nstore
225#
226# Same as store, but in network order.
227#
228sub nstore {
229 return _store(\&net_pstore, @_, 0);
230}
231
232#
233# lock_store
234#
235# Same as store, but flock the file first (advisory locking).
236#
237sub lock_store {
238 return _store(\&pstore, @_, 1);
239}
240
241#
242# lock_nstore
243#
244# Same as nstore, but flock the file first (advisory locking).
245#
246sub lock_nstore {
247 return _store(\&net_pstore, @_, 1);
248}
249
250# Internal store to file routine
251sub _store {
252 my $xsptr = shift;
253 my $self = shift;
254 my ($file, $use_locking) = @_;
255 logcroak "not a reference" unless ref($self);
256 logcroak "wrong argument number" unless @_ == 2; # No @foo in arglist
257 local *FILE;
258 if ($use_locking) {
259 open(FILE, ">>", $file) || logcroak "can't write into $file: $!";
260 unless (1) {
261 logcarp
262 "Storable::lock_store: fcntl/flock emulation broken on $^O";
263 return undef;
264 }
265 flock(FILE, LOCK_EX) ||
266 logcroak "can't get exclusive lock on $file: $!";
267 truncate FILE, 0;
268 # Unlocking will happen when FILE is closed
269 } else {
270 open(FILE, ">", $file) || logcroak "can't create $file: $!";
271 }
272 binmode FILE; # Archaic systems...
273 my $da = $@; # Don't mess if called from exception handler
274 my $ret;
275 # Call C routine nstore or pstore, depending on network order
276 eval { $ret = &$xsptr(*FILE, $self) };
277 # close will return true on success, so the or short-circuits, the ()
278 # expression is true, and for that case the block will only be entered
279 # if $@ is true (ie eval failed)
280 # if close fails, it returns false, $ret is altered, *that* is (also)
281 # false, so the () expression is false, !() is true, and the block is
282 # entered.
283 if (!(close(FILE) or undef $ret) || $@) {
284 unlink($file) or warn "Can't unlink $file: $!\n";
285 }
286 if ($@) {
287 $@ =~ s/\.?\n$/,/ unless ref $@;
288 logcroak $@;
289 }
290 $@ = $da;
291 return $ret;
292}
293
294#
295# store_fd
296#
297# Same as store, but perform on an already opened file descriptor instead.
298# Returns undef if an I/O error occurred.
299#
300sub store_fd {
301 return _store_fd(\&pstore, @_);
302}
303
304#
305# nstore_fd
306#
307# Same as store_fd, but in network order.
308#
309sub nstore_fd {
310 my ($self, $file) = @_;
311 return _store_fd(\&net_pstore, @_);
312}
313
314# Internal store routine on opened file descriptor
315sub _store_fd {
316 my $xsptr = shift;
317 my $self = shift;
318 my ($file) = @_;
319 logcroak "not a reference" unless ref($self);
320 logcroak "too many arguments" unless @_ == 1; # No @foo in arglist
321 my $fd = fileno($file);
322 logcroak "not a valid file descriptor" unless defined $fd;
323 my $da = $@; # Don't mess if called from exception handler
324 my $ret;
325 # Call C routine nstore or pstore, depending on network order
326 eval { $ret = &$xsptr($file, $self) };
327 logcroak $@ if $@ =~ s/\.?\n$/,/;
328 local $\; print $file ''; # Autoflush the file if wanted
329 $@ = $da;
330 return $ret;
331}
332
333#
334# freeze
335#
336# Store object and its hierarchy in memory and return a scalar
337# containing the result.
338#
339sub freeze {
340 _freeze(\&mstore, @_);
341}
342
343#
344# nfreeze
345#
346# Same as freeze but in network order.
347#
348sub nfreeze {
349 _freeze(\&net_mstore, @_);
350}
351
352# Internal freeze routine
353sub _freeze {
354 my $xsptr = shift;
355 my $self = shift;
356 logcroak "not a reference" unless ref($self);
357 logcroak "too many arguments" unless @_ == 0; # No @foo in arglist
358 my $da = $@; # Don't mess if called from exception handler
359 my $ret;
360 # Call C routine mstore or net_mstore, depending on network order
361 eval { $ret = &$xsptr($self) };
362 if ($@) {
363 $@ =~ s/\.?\n$/,/ unless ref $@;
364 logcroak $@;
365 }
366 $@ = $da;
367 return $ret ? $ret : undef;
368}
369
370#
371# retrieve
372#
373# Retrieve object hierarchy from disk, returning a reference to the root
374# object of that tree.
375#
376# retrieve(file, flags)
377# flags include by default BLESS_OK=2 | TIE_OK=4
378# with flags=0 or the global $Storable::flags set to 0, no resulting object
379# will be blessed nor tied.
380#
381sub retrieve {
382 _retrieve(shift, 0, @_);
383}
384
385#
386# lock_retrieve
387#
388# Same as retrieve, but with advisory locking.
389#
390sub lock_retrieve {
391 _retrieve(shift, 1, @_);
392}
393
394# Internal retrieve routine
395sub _retrieve {
396 my ($file, $use_locking, $flags) = @_;
397 $flags = $Storable::flags unless defined $flags;
398 my $FILE;
399 open($FILE, "<", $file) || logcroak "can't open $file: $!";
400 binmode $FILE; # Archaic systems...
401 my $self;
402 my $da = $@; # Could be from exception handler
403 if ($use_locking) {
404 unless (1) {
405 logcarp
406 "Storable::lock_store: fcntl/flock emulation broken on $^O";
407 return undef;
408 }
409 flock($FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!";
410 # Unlocking will happen when FILE is closed
411 }
412 eval { $self = pretrieve($FILE, $flags) }; # Call C routine
413 close($FILE);
414 if ($@) {
415 $@ =~ s/\.?\n$/,/ unless ref $@;
416 logcroak $@;
417 }
418 $@ = $da;
419 return $self;
420}
421
422#
423# fd_retrieve
424#
425# Same as retrieve, but perform from an already opened file descriptor instead.
426#
427sub fd_retrieve {
428 my ($file, $flags) = @_;
429 $flags = $Storable::flags unless defined $flags;
430 my $fd = fileno($file);
431 logcroak "not a valid file descriptor" unless defined $fd;
432 my $self;
433 my $da = $@; # Could be from exception handler
434 eval { $self = pretrieve($file, $flags) }; # Call C routine
435 if ($@) {
436 $@ =~ s/\.?\n$/,/ unless ref $@;
437 logcroak $@;
438 }
439 $@ = $da;
440 return $self;
441}
442
443sub retrieve_fd { &fd_retrieve } # Backward compatibility
444
445#
446# thaw
447#
448# Recreate objects in memory from an existing frozen image created
449# by freeze. If the frozen image passed is undef, return undef.
450#
451# thaw(frozen_obj, flags)
452# flags include by default BLESS_OK=2 | TIE_OK=4
453# with flags=0 or the global $Storable::flags set to 0, no resulting object
454# will be blessed nor tied.
455#
456sub thaw {
457 my ($frozen, $flags) = @_;
458 $flags = $Storable::flags unless defined $flags;
459 return undef unless defined $frozen;
460 my $self;
461 my $da = $@; # Could be from exception handler
462 eval { $self = mretrieve($frozen, $flags) };# Call C routine
463 if ($@) {
464 $@ =~ s/\.?\n$/,/ unless ref $@;
465 logcroak $@;
466 }
467 $@ = $da;
468 return $self;
469}
470
471#
472# _make_re($re, $flags)
473#
474# Internal function used to thaw a regular expression.
475#
476
4771200nsmy $re_flags;
478
# spent 18µs (15+3) within Storable::BEGIN@478 which was called: # once (15µs+3µs) by Encode::BEGIN@55 at line 491
BEGIN {
47913µs if ($] < 5.010) {
480 $re_flags = qr/\A[imsx]*\z/;
481 }
482 elsif ($] < 5.014) {
483 $re_flags = qr/\A[msixp]*\z/;
484 }
485 elsif ($] < 5.022) {
486 $re_flags = qr/\A[msixpdual]*\z/;
487 }
488 else {
489113µs13µs $re_flags = qr/\A[msixpdualn]*\z/;
# spent 3µs making 1 call to Storable::CORE:qr
490 }
4911122µs118µs}
# spent 18µs making 1 call to Storable::BEGIN@478
492
493sub _make_re {
494 my ($re, $flags) = @_;
495
496 $flags =~ $re_flags
497 or die "regexp flags invalid";
498
499 my $qr = eval "qr/\$re/$flags";
500 die $@ if $@;
501
502 $qr;
503}
504
5051500nsif ($] < 5.012) {
506 eval <<'EOS'
507sub _regexp_pattern {
508 my $re = "" . shift;
509 $re =~ /\A\(\?([xism]*)(?:-[xism]*)?:(.*)\)\z/s
510 or die "Cannot parse regexp /$re/";
511 return ($2, $1);
512}
5131
514EOS
515 or die "Cannot define _regexp_pattern: $@";
516}
517
518112µs1;
519__END__
 
# spent 3µs within Storable::CORE:qr which was called: # once (3µs+0s) by Storable::BEGIN@478 at line 489
sub Storable::CORE:qr; # opcode
Report produced by the NYTProf 6.06 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.