Re: [PATCH] Enhanced Storable::read_magic()

Message-ID: <lrhdah7eoc.fsf@caliper.activestate.com>

p4raw-id: //depot/perl@26107

1 files changed, 180 insertions, 32 deletions

diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm
index 1e0f5905b4..dd02fe64fe 100644
--- a/ext/Storable/Storable.pm
+++ b/ext/Storable/Storable.pm
@@ -16,6 +16,7 @@ package Storable; @ISA = qw(Exporter DynaLoader);
 	dclone
 	retrieve_fd
 	lock_store lock_nstore lock_retrieve
+        file_magic read_magic
 );
 
 use AutoLoader;
@@ -113,39 +114,85 @@ sub show_file_magic {
 EOM
 }
 
+sub file_magic {
+    my $file = shift;
+    open(my $fh, "<", $file) || die "Can't open '$file': $!";
+    binmode($fh);
+    defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!";
+    close($fh);
+
+    $file = "./$file" unless $file;  # ensure TRUE value
+
+    return read_magic($buf, $file);
+}
+
 sub read_magic {
-  my $header = shift;
-  return unless defined $header and length $header > 11;
-  my $result;
-  if ($header =~ s/^perl-store//) {
-    die "Can't deal with version 0 headers";
-  } elsif ($header =~ s/^pst0//) {
-    $result->{file} = 1;
-  }
-  # Assume it's a string.
-  my ($major, $minor, $bytelen) = unpack "C3", $header;
-
-  my $net_order = $major & 1;
-  $major >>= 1;
-  @$result{qw(major minor netorder)} = ($major, $minor, $net_order);
-
-  return $result if $net_order;
-
-  # I assume that it is rare to find v1 files, so this is an intentionally
-  # inefficient way of doing it, to make the rest of the code constant.
-  if ($major < 2) {
-    delete $result->{minor};
-    $header = '.' . $header;
-    $bytelen = $minor;
-  }
-
-  @$result{qw(byteorder intsize longsize ptrsize)} =
-    unpack "x3 A$bytelen C3", $header;
-
-  if ($major >= 2 and $minor >= 2) {
-    $result->{nvsize} = unpack "x6 x$bytelen C", $header;
-  }
-  $result;
+    my($buf, $file) = @_;
+    my %info;
+
+    my $buflen = length($buf);
+    my $magic;
+    if ($buf =~ s/^(pst0|perl-store)//) {
+	$magic = $1;
+	$info{file} = $file || 1;
+    }
+    else {
+	return undef if $file;
+	$magic = "";
+    }
+
+    return undef unless length($buf);
+
+    my $net_order;
+    if ($magic eq "perl-store" && ord(substr($buf, 0, 1)) > 1) {
+	$info{version} = -1;
+	$net_order = 0;
+    }
+    else {
+	$net_order = ord(substr($buf, 0, 1, ""));
+	my $major = $net_order >> 1;
+	return undef if $major > 4; # sanity (assuming we never go that high)
+	$info{major} = $major;
+	$net_order &= 0x01;
+	if ($major > 1) {
+	    return undef unless length($buf);
+	    my $minor = ord(substr($buf, 0, 1, ""));
+	    $info{minor} = $minor;
+	    $info{version} = "$major.$minor";
+	    $info{version_nv} = sprintf "%d.%03d", $major, $minor;
+	}
+	else {
+	    $info{version} = $major;
+	}
+    }
+    $info{version_nv} ||= $info{version};
+    $info{netorder} = $net_order;
+
+    unless ($net_order) {
+	return undef unless length($buf);
+	my $len = ord(substr($buf, 0, 1, ""));
+	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, ""));
+	if ($info{version_nv} >= 2.002) {
+	    return undef unless length($buf);
+	    $info{nvsize} = ord(substr($buf, 0, 1, ""));
+	}
+    }
+    $info{hdrsize} = $buflen - length($buf);
+
+    return \%info;
+}
+
+sub BIN_VERSION_NV {
+    sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR();
+}
+
+sub BIN_WRITE_VERSION_NV {
+    sprintf "%d.%03d", BIN_MAJOR(), BIN_WRITE_MINOR();
 }
 
 #
@@ -820,6 +867,107 @@ implementation of the C<file> utility, version 3.38 or later,
 is expected to contain support for recognising Storable files
 out-of-the-box, in addition to other kinds of Perl files.
 
+You can also use the following functions to extract the file header
+information from Storable images:
+
+=over
+
+=item $info = Storable::file_magic( $filename )
+
+If the given file is a Storable image return a hash describing it.  If
+the file is readable, but not a Storable image return C<undef>.  If
+the file does not exist or is unreadable then croak.
+
+The hash returned has the following elements:
+
+=over
+
+=item C<version>
+
+This returns the file format version.  It is a string like "2.7".
+
+Note that this version number is not the same as the version number of
+the Storable module itself.  For instance Storable v0.7 create files
+in format v2.0 and Storable v2.15 create files in format v2.7.  The
+file format version number only increment when additional features
+that would confuse older versions of the module are added.
+
+Files older than v2.0 will have the one of the version numbers "-1",
+"0" or "1".  No minor number was used at that time.
+
+=item C<version_nv>
+
+This returns the file format version as number.  It is a string like
+"2.007".  This value is suitable for numeric comparisons.
+
+The constant function C<Storable::BIN_VERSION_NV> returns a comparable
+number that represent the highest file version number that this
+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
+configuations.
+
+=item C<major>, C<minor>
+
+This also returns the file format version.  If the version is "2.7"
+then major would be 2 and minor would be 7.  The minor element is
+missing for when major is less than 2.
+
+=item C<hdrsize>
+
+The is the number of bytes that the Storable header occupies.
+
+=item C<netorder>
+
+This is TRUE if the image store data in network order.  This means
+that it was created with nstore() or similar.
+
+=item C<byteorder>
+
+This is only present when C<netorder> is FALSE.  It is the
+$Config{byteorder} string of the perl that created this image.  It is
+a string like "1234" (32 bit little endian) or "87654321" (64 bit big
+endian).  This must match the current perl for the image to be
+readable by Storable.
+
+=item C<intsize>, C<longsize>, C<ptrsize>, C<nvsize>
+
+These are only present when C<netorder> is FALSE. These are the sizes of
+various C datatypes of the perl that created this image.  These must
+match the current perl for the image to be readable by Storable.
+
+The C<nvsize> element is only present for file format v2.2 and
+higher.
+
+=item C<file>
+
+The name of the file.
+
+=back
+
+=item $info = Storable::read_magic( $buffer )
+
+=item $info = Storable::read_magic( $buffer, $must_be_file )
+
+The $buffer should be a Storable image or the first few bytes of it.
+If $buffer starts with a Storable header, then a hash describing the
+image is returned, otherwise C<undef> is returned.
+
+The hash has the same structure as the one returned by
+Storable::file_magic().  The C<file> element is true if the image is a
+file image.
+
+If the $must_be_file argument is provided and is TRUE, then return
+C<undef> unless the image looks like it belongs to a file dump.
+
+The maximum size of a Storable header is currently 21 bytes.  If the
+provided $buffer is only the first part of a Storable image it should
+at least be this long to ensure that read_magic() will recognize it as
+such.
+
+=back
+
 =head1 EXAMPLES
 
 Here are some code samples showing a possible usage of Storable: