From: Jarkko Hietaniemi Date: Thu, 4 Jan 2001 18:47:39 +0000 (+0000) Subject: Upgrade to Storable 1.0.7, from Raphael Manfredi. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=862382c78acdf83858c45ec3514945ca83ea34d6;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Storable 1.0.7, from Raphael Manfredi. p4raw-id: //depot/perl@8312 --- diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog index 352e620..92789b5 100644 --- a/ext/Storable/ChangeLog +++ b/ext/Storable/ChangeLog @@ -1,3 +1,21 @@ +Wed Jan 3 10:43:18 MET 2001 Raphael Manfredi + +. 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 . Description: diff --git a/ext/Storable/Makefile.PL b/ext/Storable/Makefile.PL index 8fbc5b3..c8151f3 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 d2a631c..06c05d4 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 a574c33..366a301 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) : "")); SvAMAGIC_on(rv); diff --git a/t/lib/st-lock.t b/t/lib/st-lock.t index 694db16..1faf082 100644 --- a/t/lib/st-lock.t +++ b/t/lib/st-lock.t @@ -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);