Profile of Storable.pm

← 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:06 2012

Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/x86_64-linux-thread-multi/Storable.pm
Statements | Executed 22 statements in 9.89ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 216µs | 216µs | Storable::::BEGIN@26Storable::BEGIN@26
1 | 1 | 1 | 56µs | 533µs | Storable::::BEGIN@51Storable::BEGIN@51
1 | 1 | 1 | 50µs | 220µs | Storable::::BEGIN@22Storable::BEGIN@22
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::::CAN_FLOCKStorable::CAN_FLOCK
0 | 0 | 0 | 0s | 0s | Storable::::CLONEStorable::CLONE
0 | 0 | 0 | 0s | 0s | Storable::::__ANON__[:39]Storable::__ANON__[:39]
0 | 0 | 0 | 0s | 0s | Storable::::__ANON__[:43]Storable::__ANON__[:43]
0 | 0 | 0 | 0s | 0s | Storable::::_freezeStorable::_freeze
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-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 |  |  |  |  |
8 | 1 | 3µs |  |  | require XSLoader;
9 | 1 | 2µs |  |  | require Exporter;
10 | 1 | 34µs |  |  | package Storable; @ISA = qw(Exporter);
11 |  |  |  |  |
12 | 1 | 4µs |  |  | @EXPORT = qw(store retrieve);
13 | 1 | 8µ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 |  |  |  |  |
22 | 2 | 599µs | 2 | 389µ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 |  |  |  |  |
24 | 1 | 2µ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 {
27 | 6 | 236µ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 {
35 |  |  |  |  | require Carp;
36 |  |  |  |  |
37 |  |  |  |  | *logcroak = sub {
38 |  |  |  |  | Carp::croak(@_);
39 |  |  |  |  | };
40 |  |  |  |  |
41 |  |  |  |  | *logcarp = sub {
42 |  |  |  |  | Carp::carp(@_);
43 |  |  |  |  | };
44 |  |  |  |  | }
45 | 1 | 243µs | 1 | 216µ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 {
52 | 3 | 35µs | 1 | 477µ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 |  |  |  |  | }
60 | 1 | 7.77ms | 1 | 533µs | } # spent 533µs making 1 call to Storable::BEGIN@51
61 |  |  |  |  |
62 |  |  |  |  | sub CLONE {
63 |  |  |  |  | # clone context under threads
64 |  |  |  |  | Storable::init_perinterp();
65 |  |  |  |  | }
66 |  |  |  |  |
67 |  |  |  |  | # By default restricted hashes are downgraded on earlier perls.
68 |  |  |  |  |
69 | 1 | 2µs |  |  | $Storable::downgrade_restricted = 1;
70 | 1 | 800ns |  |  | $Storable::accept_future_minor = 1;
71 |  |  |  |  |
72 | 1 | 907µs | 1 | 866µs | XSLoader::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 |  |  |  |  |
78 | 1 | 2µs |  |  | sub 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 |  |  |  |  |
87 |  |  |  |  | sub 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 |  |  |  |  | #
94 |  |  |  |  | 0 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 |  |  |  |  |
100 |  |  |  |  | 0 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)
106 |  |  |  |  | EOM
107 |  |  |  |  | }
108 |  |  |  |  |
109 |  |  |  |  | sub 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 |  |  |  |  |
124 |  |  |  |  | sub 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 |  |  |  |  |
184 |  |  |  |  | sub BIN_VERSION_NV {
185 |  |  |  |  | sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR();
186 |  |  |  |  | }
187 |  |  |  |  |
188 |  |  |  |  | sub 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 |  |  |  |  | #
200 |  |  |  |  | sub store {
201 |  |  |  |  | return _store(\&pstore, @_, 0);
202 |  |  |  |  | }
203 |  |  |  |  |
204 |  |  |  |  | #
205 |  |  |  |  | # nstore
206 |  |  |  |  | #
207 |  |  |  |  | # Same as store, but in network order.
208 |  |  |  |  | #
209 |  |  |  |  | sub 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 |  |  |  |  | #
218 |  |  |  |  | sub 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 |  |  |  |  | #
227 |  |  |  |  | sub lock_nstore {
228 |  |  |  |  | return _store(\&net_pstore, @_, 1);
229 |  |  |  |  | }
230 |  |  |  |  |
231 |  |  |  |  | # Internal store to file routine
232 |  |  |  |  | sub _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 |  |  |  |  | #
277 |  |  |  |  | sub store_fd {
278 |  |  |  |  | return _store_fd(\&pstore, @_);
279 |  |  |  |  | }
280 |  |  |  |  |
281 |  |  |  |  | #
282 |  |  |  |  | # nstore_fd
283 |  |  |  |  | #
284 |  |  |  |  | # Same as store_fd, but in network order.
285 |  |  |  |  | #
286 |  |  |  |  | sub nstore_fd {
287 |  |  |  |  | my ($self, $file) = @_;
288 |  |  |  |  | return _store_fd(\&net_pstore, @_);
289 |  |  |  |  | }
290 |  |  |  |  |
291 |  |  |  |  | # Internal store routine on opened file descriptor
292 |  |  |  |  | sub _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 |  |  |  |  | #
316 |  |  |  |  | sub freeze {
317 |  |  |  |  | _freeze(\&mstore, @_);
318 |  |  |  |  | }
319 |  |  |  |  |
320 |  |  |  |  | #
321 |  |  |  |  | # nfreeze
322 |  |  |  |  | #
323 |  |  |  |  | # Same as freeze but in network order.
324 |  |  |  |  | #
325 |  |  |  |  | sub nfreeze {
326 |  |  |  |  | _freeze(\&net_mstore, @_);
327 |  |  |  |  | }
328 |  |  |  |  |
329 |  |  |  |  | # Internal freeze routine
330 |  |  |  |  | sub _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 |  |  |  |  | #
350 |  |  |  |  | sub retrieve {
351 |  |  |  |  | _retrieve($_[0], 0);
352 |  |  |  |  | }
353 |  |  |  |  |
354 |  |  |  |  | #
355 |  |  |  |  | # lock_retrieve
356 |  |  |  |  | #
357 |  |  |  |  | # Same as retrieve, but with advisory locking.
358 |  |  |  |  | #
359 |  |  |  |  | sub lock_retrieve {
360 |  |  |  |  | _retrieve($_[0], 1);
361 |  |  |  |  | }
362 |  |  |  |  |
363 |  |  |  |  | # Internal retrieve routine
364 |  |  |  |  | sub _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 |  |  |  |  | #
391 |  |  |  |  | sub 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 |  |  |  |  |
403 |  |  |  |  | sub 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 |  |  |  |  | #
411 |  |  |  |  | sub 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 |  |  |  |  |
422 | 1 | 43µs |  |  | 1;
423 |  |  |  |  | __END__