File Coverage

blib/lib/Storable.pm
Criterion Covered Total %
statement 413 426 96.9
branch 66 102 64.7
condition 16 26 61.5
subroutine 105 111 94.5
pod 2 19 10.5
total 602 684 88.0


line stmt bran cond sub pod time 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             require XSLoader;
12             require Exporter;
13             package Storable; @ISA = qw(Exporter);
14              
15             @EXPORT = qw(store retrieve);
16             @EXPORT_OK = qw(
17             nstore store_fd nstore_fd fd_retrieve
18             freeze nfreeze thaw
19             dclone
20             retrieve_fd
21             lock_store lock_nstore lock_retrieve
22             file_magic read_magic
23             BLESS_OK TIE_OK FLAGS_COMPAT
24             stack_depth stack_depth_hash
25             );
26              
27 30     30   736572 use vars qw($canonical $forgive_me $VERSION $XS_VERSION);
  30         257  
  30         6381  
28              
29             $VERSION = '3.05_16';
30             $XS_VERSION = $VERSION;
31             $VERSION = eval $VERSION;
32              
33             BEGIN {
34 30 50   30   107 if (eval {
35 30         108 local $SIG{__DIE__};
36 30         214 local @INC = @INC;
37 30 50       106 pop @INC if $INC[-1] eq '.';
38 30         1947 require Log::Agent;
39 0         0 1;
40             }) {
41 0         0 Log::Agent->import;
42             }
43             #
44             # Use of Log::Agent is optional. If it hasn't imported these subs then
45             # provide a fallback implementation.
46             #
47 30 50 50     199 unless ($Storable::{logcroak} && *{$Storable::{logcroak}}{CODE}) {
  30         226  
48 30         116 require Carp;
49             *logcroak = sub {
50 106     106   11591 Carp::croak(@_);
51 30         122 };
52             }
53 30 50 50     143 unless ($Storable::{logcarp} && *{$Storable::{logcarp}}{CODE}) {
  30         148  
54 30         100 require Carp;
55             *logcarp = sub {
56 0     0   0 Carp::carp(@_);
57 30         1795 };
58             }
59             }
60              
61             #
62             # They might miss :flock in Fcntl
63             #
64              
65             BEGIN {
66 30 50 33 30   80 if (eval { require Fcntl; 1 } && exists $Fcntl::EXPORT_TAGS{'flock'}) {
  30         130  
  30         203  
67 30         6452 Fcntl->import(':flock');
68             } else {
69 0         0 eval q{
70             sub LOCK_SH () { 1 }
71             sub LOCK_EX () { 2 }
72             };
73             }
74             }
75              
76             sub CLONE {
77             # clone context under threads
78 0     0   0 Storable::init_perinterp();
79             }
80              
81             sub BLESS_OK () { 2 }
82             sub TIE_OK () { 4 }
83             sub FLAGS_COMPAT () { BLESS_OK | TIE_OK }
84              
85             # By default restricted hashes are downgraded on earlier perls.
86              
87             $Storable::flags = FLAGS_COMPAT;
88             $Storable::downgrade_restricted = 1;
89             $Storable::accept_future_minor = 1;
90              
91             XSLoader::load('Storable');
92              
93             #
94             # Determine whether locking is possible, but only when needed.
95             #
96              
97             my $CAN_FLOCK;
98             BEGIN {
99 30     30   187 require Config;
100             $CAN_FLOCK =
101             $Config::Config{'d_flock'} ||
102             $Config::Config{'d_fcntl_can_lock'} ||
103 30   0     49729 $Config::Config{'d_lockf'};
104             }
105 3     3 0 93 sub CAN_FLOCK () { $CAN_FLOCK }
106              
107             sub show_file_magic {
108 0     0 0 0 print <
109             #
110             # To recognize the data files of the Perl module Storable,
111             # the following lines need to be added to the local magic(5) file,
112             # usually either /usr/share/misc/magic or /etc/magic.
113             #
114             0 string perl-store perl Storable(v0.6) data
115             >4 byte >0 (net-order %d)
116             >>4 byte &01 (network-ordered)
117             >>4 byte =3 (major 1)
118             >>4 byte =2 (major 1)
119              
120             0 string pst0 perl Storable(v0.7) data
121             >4 byte >0
122             >>4 byte &01 (network-ordered)
123             >>4 byte =5 (major 2)
124             >>4 byte =4 (major 2)
125             >>5 byte >0 (minor %d)
126             EOM
127             }
128              
129             sub file_magic {
130 28     28 1 15821 require IO::File;
131              
132 28         5969 my $file = shift;
133 28         120 my $fh = IO::File->new;
134 28 100       1283 open($fh, "<", $file) || die "Can't open '$file': $!";
135 27         68 binmode($fh);
136 27 50       134 defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!";
137 27         99 close($fh);
138              
139 27 50       48 $file = "./$file" unless $file; # ensure TRUE value
140              
141 27         53 return read_magic($buf, $file);
142             }
143              
144             sub read_magic {
145 55     55 1 17267 my($buf, $file) = @_;
146 55         83 my %info;
147              
148 55         70 my $buflen = length($buf);
149 55         62 my $magic;
150 55 100       329 if ($buf =~ s/^(pst0|perl-store)//) {
151 52         120 $magic = $1;
152 52   100     180 $info{file} = $file || 1;
153             }
154             else {
155 3 100       13 return undef if $file;
156 2         4 $magic = "";
157             }
158              
159 54 50       121 return undef unless length($buf);
160              
161 54         69 my $net_order;
162 54 100 100     146 if ($magic eq "perl-store" && ord(substr($buf, 0, 1)) > 1) {
163 2         3 $info{version} = -1;
164 2         4 $net_order = 0;
165             }
166             else {
167 52         142 $buf =~ s/(.)//s;
168 52         114 my $major = (ord $1) >> 1;
169 52 50       107 return undef if $major > 4; # sanity (assuming we never go that high)
170 52         76 $info{major} = $major;
171 52         91 $net_order = (ord $1) & 0x01;
172 52 100       81 if ($major > 1) {
173 44 50       141 return undef unless $buf =~ s/(.)//s;
174 44         101 my $minor = ord $1;
175 44         99 $info{minor} = $minor;
176 44         95 $info{version} = "$major.$minor";
177 44         178 $info{version_nv} = sprintf "%d.%03d", $major, $minor;
178             }
179             else {
180 8         14 $info{version} = $major;
181             }
182             }
183 54   100     122 $info{version_nv} ||= $info{version};
184 54         88 $info{netorder} = $net_order;
185              
186 54 100       97 unless ($net_order) {
187 33 50       101 return undef unless $buf =~ s/(.)//s;
188 33         60 my $len = ord $1;
189 33 50       57 return undef unless length($buf) >= $len;
190 33 50 66     86 return undef unless $len == 4 || $len == 8; # sanity
191 33         197 @info{qw(byteorder intsize longsize ptrsize)}
192             = unpack "a${len}CCC", $buf;
193 33         111 (substr $buf, 0, $len + 3) = '';
194 33 100       128 if ($info{version_nv} >= 2.002) {
195 25 50       76 return undef unless $buf =~ s/(.)//s;
196 25         50 $info{nvsize} = ord $1;
197             }
198             }
199 54         90 $info{hdrsize} = $buflen - length($buf);
200              
201 54         212 return \%info;
202             }
203              
204             sub BIN_VERSION_NV {
205 0     0 0 0 sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR();
206             }
207              
208             sub BIN_WRITE_VERSION_NV {
209 2     2 0 3406 sprintf "%d.%03d", BIN_MAJOR(), BIN_WRITE_MINOR();
210             }
211              
212             #
213             # store
214             #
215             # Store target object hierarchy, identified by a reference to its root.
216             # The stored object tree may later be retrieved to memory via retrieve.
217             # Returns undef if an I/O error occurred, in which case the file is
218             # removed.
219             #
220             sub store {
221 50     50 0 78740 return _store(\&pstore, @_, 0);
222             }
223              
224             #
225             # nstore
226             #
227             # Same as store, but in network order.
228             #
229             sub nstore {
230 45     45 0 63869 return _store(\&net_pstore, @_, 0);
231             }
232              
233             #
234             # lock_store
235             #
236             # Same as store, but flock the file first (advisory locking).
237             #
238             sub lock_store {
239 1     1 0 750 return _store(\&pstore, @_, 1);
240             }
241              
242             #
243             # lock_nstore
244             #
245             # Same as nstore, but flock the file first (advisory locking).
246             #
247             sub lock_nstore {
248 0     0 0 0 return _store(\&net_pstore, @_, 1);
249             }
250              
251             # Internal store to file routine
252             sub _store {
253 96     96   158 my $xsptr = shift;
254 96         138 my $self = shift;
255 96         171 my ($file, $use_locking) = @_;
256 96 50       253 logcroak "not a reference" unless ref($self);
257 96 50       197 logcroak "wrong argument number" unless @_ == 2; # No @foo in arglist
258 96         214 local *FILE;
259 96 100       222 if ($use_locking) {
260 1 50       89 open(FILE, ">>", $file) || logcroak "can't write into $file: $!";
261 1 50       4 unless (&CAN_FLOCK) {
262 0         0 logcarp
263             "Storable::lock_store: fcntl/flock emulation broken on $^O";
264 0         0 return undef;
265             }
266 1 50       12 flock(FILE, LOCK_EX) ||
267             logcroak "can't get exclusive lock on $file: $!";
268 1         27 truncate FILE, 0;
269             # Unlocking will happen when FILE is closed
270             } else {
271 95 50       4909 open(FILE, ">", $file) || logcroak "can't create $file: $!";
272             }
273 96         338 binmode FILE; # Archaic systems...
274 96         179 my $da = $@; # Don't mess if called from exception handler
275 96         134 my $ret;
276             # Call C routine nstore or pstore, depending on network order
277 96     1   131 eval { $ret = &$xsptr(*FILE, $self) };
  96     1   2529  
  1     1   6  
  1     1   1  
  1     1   22  
  1     1   5  
  1     1   1  
  1     1   18  
  1     1   4  
  1     1   2  
  1     1   18  
  1     1   4  
  1     1   2  
  1     1   16  
  1         5  
  1         1  
  1         28  
  1         5  
  1         18  
  1         285  
  1         6  
  1         12  
  1         785  
  1         7  
  1         1  
  1         22  
  1         5  
  1         1  
  1         17  
  1         5  
  1         1  
  1         17  
  1         5  
  1         1  
  1         16  
  1         4  
  1         1  
  1         26  
  1         6  
  1         17  
  1         280  
  1         6  
  1         12  
  1         736  
278             # close will return true on success, so the or short-circuits, the ()
279             # expression is true, and for that case the block will only be entered
280             # if $@ is true (ie eval failed)
281             # if close fails, it returns false, $ret is altered, *that* is (also)
282             # false, so the () expression is false, !() is true, and the block is
283             # entered.
284 96 100 50     4866 if (!(close(FILE) or undef $ret) || $@) {
      66        
285 1 50       51 unlink($file) or warn "Can't unlink $file: $!\n";
286             }
287 96 100       343 logcroak $@ if $@ =~ s/\.?\n$/,/;
288 95         168 $@ = $da;
289 95         504 return $ret;
290             }
291              
292             #
293             # store_fd
294             #
295             # Same as store, but perform on an already opened file descriptor instead.
296             # Returns undef if an I/O error occurred.
297             #
298             sub store_fd {
299 1     1 0 4 return _store_fd(\&pstore, @_);
300             }
301              
302             #
303             # nstore_fd
304             #
305             # Same as store_fd, but in network order.
306             #
307             sub nstore_fd {
308 2     2 0 4 my ($self, $file) = @_;
309 2         5 return _store_fd(\&net_pstore, @_);
310             }
311              
312             # Internal store routine on opened file descriptor
313             sub _store_fd {
314 3     3   4 my $xsptr = shift;
315 3         5 my $self = shift;
316 3         4 my ($file) = @_;
317 3 50       7 logcroak "not a reference" unless ref($self);
318 3 50       6 logcroak "too many arguments" unless @_ == 1; # No @foo in arglist
319 3         6 my $fd = fileno($file);
320 3 50       7 logcroak "not a valid file descriptor" unless defined $fd;
321 3         4 my $da = $@; # Don't mess if called from exception handler
322 3         3 my $ret;
323             # Call C routine nstore or pstore, depending on network order
324 3         4 eval { $ret = &$xsptr($file, $self) };
  3         107  
325 3 50       12 logcroak $@ if $@ =~ s/\.?\n$/,/;
326 3         8 local $\; print $file ''; # Autoflush the file if wanted
  3         7  
327 3         4 $@ = $da;
328 3         13 return $ret;
329             }
330              
331             #
332             # freeze
333             #
334             # Store object and its hierarchy in memory and return a scalar
335             # containing the result.
336             #
337             sub freeze {
338 167     167 0 290410 _freeze(\&mstore, @_);
339             }
340              
341             #
342             # nfreeze
343             #
344             # Same as freeze but in network order.
345             #
346             sub nfreeze {
347 45     45 0 50572 _freeze(\&net_mstore, @_);
348             }
349              
350             # Internal freeze routine
351             sub _freeze {
352 212     212   351 my $xsptr = shift;
353 212         279 my $self = shift;
354 212 50       515 logcroak "not a reference" unless ref($self);
355 212 50       443 logcroak "too many arguments" unless @_ == 0; # No @foo in arglist
356 212         309 my $da = $@; # Don't mess if called from exception handler
357 212         258 my $ret;
358             # Call C routine mstore or net_mstore, depending on network order
359 212     4   265 eval { $ret = &$xsptr($self) };
  212     4   10029  
  4     4   30  
  4     4   30  
  4     3   1264  
  4     2   24  
  4     1   25  
  4     1   1294  
  4     1   23  
  4     1   27  
  4     1   1164  
  4     1   24  
  4     1   57  
  4     1   2761  
  3     1   20  
  3     1   36  
  3     1   10811  
  2     1   16  
  2     1   6  
  2     1   65  
  1     1   6  
  1     1   13  
  1     1   775  
  1     1   6  
  1     1   18  
  1     1   288  
  1     1   6  
  1     1   28  
  1     1   868  
  1     1   10  
  1     1   19  
  1     2   740  
  1     1   7  
  1     1   12  
  1     1   854  
  1     1   7  
  1     1   13  
  1     1   9691  
  1     1   6  
  1     1   13  
  1     1   740  
  1     1   7  
  1     1   11  
  1     1   227  
  1         6  
  1         13  
  1         240  
  1         5  
  1         18  
  1         741  
  1         5  
  1         14  
  1         716  
  1         7  
  1         12  
  1         757  
  1         6  
  1         13  
  1         700  
  1         6  
  1         16  
  1         280  
  1         6  
  1         17  
  1         9621  
  1         7  
  1         23  
  1         367  
  1         5  
  1         15  
  1         778  
  1         11  
  1         22  
  1         427  
  1         7  
  1         11  
  1         875  
  1         7  
  1         12  
  1         701  
  1         6  
  1         11  
  1         727  
  1         6  
  1         11  
  1         700  
  1         6  
  1         11  
  1         866  
  1         7  
  1         11  
  1         9031  
  1         6  
  1         16  
  1         756  
  2         16  
  2         4  
  2         54  
  1         6  
  1         12  
  1         711  
  1         5  
  1         3  
  1         19  
  1         6  
  1         12  
  1         738  
  1         5  
  1         2  
  1         20  
  1         5  
  1         12  
  1         729  
  1         6  
  1         2  
  1         21  
  1         5  
  1         2  
  1         22  
  1         6  
  1         2  
  1         20  
  1         6  
  1         2  
  1         19  
  1         6  
  1         2  
  1         27  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         24  
360 212 100       2291 logcroak $@ if $@ =~ s/\.?\n$/,/;
361 208         344 $@ = $da;
362 208 50       763 return $ret ? $ret : undef;
363             }
364              
365             #
366             # retrieve
367             #
368             # Retrieve object hierarchy from disk, returning a reference to the root
369             # object of that tree.
370             #
371             # retrieve(file, flags)
372             # flags include by default BLESS_OK=2 | TIE_OK=4
373             # with flags=0 or the global $Storable::flags set to 0, no resulting object
374             # will be blessed nor tied.
375             #
376             sub retrieve {
377 186     186 0 146759 _retrieve(shift, 0, @_);
378             }
379              
380             #
381             # lock_retrieve
382             #
383             # Same as retrieve, but with advisory locking.
384             #
385             sub lock_retrieve {
386 1     1 0 485 _retrieve(shift, 1, @_);
387             }
388              
389             # Internal retrieve routine
390             sub _retrieve {
391 187     187   423 my ($file, $use_locking, $flags) = @_;
392 187 50       463 $flags = $Storable::flags unless defined $flags;
393 187         232 my $FILE;
394 187 50       3553 open($FILE, "<", $file) || logcroak "can't open $file: $!";
395 187         439 binmode $FILE; # Archaic systems...
396 187         212 my $self;
397 187         260 my $da = $@; # Could be from exception handler
398 187 100       341 if ($use_locking) {
399 1 50       4 unless (&CAN_FLOCK) {
400 0         0 logcarp
401             "Storable::lock_store: fcntl/flock emulation broken on $^O";
402 0         0 return undef;
403             }
404 1 50       8 flock($FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!";
405             # Unlocking will happen when FILE is closed
406             }
407 187     1   236 eval { $self = pretrieve($FILE, $flags) }; # Call C routine
  187     1   2721  
  1     1   7  
  1     1   12  
  1     1   749  
  1     1   6  
  1     1   12  
  1     1   748  
  1     1   7  
  1     1   12  
  1         830  
  1         6  
  1         12  
  1         829  
  1         6  
  1         12  
  1         9087  
  1         6  
  1         11  
  1         728  
  1         7  
  1         11  
  1         746  
  1         6  
  1         11  
  1         692  
  1         6  
  1         11  
  1         777  
  1         6  
  1         11  
  1         9149  
408 187         1155 close($FILE);
409 187 100       793 logcroak $@ if $@ =~ s/\.?\n$/,/;
410 141         198 $@ = $da;
411 141         680 return $self;
412             }
413              
414             #
415             # fd_retrieve
416             #
417             # Same as retrieve, but perform from an already opened file descriptor instead.
418             #
419             sub fd_retrieve {
420 8     8 0 8024 my ($file, $flags) = @_;
421 8 50       24 $flags = $Storable::flags unless defined $flags;
422 8         14 my $fd = fileno($file);
423 8 50       18 logcroak "not a valid file descriptor" unless defined $fd;
424 8         9 my $self;
425 8         9 my $da = $@; # Could be from exception handler
426 8         10 eval { $self = pretrieve($file, $flags) }; # Call C routine
  8         10647  
427 8 100       74 logcroak $@ if $@ =~ s/\.?\n$/,/;
428 4         7 $@ = $da;
429 4         19 return $self;
430             }
431              
432 0     0 0 0 sub retrieve_fd { &fd_retrieve } # Backward compatibility
433              
434             #
435             # thaw
436             #
437             # Recreate objects in memory from an existing frozen image created
438             # by freeze. If the frozen image passed is undef, return undef.
439             #
440             # thaw(frozen_obj, flags)
441             # flags include by default BLESS_OK=2 | TIE_OK=4
442             # with flags=0 or the global $Storable::flags set to 0, no resulting object
443             # will be blessed nor tied.
444             #
445             sub thaw {
446 309     309 0 203385 my ($frozen, $flags) = @_;
447 309 50       748 $flags = $Storable::flags unless defined $flags;
448 309 50       593 return undef unless defined $frozen;
449 309         355 my $self;
450 309         373 my $da = $@; # Could be from exception handler
451 309     5   361 eval { $self = mretrieve($frozen, $flags) };# Call C routine
  309     5   4056  
  5     2   350  
  5     1   50  
  5     1   1372  
  5     1   89  
  5     1   37  
  5     1   1402  
  2     1   16  
  2     1   6  
  2     1   55  
  1     1   8  
  1     1   19  
  1         258  
  1         5  
  1         13  
  1         59  
  1         7  
  1         14  
  1         714  
  1         7  
  1         11  
  1         740  
  1         6  
  1         12  
  1         754  
  1         6  
  1         11  
  1         722  
  1         5  
  1         12  
  1         718  
  1         5  
  1         12  
  1         768  
  1         5  
  1         12  
  1         782  
  1         5  
  1         12  
  1         749  
452 309 100       14526 logcroak $@ if $@ =~ s/\.?\n$/,/;
453 258         351 $@ = $da;
454 258         780 return $self;
455             }
456              
457             1;
458             __END__