This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Switch Storable to IO::File from FileHandle, only load if needed
[perl5.git] / dist / Storable / Storable.pm
diff --git a/dist/Storable/Storable.pm b/dist/Storable/Storable.pm
index 2b1acb4..44b85db 100644 (file)
--- a/dist/Storable/Storable.pm
+++ b/dist/Storable/Storable.pm
@@ -5,9 +5,9 @@
 #  in the README file that comes with the distribution.
 #
 
 #  in the README file that comes with the distribution.
 #
 
-require DynaLoader;
+require XSLoader;
 require Exporter;
 require Exporter;
-package Storable; @ISA = qw(Exporter DynaLoader);
+package Storable; @ISA = qw(Exporter);
 
 @EXPORT = qw(store retrieve);
 @EXPORT_OK = qw(
 
 @EXPORT = qw(store retrieve);
 @EXPORT_OK = qw(
@@ -19,23 +19,30 @@ package Storable; @ISA = qw(Exporter DynaLoader);
         file_magic read_magic
 );
 
         file_magic read_magic
 );
 
-use AutoLoader;
-use FileHandle;
 use vars qw($canonical $forgive_me $VERSION);
 
 use vars qw($canonical $forgive_me $VERSION);
 
-$VERSION = '2.21';
-*AUTOLOAD = \&AutoLoader::AUTOLOAD;            # Grrr...
+$VERSION = '2.27';
 
 
-#
-# Use of Log::Agent is optional
-#
+BEGIN {
+    if (eval { local $SIG{__DIE__}; require Log::Agent; 1 }) {
+        Log::Agent->import;
+    }
+    #
+    # Use of Log::Agent is optional. If it hasn't imported these subs then
+    # provide a fallback implementation.
+    #
+    else {
+        require Carp;
 
 
-{
-    local $SIG{__DIE__};
-    eval "use Log::Agent";
-}
+        *logcroak = sub {
+            Carp::croak(@_);
+        };
 
 
-require Carp;
+        *logcarp = sub {
+          Carp::carp(@_);
+        };
+    }
+}
 
 #
 # They might miss :flock in Fcntl
 
 #
 # They might miss :flock in Fcntl
@@ -57,28 +64,12 @@ sub CLONE {
     Storable::init_perinterp();
 }
 
     Storable::init_perinterp();
 }
 
-# Can't Autoload cleanly as this clashes 8.3 with &retrieve
-sub retrieve_fd { &fd_retrieve }               # Backward compatibility
-
 # By default restricted hashes are downgraded on earlier perls.
 
 $Storable::downgrade_restricted = 1;
 $Storable::accept_future_minor = 1;
 # By default restricted hashes are downgraded on earlier perls.
 
 $Storable::downgrade_restricted = 1;
 $Storable::accept_future_minor = 1;
-bootstrap Storable;
-1;
-__END__
-#
-# Use of Log::Agent is optional. If it hasn't imported these subs then
-# Autoloader will kindly supply our fallback implementation.
-#
-
-sub logcroak {
-    Carp::croak(@_);
-}
 
 
-sub logcarp {
-  Carp::carp(@_);
-}
+XSLoader::load 'Storable', $Storable::VERSION;
 
 #
 # Determine whether locking is possible, but only when needed.
 
 #
 # Determine whether locking is possible, but only when needed.
