X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FStorable%2FStorable.pm;h=dd02fe64fe120c6fce805612f4494a0915f085d9;hb=2018a5c31a07546d28320839d66a2fd3f203fa85;hp=712f597747855e9f61893e10c0e44de16d9885a3;hpb=2711d9fbc9d348da12bba04fd69c8ee78a0bb77a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 712f597..dd02fe6 100644 --- a/ext/Storable/Storable.pm +++ b/ext/Storable/Storable.pm @@ -16,12 +16,13 @@ package Storable; @ISA = qw(Exporter DynaLoader); dclone retrieve_fd lock_store lock_nstore lock_retrieve + file_magic read_magic ); use AutoLoader; use vars qw($canonical $forgive_me $VERSION); -$VERSION = '2.15_01'; +$VERSION = '2.15_02'; *AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr... # @@ -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 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. If +the file does not exist or is unreadable then croak. + +The hash returned has the following elements: + +=over + +=item C + +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 + +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 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 function returns what file version +is written and might be less than C in some +configuations. + +=item C, C + +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 + +The is the number of bytes that the Storable header occupies. + +=item C + +This is TRUE if the image store data in network order. This means +that it was created with nstore() or similar. + +=item C + +This is only present when C 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, C, C, C + +These are only present when C 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 element is only present for file format v2.2 and +higher. + +=item C + +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 is returned. + +The hash has the same structure as the one returned by +Storable::file_magic(). The C element is true if the image is a +file image. + +If the $must_be_file argument is provided and is TRUE, then return +C 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: