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