This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Storable 1.0.7, from Raphael Manfredi.
authorJarkko Hietaniemi <jhi@iki.fi>
Thu, 4 Jan 2001 18:47:39 +0000 (18:47 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Thu, 4 Jan 2001 18:47:39 +0000 (18:47 +0000)
p4raw-id: //depot/perl@8312

ext/Storable/ChangeLog
ext/Storable/Makefile.PL
ext/Storable/Storable.pm
ext/Storable/Storable.xs
t/lib/st-lock.t

index 352e620..92789b5 100644 (file)
@@ -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:
index 8fbc5b3..c8151f3 100644 (file)
@@ -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' => '*%'},
 );
 
index d2a631c..06c05d4 100644 (file)
@@ -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;
                }
index a574c33..366a301 100644 (file)
@@ -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
  *  
  *  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);
 
index 694db16..1faf082 100644 (file)
@@ -1,10 +1,13 @@
 #!./perl
 
-# $Id: lock.t,v 1.0.1.3 2000/10/26 17:11:27 ram Exp ram $
+# $Id: lock.t,v 1.0.1.4 2001/01/03 09:41:00 ram Exp $
 #
 #  @COPYRIGHT@
 #
 # $Log: lock.t,v $
+# Revision 1.0.1.4  2001/01/03 09:41:00  ram
+# patch7: use new CAN_FLOCK routine to determine whether to run tests
+#
 # Revision 1.0.1.3  2000/10/26 17:11:27  ram
 # patch5: just check $^O, there's no need for the whole Config
 #
@@ -25,23 +28,19 @@ sub BEGIN {
         print "1..0 # Skip: Storable was not built\n";
         exit 0;
     }
-    if (!$Config{'d_flock'} &&
-       !$Config{'d_fcntl_can_lock'} &&
-       !$Config{'d_lockf'}) {
-        print "1..0 # Skip: no flock or flock emulation on this platform\n";
-        exit 0;
-    }
-    if ($^O eq 'dos') {
+
+    use Storable qw(lock_store lock_retrieve);
+
+    unless (&Storable::CAN_FLOCK) {
        print "1..0 # Skip: fcntl/flock emulation broken on this platform\n";
        exit 0;
     }
+
     require 'lib/st-dump.pl';
 }
 
 sub ok;
 
-use Storable qw(lock_store lock_retrieve);
-
 print "1..5\n";
 
 @a = ('first', undef, 3, -4, -3.14159, 456, 4.5);