Upgrade to Storable 1.0.7, from Raphael Manfredi.

p4raw-id: //depot/perl@8312

4 files changed, 120 insertions, 44 deletions

diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog
index 352e6200fd..92789b59a4 100644
--- a/ext/Storable/ChangeLog
+++ b/ext/Storable/ChangeLog
@@ -1,3 +1,21 @@
+Wed Jan  3 10:43:18 MET 2001   Raphael Manfredi <Raphael_Manfredi@pobox.com>
+
+. Description:
+
+	Removed spurious 'clean' entry in Makefile.PL.
+
+	Added CAN_FLOCK to determine whether we can flock() or not,
+	by inspecting Perl's configuration parameters, as determined
+	by Configure.
+
+	Trace offending package when overloading cannot be restored
+	on a scalar.
+
+	Made context cleanup safer to avoid dup freeing, mostly in the
+	presence of repeated exceptions during store/retrieve (which can
+	cause memory leaks anyway, so it's just additional safety, not a
+	definite fix).
+
 Sun Nov  5 18:23:48 MET 2000   Raphael Manfredi <Raphael_Manfredi@pobox.com>
 
 . Description:
diff --git a/ext/Storable/Makefile.PL b/ext/Storable/Makefile.PL
index 8fbc5b3a2b..c8151f3083 100644
--- a/ext/Storable/Makefile.PL
+++ b/ext/Storable/Makefile.PL
@@ -1,4 +1,4 @@
-# $Id: Makefile.PL,v 1.0 2000/09/01 19:40:41 ram Exp $
+# $Id: Makefile.PL,v 1.0.1.1 2001/01/03 09:38:39 ram Exp $
 #
 #  Copyright (c) 1995-2000, Raphael Manfredi
 #  
@@ -6,6 +6,9 @@
 #  in the README file that comes with the distribution.
 #
 # $Log: Makefile.PL,v $
+# Revision 1.0.1.1  2001/01/03 09:38:39  ram
+# patch7: removed spurious 'clean' entry
+#
 # Revision 1.0  2000/09/01 19:40:41  ram
 # Baseline for first official release.
 #
@@ -19,8 +22,5 @@ WriteMakefile(
 	'MAN3PODS'		=> {},
     'VERSION_FROM'	=> 'Storable.pm',
     'dist'			=> { SUFFIX => 'gz', COMPRESS => 'gzip -f' },
-# The % would be understood as a filename wildcard in VMS and
-# in some Windows shells.  (Charles Lane and Gurusamy Sarathy)
-#    'clean'			=> {'FILES' => '*%'},
 );
 
diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm
index d2a631c0ee..06c05d4fe9 100644
--- a/ext/Storable/Storable.pm
+++ b/ext/Storable/Storable.pm
@@ -1,4 +1,4 @@
-;# $Id: Storable.pm,v 1.0.1.5 2000/10/26 17:10:18 ram Exp $
+;# $Id: Storable.pm,v 1.0.1.7 2001/01/03 09:39:02 ram Exp $
 ;#
 ;#  Copyright (c) 1995-2000, Raphael Manfredi
 ;#  
@@ -6,6 +6,9 @@
 ;#  in the README file that comes with the distribution.
 ;#
 ;# $Log: Storable.pm,v $
+;# Revision 1.0.1.7  2001/01/03 09:39:02  ram
+;# patch7: added CAN_FLOCK to determine whether we can flock() or not
+;#
 ;# Revision 1.0.1.6  2000/11/05 17:20:25  ram
 ;# patch6: increased version number
 ;#
@@ -38,7 +41,7 @@ package Storable; @ISA = qw(Exporter DynaLoader);
 use AutoLoader;
 use vars qw($forgive_me $VERSION);
 
-$VERSION = '1.006';
+$VERSION = '1.007';
 *AUTOLOAD = \&AutoLoader::AUTOLOAD;		# Grrr...
 
 #
@@ -81,6 +84,21 @@ sub logcarp;
 
 sub retrieve_fd { &fd_retrieve }		# Backward compatibility
 
+#
+# Determine whether locking is possible, but only when needed.
+#
+
+my $CAN_FLOCK;
+
+sub CAN_FLOCK {
+	return $CAN_FLOCK if defined $CAN_FLOCK;
+	require Config; import Config;
+	return $CAN_FLOCK =
+		$Config{'d_flock'} ||
+		$Config{'d_fcntl_can_lock'} ||
+		$Config{'d_lockf'};
+}
+
 bootstrap Storable;
 1;
 __END__
