← Index
NYTProf Performance Profile   « line view »
For split.pl
  Run on Thu Apr 20 02:05:47 2023
Reported on Thu Apr 20 18:31:10 2023

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