From a2307be4b899f5bb1ef09b534ea96c8d5ffd7a73 Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Tue, 8 Oct 2002 00:35:34 +0100 Subject: [PATCH] Storable 2.06 (was Re: Bug in ext/Storable/t/integer.t) Message-ID: <20021007223534.GD286@Bagpuss.unfortu.net> p4raw-id: //depot/perl@18008 --- ext/Storable/ChangeLog | 20 ++++++++++++++++++++ ext/Storable/Makefile.PL | 3 ++- ext/Storable/README | 2 +- ext/Storable/Storable.pm | 5 ++++- ext/Storable/Storable.xs | 17 ++++++++++++++++- ext/Storable/t/downgrade.t | 17 +++++------------ ext/Storable/t/forgive.t | 3 +++ ext/Storable/t/integer.t | 23 ++++++++++++++++------- ext/Storable/t/malice.t | 16 ++++++++++------ ext/Storable/t/restrict.t | 11 ++++++++--- 10 files changed, 85 insertions(+), 32 deletions(-) diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog index 16bc783..74bad2e 100644 --- a/ext/Storable/ChangeLog +++ b/ext/Storable/ChangeLog @@ -1,3 +1,23 @@ +Mon Oct 7 21:56:38 BST 2002 Nicholas Clark + + Version 2.06 + + Remove qr// from t/downgrade.t so that it will run on 5.004 + Mention $File::Spec::VERSION a second time in t/forgive.t so that it + runs without warnings in 5.004 (this may be a 5.00405 bug I'm working + round) + Fix t/integer.t initialisation to actually generate 64 bits of 9c + Fix comparison tests to use eval to get around 64 bit IV conversion + issues on 5.6.x, following my t/integer.t ^ precedence bug found by + Rafael Garcia-Suarez + Alter t/malice.t to work with Test/More.pm in t/, and skip individual + subtests that use $Config{ptrsize}, so that the rest of the test can + now be run with 5.004 + Change t/malice.t and the error message in check_magic in Storable.xs + from "Pointer integer size" to "Pointer size" + Remove prerequisite of Test::More from Makefile.PL + Ship Test::Builder, Test::Simple and Test::More in t + Thu Oct 3 08:57:22 IST 2002 Abhijit Menon-Sen Version 2.05 diff --git a/ext/Storable/Makefile.PL b/ext/Storable/Makefile.PL index 3ac71c8..60e1453 100644 --- a/ext/Storable/Makefile.PL +++ b/ext/Storable/Makefile.PL @@ -12,7 +12,8 @@ WriteMakefile( NAME => 'Storable', DISTNAME => "Storable", MAN3PODS => {}, - PREREQ_PM => { 'Test::More' => '0.41' }, +# We now ship this in t/ +# PREREQ_PM => { 'Test::More' => '0.41' }, INSTALLDIRS => 'perl', VERSION_FROM => 'Storable.pm', dist => { SUFFIX => 'gz', COMPRESS => 'gzip -f' }, diff --git a/ext/Storable/README b/ext/Storable/README index 2ed16d5..b0d5f1b 100644 --- a/ext/Storable/README +++ b/ext/Storable/README @@ -1,4 +1,4 @@ - Storable 1.015 + Storable 2.06 Copyright (c) 1995-2000, Raphael Manfredi Copyright (c) 2001,2002, Larry Wall diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 1283b79..1a62e62 100644 --- a/ext/Storable/Storable.pm +++ b/ext/Storable/Storable.pm @@ -21,7 +21,7 @@ package Storable; @ISA = qw(Exporter DynaLoader); use AutoLoader; use vars qw($canonical $forgive_me $VERSION); -$VERSION = '2.05'; +$VERSION = '2.06'; *AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr... # @@ -361,6 +361,9 @@ sub thaw { return $self; } +1; +__END__ + =head1 NAME Storable - persistence for Perl data structures diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index b7ddc73..efa441a 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -5348,7 +5348,7 @@ static SV *magic_check(stcxt_t *cxt) /* sizeof(char *) */ if ((int) *current != sizeof(char *)) - CROAK(("Pointer integer size is not compatible")); + CROAK(("Pointer size is not compatible")); if (use_NV_size) { /* sizeof(NV) */ @@ -5642,7 +5642,22 @@ static SV *do_retrieve( if (!sv) { TRACEME(("retrieve ERROR")); +#if (PATCHLEVEL <= 4) + /* perl 5.00405 seems to screw up at this point with an + 'attempt to modify a read only value' error reported in the + eval { $self = pretrieve(*FILE) } in _retrieve. + I can't see what the cause of this error is, but I suspect a + bug in 5.004, as it seems to be capable of issuing spurious + errors or core dumping with matches on $@. I'm not going to + spend time on what could be a fruitless search for the cause, + so here's a bodge. If you're running 5.004 and don't like + this inefficiency, either upgrade to a newer perl, or you are + welcome to find the problem and send in a patch. + */ + return newSV(0); +#else return &PL_sv_undef; /* Something went wrong, return undef */ +#endif } TRACEME(("retrieve got %s(0x%"UVxf")", diff --git a/ext/Storable/t/downgrade.t b/ext/Storable/t/downgrade.t index 2274dc9..a227360 100644 --- a/ext/Storable/t/downgrade.t +++ b/ext/Storable/t/downgrade.t @@ -9,13 +9,6 @@ # I ought to keep this test easily backwards compatible to 5.004, so no # qr//; -BEGIN { - if ($] < 5.005) { - print "1..0 # Skip: usage of qr//\n"; - exit 0; - } -} - # This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features # are encountered. @@ -67,8 +60,8 @@ if ($] > 5.007002) { plan tests => 67; } -$UTF8_CROAK = qr/^Cannot retrieve UTF8 data in non-UTF8 perl/; -$RESTRICTED_CROAK = qr/^Cannot retrieve restricted hash/; +$UTF8_CROAK = "/^Cannot retrieve UTF8 data in non-UTF8 perl/"; +$RESTRICTED_CROAK = "/^Cannot retrieve restricted hash/"; my %tests; { @@ -128,11 +121,11 @@ sub test_locked_hash { my @keys = keys %$hash; my ($key, $value) = each %$hash; eval {$hash->{$key} = reverse $value}; - like( $@, qr/^Modification of a read-only value attempted/, + like( $@, "/^Modification of a read-only value attempted/", 'trying to change a locked key' ); is ($hash->{$key}, $value, "hash should not change?"); eval {$hash->{use} = 'perl'}; - like( $@, qr/^Attempt to access disallowed key 'use' in a restricted hash/, + like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/", 'trying to add another key' ); ok (eq_array([keys %$hash], \@keys), "Still the same keys?"); } @@ -146,7 +139,7 @@ sub test_restricted_hash { 'trying to change a restricted key' ); is ($hash->{$key}, reverse ($value), "hash should change"); eval {$hash->{use} = 'perl'}; - like( $@, qr/^Attempt to access disallowed key 'use' in a restricted hash/, + like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/", 'trying to add another key' ); ok (eq_array([keys %$hash], \@keys), "Still the same keys?"); } diff --git a/ext/Storable/t/forgive.t b/ext/Storable/t/forgive.t index 65a2e4c..109ba83 100644 --- a/ext/Storable/t/forgive.t +++ b/ext/Storable/t/forgive.t @@ -29,6 +29,9 @@ use Storable qw(store retrieve); if (eval { require File::Spec; 1 } || $File::Spec::VERSION < 0.8) { print "1..0 # Skip: File::Spec 0.8 needed\n"; exit 0; + # Mention $File::Spec::VERSION again, as 5.00503's harness seems to have + # warnings on. + exit $File::Spec::VERSION; } print "1..8\n"; diff --git a/ext/Storable/t/integer.t b/ext/Storable/t/integer.t index 3d0c410..8b0e6c4 100644 --- a/ext/Storable/t/integer.t +++ b/ext/Storable/t/integer.t @@ -37,10 +37,10 @@ my $max_uv_m1 = ~0 ^ 1; # use integer. my $max_iv_p1 = $max_uv ^ ($max_uv >> 1); my $lots_of_9C = do { - my $temp = sprintf "%X", ~0; - $temp =~ s/FF/9C/g; + my $temp = sprintf "%#x", ~0; + $temp =~ s/ff/9c/g; local $^W; - hex $temp; + eval $temp; }; my $max_iv = ~0 >> 1; @@ -122,7 +122,7 @@ foreach (@processes) { foreach my $number (@numbers) { # as $number is an alias into @numbers, we don't want any side effects of # conversion macros affecting later runs, so pass a copy to Storable: - my $copy1 = my $copy0 = $number; + my $copy1 = my $copy2 = my $copy0 = $number; my $copy_s = &$sub (\$copy0); if (is (ref $copy_s, "SCALAR", "got back a scalar ref?")) { # Test inside use integer to see if the bit pattern is identical @@ -148,19 +148,28 @@ foreach (@processes) { # $eq = && (($copy_s1 <=> 0) == ($copy1 <=> 0)); # Split this into 2 tests, to cater for 5.005_03 - my $bit = ok (($copy_s1 ^ $copy1) == 0, "$process $copy1 (bitpattern)"); + # Aargh. Even this doesn't work because 5.6.x sends values with (same + # number of decimal digits as ~0 + 1) via atof. So ^ is getting strings + # cast to doubles cast to integers. And that truncates low order bits. + # my $bit = ok (($copy_s1 ^ $copy1) == 0, "$process $copy1 (bitpattern)"); + + # Oh well; at least the parser gets it right. :-) + my $copy_s3 = eval $copy_s1; + die "Was supposed to have number $copy_s3, got error $@" + unless defined $copy_s3; + my $bit = ok (($copy_s3 ^ $copy1) == 0, "$process $copy1 (bitpattern)"); # This is sick. 5.005_03 survives without the IV/UV flag, and somehow # gets it right, providing you don't have side effects of conversion. # local $TODO; # $TODO = "pre 5.6 doesn't have flag to distinguish IV/UV" # if $[ < 5.005_56 and $copy1 > $max_iv; - my $sign = ok (($copy_s2 <=> 0) == ($copy1 <=> 0), + my $sign = ok (($copy_s2 <=> 0) == ($copy2 <=> 0), "$process $copy1 (sign)"); unless ($bit and $sign) { printf "# Passed in %s (%#x, %i)\n# got back '%s' (%#x, %i)\n", $copy1, $copy1, $copy1, $copy_s1, $copy_s1, $copy_s1; - # use Devel::Peek; Dump $copy_s1; Dump $$copy_s; + # use Devel::Peek; Dump $number; Dump $copy1; Dump $copy_s1; } # unless ($bit) { use Devel::Peek; Dump $copy_s1; Dump $$copy_s; } } else { diff --git a/ext/Storable/t/malice.t b/ext/Storable/t/malice.t index 6d21776..0b667d9 100644 --- a/ext/Storable/t/malice.t +++ b/ext/Storable/t/malice.t @@ -17,16 +17,15 @@ sub BEGIN { if ($ENV{PERL_CORE}){ chdir('t') if -d 't'; @INC = ('.', '../lib'); + } else { + # This lets us distribute Test::More in t/ + unshift @INC, 't'; } require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } - if ($] < 5.005) { - print "1..0 # Skip: Config{ptrsize} not defined\n"; - exit 0; - } } use strict; @@ -88,7 +87,11 @@ sub test_header { is ($header->{byteorder}, $byteorder, "byte order"); is ($header->{intsize}, $Config{intsize}, "int size"); is ($header->{longsize}, $Config{longsize}, "long size"); - is ($header->{ptrsize}, $Config{ptrsize}, "long size"); + SKIP: { + skip ("No \$Config{prtsize} on this perl version ($])", 1) + unless defined $Config{ptrsize}; + is ($header->{ptrsize}, $Config{ptrsize}, "long size"); + } is ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8, "nv size"); # 5.00405 doesn't even have doublesize in config. } @@ -115,6 +118,7 @@ sub test_truncated { for my $i (0 .. length ($data) - 1) { my $short = substr $data, 0, $i; + # local $Storable::DEBUGME = 1; my $clone = &$sub($short); is (defined ($clone), '', "truncated $what to $i should fail"); if ($i < $magic_len) { @@ -213,7 +217,7 @@ sub test_things { $where = $file_magic + 3 + length $header->{byteorder}; foreach (['intsize', "Integer"], ['longsize', "Long integer"], - ['ptrsize', "Pointer integer"], + ['ptrsize', "Pointer"], ['nvsize', "Double"]) { my ($key, $name) = @$_; $copy = $contents; diff --git a/ext/Storable/t/restrict.t b/ext/Storable/t/restrict.t index 75c9d20..4ab6d86 100644 --- a/ext/Storable/t/restrict.t +++ b/ext/Storable/t/restrict.t @@ -16,9 +16,14 @@ sub BEGIN { exit 0; } } else { - unless (eval "require Hash::Util") { - if ($@ =~ /Can\'t locate Hash\/Util\.pm in \@INC/) { - print "1..0 # Skip: No Hash::Util\n"; + if ($[ < 5.005) { + print "1..0 # Skip: No Hash::Util pre 5.005\n"; + exit 0; + # And doing this seems on 5.004 seems to create bogus warnings about + # unitialized variables, or coredumps in Perl_pp_padsv + } elsif (!eval "require Hash::Util") { + if ($@ =~ /Can\'t locate Hash\/Util\.pm in \@INC/s) { + print "1..0 # Skip: No Hash::Util:\n"; exit 0; } else { die; -- 2.7.4