Profile of Storable.pm

← Index
NYTProf Performance Profile «line view»
For t/bug-md-11.t
Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/5.38.2/x86_64-linux/Storable.pm
Statements | Executed 31 statements in 1.69ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 29µs | 29µs | Storable::::BEGIN@44Storable::BEGIN@44
1 | 1 | 1 | 6µs | 8µs | Storable::::BEGIN@487Storable::BEGIN@487
1 | 1 | 1 | 6µs | 6µs | Encode::::BEGIN@11 Encode::BEGIN@11
1 | 1 | 1 | 6µs | 133µs | Storable::::BEGIN@109Storable::BEGIN@109
1 | 1 | 1 | 4µs | 16µs | Storable::::BEGIN@66Storable::BEGIN@66
1 | 1 | 1 | 4µs | 25µs | Storable::::BEGIN@42Storable::BEGIN@42
1 | 1 | 1 | 4µs | 63µs | Storable::::BEGIN@83Storable::BEGIN@83
1 | 1 | 1 | 2µs | 2µs | Storable::::BEGIN@30Storable::BEGIN@30
0 | 0 | 0 | 0s | 0s | Storable::::BIN_VERSION_NVStorable::BIN_VERSION_NV
0 | 0 | 0 | 0s | 0s | Storable::::BIN_WRITE_VERSION_NVStorable::BIN_WRITE_VERSION_NV
0 | 0 | 0 | 0s | 0s | Storable::::CLONEStorable::CLONE
0 | 0 | 0 | 0s | 0s | Storable::::__ANON__[:72]Storable::__ANON__[:72]
0 | 0 | 0 | 0s | 0s | Storable::::_freezeStorable::_freeze
0 | 0 | 0 | 0s | 0s | Storable::::_make_reStorable::_make_re
0 | 0 | 0 | 0s | 0s | Storable::::_retrieveStorable::_retrieve
0 | 0 | 0 | 0s | 0s | Storable::::_storeStorable::_store
0 | 0 | 0 | 0s | 0s | Storable::::_store_fdStorable::_store_fd
0 | 0 | 0 | 0s | 0s | Storable::::fd_retrieveStorable::fd_retrieve
0 | 0 | 0 | 0s | 0s | Storable::::file_magicStorable::file_magic
0 | 0 | 0 | 0s | 0s | Storable::::freezeStorable::freeze
0 | 0 | 0 | 0s | 0s | Storable::::lock_nstoreStorable::lock_nstore
0 | 0 | 0 | 0s | 0s | Storable::::lock_retrieveStorable::lock_retrieve
0 | 0 | 0 | 0s | 0s | Storable::::lock_storeStorable::lock_store
0 | 0 | 0 | 0s | 0s | Storable::::nfreezeStorable::nfreeze
0 | 0 | 0 | 0s | 0s | Storable::::nstoreStorable::nstore
0 | 0 | 0 | 0s | 0s | Storable::::nstore_fdStorable::nstore_fd
0 | 0 | 0 | 0s | 0s | Storable::::read_magicStorable::read_magic
0 | 0 | 0 | 0s | 0s | Storable::::retrieveStorable::retrieve
0 | 0 | 0 | 0s | 0s | Storable::::retrieve_fdStorable::retrieve_fd
0 | 0 | 0 | 0s | 0s | Storable::::show_file_magicStorable::show_file_magic
0 | 0 | 0 | 0s | 0s | Storable::::storeStorable::store
0 | 0 | 0 | 0s | 0s | Storable::::store_fdStorable::store_fd
0 | 0 | 0 | 0s | 0s | Storable::::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 |  |  |  |  |
11 | 1 | 53µs | 1 | 6µs | # spent 6µs within Encode::BEGIN@11 which was called: # once (6µs+0s) by Encode::BEGIN@56 at line 11 BEGIN { require XSLoader } # spent 6µs making 1 call to Encode::BEGIN@11
12 | 1 | 500ns |  |  | require Exporter;
13 |  |  |  |  | package Storable;
14 |  |  |  |  |
15 | 1 | 5µs |  |  | our @ISA = qw(Exporter);
16 | 1 | 400ns |  |  | our @EXPORT = qw(store retrieve);
17 | 1 | 1µs |  |  | our @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 |  |  |  |  |
28 |  |  |  |  | our ($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 {
31 | 1 | 2µs |  |  | our $VERSION = '3.32';
32 | 1 | 24µs | 1 | 2µs | } # spent 2µs making 1 call to Storable::BEGIN@30
33 |  |  |  |  |
34 |  |  |  |  | our $recursion_limit;
35 |  |  |  |  | our $recursion_limit_hash;
36 |  |  |  |  |
37 | 1 | 300ns |  |  | $recursion_limit = 512
38 |  |  |  |  | unless defined $recursion_limit;
39 | 1 | 0s |  |  | $recursion_limit_hash = 256
40 |  |  |  |  | unless defined $recursion_limit_hash;
41 |  |  |  |  |
42 | 2 | 77µs | 2 | 47µs | # spent 25µs (4+22) within Storable::BEGIN@42 which was called: # once (4µs+22µs) by Encode::BEGIN@56 at line 42 use Carp; # spent 25µs making 1 call to Storable::BEGIN@42 # spent 22µs making 1 call to Exporter::import
43 |  |  |  |  |
44 |  |  |  |  | # spent 29µs within Storable::BEGIN@44 which was called: # once (29µs+0s) by Encode::BEGIN@56 at line 77 BEGIN {
45 | 1 | 100ns |  |  | if (eval {
46 | 1 | 1µs |  |  | local $SIG{__DIE__};
47 | 1 | 1µs |  |  | local @INC = @INC;
48 | 1 | 300ns |  |  | pop @INC if $INC[-1] eq '.';
49 | 1 | 22µ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 |  |  |  |  | #
58 | 1 | 1µ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.
66 | 2 | 69µs | 2 | 28µs | # spent 16µs (4+12) within Storable::BEGIN@66 which was called: # once (4µs+12µs) by Encode::BEGIN@56 at line 66 no warnings 'redefine'; # spent 16µs making 1 call to Storable::BEGIN@66 # spent 12µ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 |  |  |  |  | }
74 | 1 | 3µs |  |  | unless ($Storable::{logcarp} && *{$Storable::{logcarp}}{CODE}) {
75 |  |  |  |  | *logcarp = \&Carp::carp;
76 |  |  |  |  | }
77 | 1 | 41µs | 1 | 29µs | } # spent 29µs making 1 call to Storable::BEGIN@44
78 |  |  |  |  |
79 |  |  |  |  | #
80 |  |  |  |  | # They might miss :flock in Fcntl
81 |  |  |  |  | #
82 |  |  |  |  |
83 |  |  |  |  | # spent 63µs (4+59) within Storable::BEGIN@83 which was called: # once (4µs+59µs) by Encode::BEGIN@56 at line 92 BEGIN {
84 | 3 | 3µs | 1 | 59µs | if (eval { require Fcntl; 1 } && exists $Fcntl::EXPORT_TAGS{'flock'}) { # spent 59µ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 |  |  |  |  | }
92 | 1 | 56µs | 1 | 63µs | } # spent 63µs making 1 call to Storable::BEGIN@83
93 |  |  |  |  |
94 |  |  |  |  | sub CLONE {
95 |  |  |  |  | # clone context under threads
96 |  |  |  |  | Storable::init_perinterp();
97 |  |  |  |  | }
98 |  |  |  |  |
99 |  |  |  |  | sub BLESS_OK () { 2 }
100 |  |  |  |  | sub TIE_OK () { 4 }
101 |  |  |  |  | sub FLAGS_COMPAT () { BLESS_OK | TIE_OK }
102 |  |  |  |  |
103 |  |  |  |  | # By default restricted hashes are downgraded on earlier perls.
104 |  |  |  |  |
105 | 1 | 100ns |  |  | $Storable::flags = FLAGS_COMPAT;
106 | 1 | 0s |  |  | $Storable::downgrade_restricted = 1;
107 | 1 | 0s |  |  | $Storable::accept_future_minor = 1;
108 |  |  |  |  |
109 | 1 | 1.22ms | 2 | 261µs | # spent 133µs (6+128) within Storable::BEGIN@109 which was called: # once (6µs+128µs) by Encode::BEGIN@56 at line 109 BEGIN { XSLoader::load('Storable') }; # spent 133µs making 1 call to Storable::BEGIN@109 # spent 128µs making 1 call to XSLoader::load
110 |  |  |  |  |
111 |  |  |  |  | #
112 |  |  |  |  | # Determine whether locking is possible, but only when needed.
113 |  |  |  |  | #
114 |  |  |  |  |
115 |  |  |  |  | sub 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 |  |  |  |  | #
122 |  |  |  |  | 0 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 |  |  |  |  |
128 |  |  |  |  | 0 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)
134 |  |  |  |  | EOM
135 |  |  |  |  | }
136 |  |  |  |  |
137 |  |  |  |  | sub 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 |  |  |  |  |
152 |  |  |  |  | sub 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 |  |  |  |  |
212 |  |  |  |  | sub BIN_VERSION_NV {
213 |  |  |  |  | sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR();
214 |  |  |  |  | }
215 |  |  |  |  |
216 |  |  |  |  | sub 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 |  |  |  |  | #
228 |  |  |  |  | sub store {
229 |  |  |  |  | return _store(\&pstore, @_, 0);
230 |  |  |  |  | }
231 |  |  |  |  |
232 |  |  |  |  | #
233 |  |  |  |  | # nstore
234 |  |  |  |  | #
235 |  |  |  |  | # Same as store, but in network order.
236 |  |  |  |  | #
237 |  |  |  |  | sub 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 |  |  |  |  | #
246 |  |  |  |  | sub 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 |  |  |  |  | #
255 |  |  |  |  | sub lock_nstore {
256 |  |  |  |  | return _store(\&net_pstore, @_, 1);
257 |  |  |  |  | }
258 |  |  |  |  |
259 |  |  |  |  | # Internal store to file routine
260 |  |  |  |  | sub _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 |  |  |  |  | #
309 |  |  |  |  | sub store_fd {
310 |  |  |  |  | return _store_fd(\&pstore, @_);
311 |  |  |  |  | }
312 |  |  |  |  |
313 |  |  |  |  | #
314 |  |  |  |  | # nstore_fd
315 |  |  |  |  | #
316 |  |  |  |  | # Same as store_fd, but in network order.
317 |  |  |  |  | #
318 |  |  |  |  | sub nstore_fd {
319 |  |  |  |  | my ($self, $file) = @_;
320 |  |  |  |  | return _store_fd(\&net_pstore, @_);
321 |  |  |  |  | }
322 |  |  |  |  |
323 |  |  |  |  | # Internal store routine on opened file descriptor
324 |  |  |  |  | sub _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 |  |  |  |  | #
348 |  |  |  |  | sub freeze {
349 |  |  |  |  | _freeze(\&mstore, @_);
350 |  |  |  |  | }
351 |  |  |  |  |
352 |  |  |  |  | #
353 |  |  |  |  | # nfreeze
354 |  |  |  |  | #
355 |  |  |  |  | # Same as freeze but in network order.
356 |  |  |  |  | #
357 |  |  |  |  | sub nfreeze {
358 |  |  |  |  | _freeze(\&net_mstore, @_);
359 |  |  |  |  | }
360 |  |  |  |  |
361 |  |  |  |  | # Internal freeze routine
362 |  |  |  |  | sub _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 |  |  |  |  | #
390 |  |  |  |  | sub retrieve {
391 |  |  |  |  | _retrieve(shift, 0, @_);
392 |  |  |  |  | }
393 |  |  |  |  |
394 |  |  |  |  | #
395 |  |  |  |  | # lock_retrieve
396 |  |  |  |  | #
397 |  |  |  |  | # Same as retrieve, but with advisory locking.
398 |  |  |  |  | #
399 |  |  |  |  | sub lock_retrieve {
400 |  |  |  |  | _retrieve(shift, 1, @_);
401 |  |  |  |  | }
402 |  |  |  |  |
403 |  |  |  |  | # Internal retrieve routine
404 |  |  |  |  | sub _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 |  |  |  |  | #
436 |  |  |  |  | sub 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 |  |  |  |  |
452 |  |  |  |  | sub 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 |  |  |  |  | #
465 |  |  |  |  | sub 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 |  |  |  |  |
486 | 1 | 100ns |  |  | my $re_flags;
487 |  |  |  |  | # spent 8µs (6+1) within Storable::BEGIN@487 which was called: # once (6µs+1µs) by Encode::BEGIN@56 at line 500 BEGIN {
488 | 1 | 2µ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 {
498 | 1 | 5µs | 1 | 1µs | $re_flags = qr/\A[msixpdualn]*\z/; # spent 1µs making 1 call to CORE::qr
499 |  |  |  |  | }
500 | 1 | 94µs | 1 | 8µs | } # spent 8µs making 1 call to Storable::BEGIN@487
501 |  |  |  |  |
502 |  |  |  |  | sub _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 |  |  |  |  |
514 | 1 | 200ns |  |  | if ($] < 5.012) {
515 |  |  |  |  | eval <<'EOS'
516 |  |  |  |  | sub _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 |  |  |  |  | }
522 |  |  |  |  | 1
523 |  |  |  |  | EOS
524 |  |  |  |  | or die "Cannot define _regexp_pattern: $@";
525 |  |  |  |  | }
526 |  |  |  |  |
527 | 1 | 6µs |  |  | 1;
528 |  |  |  |  | __END__