@@ -135,10 +153,7 @@ sub _store {
 	open(FILE, ">$file") || logcroak "can't create $file: $!";
 	binmode FILE;				# Archaic systems...
 	if ($use_locking) {
-		require Config; import Config;
-		if (!$Config{'d_flock'} &&
-		    !$Config{'d_fcntl_can_lock'} &&
-		    !$Config{'d_lockf'}) {
+		unless (&CAN_FLOCK) {
 			logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O";
 			return undef;
 		}
@@ -258,10 +273,7 @@ sub _retrieve {
 	my $self;
 	my $da = $@;							# Could be from exception handler
 	if ($use_locking) {
-		require Config; import Config;
-		if (!$Config{'d_flock'} &&
-		    !$Config{'d_fcntl_can_lock'} &&
-		    !$Config{'d_lockf'}) {
+		unless (&CAN_FLOCK) {
 			logcarp "Storable::lock_retrieve: fcntl/flock emulation broken on $^O";
 			return undef;
 		}
diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs
index a574c33976..366a301361 100644
--- a/ext/Storable/Storable.xs
+++ b/ext/Storable/Storable.xs
@@ -3,7 +3,7 @@
  */
 
 /*
- * $Id: Storable.xs,v 1.0.1.4 2000/10/26 17:11:04 ram Exp $
+ * $Id: Storable.xs,v 1.0.1.6 2001/01/03 09:40:40 ram Exp $
  *
  *  Copyright (c) 1995-2000, Raphael Manfredi
  *  
@@ -11,6 +11,11 @@
  *  in the README file that comes with the distribution.
  *
  * $Log: Storable.xs,v $
+ * Revision 1.0.1.6  2001/01/03 09:40:40  ram
+ * patch7: prototype and casting cleanup
+ * patch7: trace offending package when overloading cannot be restored
+ * patch7: made context cleanup safer to avoid dup freeing
+ *
  * Revision 1.0.1.5  2000/11/05 17:21:24  ram
  * patch6: fixed severe "object lost" bug for STORABLE_freeze returns
  *
@@ -670,7 +675,7 @@ static char magicstr[] = "pst0";			/* Used as a magic number */
 #define GETMARK(x) do {							\
 	if (!cxt->fio)								\
 		MBUF_GETC(x);							\
-	else if ((int)(x = PerlIO_getc(cxt->fio)) == EOF)	\
+! 	else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF)	\
 		return (SV *) 0;						\
 } while (0)
 
@@ -758,14 +763,14 @@ static int store_tied_item(stcxt_t *cxt, SV *sv);
 static int store_other(stcxt_t *cxt, SV *sv);
 static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg);
 
-static int (*sv_store[])() = {
-	store_ref,			/* svis_REF */
-	store_scalar,		/* svis_SCALAR */
-	store_array,		/* svis_ARRAY */
-	store_hash,			/* svis_HASH */
-	store_tied,			/* svis_TIED */
-	store_tied_item,	/* svis_TIED_ITEM */
-	store_other,		/* svis_OTHER */
+static int (*sv_store[])(stcxt_t *cxt, SV *sv) = {
+	store_ref,										/* svis_REF */
+	store_scalar,									/* svis_SCALAR */
+	(int (*)(stcxt_t *cxt, SV *sv)) store_array,	/* svis_ARRAY */
+	(int (*)(stcxt_t *cxt, SV *sv)) store_hash,		/* svis_HASH */
+	store_tied,										/* svis_TIED */
+	store_tied_item,								/* svis_TIED_ITEM */
+	store_other,									/* svis_OTHER */
 };
 
 #define SV_STORE(x)	(*sv_store[x])
@@ -791,7 +796,7 @@ static SV *retrieve_tied_hash(stcxt_t *cxt);
 static SV *retrieve_tied_scalar(stcxt_t *cxt);
 static SV *retrieve_other(stcxt_t *cxt);
 
-static SV *(*sv_old_retrieve[])() = {
+static SV *(*sv_old_retrieve[])(stcxt_t *cxt) = {
 	0,			/* SX_OBJECT -- entry unused dynamically */
 	retrieve_lscalar,		/* SX_LSCALAR */
 	old_retrieve_array,		/* SX_ARRAY -- for pre-0.6 binaries */
@@ -832,7 +837,7 @@ static SV *retrieve_overloaded(stcxt_t *cxt);
 static SV *retrieve_tied_key(stcxt_t *cxt);
 static SV *retrieve_tied_idx(stcxt_t *cxt);
 
-static SV *(*sv_retrieve[])() = {
+static SV *(*sv_retrieve[])(stcxt_t *cxt) = {
 	0,			/* SX_OBJECT -- entry unused dynamically */
 	retrieve_lscalar,		/* SX_LSCALAR */
 	retrieve_array,			/* SX_ARRAY */
@@ -1002,19 +1007,41 @@ static void clean_store_context(stcxt_t *cxt)
 
 	/*
 	 * And now dispose of them...
+	 *
+	 * The surrounding if() protection has been added because there might be
+	 * some cases where this routine is called more than once, during
+	 * exceptionnal events.  This was reported by Marc Lehmann when Storable
+	 * is executed from mod_perl, and the fix was suggested by him.
+	 * 		-- RAM, 20/12/2000
 	 */
 
-	hv_undef(cxt->hseen);
-	sv_free((SV *) cxt->hseen);
+	if (cxt->hseen) {
+		HV *hseen = cxt->hseen;
+		cxt->hseen = 0;
+		hv_undef(hseen);
+		sv_free((SV *) hseen);
+	}
 
-	hv_undef(cxt->hclass);
-	sv_free((SV *) cxt->hclass);
+	if (cxt->hclass) {
+		HV *hclass = cxt->hclass;
+		cxt->hclass = 0;
+		hv_undef(hclass);
+		sv_free((SV *) hclass);
+	}
 
-	hv_undef(cxt->hook);
-	sv_free((SV *) cxt->hook);
+	if (cxt->hook) {
+		HV *hook = cxt->hook;
+		cxt->hook = 0;
+		hv_undef(hook);
+		sv_free((SV *) hook);
+	}
 
-	av_undef(cxt->hook_seen);
-	sv_free((SV *) cxt->hook_seen);
+	if (cxt->hook_seen) {
+		AV *hook_seen = cxt->hook_seen;
+		cxt->hook_seen = 0;
+		av_undef(hook_seen);
+		sv_free((SV *) hook_seen);
+	}
 
 	cxt->entry = 0;
 	cxt->s_dirty = 0;
@@ -1069,17 +1096,33 @@ static void clean_retrieve_context(stcxt_t *cxt)
 
 	ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()"));
 
-	av_undef(cxt->aseen);
-	sv_free((SV *) cxt->aseen);
+	if (cxt->aseen) {
+		AV *aseen = cxt->aseen;
+		cxt->aseen = 0;
+		av_undef(aseen);
+		sv_free((SV *) aseen);
+	}
 
-	av_undef(cxt->aclass);
-	sv_free((SV *) cxt->aclass);
+	if (cxt->aclass) {
+		AV *aclass = cxt->aclass;
+		cxt->aclass = 0;
+		av_undef(aclass);
+		sv_free((SV *) aclass);
+	}
 
-	hv_undef(cxt->hook);
-	sv_free((SV *) cxt->hook);
+	if (cxt->hook) {
+		HV *hook = cxt->hook;
+		cxt->hook = 0;
+		hv_undef(hook);
+		sv_free((SV *) hook);
+	}
 
-	if (cxt->hseen)
-		sv_free((SV *) cxt->hseen);		/* optional HV, for backward compat. */
+	if (cxt->hseen) {
+		HV *hseen = cxt->hseen;
+		cxt->hseen = 0;
+		hv_undef(hseen);
+		sv_free((SV *) hseen);		/* optional HV, for backward compat. */
+	}
 
 	cxt->entry = 0;
 	cxt->s_dirty = 0;
@@ -1101,6 +1144,8 @@ stcxt_t *cxt;
 		clean_retrieve_context(cxt);
 	else
 		clean_store_context(cxt);
+
+	ASSERT(!cxt->s_dirty, ("context is clean"));
 }
 
 /*
@@ -3371,9 +3416,10 @@ static SV *retrieve_overloaded(stcxt_t *cxt)
 
 	stash = (HV *) SvSTASH (sv);
 	if (!stash || !Gv_AMG(stash))
-		CROAK(("Cannot restore overloading on %s(0x%"UVxf")",
+		CROAK(("Cannot restore overloading on %s(0x%"UVxf") (package %s)",
 		       sv_reftype(sv, FALSE),
-		       PTR2UV(sv)));
+		       PTR2UV(sv),
+			   stash ? HvNAME(stash) : "<unknown>"));
 
 	SvAMAGIC_on(rv);