freeze nfreeze thaw
dclone
retrieve_fd
+ lock_store lock_nstore lock_retrieve
);
use AutoLoader;
use vars qw($forgive_me $VERSION);
-$VERSION = '1.000';
+$VERSION = '1.003';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
};
}
+#
+# They might miss :flock in Fcntl
+#
+
+BEGIN {
+ require Fcntl;
+ if (exists $Fcntl::EXPORT_TAGS{'flock'}) {
+ Fcntl->import(':flock');
+ } else {
+ eval q{
+ sub LOCK_SH () {1}
+ sub LOCK_EX () {2}
+ };
+ }
+}
+
sub logcroak;
sub retrieve_fd { &fd_retrieve } # Backward compatibility
# removed.
#
sub store {
- return _store(\&pstore, @_);
+ return _store(\&pstore, @_, 0);
}
#
# Same as store, but in network order.
#
sub nstore {
- return _store(\&net_pstore, @_);
+ return _store(\&net_pstore, @_, 0);
+}
+
+#
+# lock_store
+#
+# Same as store, but flock the file first (advisory locking).
+#
+sub lock_store {
+ return _store(\&pstore, @_, 1);
+}
+
+#
+# lock_nstore
+#
+# Same as nstore, but flock the file first (advisory locking).
+#
+sub lock_nstore {
+ return _store(\&net_pstore, @_, 1);
}
# Internal store to file routine
sub _store {
my $xsptr = shift;
my $self = shift;
- my ($file) = @_;
+ my ($file, $use_locking) = @_;
logcroak "not a reference" unless ref($self);
- logcroak "too many arguments" unless @_ == 1; # No @foo in arglist
+ logcroak "too many arguments" unless @_ == 2; # No @foo in arglist
local *FILE;
open(FILE, ">$file") || logcroak "can't create $file: $!";
binmode FILE; # Archaic systems...
+ if ($use_locking) {
+ flock(FILE, LOCK_EX) ||
+ logcroak "can't get exclusive lock on $file: $!";
+ truncate FILE, 0;
+ # Unlocking will happen when FILE is closed
+ }
my $da = $@; # Don't mess if called from exception handler
my $ret;
# Call C routine nstore or pstore, depending on network order
# object of that tree.
#
sub retrieve {
- my ($file) = @_;
+ _retrieve($_[0], 0);
+}
+
+#
+# lock_retrieve
+#
+# Same as retrieve, but with advisory locking.
+#
+sub lock_retrieve {
+ _retrieve($_[0], 1);
+}
+
+# Internal retrieve routine
+sub _retrieve {
+ my ($file, $use_locking) = @_;
local *FILE;
- open(FILE, "$file") || logcroak "can't open $file: $!";
+ open(FILE, $file) || logcroak "can't open $file: $!";
binmode FILE; # Archaic systems...
my $self;
my $da = $@; # Could be from exception handler
+ if ($use_locking) {
+ flock(FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!";
+ # Unlocking will happen when FILE is closed
+ }
eval { $self = pretrieve(*FILE) }; # Call C routine
close(FILE);
logcroak $@ if $@ =~ s/\.?\n$/,/;
# Deep (recursive) cloning
$cloneref = dclone($ref);
+ # Advisory locking
+ use Storable qw(lock_store lock_nstore lock_retrieve)
+ lock_store \%table, 'file';
+ lock_nstore \%table, 'file';
+ $hashref = lock_retrieve('file');
+
=head1 DESCRIPTION
The Storable package brings persistency to your perl data structures
connected. The routines to call have an initial C<n> prefix for I<network>,
as in C<nstore> and C<nstore_fd>. At retrieval time, your data will be
correctly restored so you don't have to know whether you're restoring
-from native or network ordered data.
+from native or network ordered data. Double values are stored stringified
+to ensure portability as well, at the slight risk of loosing some precision
+in the last decimals.
When using C<fd_retrieve>, objects are retrieved in sequence, one
object (i.e. one recursive tree) per associated C<store_fd>.
that intermediary scalar but instead freezes the structure in some
internal memory space and then immediatly thaws it out.
+=head1 ADVISORY LOCKING
+
+The C<lock_store> and C<lock_nstore> routine are equivalent to C<store>
+and C<nstore>, only they get an exclusive lock on the file before
+writing. Likewise, C<lock_retrieve> performs as C<retrieve>, but also
+gets a shared lock on the file before reading.
+
+Like with any advisory locking scheme, the protection only works if
+you systematically use C<lock_store> and C<lock_retrieve>. If one
+side of your application uses C<store> whilst the other uses C<lock_retrieve>,
+you will get no protection at all.
+
+The internal advisory locking is implemented using Perl's flock() routine.
+If your system does not support any form of flock(), or if you share
+your files across NFS, you might wish to use other forms of locking by
+using modules like LockFile::Simple which lock a file using a filesystem
+entry, instead of locking the file descriptor.
+
=head1 SPEED
The heart of Storable is written in C for decent speed. Extra low-level
operations on the same data structures, you will get different
results.
+When storing doubles in network order, their value is stored as text.
+However, you should also not expect non-numeric floating-point values
+such as infinity and "not a number" to pass successfully through a
+nstore()/retrieve() pair.
+
+As Storable neither knows nor cares about character sets (although it
+does know that characters may be more than eight bits wide), any difference
+in the interpretation of character codes between a host and a target
+system is your problem. In particular, if host and target use different
+code points to represent the characters used in the text representation
+of floating-point numbers, you will not be able be able to exchange
+floating-point data, even with nstore().
+
=head1 CREDITS
Thank you to (in chronological order):
Marc Lehmann <pcg@opengroup.org>
Justin Banks <justinb@wamnet.com>
Jarkko Hietaniemi <jhi@iki.fi> (AGAIN, as perl 5.7.0 Pumpkin!)
+ Salvador Ortiz Garcia <sog@msg.com.mx>
+ Dominic Dunlop <domo@computer.org>
+ Erik Haugan <erik@solbors.no>
for their bug reports, suggestions and contributions.
#define PL_sv_yes sv_yes
#define PL_sv_no sv_no
#define PL_sv_undef sv_undef
+#if (SUBVERSION <= 4) /* 5.004_04 has been reported to lack newSVpvn */
+#define newSVpvn newSVpv
#endif
+#endif /* PATCHLEVEL <= 4 */
#ifndef HvSHAREKEYS_off
#define HvSHAREKEYS_off(hv) /* Ignore */
#endif
#define C(x) ((char) (x)) /* For markers with dynamic retrieval handling */
#define SX_OBJECT C(0) /* Already stored object */
-#define SX_LSCALAR C(1) /* Scalar (string) forthcoming (length, data) */
+#define SX_LSCALAR C(1) /* Scalar (large binary) follows (length, data) */
#define SX_ARRAY C(2) /* Array forthcominng (size, item list) */
#define SX_HASH C(3) /* Hash forthcoming (size, key/value pair list) */
#define SX_REF C(4) /* Reference to object forthcoming */
#define SX_DOUBLE C(7) /* Double forthcoming */
#define SX_BYTE C(8) /* (signed) byte forthcoming */
#define SX_NETINT C(9) /* Integer in network order forthcoming */
-#define SX_SCALAR C(10) /* Scalar (small) forthcoming (length, data) */
+#define SX_SCALAR C(10) /* Scalar (binary, small) follows (length, data) */
#define SX_TIED_ARRAY C(11) /* Tied array forthcoming */
#define SX_TIED_HASH C(12) /* Tied hash forthcoming */
#define SX_TIED_SCALAR C(13) /* Tied scalar forthcoming */
#define SX_OVERLOAD C(20) /* Overloaded reference */
#define SX_TIED_KEY C(21) /* Tied magic key forthcoming */
#define SX_TIED_IDX C(22) /* Tied magic index forthcoming */
-#define SX_ERROR C(23) /* Error */
+#define SX_UTF8STR C(23) /* UTF-8 string forthcoming (small) */
+#define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */
+#define SX_ERROR C(25) /* Error */
/*
* Those are only used to retrieve "old" pre-0.6 binary images.
#define MY_VERSION "Storable(" XS_VERSION ")"
+/*
+ * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include
+ * files remap tainted and dirty when threading is enabled. That's bad for
+ * perl to remap such common words. -- RAM, 29/09/00
+ */
+
typedef struct stcxt {
int entry; /* flags recursion */
int optype; /* type of traversal operation */
I32 tagnum; /* incremented at store time for each seen object */
I32 classnum; /* incremented at store time for each seen classname */
int netorder; /* true if network order used */
+ int s_tainted; /* true if input source is tainted, at retrieve time */
int forgive_me; /* whether to be forgiving... */
int canonical; /* whether to store hashes sorted by key */
- int dirty; /* context is dirty due to CROAK() -- can be cleaned */
+ int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */
struct extendable keybuf; /* for hash key retrieval */
struct extendable membuf; /* for memory store/retrieve operations */
PerlIO *fio; /* where I/O are performed, NULL for memory */
* but the topmost context stacked.
*/
-#define CROAK(x) do { cxt->dirty = 1; croak x; } while (0)
+#define CROAK(x) do { cxt->s_dirty = 1; croak x; } while (0)
/*
* End of "thread-safe" related definitions.
static char magicstr[] = "pst0"; /* Used as a magic number */
#define STORABLE_BIN_MAJOR 2 /* Binary major "version" */
-#define STORABLE_BIN_MINOR 2 /* Binary minor "version" */
+#define STORABLE_BIN_MINOR 3 /* Binary minor "version" */
/*
* Useful store shortcuts...
return -1; \
} while (0)
-#define STORE_SCALAR(pv, len) do { \
+#define STORE_PV_LEN(pv, len, small, large) do { \
if (len <= LG_SCALAR) { \
unsigned char clen = (unsigned char) len; \
- PUTMARK(SX_SCALAR); \
+ PUTMARK(small); \
PUTMARK(clen); \
if (len) \
WRITE(pv, len); \
} else { \
- PUTMARK(SX_LSCALAR); \
+ PUTMARK(large); \
WLEN(len); \
WRITE(pv, len); \
} \
} while (0)
+#define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR)
+
+/*
+ * Conditional UTF8 support.
+ * On non-UTF8 perls, UTF8 strings are returned as normal strings.
+ *
+ */
+#ifdef SvUTF8_on
+#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR)
+#else
+#define SvUTF8(sv) 0
+#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl"))
+#define SvUTF8_on(sv) CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl"))
+#endif
+
/*
* Store undef in arrays and hashes without recursing through store().
*/
*/
static SV *retrieve_lscalar(stcxt_t *cxt);
+static SV *retrieve_lutf8str(stcxt_t *cxt);
static SV *old_retrieve_array(stcxt_t *cxt);
static SV *old_retrieve_hash(stcxt_t *cxt);
static SV *retrieve_ref(stcxt_t *cxt);
static SV *retrieve_byte(stcxt_t *cxt);
static SV *retrieve_netint(stcxt_t *cxt);
static SV *retrieve_scalar(stcxt_t *cxt);
+static SV *retrieve_utf8str(stcxt_t *cxt);
static SV *retrieve_tied_array(stcxt_t *cxt);
static SV *retrieve_tied_hash(stcxt_t *cxt);
static SV *retrieve_tied_scalar(stcxt_t *cxt);
retrieve_other, /* SX_OVERLOADED not supported */
retrieve_other, /* SX_TIED_KEY not supported */
retrieve_other, /* SX_TIED_IDX not supported */
+ retrieve_other, /* SX_UTF8STR not supported */
+ retrieve_other, /* SX_LUTF8STR not supported */
retrieve_other, /* SX_ERROR */
};
retrieve_overloaded, /* SX_OVERLOAD */
retrieve_tied_key, /* SX_TIED_KEY */
retrieve_tied_idx, /* SX_TIED_IDX */
+ retrieve_utf8str, /* SX_UTF8STR */
+ retrieve_lutf8str, /* SX_LUTF8STR */
retrieve_other, /* SX_ERROR */
};
sv_free((SV *) cxt->hook);
cxt->entry = 0;
- cxt->dirty = 0;
+ cxt->s_dirty = 0;
}
/*
*
* Initialize a new retrieve context for real recursion.
*/
-static void init_retrieve_context(cxt, optype)
-stcxt_t *cxt;
-int optype;
+static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted)
{
TRACEME(("init_retrieve_context"));
cxt->tagnum = 0; /* Have to count objects... */
cxt->classnum = 0; /* ...and class names as well */
cxt->optype = optype;
+ cxt->s_tainted = is_tainted;
cxt->entry = 1; /* No recursion yet */
}
*
* Clean retrieve context by
*/
-static void clean_retrieve_context(cxt)
-stcxt_t *cxt;
+static void clean_retrieve_context(stcxt_t *cxt)
{
TRACEME(("clean_retrieve_context"));
sv_free((SV *) cxt->hseen); /* optional HV, for backward compat. */
cxt->entry = 0;
- cxt->dirty = 0;
+ cxt->s_dirty = 0;
}
/*
{
TRACEME(("clean_context"));
- ASSERT(cxt->dirty, ("dirty context"));
+ ASSERT(cxt->s_dirty, ("dirty context"));
if (cxt->optype & ST_RETRIEVE)
clean_retrieve_context(cxt);
TRACEME(("allocate_context"));
- ASSERT(!parent_cxt->dirty, ("parent context clean"));
+ ASSERT(!parent_cxt->s_dirty, ("parent context clean"));
Newz(0, cxt, 1, stcxt_t);
cxt->prev = parent_cxt;
TRACEME(("free_context"));
- ASSERT(!cxt->dirty, ("clean context"));
+ ASSERT(!cxt->s_dirty, ("clean context"));
ASSERT(prev, ("not freeing root context"));
if (kbuf)
string:
wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
- STORE_SCALAR(pv, wlen);
+ if (SvUTF8 (sv))
+ STORE_UTF8STR(pv, wlen);
+ else
+ STORE_SCALAR(pv, wlen);
TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")",
PTR2UV(sv), SvPVX(sv), (IV)len));
pv = SvPV(ary[0], len2);
/*
- * Allocate a class ID if not already done.
- */
-
- if (!known_class(cxt, class, len, &classnum)) {
- TRACEME(("first time we see class %s, ID = %d", class, classnum));
- classnum = -1; /* Mark: we must store classname */
- } else {
- TRACEME(("already seen class %s, ID = %d", class, classnum));
- }
-
- /*
* If they returned more than one item, we need to serialize some
* extra references if not already done.
*
}
/*
+ * Allocate a class ID if not already done.
+ *
+ * This needs to be done after the recursion above, since at retrieval
+ * time, we'll see the inner objects first. Many thanks to
+ * Salvador Ortiz Garcia <sog@msg.com.mx> who spot that bug and
+ * proposed the right fix. -- RAM, 15/09/2000
+ */
+
+ if (!known_class(cxt, class, len, &classnum)) {
+ TRACEME(("first time we see class %s, ID = %d", class, classnum));
+ classnum = -1; /* Mark: we must store classname */
+ } else {
+ TRACEME(("already seen class %s, ID = %d", class, classnum));
+ }
+
+ /*
* Compute leading flags.
*/
* free up memory for them now.
*/
- if (cxt->dirty)
+ if (cxt->s_dirty)
clean_context(cxt);
/*
cxt->entry++;
ASSERT(cxt->entry == 1, ("starting new recursion"));
- ASSERT(!cxt->dirty, ("clean context"));
+ ASSERT(!cxt->s_dirty, ("clean context"));
/*
* Ensure sv is actually a reference. From perl, we called something
*SvEND(frozen) = '\0';
}
(void) SvPOK_only(frozen); /* Validates string pointer */
- SvTAINT(frozen);
+ if (cxt->s_tainted) /* Is input source tainted? */
+ SvTAINT(frozen);
TRACEME(("frozen string: %d bytes", len2));
SvCUR_set(sv, len); /* Record C string length */
*SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */
(void) SvPOK_only(sv); /* Validate string pointer */
- SvTAINT(sv); /* External data cannot be trusted */
+ if (cxt->s_tainted) /* Is input source tainted? */
+ SvTAINT(sv); /* External data cannot be trusted */
TRACEME(("large scalar len %"IVdf" '%s'", len, SvPVX(sv)));
TRACEME(("ok (retrieve_lscalar at 0x%"UVxf")", PTR2UV(sv)));
}
(void) SvPOK_only(sv); /* Validate string pointer */
- SvTAINT(sv); /* External data cannot be trusted */
+ if (cxt->s_tainted) /* Is input source tainted? */
+ SvTAINT(sv); /* External data cannot be trusted */
TRACEME(("ok (retrieve_scalar at 0x%"UVxf")", PTR2UV(sv)));
return sv;
}
/*
+ * retrieve_utf8str
+ *
+ * Like retrieve_scalar(), but tag result as utf8.
+ * If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
+ */
+static SV *retrieve_utf8str(stcxt_t *cxt)
+{
+ SV *sv;
+
+ TRACEME(("retrieve_utf8str"));
+
+ sv = retrieve_scalar(cxt);
+ if (sv)
+ SvUTF8_on(sv);
+
+ return sv;
+}
+
+/*
+ * retrieve_lutf8str
+ *
+ * Like retrieve_lscalar(), but tag result as utf8.
+ * If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
+ */
+static SV *retrieve_lutf8str(stcxt_t *cxt)
+{
+ SV *sv;
+
+ TRACEME(("retrieve_lutf8str"));
+
+ sv = retrieve_lscalar(cxt);
+ if (sv)
+ SvUTF8_on(sv);
+
+ return sv;
+}
+
+/*
* retrieve_integer
*
* Retrieve defined integer.
{
dSTCXT;
SV *sv;
+ int is_tainted; /* Is input source tainted? */
struct extendable msave; /* Where potentially valid mbuf is saved */
TRACEME(("do_retrieve (optype = 0x%x)", optype));
* free up memory for them now.
*/
- if (cxt->dirty)
+ if (cxt->s_dirty)
clean_context(cxt);
/*
cxt->entry++;
ASSERT(cxt->entry == 1, ("starting new recursion"));
- ASSERT(!cxt->dirty, ("clean context"));
+ ASSERT(!cxt->s_dirty, ("clean context"));
/*
* Prepare context.
TRACEME(("data stored in %s format",
cxt->netorder ? "net order" : "native"));
- init_retrieve_context(cxt, optype);
+ /*
+ * Check whether input source is tainted, so that we don't wrongly
+ * taint perfectly good values...
+ *
+ * We assume file input is always tainted. If both `f' and `in' are
+ * NULL, then we come from dclone, and tainted is already filled in
+ * the context. That's a kludge, but the whole dclone() thing is
+ * already quite a kludge anyway! -- RAM, 15/09/2000.
+ */
+
+ is_tainted = f ? 1 : (in ? SvTAINTED(in) : cxt->s_tainted);
+ TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted"));
+ init_retrieve_context(cxt, optype, is_tainted);
ASSERT(is_retrieving(), ("within retrieve operation"));
* free up memory for them now.
*/
- if (cxt->dirty)
+ if (cxt->s_dirty)
clean_context(cxt);
/*
* Now, `cxt' may refer to a new context.
*/
- ASSERT(!cxt->dirty, ("clean context"));
+ ASSERT(!cxt->s_dirty, ("clean context"));
ASSERT(!cxt->entry, ("entry will not cause new context allocation"));
size = MBUF_SIZE();
TRACEME(("dclone stored %d bytes", size));
-
MBUF_INIT(size);
- out = do_retrieve((PerlIO*) 0, Nullsv, ST_CLONE); /* Will free non-root context */
+
+ /*
+ * Since we're passing do_retrieve() both a NULL file and sv, we need
+ * to pre-compute the taintedness of the input by setting cxt->tainted
+ * to whatever state our own input string was. -- RAM, 15/09/2000
+ *
+ * do_retrieve() will free non-root context.
+ */
+
+ cxt->s_tainted = SvTAINTED(sv);
+ out = do_retrieve((PerlIO*) 0, Nullsv, ST_CLONE);
TRACEME(("dclone returns 0x%"UVxf, PTR2UV(out)));
projects / p5sagit/p5-mst-13.2.git / commitdiff