From: Nicholas Clark Date: Thu, 25 Apr 2002 22:41:57 +0000 (+0100) Subject: Re: [PATCH] another Storable test (Re: perl@16005) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=530b72baaecf6b4faf758663fc0fded0f4426004;p=p5sagit%2Fp5-mst-13.2.git Re: [PATCH] another Storable test (Re: perl@16005) Message-ID: <20020425214156.GB295@Bagpuss.unfortu.net> p4raw-id: //depot/perl@16172 --- diff --git a/MANIFEST b/MANIFEST index b9a3c83..72c4435 100644 --- a/MANIFEST +++ b/MANIFEST @@ -197,43 +197,33 @@ ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer ext/DynaLoader/README Dynamic Loader notes and intro ext/DynaLoader/XSLoader_pm.PL Simple XS Loader perl module ext/Encode/AUTHORS List of authors +ext/Encode/bin/enc2xs Encode module generator +ext/Encode/bin/piconv iconv by perl +ext/Encode/bin/ucm2table Table Generator for testing +ext/Encode/bin/ucmlint A UCM Lint utility +ext/Encode/bin/unidump Unicode Dump like hexdump(1) ext/Encode/Byte/Byte.pm Encode extension ext/Encode/Byte/Makefile.PL Encode extension +ext/Encode/Changes Change Log ext/Encode/CN/CN.pm Encode extension ext/Encode/CN/Makefile.PL Encode extension -ext/Encode/Changes Change Log ext/Encode/EBCDIC/EBCDIC.pm Encode extension ext/Encode/EBCDIC/Makefile.PL Encode extension +ext/Encode/encengine.c Encode extension ext/Encode/Encode.pm Mother of all Encode extensions ext/Encode/Encode.xs Encode extension ext/Encode/Encode/Changes.e2x Skeleton file for enc2xs ext/Encode/Encode/ConfigLocal_PM.e2x Skeleton file for enc2xs +ext/Encode/Encode/encode.h Encode extension header file ext/Encode/Encode/Makefile_PL.e2x Skeleton file for enc2xs ext/Encode/Encode/README.e2x Skeleton file for enc2xs ext/Encode/Encode/_PM.e2x Skeleton file for enc2xs ext/Encode/Encode/_T.e2x Skeleton file for enc2xs -ext/Encode/Encode/encode.h Encode extension header file +ext/Encode/encoding.pm Perl Pragmactic Module ext/Encode/JP/JP.pm Encode extension ext/Encode/JP/Makefile.PL Encode extension ext/Encode/KR/KR.pm Encode extension ext/Encode/KR/Makefile.PL Encode extension -ext/Encode/MANIFEST Encode extension -ext/Encode/Makefile.PL Encode extension makefile writer -ext/Encode/README Encode extension -ext/Encode/Symbol/Makefile.PL Encode extension -ext/Encode/Symbol/Symbol.pm Encode extension -ext/Encode/TW/Makefile.PL Encode extension -ext/Encode/TW/TW.pm Encode extension -ext/Encode/Unicode/Makefile.PL Encode extension -ext/Encode/Unicode/Unicode.pm Encode extension -ext/Encode/Unicode/Unicode.xs Encode extension -ext/Encode/bin/enc2xs Encode module generator -ext/Encode/bin/piconv iconv by perl -ext/Encode/bin/ucm2table Table Generator for testing -ext/Encode/bin/ucmlint A UCM Lint utility -ext/Encode/bin/unidump Unicode Dump like hexdump(1) -ext/Encode/encengine.c Encode extension -ext/Encode/encoding.pm Perl Pragmactic Module ext/Encode/lib/Encode/Alias.pm Encode extension ext/Encode/lib/Encode/CJKConstants.pm Encode extension ext/Encode/lib/Encode/CN/HZ.pm Encode extension @@ -247,17 +237,21 @@ ext/Encode/lib/Encode/KR/2022_KR.pm Encode extension ext/Encode/lib/Encode/MIME/Header.pm Encode extension ext/Encode/lib/Encode/PerlIO.pod Documents for Encode & PerlIO ext/Encode/lib/Encode/Supported.pod Documents for supported encodings +ext/Encode/Makefile.PL Encode extension makefile writer +ext/Encode/MANIFEST Encode extension +ext/Encode/README Encode extension +ext/Encode/Symbol/Makefile.PL Encode extension +ext/Encode/Symbol/Symbol.pm Encode extension ext/Encode/t/Aliases.t test script -ext/Encode/t/CJKT.t test script -ext/Encode/t/Encode.t test script -ext/Encode/t/Encoder.t test script -ext/Encode/t/Unicode.t test script ext/Encode/t/at-cn.t test script ext/Encode/t/at-tw.t test script ext/Encode/t/big5-eten.enc test data ext/Encode/t/big5-eten.utf test data ext/Encode/t/big5-hkscs.enc test data ext/Encode/t/big5-hkscs.utf test data +ext/Encode/t/CJKT.t test script +ext/Encode/t/Encode.t test script +ext/Encode/t/Encoder.t test script ext/Encode/t/encoding.t test script ext/Encode/t/fallback.t test script ext/Encode/t/gb2312.enc test data @@ -276,6 +270,9 @@ ext/Encode/t/ksc5601.utf test data ext/Encode/t/mime-header.t test script ext/Encode/t/perlio.t test script ext/Encode/t/unibench.pl benchmark script +ext/Encode/t/Unicode.t test script +ext/Encode/TW/Makefile.PL Encode extension +ext/Encode/TW/TW.pm Encode extension ext/Encode/ucm/8859-1.ucm Unicode Character Map ext/Encode/ucm/8859-10.ucm Unicode Character Map ext/Encode/ucm/8859-11.ucm Unicode Character Map @@ -364,9 +361,9 @@ ext/Encode/ucm/macHebrew.ucm Unicode Character Map ext/Encode/ucm/macIceland.ucm Unicode Character Map ext/Encode/ucm/macJapanese.ucm Unicode Character Map ext/Encode/ucm/macKorean.ucm Unicode Character Map +ext/Encode/ucm/macRoman.ucm Unicode Character Map ext/Encode/ucm/macROMnn.ucm Unicode Character Map ext/Encode/ucm/macRUMnn.ucm Unicode Character Map -ext/Encode/ucm/macRoman.ucm Unicode Character Map ext/Encode/ucm/macSami.ucm Unicode Character Map ext/Encode/ucm/macSymbol.ucm Unicode Character Map ext/Encode/ucm/macThai.ucm Unicode Character Map @@ -377,6 +374,9 @@ ext/Encode/ucm/posix-bc.ucm Unicode Character Map ext/Encode/ucm/shiftjis.ucm Unicode Character Map ext/Encode/ucm/symbol.ucm Unicode Character Map ext/Encode/ucm/viscii.ucm Unicode Character Map +ext/Encode/Unicode/Makefile.PL Encode extension +ext/Encode/Unicode/Unicode.pm Encode extension +ext/Encode/Unicode/Unicode.xs Encode extension ext/Errno/ChangeLog See if Errno works ext/Errno/Errno.t See if Errno works ext/Errno/Errno_pm.PL Errno perl module create script @@ -599,10 +599,13 @@ ext/Storable/Storable.xs Storable extension ext/Storable/t/blessed.t See if Storable works ext/Storable/t/canonical.t See if Storable works ext/Storable/t/compat06.t See if Storable works +ext/Storable/t/croak.t See if Storable works ext/Storable/t/dclone.t See if Storable works +ext/Storable/t/downgrade.t See if Storable works ext/Storable/t/forgive.t See if Storable works ext/Storable/t/freeze.t See if Storable works ext/Storable/t/lock.t See if Storable works +ext/Storable/t/make_downgrade.pl See if Storable works ext/Storable/t/malice.t See if Storable copes with corrupt files ext/Storable/t/overload.t See if Storable works ext/Storable/t/recurse.t See if Storable works diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 2f352f3..1ac12e1 100644 --- a/ext/Storable/Storable.pm +++ b/ext/Storable/Storable.pm @@ -79,18 +79,7 @@ $VERSION = '1.015'; eval "use Log::Agent"; -unless (defined @Log::Agent::EXPORT) { - eval q{ - sub logcroak { - require Carp; - Carp::croak(@_); - } - sub logcarp { - require Carp; - Carp::carp(@_); - } - }; -} +require Carp; # # They might miss :flock in Fcntl @@ -107,22 +96,33 @@ BEGIN { } } -sub logcroak; -sub logcarp; - # 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; 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(@_); +} # # Determine whether locking is possible, but only when needed. # -sub CAN_FLOCK { - my $CAN_FLOCK if 0; +sub CAN_FLOCK; my $CAN_FLOCK; sub CAN_FLOCK { return $CAN_FLOCK if defined $CAN_FLOCK; require Config; import Config; return $CAN_FLOCK = diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 6098d70..2e49754 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -58,7 +58,7 @@ #include /* Perl's one, needed since 5.6 */ #include -#if 0 +#if 1 #define DEBUGME /* Debug mode, turns assertions on as well */ #define DASSERT /* Assertion mode */ #endif @@ -272,6 +272,39 @@ typedef unsigned long stag_t; /* Used by pre-0.6 binary format */ #define MY_VERSION "Storable(" XS_VERSION ")" + +/* + * Conditional UTF8 support. + * + */ +#ifdef SvUTF8_on +#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR) +#define HAS_UTF8_SCALARS +#ifdef HeKUTF8 +#define HAS_UTF8_HASHES +#define HAS_UTF8_ALL +#else +/* 5.6 perl has utf8 scalars but not hashes */ +#endif +#else +#define SvUTF8(sv) 0 +#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl")) +#endif +#ifndef HAS_UTF8_ALL +#define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl")) +#endif + +#ifdef HvPLACEHOLDERS +#define HAS_RESTRICTED_HASHES +#else +#define HVhek_PLACEHOLD 0x200 +#define RESTRICTED_HASH_CROAK() CROAK(("Cannot retrieve restricted hash")) +#endif + +#ifdef HvHASKFLAGS +#define HAS_HASH_KEY_FLAGS +#endif + /* * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include * files remap tainted and dirty when threading is enabled. That's bad for @@ -293,6 +326,12 @@ typedef struct stcxt { int s_tainted; /* true if input source is tainted, at retrieve time */ int forgive_me; /* whether to be forgiving... */ int canonical; /* whether to store hashes sorted by key */ +#ifndef HAS_RESTRICTED_HASHES + int derestrict; /* whether to downgrade restrcted hashes */ +#endif +#ifndef HAS_UTF8_ALL + int use_bytes; /* whether to bytes-ify utf8 */ +#endif int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */ int membuf_ro; /* true means membuf is read-only and msaved is rw */ struct extendable keybuf; /* for hash key retrieval */ @@ -658,15 +697,23 @@ static stcxt_t *Context_ptr = &Context; static char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */ static char magicstr[] = "pst0"; /* Used as a magic number */ + #define STORABLE_BIN_MAJOR 2 /* Binary major "version" */ +#define STORABLE_BIN_MINOR 5 /* Binary minor "version" */ + +/* If we aren't 5.7.3 or later, we won't be writing out files that use the + * new flagged hash introdued in 2.5, so put 2.4 in the binary header to + * maximise ease of interoperation with older Storables. + * Could we write 2.3s if we're on 5.005_03? NWC + */ #if (PATCHLEVEL <= 6) -#define STORABLE_BIN_MINOR 4 /* Binary minor "version" */ +#define STORABLE_BIN_WRITE_MINOR 4 #else /* * As of perl 5.7.3, utf8 hash key is introduced. * So this must change -- dankogai */ -#define STORABLE_BIN_MINOR 5 /* Binary minor "version" */ +#define STORABLE_BIN_WRITE_MINOR 5 #endif /* (PATCHLEVEL <= 6) */ /* @@ -731,19 +778,6 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ #define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR) /* - * Conditional UTF8 support. - * On non-UTF8 perls, UTF8 strings are returned as normal strings. - * - */ -#ifdef SvUTF8_on -#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR) -#else -#define SvUTF8(sv) 0 -#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl")) -#define SvUTF8_on(sv) CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl")) -#endif - -/* * Store undef in arrays and hashes without recursing through store(). */ #define STORE_UNDEF() do { \ @@ -1202,6 +1236,12 @@ static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted) cxt->optype = optype; cxt->s_tainted = is_tainted; cxt->entry = 1; /* No recursion yet */ +#ifndef HAS_RESTRICTED_HASHES + cxt->derestrict = -1; /* Fetched from perl if needed */ +#endif +#ifndef HAS_UTF8_ALL + cxt->use_bytes = -1; /* Fetched from perl if needed */ +#endif } /* @@ -1902,12 +1942,21 @@ sortcmp(const void *a, const void *b) */ static int store_hash(stcxt_t *cxt, HV *hv) { - I32 len = HvTOTALKEYS(hv); + I32 len = +#ifdef HAS_RESTRICTED_HASHES + HvTOTALKEYS(hv); +#else + HvKEYS(hv); +#endif I32 i; int ret = 0; I32 riter; HE *eiter; - int flagged_hash = ((SvREADONLY(hv) || HvHASKFLAGS(hv)) ? 1 : 0); + int flagged_hash = ((SvREADONLY(hv) +#ifdef HAS_HASH_KEY_FLAGS + || HvHASKFLAGS(hv) +#endif + ) ? 1 : 0); unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0); if (flagged_hash) { @@ -1969,7 +2018,11 @@ static int store_hash(stcxt_t *cxt, HV *hv) TRACEME(("using canonical order")); for (i = 0; i < len; i++) { +#ifdef HAS_RESTRICTED_HASHES HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); +#else + HE *he = hv_iternext(hv); +#endif SV *key = hv_iterkeysv(he); av_store(av, AvFILLp(av)+1, key); /* av_push(), really */ } @@ -2015,6 +2068,12 @@ static int store_hash(stcxt_t *cxt, HV *hv) keyval = SvPV(key, keylen_tmp); keylen = keylen_tmp; +#ifdef HAS_UTF8_HASHES + /* If you build without optimisation on pre 5.6 + then nothing spots that SvUTF8(key) is always 0, + so the block isn't optimised away, at which point + the linker dislikes the reference to + bytes_from_utf8. */ if (SvUTF8(key)) { const char *keysave = keyval; bool is_utf8 = TRUE; @@ -2039,6 +2098,7 @@ static int store_hash(stcxt_t *cxt, HV *hv) flags |= SHV_K_UTF8; } } +#endif if (flagged_hash) { PUTMARK(flags); @@ -2072,7 +2132,11 @@ static int store_hash(stcxt_t *cxt, HV *hv) char *key; I32 len; unsigned char flags; +#ifdef HV_ITERNEXT_WANTPLACEHOLDERS HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); +#else + HE *he = hv_iternext(hv); +#endif SV *val = (he ? hv_iterval(hv, he) : 0); SV *key_sv = NULL; HEK *hek; @@ -2111,10 +2175,12 @@ static int store_hash(stcxt_t *cxt, HV *hv) flags |= SHV_K_ISSV; } else { /* Regular string key. */ +#ifdef HAS_HASH_KEY_FLAGS if (HEK_UTF8(hek)) flags |= SHV_K_UTF8; if (HEK_WASUTF8(hek)) flags |= SHV_K_WASUTF8; +#endif key = HEK_KEY(hek); } /* @@ -3011,7 +3077,7 @@ static int magic_write(stcxt_t *cxt) * introduced, for instance, but when backward compatibility is preserved. */ - PUTMARK((unsigned char) STORABLE_BIN_MINOR); + PUTMARK((unsigned char) STORABLE_BIN_WRITE_MINOR); if (use_network_order) return 0; /* Don't bother with byte ordering */ @@ -4098,15 +4164,25 @@ static SV *retrieve_scalar(stcxt_t *cxt, char *cname) */ static SV *retrieve_utf8str(stcxt_t *cxt, char *cname) { - SV *sv; + SV *sv; - TRACEME(("retrieve_utf8str")); + TRACEME(("retrieve_utf8str")); - sv = retrieve_scalar(cxt, cname); - if (sv) - SvUTF8_on(sv); + sv = retrieve_scalar(cxt, cname); + if (sv) { +#ifdef HAS_UTF8_SCALARS + SvUTF8_on(sv); +#else + if (cxt->use_bytes < 0) + cxt->use_bytes + = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE)) + ? 1 : 0); + if (cxt->use_bytes == 0) + UTF8_CROAK(); +#endif + } - return sv; + return sv; } /* @@ -4117,15 +4193,24 @@ static SV *retrieve_utf8str(stcxt_t *cxt, char *cname) */ static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname) { - SV *sv; - - TRACEME(("retrieve_lutf8str")); + SV *sv; - sv = retrieve_lscalar(cxt, cname); - if (sv) - SvUTF8_on(sv); + TRACEME(("retrieve_lutf8str")); - return sv; + sv = retrieve_lscalar(cxt, cname); + if (sv) { +#ifdef HAS_UTF8_SCALARS + SvUTF8_on(sv); +#else + if (cxt->use_bytes < 0) + cxt->use_bytes + = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE)) + ? 1 : 0); + if (cxt->use_bytes == 0) + UTF8_CROAK(); +#endif + } + return sv; } /* @@ -4434,11 +4519,22 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) int hash_flags; GETMARK(hash_flags); - TRACEME(("retrieve_flag_hash (#%d)", cxt->tagnum)); + TRACEME(("retrieve_flag_hash (#%d)", cxt->tagnum)); /* * Read length, allocate table. */ +#ifndef HAS_RESTRICTED_HASHES + if (hash_flags & SHV_RESTRICTED) { + if (cxt->derestrict < 0) + cxt->derestrict + = (SvTRUE(perl_get_sv("Storable::downgrade_restricted", TRUE)) + ? 1 : 0); + if (cxt->derestrict == 0) + RESTRICTED_HASH_CROAK(); + } +#endif + RLEN(len); TRACEME(("size = %d, flags = %d", len, hash_flags)); hv = newHV(); @@ -4464,8 +4560,10 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) return (SV *) 0; GETMARK(flags); +#ifdef HAS_RESTRICTED_HASHES if ((hash_flags & SHV_RESTRICTED) && (flags & SHV_K_LOCKED)) SvREADONLY_on(sv); +#endif if (flags & SHV_K_ISSV) { /* XXX you can't set a placeholder with an SV key. @@ -4493,10 +4591,22 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) sv = &PL_sv_undef; store_flags |= HVhek_PLACEHOLD; } - if (flags & SHV_K_UTF8) + if (flags & SHV_K_UTF8) { +#ifdef HAS_UTF8_HASHES store_flags |= HVhek_UTF8; +#else + if (cxt->use_bytes < 0) + cxt->use_bytes + = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE)) + ? 1 : 0); + if (cxt->use_bytes == 0) + UTF8_CROAK(); +#endif + } +#ifdef HAS_UTF8_HASHES if (flags & SHV_K_WASUTF8) store_flags |= HVhek_WASUTF8; +#endif RLEN(size); /* Get key size */ KBUFCHK(size); /* Grow hash key read pool if needed */ @@ -4510,12 +4620,20 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) * Enter key/value pair into hash table. */ +#ifdef HAS_RESTRICTED_HASHES if (hv_store_flags(hv, kbuf, size, sv, 0, flags) == 0) return (SV *) 0; +#else + if (!(store_flags & HVhek_PLACEHOLD)) + if (hv_store(hv, kbuf, size, sv, 0) == 0) + return (SV *) 0; +#endif } } +#ifdef HAS_RESTRICTED_HASHES if (hash_flags & SHV_RESTRICTED) SvREADONLY_on(hv); +#endif TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv))); @@ -4765,10 +4883,14 @@ magic_ok: version_major > STORABLE_BIN_MAJOR || (version_major == STORABLE_BIN_MAJOR && version_minor > STORABLE_BIN_MINOR) - ) + ) { + TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR, + STORABLE_BIN_MINOR)); + CROAK(("Storable binary image v%d.%d more recent than I am (v%d.%d)", version_major, version_minor, STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR)); + } /* * If they stored using network order, there's no byte ordering @@ -4783,6 +4905,8 @@ magic_ok: READ(buf, c); /* Not null-terminated */ buf[c] = '\0'; /* Is now */ + TRACEME(("byte order '%s'", buf)); + if (strcmp(buf, byteorder)) CROAK(("Byte order is not compatible")); diff --git a/ext/Storable/t/croak.t b/ext/Storable/t/croak.t new file mode 100644 index 0000000..ad07f3a --- /dev/null +++ b/ext/Storable/t/croak.t @@ -0,0 +1,41 @@ +#!./perl -w + +# Please keep this test this simple. (ie just one test.) +# There's some sort of not-croaking properly problem in Storable when built +# with 5.005_03. This test shows it up, whereas malice.t does not. +# In particular, don't use Test; as this covers up the problem. + +sub BEGIN { + if ($ENV{PERL_CORE}){ + chdir('t') if -d 't'; + @INC = '.'; + push @INC, '../lib'; + } + require Config; import Config; + if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { + print "1..0 # Skip: Storable was not built\n"; + exit 0; + } + # require 'lib/st-dump.pl'; +} + +use strict; + +BEGIN { + die "Oi! No! Don't change this test so that Carp is used before Storable" + if defined &Carp::carp; +} +use Storable qw(freeze thaw); + +print "1..2\n"; + +for my $test (1,2) { + eval {thaw "\xFF\xFF"}; + if ($@ =~ /Storable binary image v127.255 more recent than I am \(v2\.\d+\)/) + { + print "ok $test\n"; + } else { + chomp $@; + print "not ok $test # Expected a meaningful croak. Got '$@'\n"; + } +} diff --git a/ext/Storable/t/downgrade.t b/ext/Storable/t/downgrade.t new file mode 100644 index 0000000..af5de4a --- /dev/null +++ b/ext/Storable/t/downgrade.t @@ -0,0 +1,378 @@ +#!./perl -w + +# +# Copyright 2002, Larry Wall. +# +# You may redistribute only under the same terms as Perl 5, as specified +# in the README file that comes with the distribution. +# + +# I ought to keep this test easily backwards compatible to 5.004, so no +# qr//; + +# This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features +# are encountered. + +sub BEGIN { + if ($ENV{PERL_CORE}){ + chdir('t') if -d 't'; + @INC = '.'; + push @INC, '../lib'; + } + require Config; import Config; + if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { + print "1..0 # Skip: Storable was not built\n"; + exit 0; + } + # require 'lib/st-dump.pl'; +} + +BEGIN { + if (ord 'A' != 65) { + die <<'EBCDIC'; +This test doesn't have EBCDIC data yet. Please run t/make_downgrade.pl using +perl 5.8 (or later) and append its output to the end of the test. +Please also mail the output to perlbug@perl.org so that the CPAN copy of +Storable can be updated. +EBCDIC + } +} +use Test::More; +use Storable 'thaw'; + +use strict; +use vars qw(@RESTRICT_TESTS %R_HASH %U_HASH $UTF8_CROAK $RESTRICTED_CROAK); + +@RESTRICT_TESTS = ('Locked hash', 'Locked hash placeholder', + 'Locked keys', 'Locked keys placeholder', + ); +%R_HASH = (perl => 'rules'); + +if ($] >= 5.007003) { + my $utf8 = "Schlo\xdf" . chr 256; + chop $utf8; + + %U_HASH = (map {$_, $_} 'castle', "ch\xe5teau", $utf8, chr 0x57CE); + plan tests => 169; +} elsif ($] >= 5.006) { + plan tests => 59; +} else { + plan tests => 67; +} + +$UTF8_CROAK = qr/^Cannot retrieve UTF8 data in non-UTF8 perl/; +$RESTRICTED_CROAK = qr/^Cannot retrieve restricted hash/; + +my %tests; +{ + local $/ = "\n\nend\n"; + while () { + next unless /\S/s; + unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) { + s/\n.*//s; + warn "Dodgy data in section starting '$_'"; + next; + } + next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa + my $data = unpack 'u', $3; + $tests{$2} = $data; + } +} + +# use Data::Dumper; $Data::Dumper::Useqq = 1; print Dumper \%tests; +sub thaw_hash { + my ($name, $expected) = @_; + my $hash = eval {thaw $tests{$name}}; + is ($@, '', "Thawed $name without error?"); + isa_ok ($hash, 'HASH'); + ok (defined $hash && eq_hash($hash, $expected), + "And it is the hash we expected?"); + $hash; +} + +sub thaw_scalar { + my ($name, $expected) = @_; + my $scalar = eval {thaw $tests{$name}}; + is ($@, '', "Thawed $name without error?"); + isa_ok ($scalar, 'SCALAR', "Thawed $name?"); + is ($$scalar, $expected, "And it is the data we expected?"); + $scalar; +} + +sub thaw_fail { + my ($name, $expected) = @_; + my $thing = eval {thaw $tests{$name}}; + is ($thing, undef, "Thawed $name failed as expected?"); + like ($@, $expected, "Error as predicted?"); +} + +sub test_locked_hash { + my $hash = shift; + my @keys = keys %$hash; + my ($key, $value) = each %$hash; + eval {$hash->{$key} = reverse $value}; + like( $@, qr/^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/, + 'trying to add another key' ); + ok (eq_array([keys %$hash], \@keys), "Still the same keys?"); +} + +sub test_restricted_hash { + my $hash = shift; + my @keys = keys %$hash; + my ($key, $value) = each %$hash; + eval {$hash->{$key} = reverse $value}; + is( $@, '', + '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/, + 'trying to add another key' ); + ok (eq_array([keys %$hash], \@keys), "Still the same keys?"); +} + +sub test_placeholder { + my $hash = shift; + eval {$hash->{rules} = 42}; + is ($@, '', 'No errors'); + is ($hash->{rules}, 42, "New value added"); +} + +sub test_newkey { + my $hash = shift; + eval {$hash->{nms} = "http://nms-cgi.sourceforge.net/"}; + is ($@, '', 'No errors'); + is ($hash->{nms}, "http://nms-cgi.sourceforge.net/", "New value added"); +} + +# $Storable::DEBUGME = 1; +thaw_hash ('Hash with utf8 flag but no utf8 keys', \%R_HASH); + +if (eval "use Hash::Util; 1") { + print "# We have Hash::Util, so test that the restricted hashes in are valid\n"; + for $Storable::downgrade_restricted (0, 1, undef, "cheese") { + my $hash = thaw_hash ('Locked hash', \%R_HASH); + test_locked_hash ($hash); + $hash = thaw_hash ('Locked hash placeholder', \%R_HASH); + test_locked_hash ($hash); + test_placeholder ($hash); + + $hash = thaw_hash ('Locked keys', \%R_HASH); + test_restricted_hash ($hash); + $hash = thaw_hash ('Locked keys placeholder', \%R_HASH); + test_restricted_hash ($hash); + test_placeholder ($hash); + } +} else { + print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n"; + my $hash = thaw_hash ('Locked hash', \%R_HASH); + test_newkey ($hash); + $hash = thaw_hash ('Locked hash placeholder', \%R_HASH); + test_newkey ($hash); + $hash = thaw_hash ('Locked keys', \%R_HASH); + test_newkey ($hash); + $hash = thaw_hash ('Locked keys placeholder', \%R_HASH); + test_newkey ($hash); + local $Storable::downgrade_restricted = 0; + thaw_fail ('Locked hash', $RESTRICTED_CROAK); + thaw_fail ('Locked hash placeholder', $RESTRICTED_CROAK); + thaw_fail ('Locked keys', $RESTRICTED_CROAK); + thaw_fail ('Locked keys placeholder', $RESTRICTED_CROAK); +} + +if ($] >= 5.006) { + print "# We have utf8 scalars, so test that the utf8 scalars in are valid\n"; + print "# These seem to fail on 5.6 - you should seriously consider upgrading to 5.6.1\n" if $] == 5.006; + thaw_scalar ('Short 8 bit utf8 data', "\xDF"); + thaw_scalar ('Long 8 bit utf8 data', "\xDF" x 256); + thaw_scalar ('Short 24 bit utf8 data', chr 0xC0FFEE); + thaw_scalar ('Long 24 bit utf8 data', chr (0xC0FFEE) x 256); +} else { + print "# We don't have utf8 scalars, so test that the utf8 scalars downgrade\n"; + thaw_fail ('Short 8 bit utf8 data', $UTF8_CROAK); + thaw_fail ('Long 8 bit utf8 data', $UTF8_CROAK); + thaw_fail ('Short 24 bit utf8 data', $UTF8_CROAK); + thaw_fail ('Long 24 bit utf8 data', $UTF8_CROAK); + local $Storable::drop_utf8 = 1; + my $bytes = thaw $tests{'Short 8 bit utf8 data as bytes'}; + thaw_scalar ('Short 8 bit utf8 data', $$bytes); + thaw_scalar ('Long 8 bit utf8 data', $$bytes x 256); + $bytes = thaw $tests{'Short 24 bit utf8 data as bytes'}; + thaw_scalar ('Short 24 bit utf8 data', $$bytes); + thaw_scalar ('Long 24 bit utf8 data', $$bytes x 256); +} + +if ($] >= 5.007003) { + print "# We have utf8 hashes, so test that the utf8 hashes in are valid\n"; + my $hash = thaw_hash ('Hash with utf8 keys', \%U_HASH); + for (keys %$hash) { + my $l = 0 + /^\w+$/; + my $r = 0 + $hash->{$_} =~ /^\w+$/; + cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); + cmp_ok ($l, '==', $_ eq "ch\xe5teau" ? 0 : 1); + } + if (eval "use Hash::Util; 1") { + print "# We have Hash::Util, so test that the restricted utf8 hash is valid\n"; + my $hash = thaw_hash ('Locked hash with utf8 keys', \%U_HASH); + for (keys %$hash) { + my $l = 0 + /^\w+$/; + my $r = 0 + $hash->{$_} =~ /^\w+$/; + cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); + cmp_ok ($l, '==', $_ eq "ch\xe5teau" ? 0 : 1); + } + test_locked_hash ($hash); + } else { + print "# We don't have Hash::Util, so test that the utf8 hash downgrades\n"; + fail ("You can't get here [perl version $]]. This is a bug in the test. +# Please send the output of perl -V to perlbug\@perl.org"); + } +} else { + print "# We don't have utf8 hashes, so test that the utf8 hashes downgrade\n"; + thaw_fail ('Hash with utf8 keys', $UTF8_CROAK); + thaw_fail ('Locked hash with utf8 keys', $UTF8_CROAK); + local $Storable::drop_utf8 = 1; + my $what = $] < 5.006 ? 'pre 5.6' : '5.6'; + my $expect = thaw $tests{"Hash with utf8 keys for $what"}; + thaw_hash ('Hash with utf8 keys', $expect); + #foreach (keys %$expect) { print "'$_':\t'$expect->{$_}'\n"; } + #foreach (keys %$got) { print "'$_':\t'$got->{$_}'\n"; } + if (eval "use Hash::Util; 1") { + print "# We have Hash::Util, so test that the restricted hashes in are valid\n"; + fail ("You can't get here [perl version $]]. This is a bug in the test. +# Please send the output of perl -V to perlbug\@perl.org"); + } else { + print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n"; + my $hash = thaw_hash ('Locked hash with utf8 keys', $expect); + test_newkey ($hash); + local $Storable::downgrade_restricted = 0; + thaw_fail ('Locked hash with utf8 keys', $RESTRICTED_CROAK); + # Which croak comes first is a bit of an implementation issue :-) + local $Storable::drop_utf8 = 0; + thaw_fail ('Locked hash with utf8 keys', $RESTRICTED_CROAK); + } +} +__END__ +# A whole run of 2.x nfreeze data, uuencoded. The "mode bits" are the octal +# value of 'A', the "file name" is the test name. Use make_downgrade.pl to +# generate these. +begin 101 Locked hash +8!049`0````$*!7)U;&5S!`````1P97)L + +end + +begin 101 Locked hash placeholder +C!049`0````(*!7)U;&5S!`````1P97)L#A0````%"rules"); + +lock_hash %hash; + +uuencode_it (\%hash, "Locked hash"); + +unlock_hash %hash; + +lock_keys %hash, 'perl', 'rules'; +lock_hash %hash; + +uuencode_it (\%hash, "Locked hash placeholder"); + +unlock_hash %hash; + +lock_keys %hash, 'perl'; + +uuencode_it (\%hash, "Locked keys"); + +unlock_hash %hash; + +lock_keys %hash, 'perl', 'rules'; + +uuencode_it (\%hash, "Locked keys placeholder"); + +unlock_hash %hash; + +my $utf8 = "\x{DF}\x{100}"; +chop $utf8; + +uuencode_it (\$utf8, "Short 8 bit utf8 data"); + +utf8::encode ($utf8); + +uuencode_it (\$utf8, "Short 8 bit utf8 data as bytes"); + +$utf8 x= 256; + +uuencode_it (\$utf8, "Long 8 bit utf8 data"); + +$utf8 = "\x{C0FFEE}"; + +uuencode_it (\$utf8, "Short 24 bit utf8 data"); + +utf8::encode ($utf8); + +uuencode_it (\$utf8, "Short 24 bit utf8 data as bytes"); + +$utf8 x= 256; + +uuencode_it (\$utf8, "Long 24 bit utf8 data"); + +# Hash which has the utf8 bit set, but no longer has any utf8 keys +my %uhash = ("\x{100}", "gone", "perl", "rules"); +delete $uhash{"\x{100}"}; + +# use Devel::Peek; Dump \%uhash; +uuencode_it (\%uhash, "Hash with utf8 flag but no utf8 keys"); + +$utf8 = "Schlo\xdf" . chr 256; +chop $utf8; +%uhash = (map {$_, $_} 'castle', "ch\xe5teau", $utf8, "\x{57CE}"); + +uuencode_it (\%uhash, "Hash with utf8 keys"); + +lock_hash %uhash; + +uuencode_it (\%uhash, "Locked hash with utf8 keys"); + +my (%pre56, %pre58); + +while (my ($key, $val) = each %uhash) { + # hash keys are always stored downgraded to bytes if possible, with a flag + # to say "promote back to utf8" + # Whereas scalars are stored as is. + utf8::encode ($key) if ord $key > 256; + $pre58{$key} = $val; + utf8::encode ($val) unless $val eq "ch\xe5teau"; + $pre56{$key} = $val; + +} +uuencode_it (\%pre56, "Hash with utf8 keys for pre 5.6"); +uuencode_it (\%pre58, "Hash with utf8 keys for 5.6"); diff --git a/ext/Storable/t/malice.t b/ext/Storable/t/malice.t index 54c0ea4..9f1d8ff 100644 --- a/ext/Storable/t/malice.t +++ b/ext/Storable/t/malice.t @@ -30,14 +30,14 @@ sub BEGIN { } use strict; -use vars qw($file_magic_str $other_magic $network_magic $major $minor); - -# header size depends on the size of the byteorder string +use vars qw($file_magic_str $other_magic $network_magic $major $minor + $minor_write); $file_magic_str = 'pst0'; $other_magic = 7 + length($Config{byteorder}); $network_magic = 2; $major = 2; $minor = 5; +$minor_write = $] > 5.007 ? 5 : 4; use Test; BEGIN { plan tests => 334 + length($Config{byteorder}) * 4} @@ -63,7 +63,7 @@ sub test_header { my ($header, $isfile, $isnetorder) = @_; ok (!!$header->{file}, !!$isfile, "is file"); ok ($header->{major}, $major, "major number"); - ok ($header->{minor}, $minor, "minor number"); + ok ($header->{minor}, $minor_write, "minor number"); ok (!!$header->{netorder}, !!$isnetorder, "is network order"); if ($isnetorder) { # Skip these @@ -148,24 +148,34 @@ sub test_things { } $copy = $contents; - my $minor1 = $header->{minor} + 1; - substr ($copy, $file_magic + 1, 1) = chr $minor1; + # Needs to be more than 1, as we're already coding a spread of 1 minor version + # number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3 + # on 5.005_03 (No utf8). + # 4 allows for a small safety margin + # (Joke: + # Question: What is the value of pi? + # Mathematician answers "It's pi, isn't it" + # Physicist answers "3.1, within experimental error" + # Engineer answers "Well, allowing for a small safety margin, 18" + # ) + my $minor4 = $header->{minor} + 4; + substr ($copy, $file_magic + 1, 1) = chr $minor4; test_corrupt ($copy, $sub, - "/^Storable binary image v$header->{major}\.$minor1 more recent than I am \\(v$header->{major}\.$header->{minor}\\)/", + "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/", "higher minor"); $copy = $contents; my $major1 = $header->{major} + 1; substr ($copy, $file_magic, 1) = chr 2*$major1; test_corrupt ($copy, $sub, - "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$header->{minor}\\)/", + "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/", "higher major"); # Continue messing with the previous copy - $minor1 = $header->{minor} - 1; + my $minor1 = $header->{minor} - 1; substr ($copy, $file_magic + 1, 1) = chr $minor1; test_corrupt ($copy, $sub, - "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$header->{minor}\\)/", + "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/", "higher major, lower minor"); my $where; diff --git a/ext/Storable/t/restrict.t b/ext/Storable/t/restrict.t index 0eb299f..841baab 100644 --- a/ext/Storable/t/restrict.t +++ b/ext/Storable/t/restrict.t @@ -1,4 +1,4 @@ -#!./perl +#!./perl -w # # Copyright 2002, Larry Wall. @@ -8,13 +8,24 @@ # sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; + if ($ENV{PERL_CORE}){ + chdir('t') if -d 't'; + @INC = '.'; + push @INC, '../lib'; + require Config; + if ($Config::Config{'extensions'} !~ /\bStorable\b/) { + print "1..0 # Skip: Storable was not built\n"; + 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"; + exit 0; + } else { + die; + } + } } require 'lib/st-dump.pl'; } @@ -67,7 +78,7 @@ sub testit { unless (ok ++$test, !$@, "Can assign to reserved key 'extra'?") { my $diag = $@; $diag =~ s/\n.*\z//s; - print "# \$@: $diag\n"; + print "# \$\@: $diag\n"; } eval { $copy->{nono} = 7 } ; diff --git a/ext/Storable/t/utf8hash.t b/ext/Storable/t/utf8hash.t index 5e93914..25d5307 100644 --- a/ext/Storable/t/utf8hash.t +++ b/ext/Storable/t/utf8hash.t @@ -38,6 +38,8 @@ use bytes (); use Encode qw(is_utf8); my %utf8hash; +$Storable::canonical = $Storable::canonical; # Shut up a used only once warning. + for $Storable::canonical (0, 1) { # first we generate a nasty hash which keys include both utf8