diff options
| -rw-r--r-- | MANIFEST | 2 | ||||
| -rw-r--r-- | ext/Storable/ChangeLog | 6 | ||||
| -rw-r--r-- | ext/Storable/MANIFEST | 2 | ||||
| -rw-r--r-- | ext/Storable/README | 2 | ||||
| -rw-r--r-- | ext/Storable/Storable.pm | 2 | ||||
| -rw-r--r-- | ext/Storable/Storable.xs | 89 | ||||
| -rw-r--r-- | ext/Storable/t/malice.t | 48 | ||||
| -rw-r--r-- | ext/Storable/t/testlib.pl | 38 | ||||
| -rw-r--r-- | ext/Storable/t/weak.t | 147 |
9 files changed, 279 insertions, 57 deletions
@@ -686,12 +686,14 @@ ext/Storable/t/restrict.t See if Storable works ext/Storable/t/retrieve.t See if Storable works ext/Storable/t/st-dump.pl See if Storable works ext/Storable/t/store.t See if Storable works +ext/Storable/t/testlib.pl more helper routines for tests ext/Storable/t/threads.t Does Storable work with threads? ext/Storable/t/tied_hook.t See if Storable works ext/Storable/t/tied_items.t See if Storable works ext/Storable/t/tied.t See if Storable works ext/Storable/t/utf8hash.t See if Storable works ext/Storable/t/utf8.t See if Storable works +ext/Storable/t/weak.t Can Storable store weakrefs ext/Sys/Hostname/Hostname.pm Sys::Hostname extension Perl module ext/Sys/Hostname/Hostname.xs Sys::Hostname extension external subroutines ext/Sys/Hostname/Makefile.PL Sys::Hostname extension makefile writer diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog index 4745df4dc2..8371914364 100644 --- a/ext/Storable/ChangeLog +++ b/ext/Storable/ChangeLog @@ -1,3 +1,9 @@ +Sat Jul 10 22:37:47 BST 2004 Nicholas Clark <nick@ccl4.org> + + Version 2.14 + + 1. Store weak references + Thu Jun 17 12:26:43 BST 2004 Nicholas Clark <nick@ccl4.org> Version 2.13 diff --git a/ext/Storable/MANIFEST b/ext/Storable/MANIFEST index bc8ecb5388..c87345d6f0 100644 --- a/ext/Storable/MANIFEST +++ b/ext/Storable/MANIFEST @@ -30,12 +30,14 @@ t/restrict.t See if Storable works t/retrieve.t See if Storable works t/st-dump.pl helper routines for tests t/store.t See if Storable works +t/testlib.pl more helper routines for tests t/tied.t See if Storable works t/tied_hook.t See if Storable works t/tied_items.t See if Storable works t/threads.t See if Storable works under ithreads t/utf8.t See if Storable works t/utf8hash.t See if Storable works +/t/weak.t Can Storable store weakrefs # t/Test/Builder.pm For testing the CPAN release on pre 5.6.2 # t/Test/More.pm For testing the CPAN release on pre 5.6.2 # t/Test/Simple.pm For testing the CPAN release on pre 5.6.2 diff --git a/ext/Storable/README b/ext/Storable/README index db46b4361d..5d0b89118b 100644 --- a/ext/Storable/README +++ b/ext/Storable/README @@ -1,4 +1,4 @@ - Storable 2.13 + Storable 2.14 Copyright (c) 1995-2000, Raphael Manfredi Copyright (c) 2001-2004, Larry Wall diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 3a361ba226..bdfaa19735 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.13'; +$VERSION = '2.14'; *AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr... # diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 0a909f62d2..851443b1fc 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -161,7 +161,9 @@ typedef double NV; /* Older perls lack the NV type */ #define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */ #define SX_FLAG_HASH C(25) /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */ #define SX_CODE C(26) /* Code references as perl source code */ -#define SX_ERROR C(27) /* Error */ +#define SX_WEAKREF C(27) /* Weak reference to object forthcoming */ +#define SX_WEAKOVERLOAD C(28) /* Overloaded weak reference */ +#define SX_ERROR C(29) /* Error */ /* * Those are only used to retrieve "old" pre-0.6 binary images. @@ -269,6 +271,9 @@ typedef unsigned long stag_t; /* Used by pre-0.6 binary format */ #ifndef HAS_UTF8_ALL #define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl")) #endif +#ifndef SvWEAKREF +#define WEAKREF_CROAK() CROAK(("Cannot retrieve weak references in this perl")) +#endif #ifdef HvPLACEHOLDERS #define HAS_RESTRICTED_HASHES @@ -772,22 +777,16 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; #endif #define STORABLE_BIN_MAJOR 2 /* Binary major "version" */ -#define STORABLE_BIN_MINOR 6 /* Binary minor "version" */ +#define STORABLE_BIN_MINOR 7 /* 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) +#if (PATCHLEVEL <= 5) #define STORABLE_BIN_WRITE_MINOR 4 #else -/* - * As of perl 5.7.3, utf8 hash key is introduced. - * So this must change -- dankogai +/* + * Perl 5.6.0 onwards can do weak references. */ -#define STORABLE_BIN_WRITE_MINOR 6 -#endif /* (PATCHLEVEL <= 6) */ +#define STORABLE_BIN_WRITE_MINOR 7 +#endif /* (PATCHLEVEL <= 5) */ #if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1)) #define PL_sv_placeholder PL_sv_undef @@ -1089,6 +1088,8 @@ static SV *(*sv_old_retrieve[])(pTHX_ stcxt_t *cxt, char *cname) = { retrieve_other, /* SX_LUTF8STR not supported */ retrieve_other, /* SX_FLAG_HASH not supported */ retrieve_other, /* SX_CODE not supported */ + retrieve_other, /* SX_WEAKREF not supported */ + retrieve_other, /* SX_WEAKOVERLOAD not supported */ retrieve_other, /* SX_ERROR */ }; @@ -1105,6 +1106,8 @@ static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, char *cname); static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, char *cname); static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, char *cname); static SV *retrieve_code(pTHX_ stcxt_t *cxt, char *cname); +static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, char *cname); +static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, char *cname); static SV *(*sv_retrieve[])(pTHX_ stcxt_t *cxt, char *cname) = { 0, /* SX_OBJECT -- entry unused dynamically */ @@ -1134,6 +1137,8 @@ static SV *(*sv_retrieve[])(pTHX_ stcxt_t *cxt, char *cname) = { retrieve_lutf8str, /* SX_LUTF8STR */ retrieve_flag_hash, /* SX_HASH */ retrieve_code, /* SX_CODE */ + retrieve_weakref, /* SX_WEAKREF */ + retrieve_weakoverloaded, /* SX_WEAKOVERLOAD */ retrieve_other, /* SX_ERROR */ }; @@ -1831,23 +1836,29 @@ static int known_class( */ static int store_ref(pTHX_ stcxt_t *cxt, SV *sv) { + int is_weak = 0; TRACEME(("store_ref (0x%"UVxf")", PTR2UV(sv))); /* * Follow reference, and check if target is overloaded. */ +#ifdef SvWEAKREF; + if (SvWEAKREF(sv)) + is_weak = 1; + TRACEME(("ref (0x%"UVxf") is%s weak", PTR2UV(sv), is_weak ? "" : "n't")); +#endif sv = SvRV(sv); if (SvOBJECT(sv)) { HV *stash = (HV *) SvSTASH(sv); if (stash && Gv_AMG(stash)) { TRACEME(("ref (0x%"UVxf") is overloaded", PTR2UV(sv))); - PUTMARK(SX_OVERLOAD); + PUTMARK(is_weak ? SX_WEAKOVERLOAD : SX_OVERLOAD); } else - PUTMARK(SX_REF); + PUTMARK(is_weak ? SX_WEAKREF : SX_REF); } else - PUTMARK(SX_REF); + PUTMARK(is_weak ? SX_WEAKREF : SX_REF); return store(aTHX_ cxt, sv); } @@ -4302,6 +4313,29 @@ static SV *retrieve_ref(pTHX_ stcxt_t *cxt, char *cname) } /* + * retrieve_weakref + * + * Retrieve weak reference to some other scalar. + * Layout is SX_WEAKREF <object>, with SX_WEAKREF already read. + */ +static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, char *cname) +{ + SV *sv; + + TRACEME(("retrieve_weakref (#%d)", cxt->tagnum)); + + sv = retrieve_ref(aTHX_ cxt, cname); + if (sv) { +#ifdef SvWEAKREF + sv_rvweaken(sv); +#else + WEAKREF_CROAK(); +#endif + } + return sv; +} + +/* * retrieve_overloaded * * Retrieve reference to some other scalar with overloading. @@ -4371,6 +4405,29 @@ static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, char *cname) } /* + * retrieve_weakoverloaded + * + * Retrieve weak overloaded reference to some other scalar. + * Layout is SX_WEAKOVERLOADED <object>, with SX_WEAKOVERLOADED already read. + */ +static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, char *cname) +{ + SV *sv; + + TRACEME(("retrieve_weakoverloaded (#%d)", cxt->tagnum)); + + sv = retrieve_overloaded(aTHX_ cxt, cname); + if (sv) { +#ifdef SvWEAKREF + sv_rvweaken(sv); +#else + WEAKREF_CROAK(); +#endif + } + return sv; +} + +/* * retrieve_tied_array * * Retrieve tied array diff --git a/ext/Storable/t/malice.t b/ext/Storable/t/malice.t index 955dcf1fa2..703ce47bd6 100644 --- a/ext/Storable/t/malice.t +++ b/ext/Storable/t/malice.t @@ -16,7 +16,7 @@ sub BEGIN { if ($ENV{PERL_CORE}){ chdir('t') if -d 't'; - @INC = ('.', '../lib'); + @INC = ('.', '../lib', '../ext/Storable/t'); } else { # This lets us distribute Test::More in t/ unshift @INC, 't'; @@ -38,8 +38,8 @@ $file_magic_str = 'pst0'; $other_magic = 7 + length $byteorder; $network_magic = 2; $major = 2; -$minor = 6; -$minor_write = $] > 5.007 ? 6 : 4; +$minor = 7; +$minor_write = $] > 5.005_50 ? 7 : 4; use Test::More; @@ -54,11 +54,8 @@ $fancy = ($] > 5.007 ? 2 : 0); plan tests => 368 + length ($byteorder) * 4 + $fancy * 8 + 1; use Storable qw (store retrieve freeze thaw nstore nfreeze); - -my $file = "malice.$$"; -die "Temporary file 'malice.$$' already exists" if -e $file; - -END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }} +require 'testlib.pl'; +use vars '$file'; # The chr 256 is a hack to force the hash to always have the utf8 keys flag # set on 5.7.3 and later. Otherwise the test fails if run with -Mutf8 because @@ -97,22 +94,6 @@ sub test_header { } } -sub store_and_retrieve { - my $data = shift; - unlink $file or die "Can't unlink '$file': $!"; - open FH, ">$file" or die "Can't open '$file': $!"; - binmode FH; - print FH $data or die "Can't print to '$file': $!"; - close FH or die "Can't close '$file': $!"; - - return eval {retrieve $file}; -} - -sub freeze_and_thaw { - my $data = shift; - return eval {thaw $data}; -} - sub test_truncated { my ($data, $sub, $magic_len, $what) = @_; for my $i (0 .. length ($data) - 1) { @@ -229,7 +210,7 @@ sub test_things { $where = $file_magic + $network_magic; } - # Just the header and a tag 255. As 26 is currently the highest tag, this + # Just the header and a tag 255. As 28 is currently the highest tag, this # is "unexpected" $copy = substr ($contents, 0, $where) . chr 255; @@ -249,7 +230,7 @@ sub test_things { # local $Storable::DEBUGME = 1; # This is the delayed croak test_corrupt ($copy, $sub, - "/^Storable binary image v$header->{major}.$minor4 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 26/", + "/^Storable binary image v$header->{major}.$minor4 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 28/", "bogus tag, minor plus 4"); # And check again that this croak is not delayed: { @@ -261,17 +242,6 @@ sub test_things { } } -sub slurp { - my $file = shift; - local (*FH, $/); - open FH, "<$file" or die "Can't open '$file': $!"; - binmode FH; - my $contents = <FH>; - die "Can't read $file: $!" unless defined $contents; - return $contents; -} - - ok (defined store(\%hash, $file)); my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy; @@ -284,7 +254,7 @@ die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but unless $length == $expected; # Read the contents into memory: -my $contents = slurp $file; +my $contents = slurp ($file); # Test the original direct from disk my $clone = retrieve $file; @@ -312,7 +282,7 @@ die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but unless $length == $expected; # Read the contents into memory: -$contents = slurp $file; +$contents = slurp ($file); # Test the original direct from disk $clone = retrieve $file; diff --git a/ext/Storable/t/testlib.pl b/ext/Storable/t/testlib.pl new file mode 100644 index 0000000000..6d885d7f68 --- /dev/null +++ b/ext/Storable/t/testlib.pl @@ -0,0 +1,38 @@ +#!perl -w +use strict; +use vars '$file'; + +$file = "storable-testfile.$$"; +die "Temporary file '$file' already exists" if -e $file; + +END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }} + +use Storable qw (store retrieve freeze thaw nstore nfreeze); + +sub slurp { + my $file = shift; + local (*FH, $/); + open FH, "<$file" or die "Can't open '$file': $!"; + binmode FH; + my $contents = <FH>; + die "Can't read $file: $!" unless defined $contents; + return $contents; +} + +sub store_and_retrieve { + my $data = shift; + unlink $file or die "Can't unlink '$file': $!"; + open FH, ">$file" or die "Can't open '$file': $!"; + binmode FH; + print FH $data or die "Can't print to '$file': $!"; + close FH or die "Can't close '$file': $!"; + + return eval {retrieve $file}; +} + +sub freeze_and_thaw { + my $data = shift; + return eval {thaw $data}; +} + +$file; diff --git a/ext/Storable/t/weak.t b/ext/Storable/t/weak.t new file mode 100644 index 0000000000..59e8e2b2c8 --- /dev/null +++ b/ext/Storable/t/weak.t @@ -0,0 +1,147 @@ +#!./perl -w +# +# Copyright 2004, Larry Wall. +# +# You may redistribute only under the same terms as Perl 5, as specified +# in the README file that comes with the distribution. +# + +sub BEGIN { + if ($ENV{PERL_CORE}){ + chdir('t') if -d 't'; + @INC = ('.', '../lib', '../ext/Storable/t'); + } 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 ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + + require Scalar::Util; + Scalar::Util->import qw(weaken isweak); + if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) { + print("1..0 # Skip: No support for weaken in Scalar::Util\n"); + exit 0; + } +} + +use Test::More 'no_plan'; +use Storable qw (store retrieve freeze thaw nstore nfreeze); +require 'testlib.pl'; +use vars '$file'; +use strict; + +sub tester { + my ($contents, $sub, $testersub, $what) = @_; + # Test that if we re-write it, everything still works: + my $clone = &$sub ($contents); + is ($@, "", "There should be no error extracting for $what"); + &$testersub ($clone, $what); +} + +my $r = {}; +my $s1 = [$r, $r]; +weaken $s1->[1]; +ok (isweak($s1->[1]), "element 1 is a weak reference"); + +my $s0 = [$r, $r]; +weaken $s0->[0]; +ok (isweak($s0->[0]), "element 0 is a weak reference"); + +my $w = [$r]; +weaken $w->[0]; +ok (isweak($w->[0]), "element 0 is a weak reference"); + +package OVERLOADED; + +use overload + '""' => sub { $_[0][0] }; + +package main; + +$a = bless [77], 'OVERLOADED'; + +my $o = [$a, $a]; +weaken $o->[0]; +ok (isweak($o->[0]), "element 0 is a weak reference"); + +my @tests = ( +[$s1, + sub { + my ($clone, $what) = @_; + isa_ok($clone,'ARRAY'); + isa_ok($clone->[0],'HASH'); + isa_ok($clone->[1],'HASH'); + ok(!isweak $clone->[0], "Element 0 isn't weak"); + ok(isweak $clone->[1], "Element 1 is weak"); +} +], +# The weak reference needs to hang around long enough for other stuff to +# be able to make references to it. So try it second. +[$s0, + sub { + my ($clone, $what) = @_; + isa_ok($clone,'ARRAY'); + isa_ok($clone->[0],'HASH'); + isa_ok($clone->[1],'HASH'); + ok(isweak $clone->[0], "Element 0 is weak"); + ok(!isweak $clone->[1], "Element 1 isn't weak"); +} +], +[$w, + sub { + my ($clone, $what) = @_; + isa_ok($clone,'ARRAY'); + if ($what eq 'nothing') { + # We're the original, so we're still a weakref to a hash + isa_ok($clone->[0],'HASH'); + ok(isweak $clone->[0], "Element 0 is weak"); + } else { + is($clone->[0],undef); + } +} +], +[$o, +sub { + my ($clone, $what) = @_; + isa_ok($clone,'ARRAY'); + isa_ok($clone->[0],'OVERLOADED'); + isa_ok($clone->[1],'OVERLOADED'); + ok(isweak $clone->[0], "Element 0 is weak"); + ok(!isweak $clone->[1], "Element 1 isn't weak"); + is ("$clone->[0]", 77, "Element 0 stringifies to 77"); + is ("$clone->[1]", 77, "Element 1 stringifies to 77"); +} +], +); + +foreach (@tests) { + my ($input, $testsub) = @$_; + + tester($input, sub {return shift}, $testsub, 'nothing'); + + ok (defined store($input, $file)); + + # Read the contents into memory: + my $contents = slurp ($file); + + tester($contents, \&store_and_retrieve, $testsub, 'file'); + + # And now try almost everything again with a Storable string + my $stored = freeze $input; + tester($stored, \&freeze_and_thaw, $testsub, 'string'); + + ok (defined nstore($input, $file)); + + tester($contents, \&store_and_retrieve, $testsub, 'network file'); + + $stored = nfreeze $input; + tester($stored, \&freeze_and_thaw, $testsub, 'network string'); +} |