@@ -116,8 +107,10 @@ EOM
 }
 
 sub file_magic {
 }
 
 sub file_magic {
+    require IO::File;
+
     my $file = shift;
     my $file = shift;
-    my $fh = new FileHandle;
+    my $fh = IO::File->new;
     open($fh, "<". $file) || die "Can't open '$file': $!";
     binmode($fh);
     defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!";
     open($fh, "<". $file) || die "Can't open '$file': $!";
     binmode($fh);
     defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!";
@@ -151,14 +144,14 @@ sub read_magic {
        $net_order = 0;
     }
     else {
        $net_order = 0;
     }
     else {
-       $net_order = ord(substr($buf, 0, 1, ""));
-       my $major = $net_order >> 1;
+       $buf =~ s/(.)//s;
+       my $major = (ord $1) >> 1;
        return undef if $major > 4; # sanity (assuming we never go that high)
        $info{major} = $major;
        return undef if $major > 4; # sanity (assuming we never go that high)
        $info{major} = $major;
-       $net_order &= 0x01;
+       $net_order = (ord $1) & 0x01;
        if ($major > 1) {
        if ($major > 1) {
-           return undef unless length($buf);
-           my $minor = ord(substr($buf, 0, 1, ""));
+           return undef unless $buf =~ s/(.)//s;
+           my $minor = ord $1;
            $info{minor} = $minor;
            $info{version} = "$major.$minor";
            $info{version_nv} = sprintf "%d.%03d", $major, $minor;
            $info{minor} = $minor;
            $info{version} = "$major.$minor";
            $info{version_nv} = sprintf "%d.%03d", $major, $minor;
@@ -171,17 +164,16 @@ sub read_magic {
     $info{netorder} = $net_order;
 
     unless ($net_order) {
     $info{netorder} = $net_order;
 
     unless ($net_order) {
-       return undef unless length($buf);
-       my $len = ord(substr($buf, 0, 1, ""));
+       return undef unless $buf =~ s/(.)//s;
+       my $len = ord $1;
        return undef unless length($buf) >= $len;
        return undef unless $len == 4 || $len == 8;  # sanity
        return undef unless length($buf) >= $len;
        return undef unless $len == 4 || $len == 8;  # sanity
-       $info{byteorder} = substr($buf, 0, $len, "");
-       $info{intsize} = ord(substr($buf, 0, 1, ""));
-       $info{longsize} = ord(substr($buf, 0, 1, ""));
-       $info{ptrsize} = ord(substr($buf, 0, 1, ""));
+       @info{qw(byteorder intsize longsize ptrsize)}
+           = unpack "a${len}CCC", $buf;
+       (substr $buf, 0, $len + 3) = '';
        if ($info{version_nv} >= 2.002) {
        if ($info{version_nv} >= 2.002) {
-           return undef unless length($buf);
-           $info{nvsize} = ord(substr($buf, 0, 1, ""));
+           return undef unless $buf =~ s/(.)//s;
+           $info{nvsize} = ord $1;
        }
     }
     $info{hdrsize} = $buflen - length($buf);
        }
     }
     $info{hdrsize} = $buflen - length($buf);
@@ -262,11 +254,18 @@ sub _store {
        my $ret;
        # Call C routine nstore or pstore, depending on network order
        eval { $ret = &$xsptr(*FILE, $self) };
        my $ret;
        # Call C routine nstore or pstore, depending on network order
        eval { $ret = &$xsptr(*FILE, $self) };
-       close(FILE) or $ret = undef;
-       unlink($file) or warn "Can't unlink $file: $!\n" if $@ || !defined $ret;
+       # close will return true on success, so the or short-circuits, the ()
+       # expression is true, and for that case the block will only be entered
+       # if $@ is true (ie eval failed)
+       # if close fails, it returns false, $ret is altered, *that* is (also)
+       # false, so the () expression is false, !() is true, and the block is
+       # entered.
+       if (!(close(FILE) or undef $ret) || $@) {
+               unlink($file) or warn "Can't unlink $file: $!\n";
+       }
        logcroak $@ if $@ =~ s/\.?\n$/,/;
        $@ = $da;
        logcroak $@ if $@ =~ s/\.?\n$/,/;
        $@ = $da;
-       return $ret ? $ret : undef;
+       return $ret;
 }
 
 #
 }
 
 #
@@ -305,7 +304,7 @@ sub _store_fd {
        logcroak $@ if $@ =~ s/\.?\n$/,/;
        local $\; print $file '';       # Autoflush the file if wanted
        $@ = $da;
        logcroak $@ if $@ =~ s/\.?\n$/,/;
        local $\; print $file '';       # Autoflush the file if wanted
        $@ = $da;
-       return $ret ? $ret : undef;
+       return $ret;
 }
 
 #
 }
 
 #
@@ -401,6 +400,8 @@ sub fd_retrieve {
        return $self;
 }
 
        return $self;
 }
 
+sub retrieve_fd { &fd_retrieve }               # Backward compatibility
+
 #
 # thaw
 #
 #
 # thaw
 #
@@ -908,7 +909,7 @@ version of Storable fully support (but see discussion of
 C<$Storable::accept_future_minor> above).  The constant
 C<Storable::BIN_WRITE_VERSION_NV> function returns what file version
 is written and might be less than C<Storable::BIN_VERSION_NV> in some
 C<$Storable::accept_future_minor> above).  The constant
 C<Storable::BIN_WRITE_VERSION_NV> function returns what file version
 is written and might be less than C<Storable::BIN_VERSION_NV> in some
-configuations.
+configurations.
 
 =item C<major>, C<minor>
 
 
 =item C<major>, C<minor>
 
@@ -1045,7 +1046,7 @@ your data.  There is no slowdown on retrieval.
 
 =head1 BUGS
 
 
 =head1 BUGS
 
-You can't store GLOB, FORMLINE, etc.... If you can define semantics
+You can't store GLOB, FORMLINE, REGEXP, etc.... If you can define semantics
 for those operations, feel free to enhance Storable so that it can
 deal with them.
 
 for those operations, feel free to enhance Storable so that it can
 deal with them.
 
@@ -1147,7 +1148,7 @@ Thank you to (in chronological order):
 
        Jarkko Hietaniemi <jhi@iki.fi>
        Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
 
        Jarkko Hietaniemi <jhi@iki.fi>
        Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
-       Benjamin A. Holzman <bah@ecnvantage.com>
+       Benjamin A. Holzman <bholzman@earthlink.net>
        Andrew Ford <A.Ford@ford-mason.co.uk>
        Gisle Aas <gisle@aas.no>
        Jeff Gresham <gresham_jeffrey@jpmorgan.com>
        Andrew Ford <A.Ford@ford-mason.co.uk>
        Gisle Aas <gisle@aas.no>
        Jeff Gresham <gresham_jeffrey@jpmorgan.com>
@@ -1158,6 +1159,7 @@ Thank you to (in chronological order):
        Salvador Ortiz Garcia <sog@msg.com.mx>
        Dominic Dunlop <domo@computer.org>
        Erik Haugan <erik@solbors.no>
        Salvador Ortiz Garcia <sog@msg.com.mx>
        Dominic Dunlop <domo@computer.org>
        Erik Haugan <erik@solbors.no>
+    Benjamin A. Holzman <ben.holzman@grantstreet.com>
 
 for their bug reports, suggestions and contributions.
 
 
 for their bug reports, suggestions and contributions.
 
@@ -1169,7 +1171,9 @@ simply counting the objects instead of tagging them (leading to
 a binary incompatibility for the Storable image starting at version
 0.6--older images are, of course, still properly understood).
 Murray Nesbitt made Storable thread-safe.  Marc Lehmann added overloading
 a binary incompatibility for the Storable image starting at version
 0.6--older images are, of course, still properly understood).
 Murray Nesbitt made Storable thread-safe.  Marc Lehmann added overloading
-and references to tied items support.
+and references to tied items support.  Benjamin Holzman added a performance
+improvement for overloaded classes; thanks to Grant Street Group for footing
+the bill.
 
 =head1 AUTHOR
 
 
 =head1 AUTHOR
 
Unnamed repository; edit this file 'description' to name the repository.