-;# $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
;#
;# 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
;#
use AutoLoader;
use vars qw($forgive_me $VERSION);
-$VERSION = '1.006';
+$VERSION = '1.007';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
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__
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;
}
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;
}
*/
/*
- * $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
*
#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)
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])
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 */
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 */
/*
* 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;
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;
clean_retrieve_context(cxt);
else
clean_store_context(cxt);
+
+ ASSERT(!cxt->s_dirty, ("context is clean"));
}
/*
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);
#!./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
#
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);
projects / p5sagit/p5-mst-13.2.git / commitdiff