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__ |