Profile of Storable.pm

← Index
NYTProf Performance Profile «line view»
For script/ponapi
Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:09 2016

Filename | /usr/lib/perl/5.18/Storable.pm
Statements | Executed 25 statements in 2.91ms

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