From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 10 Jul 2004 21:58:34 +0000 (+0000)
Subject: Store weak references.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c3c530331f21054a140c9b28847ce487ae5cbca4;p=p5sagit%2Fp5-mst-13.2.git

Store weak references.

p4raw-id: //depot/perl@23079
---

diff --git a/MANIFEST b/MANIFEST
index 20b14fa..6947f88 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -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 4745df4..8371914 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 bc8ecb5..c87345d 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 db46b43..5d0b891 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 3a361ba..bdfaa19 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 0a909f6..851443b 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 955dcf1..703ce47 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 0000000..6d885d7
--- /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 0000000..59e8e2b
--- /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');
+}