| 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 |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 29µs | 29µs | Storable::BEGIN@44 |
| 1 | 1 | 1 | 6µs | 8µs | Storable::BEGIN@487 |
| 1 | 1 | 1 | 6µs | 6µs | Encode::BEGIN@11 |
| 1 | 1 | 1 | 6µs | 133µs | Storable::BEGIN@109 |
| 1 | 1 | 1 | 4µs | 16µs | Storable::BEGIN@66 |
| 1 | 1 | 1 | 4µs | 25µs | Storable::BEGIN@42 |
| 1 | 1 | 1 | 4µs | 63µs | Storable::BEGIN@83 |
| 1 | 1 | 1 | 2µs | 2µs | Storable::BEGIN@30 |
| 0 | 0 | 0 | 0s | 0s | Storable::BIN_VERSION_NV |
| 0 | 0 | 0 | 0s | 0s | Storable::BIN_WRITE_VERSION_NV |
| 0 | 0 | 0 | 0s | 0s | Storable::CLONE |
| 0 | 0 | 0 | 0s | 0s | Storable::__ANON__[:72] |
| 0 | 0 | 0 | 0s | 0s | Storable::_freeze |
| 0 | 0 | 0 | 0s | 0s | Storable::_make_re |
| 0 | 0 | 0 | 0s | 0s | Storable::_retrieve |
| 0 | 0 | 0 | 0s | 0s | Storable::_store |
| 0 | 0 | 0 | 0s | 0s | Storable::_store_fd |
| 0 | 0 | 0 | 0s | 0s | Storable::fd_retrieve |
| 0 | 0 | 0 | 0s | 0s | Storable::file_magic |
| 0 | 0 | 0 | 0s | 0s | Storable::freeze |
| 0 | 0 | 0 | 0s | 0s | Storable::lock_nstore |
| 0 | 0 | 0 | 0s | 0s | Storable::lock_retrieve |
| 0 | 0 | 0 | 0s | 0s | Storable::lock_store |
| 0 | 0 | 0 | 0s | 0s | Storable::nfreeze |
| 0 | 0 | 0 | 0s | 0s | Storable::nstore |
| 0 | 0 | 0 | 0s | 0s | Storable::nstore_fd |
| 0 | 0 | 0 | 0s | 0s | Storable::read_magic |
| 0 | 0 | 0 | 0s | 0s | Storable::retrieve |
| 0 | 0 | 0 | 0s | 0s | Storable::retrieve_fd |
| 0 | 0 | 0 | 0s | 0s | Storable::show_file_magic |
| 0 | 0 | 0 | 0s | 0s | Storable::store |
| 0 | 0 | 0 | 0s | 0s | Storable::store_fd |
| 0 | 0 | 0 | 0s | 0s | Storable::thaw |
| 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 # 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 | ||||
| 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 # 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 | ||||
| 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 # 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 | ||||
| 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 # 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 | ||||
| 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__ |