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
+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
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
- Storable 2.13
+ Storable 2.14
Copyright (c) 1995-2000, Raphael Manfredi
Copyright (c) 2001-2004, Larry Wall
use AutoLoader;
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.13';
+$VERSION = '2.14';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
#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.
#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
#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
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 */
};
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 */
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 */
};
*/
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);
}
}
/*
+ * 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.
}
/*
+ * 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
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';
$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;
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
}
}
-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) {
$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;
# 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:
{
}
}
-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;
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;
unless $length == $expected;
# Read the contents into memory:
-$contents = slurp $file;
+$contents = slurp ($file);
# Test the original direct from disk
$clone = retrieve $file;
--- /dev/null
+#!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;
--- /dev/null
+#!./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');
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff