X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FStorable%2FStorable.xs;h=5b3868b8f7e35aae95ae13ac138cf3d50908eddc;hb=821bf9a5d89e1fc44be0165540e1f57de5c874e1;hp=d3cb8072d56148be6b9c93528a8735b2d24843dd;hpb=7c436af33814ce716234caa65f470fe47c2a0efa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index d3cb807..5b3868b 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -1,67 +1,35 @@ /* - * Store and retrieve mechanism. - */ - -/* - * $Id: Storable.xs,v 1.0.1.10 2001/08/28 21:52:14 ram Exp $ + * Store and retrieve mechanism. * * Copyright (c) 1995-2000, Raphael Manfredi * * You may redistribute only under the same terms as Perl 5, as specified * in the README file that comes with the distribution. * - * $Log: Storable.xs,v $ - * Revision 1.0.1.10 2001/08/28 21:52:14 ram - * patch13: removed spurious debugging messages - * - * Revision 1.0.1.9 2001/07/01 11:25:02 ram - * patch12: fixed memory corruption on croaks during thaw() - * patch12: made code compile cleanly with -Wall (Jarkko Hietaniemi) - * patch12: changed tagnum and classnum from I32 to IV in context - * - * Revision 1.0.1.8 2001/03/15 00:20:55 ram - * patch11: last version was wrongly compiling with assertions on - * - * Revision 1.0.1.7 2001/02/17 12:25:26 ram - * patch8: now bless objects ASAP at retrieve time - * patch8: added support for blessed ref to tied structures - * - * 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 - * - * Revision 1.0.1.4 2000/10/26 17:11:04 ram - * patch5: auto requires module of blessed ref when STORABLE_thaw misses - * - * Revision 1.0.1.3 2000/09/29 19:49:57 ram - * patch3: avoid using "tainted" and "dirty" since Perl remaps them via cpp - * - * Revision 1.0.1.2 2000/09/28 21:43:10 ram - * patch2: perls before 5.004_04 lack newSVpvn - * - * Revision 1.0.1.1 2000/09/17 16:47:49 ram - * patch1: now only taint retrieved data when source was tainted - * patch1: added support for UTF-8 strings - * patch1: fixed store hook bug: was allocating class id too soon - * - * Revision 1.0 2000/09/01 19:40:41 ram - * Baseline for first official release. - * */ #include #include -#include /* Perl's one, needed since 5.6 */ #include -#if 1 +#ifndef PATCHLEVEL +# include /* Perl's one, needed since 5.6 */ +# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL))) +# include +# endif +#endif + +#ifndef NETWARE +#if 0 #define DEBUGME /* Debug mode, turns assertions on as well */ #define DASSERT /* Assertion mode */ #endif +#else /* NETWARE */ +#if 0 /* On NetWare USE_PERLIO is not used */ +#define DEBUGME /* Debug mode, turns assertions on as well */ +#define DASSERT /* Assertion mode */ +#endif +#endif /* * Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined @@ -133,22 +101,24 @@ typedef double NV; /* Older perls lack the NV type */ * TRACEME() will only output things when the $Storable::DEBUGME is true. */ -#define TRACEME(x) do { \ +#define TRACEME(x) \ + STMT_START { \ if (SvTRUE(perl_get_sv("Storable::DEBUGME", TRUE))) \ - { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \ -} while (0) + { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \ + } STMT_END #else #define TRACEME(x) #endif /* DEBUGME */ #ifdef DASSERT -#define ASSERT(x,y) do { \ +#define ASSERT(x,y) \ + STMT_START { \ if (!(x)) { \ PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ", \ __FILE__, __LINE__); \ PerlIO_stdoutf y; PerlIO_stdoutf("\n"); \ } \ -} while (0) + } STMT_END #else #define ASSERT(x,y) #endif @@ -170,9 +140,9 @@ typedef double NV; /* Older perls lack the NV type */ #define SX_BYTE C(8) /* (signed) byte forthcoming */ #define SX_NETINT C(9) /* Integer in network order forthcoming */ #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_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_SV_UNDEF C(14) /* Perl's immortal PL_sv_undef */ #define SX_SV_YES C(15) /* Perl's immortal PL_sv_yes */ #define SX_SV_NO C(16) /* Perl's immortal PL_sv_no */ @@ -180,12 +150,13 @@ typedef double NV; /* Older perls lack the NV type */ #define SX_IX_BLESS C(18) /* Object is blessed, classname given by index */ #define SX_HOOK C(19) /* Stored via hook, user-defined */ #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_UTF8STR C(23) /* UTF-8 string forthcoming (small) */ -#define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */ -#define SX_FLAG_HASH C(25) /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */ -#define SX_ERROR C(26) /* Error */ +#define SX_TIED_KEY C(21) /* Tied magic key forthcoming */ +#define SX_TIED_IDX C(22) /* Tied magic index forthcoming */ +#define SX_UTF8STR C(23) /* UTF-8 string forthcoming (small) */ +#define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */ +#define SX_FLAG_HASH C(25) /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */ +#define SX_CODE C(26) /* Code references as perl source code */ +#define SX_ERROR C(27) /* Error */ /* * Those are only used to retrieve "old" pre-0.6 binary images. @@ -201,7 +172,7 @@ typedef double NV; /* Older perls lack the NV type */ */ #define SX_CLASS 'b' /* Object is blessed, class name length <255 */ -#define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */ +#define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */ #define SX_STORED 'X' /* End of object */ /* @@ -325,6 +296,8 @@ typedef struct stcxt { 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 deparse; /* whether to deparse code refs */ + SV *eval; /* whether to eval source code */ int canonical; /* whether to store hashes sorted by key */ #ifndef HAS_RESTRICTED_HASHES int derestrict; /* whether to downgrade restrcted hashes */ @@ -332,6 +305,7 @@ typedef struct stcxt { #ifndef HAS_UTF8_ALL int use_bytes; /* whether to bytes-ify utf8 */ #endif + int accept_future_minor; /* croak immediately on future minor versions? */ int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */ int membuf_ro; /* true means membuf is read-only and msaved is rw */ struct extendable keybuf; /* for hash key retrieval */ @@ -341,9 +315,20 @@ typedef struct stcxt { int ver_major; /* major of version for retrieved object */ int ver_minor; /* minor of version for retrieved object */ SV *(**retrieve_vtbl)(); /* retrieve dispatch table */ - struct stcxt *prev; /* contexts chained backwards in real recursion */ + SV *prev; /* contexts chained backwards in real recursion */ + SV *my_sv; /* the blessed scalar who's SvPVX() I am */ } stcxt_t; +#define NEW_STORABLE_CXT_OBJ(cxt) \ + STMT_START { \ + SV *self = newSV(sizeof(stcxt_t) - 1); \ + SV *my_sv = newRV_noinc(self); \ + sv_bless(my_sv, gv_stashpv("Storable::Cxt", TRUE)); \ + cxt = (stcxt_t *)SvPVX(self); \ + Zero(cxt, 1, stcxt_t); \ + cxt->my_sv = my_sv; \ + } STMT_END + #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI) #if (PATCHLEVEL <= 4) && (SUBVERSION < 68) @@ -356,29 +341,33 @@ typedef struct stcxt { #endif /* < perl5.004_68 */ #define dSTCXT_PTR(T,name) \ - T name = ((perinterp_sv && SvIOK(perinterp_sv) \ - ? INT2PTR(T, SvIVX(perinterp_sv)) : (T) 0)) + T name = ((perinterp_sv && SvIOK(perinterp_sv) && SvIVX(perinterp_sv) \ + ? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0)) #define dSTCXT \ dSTCXT_SV; \ dSTCXT_PTR(stcxt_t *, cxt) -#define INIT_STCXT \ - dSTCXT; \ - Newz(0, cxt, 1, stcxt_t); \ - sv_setiv(perinterp_sv, PTR2IV(cxt)) +#define INIT_STCXT \ + dSTCXT; \ + NEW_STORABLE_CXT_OBJ(cxt); \ + sv_setiv(perinterp_sv, PTR2IV(cxt->my_sv)) -#define SET_STCXT(x) do { \ +#define SET_STCXT(x) \ + STMT_START { \ dSTCXT_SV; \ - sv_setiv(perinterp_sv, PTR2IV(x)); \ -} while (0) + sv_setiv(perinterp_sv, PTR2IV(x->my_sv)); \ + } STMT_END #else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */ -static stcxt_t Context; -static stcxt_t *Context_ptr = &Context; +static stcxt_t *Context_ptr = NULL; #define dSTCXT stcxt_t *cxt = Context_ptr -#define INIT_STCXT dSTCXT -#define SET_STCXT(x) Context_ptr = x +#define SET_STCXT(x) Context_ptr = x +#define INIT_STCXT \ + dSTCXT; \ + NEW_STORABLE_CXT_OBJ(cxt); \ + SET_STCXT(cxt) + #endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */ @@ -399,7 +388,7 @@ static stcxt_t *Context_ptr = &Context; * but the topmost context stacked. */ -#define CROAK(x) do { cxt->s_dirty = 1; croak x; } while (0) +#define CROAK(x) STMT_START { cxt->s_dirty = 1; croak x; } STMT_END /* * End of "thread-safe" related definitions. @@ -441,20 +430,22 @@ static stcxt_t *Context_ptr = &Context; */ #define kbuf (cxt->keybuf).arena #define ksiz (cxt->keybuf).asiz -#define KBUFINIT() do { \ +#define KBUFINIT() \ + STMT_START { \ if (!kbuf) { \ TRACEME(("** allocating kbuf of 128 bytes")); \ New(10003, kbuf, 128, char); \ ksiz = 128; \ } \ -} while (0) -#define KBUFCHK(x) do { \ + } STMT_END +#define KBUFCHK(x) \ + STMT_START { \ if (x >= ksiz) { \ TRACEME(("** extending kbuf to %d bytes (had %d)", x+1, ksiz)); \ Renew(kbuf, x+1, char); \ ksiz = x+1; \ } \ -} while (0) + } STMT_END /* * memory buffer handling @@ -474,18 +465,19 @@ static stcxt_t *Context_ptr = &Context; #define int_aligned(x) \ ((unsigned long) (x) == trunc_int(x)) -#define MBUF_INIT(x) do { \ +#define MBUF_INIT(x) \ + STMT_START { \ if (!mbase) { \ TRACEME(("** allocating mbase of %d bytes", MGROW)); \ New(10003, mbase, MGROW, char); \ - msiz = MGROW; \ + msiz = (STRLEN)MGROW; \ } \ mptr = mbase; \ if (x) \ mend = mbase + x; \ else \ mend = mbase + msiz; \ -} while (0) + } STMT_END #define MBUF_TRUNC(x) mptr = mbase + x #define MBUF_SIZE() (mptr - mbase) @@ -498,34 +490,38 @@ static stcxt_t *Context_ptr = &Context; * buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve * data from a string. */ -#define MBUF_SAVE_AND_LOAD(in) do { \ +#define MBUF_SAVE_AND_LOAD(in) \ + STMT_START { \ ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \ cxt->membuf_ro = 1; \ TRACEME(("saving mbuf")); \ StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \ MBUF_LOAD(in); \ -} while (0) + } STMT_END -#define MBUF_RESTORE() do { \ +#define MBUF_RESTORE() \ + STMT_START { \ ASSERT(cxt->membuf_ro, ("mbase is read-only")); \ cxt->membuf_ro = 0; \ TRACEME(("restoring mbuf")); \ StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \ -} while (0) + } STMT_END /* * Use SvPOKp(), because SvPOK() fails on tainted scalars. * See store_scalar() for other usage of this workaround. */ -#define MBUF_LOAD(v) do { \ +#define MBUF_LOAD(v) \ + STMT_START { \ ASSERT(cxt->membuf_ro, ("mbase is read-only")); \ if (!SvPOKp(v)) \ CROAK(("Not a scalar string")); \ mptr = mbase = SvPV(v, msiz); \ mend = mbase + msiz; \ -} while (0) + } STMT_END -#define MBUF_XTEND(x) do { \ +#define MBUF_XTEND(x) \ + STMT_START { \ int nsz = (int) round_mgrow((x)+msiz); \ int offset = mptr - mbase; \ ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \ @@ -535,31 +531,35 @@ static stcxt_t *Context_ptr = &Context; msiz = nsz; \ mptr = mbase + offset; \ mend = mbase + nsz; \ -} while (0) + } STMT_END -#define MBUF_CHK(x) do { \ +#define MBUF_CHK(x) \ + STMT_START { \ if ((mptr + (x)) > mend) \ MBUF_XTEND(x); \ -} while (0) + } STMT_END -#define MBUF_GETC(x) do { \ +#define MBUF_GETC(x) \ + STMT_START { \ if (mptr < mend) \ x = (int) (unsigned char) *mptr++; \ else \ return (SV *) 0; \ -} while (0) + } STMT_END #ifdef CRAY_HACK -#define MBUF_GETINT(x) do { \ +#define MBUF_GETINT(x) \ + STMT_START { \ oC(x); \ if ((mptr + 4) <= mend) { \ memcpy(oI(&x), mptr, 4); \ mptr += 4; \ } else \ return (SV *) 0; \ -} while (0) + } STMT_END #else -#define MBUF_GETINT(x) do { \ +#define MBUF_GETINT(x) \ + STMT_START { \ if ((mptr + sizeof(int)) <= mend) { \ if (int_aligned(mptr)) \ x = *(int *) mptr; \ @@ -568,18 +568,20 @@ static stcxt_t *Context_ptr = &Context; mptr += sizeof(int); \ } else \ return (SV *) 0; \ -} while (0) + } STMT_END #endif -#define MBUF_READ(x,s) do { \ +#define MBUF_READ(x,s) \ + STMT_START { \ if ((mptr + (s)) <= mend) { \ memcpy(x, mptr, s); \ mptr += s; \ } else \ return (SV *) 0; \ -} while (0) + } STMT_END -#define MBUF_SAFEREAD(x,s,z) do { \ +#define MBUF_SAFEREAD(x,s,z) \ + STMT_START { \ if ((mptr + (s)) <= mend) { \ memcpy(x, mptr, s); \ mptr += s; \ @@ -587,39 +589,43 @@ static stcxt_t *Context_ptr = &Context; sv_free(z); \ return (SV *) 0; \ } \ -} while (0) + } STMT_END -#define MBUF_PUTC(c) do { \ +#define MBUF_PUTC(c) \ + STMT_START { \ if (mptr < mend) \ *mptr++ = (char) c; \ else { \ MBUF_XTEND(1); \ *mptr++ = (char) c; \ } \ -} while (0) + } STMT_END #ifdef CRAY_HACK -#define MBUF_PUTINT(i) do { \ +#define MBUF_PUTINT(i) \ + STMT_START { \ MBUF_CHK(4); \ memcpy(mptr, oI(&i), 4); \ mptr += 4; \ -} while (0) + } STMT_END #else -#define MBUF_PUTINT(i) do { \ +#define MBUF_PUTINT(i) \ + STMT_START { \ MBUF_CHK(sizeof(int)); \ if (int_aligned(mptr)) \ *(int *) mptr = i; \ else \ memcpy(mptr, &i, sizeof(int)); \ mptr += sizeof(int); \ -} while (0) + } STMT_END #endif -#define MBUF_WRITE(x,s) do { \ +#define MBUF_WRITE(x,s) \ + STMT_START { \ MBUF_CHK(s); \ memcpy(mptr, x, s); \ mptr += s; \ -} while (0) + } STMT_END /* * Possible return values for sv_type(). @@ -631,7 +637,8 @@ static stcxt_t *Context_ptr = &Context; #define svis_HASH 3 #define svis_TIED 4 #define svis_TIED_ITEM 5 -#define svis_OTHER 6 +#define svis_CODE 6 +#define svis_OTHER 7 /* * Flags for SX_HOOK. @@ -694,12 +701,72 @@ static stcxt_t *Context_ptr = &Context; * a "minor" version, to better track this kind of evolution from now on. * */ -static char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */ -static char magicstr[] = "pst0"; /* Used as a magic number */ +static const char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */ +static const char magicstr[] = "pst0"; /* Used as a magic number */ + +#define MAGICSTR_BYTES 'p','s','t','0' +#define OLDMAGICSTR_BYTES 'p','e','r','l','-','s','t','o','r','e' + +/* 5.6.x introduced the ability to have IVs as long long. + However, Configure still defined BYTEORDER based on the size of a long. + Storable uses the BYTEORDER value as part of the header, but doesn't + explicity store sizeof(IV) anywhere in the header. Hence on 5.6.x built + with IV as long long on a platform that uses Configure (ie most things + except VMS and Windows) headers are identical for the different IV sizes, + despite the files containing some fields based on sizeof(IV) + Erk. Broken-ness. + 5.8 is consistent - the following redifinition kludge is only needed on + 5.6.x, but the interwork is needed on 5.8 while data survives in files + with the 5.6 header. + +*/ + +#if defined (IVSIZE) && (IVSIZE == 8) && (LONGSIZE == 4) +#ifndef NO_56_INTERWORK_KLUDGE +#define USE_56_INTERWORK_KLUDGE +#endif +#if BYTEORDER == 0x1234 +#undef BYTEORDER +#define BYTEORDER 0x12345678 +#else +#if BYTEORDER == 0x4321 +#undef BYTEORDER +#define BYTEORDER 0x87654321 +#endif +#endif +#endif + +#if BYTEORDER == 0x1234 +#define BYTEORDER_BYTES '1','2','3','4' +#else +#if BYTEORDER == 0x12345678 +#define BYTEORDER_BYTES '1','2','3','4','5','6','7','8' +#ifdef USE_56_INTERWORK_KLUDGE +#define BYTEORDER_BYTES_56 '1','2','3','4' +#endif +#else +#if BYTEORDER == 0x87654321 +#define BYTEORDER_BYTES '8','7','6','5','4','3','2','1' +#ifdef USE_56_INTERWORK_KLUDGE +#define BYTEORDER_BYTES_56 '4','3','2','1' +#endif +#else +#if BYTEORDER == 0x4321 +#define BYTEORDER_BYTES '4','3','2','1' +#else +#error Unknown byteoder. Please append your byteorder to Storable.xs +#endif +#endif +#endif +#endif +static const char byteorderstr[] = {BYTEORDER_BYTES, 0}; +#ifdef USE_56_INTERWORK_KLUDGE +static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; +#endif #define STORABLE_BIN_MAJOR 2 /* Binary major "version" */ -#define STORABLE_BIN_MINOR 5 /* Binary minor "version" */ +#define STORABLE_BIN_MINOR 6 /* Binary minor "version" */ /* If we aren't 5.7.3 or later, we won't be writing out files that use the * new flagged hash introdued in 2.5, so put 2.4 in the binary header to @@ -713,30 +780,44 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ * As of perl 5.7.3, utf8 hash key is introduced. * So this must change -- dankogai */ -#define STORABLE_BIN_WRITE_MINOR 5 +#define STORABLE_BIN_WRITE_MINOR 6 #endif /* (PATCHLEVEL <= 6) */ +#if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1)) +#define PL_sv_placeholder PL_sv_undef +#endif + /* * Useful store shortcuts... */ -#define PUTMARK(x) do { \ +/* + * Note that if you put more than one mark for storing a particular + * type of thing, *and* in the retrieve_foo() function you mark both + * the thingy's you get off with SEEN(), you *must* increase the + * tagnum with cxt->tagnum++ along with this macro! + * - samv 20Jan04 + */ +#define PUTMARK(x) \ + STMT_START { \ if (!cxt->fio) \ MBUF_PUTC(x); \ else if (PerlIO_putc(cxt->fio, x) == EOF) \ return -1; \ -} while (0) + } STMT_END -#define WRITE_I32(x) do { \ +#define WRITE_I32(x) \ + STMT_START { \ ASSERT(sizeof(x) == sizeof(I32), ("writing an I32")); \ if (!cxt->fio) \ MBUF_PUTINT(x); \ else if (PerlIO_write(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \ return -1; \ - } while (0) + } STMT_END #ifdef HAS_HTONL -#define WLEN(x) do { \ +#define WLEN(x) \ + STMT_START { \ if (cxt->netorder) { \ int y = (int) htonl(x); \ if (!cxt->fio) \ @@ -749,19 +830,21 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ else if (PerlIO_write(cxt->fio,oI(&x),oS(sizeof(x))) != oS(sizeof(x))) \ return -1; \ } \ -} while (0) + } STMT_END #else #define WLEN(x) WRITE_I32(x) #endif -#define WRITE(x,y) do { \ +#define WRITE(x,y) \ + STMT_START { \ if (!cxt->fio) \ MBUF_WRITE(x,y); \ else if (PerlIO_write(cxt->fio, x, y) != y) \ return -1; \ - } while (0) + } STMT_END -#define STORE_PV_LEN(pv, len, small, large) do { \ +#define STORE_PV_LEN(pv, len, small, large) \ + STMT_START { \ if (len <= LG_SCALAR) { \ unsigned char clen = (unsigned char) len; \ PUTMARK(small); \ @@ -773,17 +856,18 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ WLEN(len); \ WRITE(pv, len); \ } \ -} while (0) + } STMT_END #define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR) /* - * Store undef in arrays and hashes without recursing through store(). + * Store &PL_sv_undef in arrays without recursing through store(). */ -#define STORE_UNDEF() do { \ +#define STORE_SV_UNDEF() \ + STMT_START { \ cxt->tagnum++; \ - PUTMARK(SX_UNDEF); \ -} while (0) + PUTMARK(SX_SV_UNDEF); \ + } STMT_END /* * Useful retrieve shortcuts... @@ -792,24 +876,27 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ #define GETCHAR() \ (cxt->fio ? PerlIO_getc(cxt->fio) : (mptr >= mend ? EOF : (int) *mptr++)) -#define GETMARK(x) do { \ +#define GETMARK(x) \ + STMT_START { \ if (!cxt->fio) \ MBUF_GETC(x); \ else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \ return (SV *) 0; \ -} while (0) + } STMT_END -#define READ_I32(x) do { \ +#define READ_I32(x) \ + STMT_START { \ ASSERT(sizeof(x) == sizeof(I32), ("reading an I32")); \ oC(x); \ if (!cxt->fio) \ MBUF_GETINT(x); \ else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \ return (SV *) 0; \ -} while (0) + } STMT_END #ifdef HAS_NTOHL -#define RLEN(x) do { \ +#define RLEN(x) \ + STMT_START { \ oC(x); \ if (!cxt->fio) \ MBUF_GETINT(x); \ @@ -817,26 +904,28 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ return (SV *) 0; \ if (cxt->netorder) \ x = (int) ntohl(x); \ -} while (0) + } STMT_END #else #define RLEN(x) READ_I32(x) #endif -#define READ(x,y) do { \ +#define READ(x,y) \ + STMT_START { \ if (!cxt->fio) \ MBUF_READ(x, y); \ else if (PerlIO_read(cxt->fio, x, y) != y) \ return (SV *) 0; \ -} while (0) + } STMT_END -#define SAFEREAD(x,y,z) do { \ +#define SAFEREAD(x,y,z) \ + STMT_START { \ if (!cxt->fio) \ MBUF_SAFEREAD(x,y,z); \ else if (PerlIO_read(cxt->fio, x, y) != y) { \ sv_free(z); \ return (SV *) 0; \ } \ -} while (0) + } STMT_END /* * This macro is used at retrieve time, to remember where object 'y', bearing a @@ -856,7 +945,8 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ * recursively, and the first SEEN() call for which the class name is not NULL * will bless the object. */ -#define SEEN(y,c) do { \ +#define SEEN(y,c) \ + STMT_START { \ if (!y) \ return (SV *) 0; \ if (av_store(cxt->aseen, cxt->tagnum++, SvREFCNT_inc(y)) == 0) \ @@ -865,12 +955,13 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ PTR2UV(y), SvREFCNT(y)-1)); \ if (c) \ BLESS((SV *) (y), c); \ -} while (0) + } STMT_END /* * Bless `s' in `p', via a temporary reference, required by sv_bless(). */ -#define BLESS(s,p) do { \ +#define BLESS(s,p) \ + STMT_START { \ SV *ref; \ HV *stash; \ TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (p))); \ @@ -879,7 +970,7 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ (void) sv_bless(ref, stash); \ SvRV(ref) = 0; \ SvREFCNT_dec(ref); \ -} while (0) + } STMT_END static int store(); static SV *retrieve(stcxt_t *cxt, char *cname); @@ -894,6 +985,7 @@ static int store_array(stcxt_t *cxt, AV *av); static int store_hash(stcxt_t *cxt, HV *hv); static int store_tied(stcxt_t *cxt, SV *sv); static int store_tied_item(stcxt_t *cxt, SV *sv); +static int store_code(stcxt_t *cxt, CV *cv); static int store_other(stcxt_t *cxt, SV *sv); static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg); @@ -904,6 +996,7 @@ static int (*sv_store[])(stcxt_t *cxt, SV *sv) = { (int (*)(stcxt_t *cxt, SV *sv)) store_hash, /* svis_HASH */ store_tied, /* svis_TIED */ store_tied_item, /* svis_TIED_ITEM */ + (int (*)(stcxt_t *cxt, SV *sv)) store_code, /* svis_CODE */ store_other, /* svis_OTHER */ }; @@ -957,6 +1050,7 @@ static SV *(*sv_old_retrieve[])(stcxt_t *cxt, char *cname) = { retrieve_other, /* SX_UTF8STR not supported */ retrieve_other, /* SX_LUTF8STR not supported */ retrieve_other, /* SX_FLAG_HASH not supported */ + retrieve_other, /* SX_CODE not supported */ retrieve_other, /* SX_ERROR */ }; @@ -972,6 +1066,7 @@ static SV *retrieve_overloaded(stcxt_t *cxt, char *cname); static SV *retrieve_tied_key(stcxt_t *cxt, char *cname); static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname); static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname); +static SV *retrieve_code(stcxt_t *cxt, char *cname); static SV *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = { 0, /* SX_OBJECT -- entry unused dynamically */ @@ -1000,6 +1095,7 @@ static SV *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = { retrieve_utf8str, /* SX_UTF8STR */ retrieve_lutf8str, /* SX_LUTF8STR */ retrieve_flag_hash, /* SX_HASH */ + retrieve_code, /* SX_CODE */ retrieve_other, /* SX_ERROR */ }; @@ -1052,6 +1148,8 @@ static void init_store_context( cxt->netorder = network_order; cxt->forgive_me = -1; /* Fetched from perl if needed */ + cxt->deparse = -1; /* Idem */ + cxt->eval = NULL; /* Idem */ cxt->canonical = -1; /* Idem */ cxt->tagnum = -1; /* Reset tag numbers */ cxt->classnum = -1; /* Reset class numbers */ @@ -1197,6 +1295,14 @@ static void clean_store_context(stcxt_t *cxt) sv_free((SV *) hook_seen); } + cxt->forgive_me = -1; /* Fetched from perl if needed */ + cxt->deparse = -1; /* Idem */ + if (cxt->eval) { + SvREFCNT_dec(cxt->eval); + } + cxt->eval = NULL; /* Idem */ + cxt->canonical = -1; /* Idem */ + reset_context(cxt); } @@ -1227,7 +1333,8 @@ static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted) * new retrieve routines. */ - cxt->hseen = ((cxt->retrieve_vtbl == sv_old_retrieve) ? newHV() : 0); + cxt->hseen = (((void*)cxt->retrieve_vtbl == (void*)sv_old_retrieve) + ? newHV() : 0); cxt->aseen = newAV(); /* Where retrieved objects are kept */ cxt->aclass = newAV(); /* Where seen classnames are kept */ @@ -1242,6 +1349,7 @@ static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted) #ifndef HAS_UTF8_ALL cxt->use_bytes = -1; /* Fetched from perl if needed */ #endif + cxt->accept_future_minor = -1; /* Fetched from perl if needed */ } /* @@ -1283,6 +1391,14 @@ static void clean_retrieve_context(stcxt_t *cxt) sv_free((SV *) hseen); /* optional HV, for backward compat. */ } +#ifndef HAS_RESTRICTED_HASHES + cxt->derestrict = -1; /* Fetched from perl if needed */ +#endif +#ifndef HAS_UTF8_ALL + cxt->use_bytes = -1; /* Fetched from perl if needed */ +#endif + cxt->accept_future_minor = -1; /* Fetched from perl if needed */ + reset_context(cxt); } @@ -1328,8 +1444,8 @@ stcxt_t *parent_cxt; ASSERT(!parent_cxt->s_dirty, ("parent context clean")); - Newz(0, cxt, 1, stcxt_t); - cxt->prev = parent_cxt; + NEW_STORABLE_CXT_OBJ(cxt); + cxt->prev = parent_cxt->my_sv; SET_STCXT(cxt); ASSERT(!cxt->s_dirty, ("clean context")); @@ -1346,19 +1462,14 @@ stcxt_t *parent_cxt; static void free_context(cxt) stcxt_t *cxt; { - stcxt_t *prev = cxt->prev; + stcxt_t *prev = (stcxt_t *)(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0); TRACEME(("free_context")); ASSERT(!cxt->s_dirty, ("clean context")); ASSERT(prev, ("not freeing root context")); - if (kbuf) - Safefree(kbuf); - if (mbase) - Safefree(mbase); - - Safefree(cxt); + SvREFCNT_dec(cxt->my_sv); SET_STCXT(prev); ASSERT(cxt, ("context not void")); @@ -1774,89 +1885,134 @@ static int store_scalar(stcxt_t *cxt, SV *sv) pv = SvPV(sv, len); /* We know it's SvPOK */ goto string; /* Share code below */ } - } else if (flags & SVp_POK) { /* SvPOKp(sv) => string */ - I32 wlen; /* For 64-bit machines */ - pv = SvPV(sv, len); - - /* - * Will come here from below with pv and len set if double & netorder, - * or from above if it was readonly, POK and NOK but neither &PL_sv_yes - * nor &PL_sv_no. - */ - string: + } else if (flags & SVf_POK) { + /* public string - go direct to string read. */ + goto string_readlen; + } else if ( +#if (PATCHLEVEL <= 6) + /* For 5.6 and earlier NV flag trumps IV flag, so only use integer + direct if NV flag is off. */ + (flags & (SVf_NOK | SVf_IOK)) == SVf_IOK +#else + /* 5.7 rules are that if IV public flag is set, IV value is as + good, if not better, than NV value. */ + flags & SVf_IOK +#endif + ) { + iv = SvIV(sv); + /* + * Will come here from below with iv set if double is an integer. + */ + integer: - wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */ - 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)); + /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ +#ifdef SVf_IVisUV + /* Need to do this out here, else 0xFFFFFFFF becomes iv of -1 + * (for example) and that ends up in the optimised small integer + * case. + */ + if ((flags & SVf_IVisUV) && SvUV(sv) > IV_MAX) { + TRACEME(("large unsigned integer as string, value = %"UVuf, SvUV(sv))); + goto string_readlen; + } +#endif + /* + * Optimize small integers into a single byte, otherwise store as + * a real integer (converted into network order if they asked). + */ - } else if (flags & SVp_NOK) { /* SvNOKp(sv) => double */ - NV nv = SvNV(sv); + if (iv >= -128 && iv <= 127) { + unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */ + PUTMARK(SX_BYTE); + PUTMARK(siv); + TRACEME(("small integer stored as %d", siv)); + } else if (cxt->netorder) { +#ifndef HAS_HTONL + TRACEME(("no htonl, fall back to string for integer")); + goto string_readlen; +#else + I32 niv; - /* - * Watch for number being an integer in disguise. - */ - if (nv == (NV) (iv = I_V(nv))) { - TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv)); - goto integer; /* Share code below */ - } - if (cxt->netorder) { - TRACEME(("double %"NVff" stored as string", nv)); - pv = SvPV(sv, len); - goto string; /* Share code above */ - } +#if IVSIZE > 4 + if ( +#ifdef SVf_IVisUV + /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ + ((flags & SVf_IVisUV) && SvUV(sv) > 0x7FFFFFFF) || +#endif + (iv > 0x7FFFFFFF) || (iv < -0x80000000)) { + /* Bigger than 32 bits. */ + TRACEME(("large network order integer as string, value = %"IVdf, iv)); + goto string_readlen; + } +#endif - PUTMARK(SX_DOUBLE); - WRITE(&nv, sizeof(nv)); + niv = (I32) htonl((I32) iv); + TRACEME(("using network order")); + PUTMARK(SX_NETINT); + WRITE_I32(niv); +#endif + } else { + PUTMARK(SX_INTEGER); + WRITE(&iv, sizeof(iv)); + } + + TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv)); + } else if (flags & SVf_NOK) { + NV nv; +#if (PATCHLEVEL <= 6) + nv = SvNV(sv); + /* + * Watch for number being an integer in disguise. + */ + if (nv == (NV) (iv = I_V(nv))) { + TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv)); + goto integer; /* Share code above */ + } +#else - TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv)); + SvIV_please(sv); + if (SvIOK_notUV(sv)) { + iv = SvIV(sv); + goto integer; /* Share code above */ + } + nv = SvNV(sv); +#endif - } else if (flags & SVp_IOK) { /* SvIOKp(sv) => integer */ - iv = SvIV(sv); + if (cxt->netorder) { + TRACEME(("double %"NVff" stored as string", nv)); + goto string_readlen; /* Share code below */ + } - /* - * Will come here from above with iv set if double is an integer. - */ - integer: + PUTMARK(SX_DOUBLE); + WRITE(&nv, sizeof(nv)); - /* - * Optimize small integers into a single byte, otherwise store as - * a real integer (converted into network order if they asked). - */ + TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv)); - if (iv >= -128 && iv <= 127) { - unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */ - PUTMARK(SX_BYTE); - PUTMARK(siv); - TRACEME(("small integer stored as %d", siv)); - } else if (cxt->netorder) { - I32 niv; -#ifdef HAS_HTONL - niv = (I32) htonl(iv); - TRACEME(("using network order")); -#else - niv = (I32) iv; - TRACEME(("as-is for network order")); -#endif - PUTMARK(SX_NETINT); - WRITE_I32(niv); - } else { - PUTMARK(SX_INTEGER); - WRITE(&iv, sizeof(iv)); - } + } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) { + I32 wlen; /* For 64-bit machines */ - TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv)); + string_readlen: + pv = SvPV(sv, len); + /* + * Will come here from above if it was readonly, POK and NOK but + * neither &PL_sv_yes nor &PL_sv_no. + */ + string: + + wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */ + 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)); } else - CROAK(("Can't determine type of %s(0x%"UVxf")", - sv_reftype(sv, FALSE), - PTR2UV(sv))); - - return 0; /* Ok, no recursion on scalars */ + CROAK(("Can't determine type of %s(0x%"UVxf")", + sv_reftype(sv, FALSE), + PTR2UV(sv))); + return 0; /* Ok, no recursion on scalars */ } /* @@ -1892,7 +2048,7 @@ static int store_array(stcxt_t *cxt, AV *av) sav = av_fetch(av, i, 0); if (!sav) { TRACEME(("(#%d) undef item", i)); - STORE_UNDEF(); + STORE_SV_UNDEF(); continue; } TRACEME(("(#%d) item", i)); @@ -2063,7 +2219,7 @@ static int store_hash(stcxt_t *cxt, HV *hv) = (((hash_flags & SHV_RESTRICTED) && SvREADONLY(val)) ? SHV_K_LOCKED : 0); - if (val == &PL_sv_undef) + if (val == &PL_sv_placeholder) flags |= SHV_K_PLACEHOLDER; keyval = SvPV(key, keylen_tmp); @@ -2104,7 +2260,13 @@ static int store_hash(stcxt_t *cxt, HV *hv) PUTMARK(flags); TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval)); } else { - assert (flags == 0); + /* This is a workaround for a bug in 5.8.0 + that causes the HEK_WASUTF8 flag to be + set on an HEK without the hash being + marked as having key flags. We just + cross our fingers and drop the flag. + AMS 20030901 */ + assert (flags == 0 || flags == SHV_K_WASUTF8); TRACEME(("(#%d) key '%s'", i, keyval)); } WLEN(keylen); @@ -2125,7 +2287,7 @@ static int store_hash(stcxt_t *cxt, HV *hv) /* * Storing in "random" order (in the order the keys are stored - * within the the hash). This is the default and will be faster! + * within the hash). This is the default and will be faster! */ for (i = 0; i < len; i++) { @@ -2159,7 +2321,7 @@ static int store_hash(stcxt_t *cxt, HV *hv) = (((hash_flags & SHV_RESTRICTED) && SvREADONLY(val)) ? SHV_K_LOCKED : 0); - if (val == &PL_sv_undef) + if (val == &PL_sv_placeholder) flags |= SHV_K_PLACEHOLDER; hek = HeKEY_hek(he); @@ -2195,7 +2357,13 @@ static int store_hash(stcxt_t *cxt, HV *hv) PUTMARK(flags); TRACEME(("(#%d) key '%s' flags %x", i, key, flags)); } else { - assert (flags == 0); + /* This is a workaround for a bug in 5.8.0 + that causes the HEK_WASUTF8 flag to be + set on an HEK without the hash being + marked as having key flags. We just + cross our fingers and drop the flag. + AMS 20030901 */ + assert (flags == 0 || flags == SHV_K_WASUTF8); TRACEME(("(#%d) key '%s'", i, key)); } if (flags & SHV_K_ISSV) { @@ -2218,6 +2386,110 @@ out: } /* + * store_code + * + * Store a code reference. + * + * Layout is SX_CODE followed by a scalar containing the perl + * source code of the code reference. + */ +static int store_code(stcxt_t *cxt, CV *cv) +{ +#if PERL_VERSION < 6 + /* + * retrieve_code does not work with perl 5.005 or less + */ + return store_other(cxt, (SV*)cv); +#else + dSP; + I32 len; + int count, reallen; + SV *text, *bdeparse; + + TRACEME(("store_code (0x%"UVxf")", PTR2UV(cv))); + + if ( + cxt->deparse == 0 || + (cxt->deparse < 0 && !(cxt->deparse = + SvTRUE(perl_get_sv("Storable::Deparse", TRUE)) ? 1 : 0)) + ) { + return store_other(cxt, (SV*)cv); + } + + /* + * Require B::Deparse. At least B::Deparse 0.61 is needed for + * blessed code references. + */ + /* XXX sv_2mortal seems to be evil here. why? */ + load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("B::Deparse",10), newSVnv(0.61)); + + ENTER; + SAVETMPS; + + /* + * create the B::Deparse object + */ + + PUSHMARK(sp); + XPUSHs(sv_2mortal(newSVpvn("B::Deparse",10))); + PUTBACK; + count = call_method("new", G_SCALAR); + SPAGAIN; + if (count != 1) + CROAK(("Unexpected return value from B::Deparse::new\n")); + bdeparse = POPs; + + /* + * call the coderef2text method + */ + + PUSHMARK(sp); + XPUSHs(bdeparse); /* XXX is this already mortal? */ + XPUSHs(sv_2mortal(newRV_inc((SV*)cv))); + PUTBACK; + count = call_method("coderef2text", G_SCALAR); + SPAGAIN; + if (count != 1) + CROAK(("Unexpected return value from B::Deparse::coderef2text\n")); + + text = POPs; + len = SvLEN(text); + reallen = strlen(SvPV_nolen(text)); + + /* + * Empty code references or XS functions are deparsed as + * "(prototype) ;" or ";". + */ + + if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') { + CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n")); + } + + /* + * Signal code by emitting SX_CODE. + */ + + PUTMARK(SX_CODE); + cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */ + TRACEME(("size = %d", len)); + TRACEME(("code = %s", SvPV_nolen(text))); + + /* + * Now store the source code. + */ + + STORE_SCALAR(SvPV_nolen(text), len); + + FREETMPS; + LEAVE; + + TRACEME(("ok (code)")); + + return 0; +#endif +} + +/* * store_tied * * When storing a tied object (be it a tied scalar, array or hash), we lay out @@ -2228,6 +2500,7 @@ out: static int store_tied(stcxt_t *cxt, SV *sv) { MAGIC *mg; + SV *obj = NULL; int ret = 0; int svt = SvTYPE(sv); char mtype = 'P'; @@ -2273,7 +2546,9 @@ static int store_tied(stcxt_t *cxt, SV *sv) * accesses on the retrieved object will indeed call the magic methods... */ - if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ + /* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */ + obj = mg->mg_obj ? mg->mg_obj : newSV(0); + if ((ret = store(cxt, obj))) return ret; TRACEME(("ok (tied)")); @@ -2523,7 +2798,7 @@ static int store_hook( * If they returned more than one item, we need to serialize some * extra references if not already done. * - * Loop over the array, starting at postion #1, and for each item, + * Loop over the array, starting at position #1, and for each item, * ensure it is a reference, serialize it if not already done, and * replace the entry with the tag ID of the corresponding serialized * object. @@ -2892,7 +3167,7 @@ static int store_other(stcxt_t *cxt, SV *sv) len = strlen(buf); STORE_SCALAR(buf, len); - TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, len)); + TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, (IV) len)); return 0; } @@ -2951,6 +3226,8 @@ static int sv_type(SV *sv) if (SvRMAGICAL(sv) && (mg_find(sv, 'P'))) return svis_TIED; return svis_HASH; + case SVt_PVCV: + return svis_CODE; default: break; } @@ -2983,7 +3260,7 @@ static int store(stcxt_t *cxt, SV *sv) * * NOTA BENE, for 64-bit machines: the "*svh" below does not yield a * real pointer, rather a tag number (watch the insertion code below). - * That means it pobably safe to assume it is well under the 32-bit limit, + * That means it probably safe to assume it is well under the 32-bit limit, * and makes the truncation safe. * -- RAM, 14/09/1999 */ @@ -3051,52 +3328,87 @@ static int store(stcxt_t *cxt, SV *sv) */ static int magic_write(stcxt_t *cxt) { - char buf[256]; /* Enough room for 256 hexa digits */ - unsigned char c; - int use_network_order = cxt->netorder; - - TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio) - : -1)); - - if (cxt->fio) - WRITE(magicstr, (SSize_t)strlen(magicstr)); /* Don't write final \0 */ - - /* - * Starting with 0.6, the "use_network_order" byte flag is also used to - * indicate the version number of the binary image, encoded in the upper - * bits. The bit 0 is always used to indicate network order. - */ - - c = (unsigned char) - ((use_network_order ? 0x1 : 0x0) | (STORABLE_BIN_MAJOR << 1)); - PUTMARK(c); - - /* - * Starting with 0.7, a full byte is dedicated to the minor version of - * the binary format, which is incremented only when new markers are - * introduced, for instance, but when backward compatibility is preserved. - */ + /* + * Starting with 0.6, the "use_network_order" byte flag is also used to + * indicate the version number of the binary image, encoded in the upper + * bits. The bit 0 is always used to indicate network order. + */ + /* + * Starting with 0.7, a full byte is dedicated to the minor version of + * the binary format, which is incremented only when new markers are + * introduced, for instance, but when backward compatibility is preserved. + */ - PUTMARK((unsigned char) STORABLE_BIN_WRITE_MINOR); + /* Make these at compile time. The WRITE() macro is sufficiently complex + that it saves about 200 bytes doing it this way and only using it + once. */ + static const unsigned char network_file_header[] = { + MAGICSTR_BYTES, + (STORABLE_BIN_MAJOR << 1) | 1, + STORABLE_BIN_WRITE_MINOR + }; + static const unsigned char file_header[] = { + MAGICSTR_BYTES, + (STORABLE_BIN_MAJOR << 1) | 0, + STORABLE_BIN_WRITE_MINOR, + /* sizeof the array includes the 0 byte at the end: */ + (char) sizeof (byteorderstr) - 1, + BYTEORDER_BYTES, + (unsigned char) sizeof(int), + (unsigned char) sizeof(long), + (unsigned char) sizeof(char *), + (unsigned char) sizeof(NV) + }; +#ifdef USE_56_INTERWORK_KLUDGE + static const unsigned char file_header_56[] = { + MAGICSTR_BYTES, + (STORABLE_BIN_MAJOR << 1) | 0, + STORABLE_BIN_WRITE_MINOR, + /* sizeof the array includes the 0 byte at the end: */ + (char) sizeof (byteorderstr_56) - 1, + BYTEORDER_BYTES_56, + (unsigned char) sizeof(int), + (unsigned char) sizeof(long), + (unsigned char) sizeof(char *), + (unsigned char) sizeof(NV) + }; +#endif + const unsigned char *header; + SSize_t length; + + TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio) : -1)); + + if (cxt->netorder) { + header = network_file_header; + length = sizeof (network_file_header); + } else { +#ifdef USE_56_INTERWORK_KLUDGE + if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", TRUE))) { + header = file_header_56; + length = sizeof (file_header_56); + } else +#endif + { + header = file_header; + length = sizeof (file_header); + } + } - if (use_network_order) - return 0; /* Don't bother with byte ordering */ + if (!cxt->fio) { + /* sizeof the array includes the 0 byte at the end. */ + header += sizeof (magicstr) - 1; + length -= sizeof (magicstr) - 1; + } - sprintf(buf, "%lx", (unsigned long) BYTEORDER); - c = (unsigned char) strlen(buf); - PUTMARK(c); - WRITE(buf, (SSize_t)c); /* Don't write final \0 */ - PUTMARK((unsigned char) sizeof(int)); - PUTMARK((unsigned char) sizeof(long)); - PUTMARK((unsigned char) sizeof(char *)); - PUTMARK((unsigned char) sizeof(NV)); + WRITE( (unsigned char*) header, length); + if (!cxt->netorder) { TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)", - (unsigned long) BYTEORDER, (int) c, + (unsigned long) BYTEORDER, (int) sizeof (byteorderstr) - 1, (int) sizeof(int), (int) sizeof(long), (int) sizeof(char *), (int) sizeof(NV))); - - return 0; + } + return 0; } /* @@ -3520,6 +3832,10 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) * We don't need to remember the addresses returned by retrieval, because * all the references will be obtained through indirection via the object * tags in the object-ID list. + * + * We need to decrement the reference count for these objects + * because, if the user doesn't save a reference to them in the hook, + * they must be freed when this context is cleaned. */ while (flags & SHF_NEED_RECURSE) { @@ -3527,6 +3843,7 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) rv = retrieve(cxt, 0); if (!rv) return (SV *) 0; + SvREFCNT_dec(rv); TRACEME(("retrieve_hook back with rv=0x%"UVxf, PTR2UV(rv))); GETMARK(flags); @@ -3722,7 +4039,7 @@ static SV *retrieve_hook(stcxt_t *cxt, char *cname) */ TRACEME(("calling STORABLE_thaw on %s at 0x%"UVxf" (%"IVdf" args)", - class, PTR2UV(sv), AvFILLp(av) + 1)); + class, PTR2UV(sv), (IV) AvFILLp(av) + 1)); rv = newRV(sv); (void) scalar_call(rv, hook, clone, av, G_SCALAR|G_DISCARD); @@ -3842,7 +4159,14 @@ static SV *retrieve_ref(stcxt_t *cxt, char *cname) * an SX_OBJECT indication, a ref count increment was done. */ - sv_upgrade(rv, SVt_RV); + if (cname) { + /* Do not use sv_upgrade to preserve STASH */ + SvFLAGS(rv) &= ~SVTYPEMASK; + SvFLAGS(rv) |= SVt_RV; + } else { + sv_upgrade(rv, SVt_RV); + } + SvRV(rv) = sv; /* $rv = \$sv */ SvROK_on(rv); @@ -3886,10 +4210,11 @@ static SV *retrieve_overloaded(stcxt_t *cxt, char *cname) /* * Restore overloading magic. */ - - stash = (HV *) SvSTASH (sv); - if (!stash || !Gv_AMG(stash)) - CROAK(("Cannot restore overloading on %s(0x%"UVxf") (package %s)", + if (!SvTYPE(sv) + || !(stash = (HV *) SvSTASH (sv)) + || !Gv_AMG(stash)) + CROAK(("Cannot restore overloading on %s(0x%"UVxf + ") (package %s)", sv_reftype(sv, FALSE), PTR2UV(sv), stash ? HvNAME(stash) : "")); @@ -3967,19 +4292,27 @@ static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname) static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname) { SV *tv; - SV *sv; + SV *sv, *obj = NULL; TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum)); tv = NEWSV(10002, 0); SEEN(tv, cname); /* Will return if rv is null */ sv = retrieve(cxt, 0); /* Retrieve */ - if (!sv) + if (!sv) { return (SV *) 0; /* Failed */ + } + else if (SvTYPE(sv) != SVt_NULL) { + obj = sv; + } sv_upgrade(tv, SVt_PVMG); - sv_magic(tv, sv, 'q', Nullch, 0); - SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ + sv_magic(tv, obj, 'q', Nullch, 0); + + if (obj) { + /* Undo refcnt inc from sv_magic() */ + SvREFCNT_dec(obj); + } TRACEME(("ok (retrieve_tied_scalar at 0x%"UVxf")", PTR2UV(tv))); @@ -4063,7 +4396,7 @@ static SV *retrieve_lscalar(stcxt_t *cxt, char *cname) SV *sv; RLEN(len); - TRACEME(("retrieve_lscalar (#%d), len = %"IVdf, cxt->tagnum, len)); + TRACEME(("retrieve_lscalar (#%d), len = %"IVdf, cxt->tagnum, (IV) len)); /* * Allocate an empty scalar of the suitable length. @@ -4088,7 +4421,7 @@ static SV *retrieve_lscalar(stcxt_t *cxt, char *cname) 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(("large scalar len %"IVdf" '%s'", (IV) len, SvPVX(sv))); TRACEME(("ok (retrieve_lscalar at 0x%"UVxf")", PTR2UV(sv))); return sv; @@ -4371,6 +4704,7 @@ static SV *retrieve_sv_no(stcxt_t *cxt, char *cname) TRACEME(("retrieve_sv_no")); + cxt->tagnum--; /* undo the tagnum increment in retrieve_l?scalar */ SEEN(sv, cname); return sv; } @@ -4588,7 +4922,7 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) if (flags & SHV_K_PLACEHOLDER) { SvREFCNT_dec (sv); - sv = &PL_sv_undef; + sv = &PL_sv_placeholder; store_flags |= HVhek_PLACEHOLD; } if (flags & SHV_K_UTF8) { @@ -4621,7 +4955,7 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) */ #ifdef HAS_RESTRICTED_HASHES - if (hv_store_flags(hv, kbuf, size, sv, 0, flags) == 0) + if (hv_store_flags(hv, kbuf, size, sv, 0, store_flags) == 0) return (SV *) 0; #else if (!(store_flags & HVhek_PLACEHOLD)) @@ -4641,6 +4975,122 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) } /* + * retrieve_code + * + * Return a code reference. + */ +static SV *retrieve_code(stcxt_t *cxt, char *cname) +{ +#if PERL_VERSION < 6 + CROAK(("retrieve_code does not work with perl 5.005 or less\n")); +#else + dSP; + int type, count, tagnum; + SV *cv; + SV *sv, *text, *sub; + + TRACEME(("retrieve_code (#%d)", cxt->tagnum)); + + /* + * Insert dummy SV in the aseen array so that we don't screw + * up the tag numbers. We would just make the internal + * scalar an untagged item in the stream, but + * retrieve_scalar() calls SEEN(). So we just increase the + * tag number. + */ + tagnum = cxt->tagnum; + sv = newSViv(0); + SEEN(sv, cname); + + /* + * Retrieve the source of the code reference + * as a small or large scalar + */ + + GETMARK(type); + switch (type) { + case SX_SCALAR: + text = retrieve_scalar(cxt, cname); + break; + case SX_LSCALAR: + text = retrieve_lscalar(cxt, cname); + break; + default: + CROAK(("Unexpected type %d in retrieve_code\n", type)); + } + + /* + * prepend "sub " to the source + */ + + sub = newSVpvn("sub ", 4); + sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */ + SvREFCNT_dec(text); + + /* + * evaluate the source to a code reference and use the CV value + */ + + if (cxt->eval == NULL) { + cxt->eval = perl_get_sv("Storable::Eval", TRUE); + SvREFCNT_inc(cxt->eval); + } + if (!SvTRUE(cxt->eval)) { + if ( + cxt->forgive_me == 0 || + (cxt->forgive_me < 0 && !(cxt->forgive_me = + SvTRUE(perl_get_sv("Storable::forgive_me", TRUE)) ? 1 : 0)) + ) { + CROAK(("Can't eval, please set $Storable::Eval to a true value")); + } else { + sv = newSVsv(sub); + /* fix up the dummy entry... */ + av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); + return sv; + } + } + + ENTER; + SAVETMPS; + + if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) { + SV* errsv = get_sv("@", TRUE); + sv_setpv(errsv, ""); /* clear $@ */ + PUSHMARK(sp); + XPUSHs(sv_2mortal(newSVsv(sub))); + PUTBACK; + count = call_sv(cxt->eval, G_SCALAR); + SPAGAIN; + if (count != 1) + CROAK(("Unexpected return value from $Storable::Eval callback\n")); + cv = POPs; + if (SvTRUE(errsv)) { + CROAK(("code %s caused an error: %s", + SvPV_nolen(sub), SvPV_nolen(errsv))); + } + PUTBACK; + } else { + cv = eval_pv(SvPV_nolen(sub), TRUE); + } + if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) { + sv = SvRV(cv); + } else { + CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub))); + } + + SvREFCNT_inc(sv); /* XXX seems to be necessary */ + SvREFCNT_dec(sub); + + FREETMPS; + LEAVE; + /* fix up the dummy entry... */ + av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); + + return sv; +#endif +} + +/* * old_retrieve_array * * Retrieve a whole array in pre-0.6 binary format. @@ -4809,126 +5259,170 @@ static SV *old_retrieve_hash(stcxt_t *cxt, char *cname) */ static SV *magic_check(stcxt_t *cxt) { - char buf[256]; - char byteorder[256]; - int c; - int use_network_order; - int version_major; - int version_minor = 0; + /* The worst case for a malicious header would be old magic (which is + longer), major, minor, byteorder length byte of 255, 255 bytes of + garbage, sizeof int, long, pointer, NV. + So the worse of that we can read is 255 bytes of garbage plus 4. + Err, I am assuming 8 bit bytes here. Please file a bug report if you're + compiling perl on a system with chars that are larger than 8 bits. + (Even Crays aren't *that* perverse). + */ + unsigned char buf[4 + 255]; + unsigned char *current; + int c; + int length; + int use_network_order; + int use_NV_size; + int version_major; + int version_minor = 0; + + TRACEME(("magic_check")); - TRACEME(("magic_check")); + /* + * The "magic number" is only for files, not when freezing in memory. + */ - /* - * The "magic number" is only for files, not when freezing in memory. - */ + if (cxt->fio) { + /* This includes the '\0' at the end. I want to read the extra byte, + which is usually going to be the major version number. */ + STRLEN len = sizeof(magicstr); + STRLEN old_len; - if (cxt->fio) { - STRLEN len = sizeof(magicstr) - 1; - STRLEN old_len; + READ(buf, (SSize_t)(len)); /* Not null-terminated */ - READ(buf, (SSize_t)len); /* Not null-terminated */ - buf[len] = '\0'; /* Is now */ + /* Point at the byte after the byte we read. */ + current = buf + --len; /* Do the -- outside of macros. */ - if (0 == strcmp(buf, magicstr)) - goto magic_ok; + if (memNE(buf, magicstr, len)) { + /* + * Try to read more bytes to check for the old magic number, which + * was longer. + */ - /* - * Try to read more bytes to check for the old magic number, which - * was longer. - */ + TRACEME(("trying for old magic number")); - old_len = sizeof(old_magicstr) - 1; - READ(&buf[len], (SSize_t)(old_len - len)); - buf[old_len] = '\0'; /* Is now null-terminated */ + old_len = sizeof(old_magicstr) - 1; + READ(current + 1, (SSize_t)(old_len - len)); + + if (memNE(buf, old_magicstr, old_len)) + CROAK(("File is not a perl storable")); + current = buf + old_len; + } + use_network_order = *current; + } else + GETMARK(use_network_order); + + /* + * Starting with 0.6, the "use_network_order" byte flag is also used to + * indicate the version number of the binary, and therefore governs the + * setting of sv_retrieve_vtbl. See magic_write(). + */ - if (strcmp(buf, old_magicstr)) - CROAK(("File is not a perl storable")); - } + version_major = use_network_order >> 1; + cxt->retrieve_vtbl = version_major ? sv_retrieve : sv_old_retrieve; -magic_ok: - /* - * Starting with 0.6, the "use_network_order" byte flag is also used to - * indicate the version number of the binary, and therefore governs the - * setting of sv_retrieve_vtbl. See magic_write(). - */ + TRACEME(("magic_check: netorder = 0x%x", use_network_order)); - GETMARK(use_network_order); - version_major = use_network_order >> 1; - cxt->retrieve_vtbl = version_major ? sv_retrieve : sv_old_retrieve; - TRACEME(("magic_check: netorder = 0x%x", use_network_order)); + /* + * Starting with 0.7 (binary major 2), a full byte is dedicated to the + * minor version of the protocol. See magic_write(). + */ + if (version_major > 1) + GETMARK(version_minor); - /* - * Starting with 0.7 (binary major 2), a full byte is dedicated to the - * minor version of the protocol. See magic_write(). - */ + cxt->ver_major = version_major; + cxt->ver_minor = version_minor; - if (version_major > 1) - GETMARK(version_minor); + TRACEME(("binary image version is %d.%d", version_major, version_minor)); - cxt->ver_major = version_major; - cxt->ver_minor = version_minor; + /* + * Inter-operability sanity check: we can't retrieve something stored + * using a format more recent than ours, because we have no way to + * know what has changed, and letting retrieval go would mean a probable + * failure reporting a "corrupted" storable file. + */ - TRACEME(("binary image version is %d.%d", version_major, version_minor)); + if ( + version_major > STORABLE_BIN_MAJOR || + (version_major == STORABLE_BIN_MAJOR && + version_minor > STORABLE_BIN_MINOR) + ) { + int croak_now = 1; + TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR, + STORABLE_BIN_MINOR)); + + if (version_major == STORABLE_BIN_MAJOR) { + TRACEME(("cxt->accept_future_minor is %d", + cxt->accept_future_minor)); + if (cxt->accept_future_minor < 0) + cxt->accept_future_minor + = (SvTRUE(perl_get_sv("Storable::accept_future_minor", + TRUE)) + ? 1 : 0); + if (cxt->accept_future_minor == 1) + croak_now = 0; /* Don't croak yet. */ + } + if (croak_now) { + CROAK(("Storable binary image v%d.%d more recent than I am (v%d.%d)", + version_major, version_minor, + STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR)); + } + } - /* - * Inter-operability sanity check: we can't retrieve something stored - * using a format more recent than ours, because we have no way to - * know what has changed, and letting retrieval go would mean a probable - * failure reporting a "corrupted" storable file. - */ + /* + * If they stored using network order, there's no byte ordering + * information to check. + */ - if ( - version_major > STORABLE_BIN_MAJOR || - (version_major == STORABLE_BIN_MAJOR && - version_minor > STORABLE_BIN_MINOR) - ) { - TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR, - STORABLE_BIN_MINOR)); + if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */ + return &PL_sv_undef; /* No byte ordering info */ - CROAK(("Storable binary image v%d.%d more recent than I am (v%d.%d)", - version_major, version_minor, - STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR)); - } + /* In C truth is 1, falsehood is 0. Very convienient. */ + use_NV_size = version_major >= 2 && version_minor >= 2; - /* - * If they stored using network order, there's no byte ordering - * information to check. - */ + GETMARK(c); + length = c + 3 + use_NV_size; + READ(buf, length); /* Not null-terminated */ - if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */ - return &PL_sv_undef; /* No byte ordering info */ + TRACEME(("byte order '%.*s' %d", c, buf, c)); - sprintf(byteorder, "%lx", (unsigned long) BYTEORDER); - GETMARK(c); - READ(buf, c); /* Not null-terminated */ - buf[c] = '\0'; /* Is now */ +#ifdef USE_56_INTERWORK_KLUDGE + /* No point in caching this in the context as we only need it once per + retrieve, and we need to recheck it each read. */ + if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", TRUE))) { + if ((c != (sizeof (byteorderstr_56) - 1)) + || memNE(buf, byteorderstr_56, c)) + CROAK(("Byte order is not compatible")); + } else +#endif + { + if ((c != (sizeof (byteorderstr) - 1)) || memNE(buf, byteorderstr, c)) + CROAK(("Byte order is not compatible")); + } - TRACEME(("byte order '%s'", buf)); + current = buf + c; + + /* sizeof(int) */ + if ((int) *current++ != sizeof(int)) + CROAK(("Integer size is not compatible")); - if (strcmp(buf, byteorder)) - CROAK(("Byte order is not compatible")); - - GETMARK(c); /* sizeof(int) */ - if ((int) c != sizeof(int)) - CROAK(("Integer size is not compatible")); - - GETMARK(c); /* sizeof(long) */ - if ((int) c != sizeof(long)) - CROAK(("Long integer size is not compatible")); - - GETMARK(c); /* sizeof(char *) */ - if ((int) c != sizeof(char *)) - CROAK(("Pointer integer size is not compatible")); - - if (version_major >= 2 && version_minor >= 2) { - GETMARK(c); /* sizeof(NV) */ - if ((int) c != sizeof(NV)) - CROAK(("Double size is not compatible")); - } + /* sizeof(long) */ + if ((int) *current++ != sizeof(long)) + CROAK(("Long integer size is not compatible")); + + /* sizeof(char *) */ + if ((int) *current != sizeof(char *)) + CROAK(("Pointer size is not compatible")); - return &PL_sv_undef; /* OK */ + if (use_NV_size) { + /* sizeof(NV) */ + if ((int) *++current != sizeof(NV)) + CROAK(("Double size is not compatible")); + } + + return &PL_sv_undef; /* OK */ } /* @@ -5027,7 +5521,19 @@ static SV *retrieve(stcxt_t *cxt, char *cname) TRACEME(("had retrieved #%d at 0x%"UVxf, tag, PTR2UV(sv))); SvREFCNT_inc(sv); /* One more reference to this same sv */ return sv; /* The SV pointer where object was retrieved */ - } + } else if (type >= SX_ERROR && cxt->ver_minor > STORABLE_BIN_MINOR) { + if (cxt->accept_future_minor < 0) + cxt->accept_future_minor + = (SvTRUE(perl_get_sv("Storable::accept_future_minor", + TRUE)) + ? 1 : 0); + if (cxt->accept_future_minor == 1) { + CROAK(("Storable binary image v%d.%d contains data of type %d. " + "This Storable is v%d.%d and can only handle data types up to %d", + cxt->ver_major, cxt->ver_minor, type, + STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR, SX_ERROR - 1)); + } + } first_time: /* Will disappear when support for old format is dropped */ @@ -5202,7 +5708,22 @@ static SV *do_retrieve( if (!sv) { TRACEME(("retrieve ERROR")); +#if (PATCHLEVEL <= 4) + /* perl 5.00405 seems to screw up at this point with an + 'attempt to modify a read only value' error reported in the + eval { $self = pretrieve(*FILE) } in _retrieve. + I can't see what the cause of this error is, but I suspect a + bug in 5.004, as it seems to be capable of issuing spurious + errors or core dumping with matches on $@. I'm not going to + spend time on what could be a fruitless search for the cause, + so here's a bodge. If you're running 5.004 and don't like + this inefficiency, either upgrade to a newer perl, or you are + welcome to find the problem and send in a patch. + */ + return newSV(0); +#else return &PL_sv_undef; /* Something went wrong, return undef */ +#endif } TRACEME(("retrieve got %s(0x%"UVxf")", @@ -5373,12 +5894,39 @@ SV *dclone(SV *sv) #define InputStream PerlIO * #endif /* !OutputStream */ +MODULE = Storable PACKAGE = Storable::Cxt + +void +DESTROY(self) + SV *self +PREINIT: + stcxt_t *cxt = (stcxt_t *)SvPVX(SvRV(self)); +PPCODE: + if (kbuf) + Safefree(kbuf); + if (!cxt->membuf_ro && mbase) + Safefree(mbase); + if (cxt->membuf_ro && (cxt->msaved).arena) + Safefree((cxt->msaved).arena); + + MODULE = Storable PACKAGE = Storable PROTOTYPES: ENABLE BOOT: init_perinterp(); + gv_fetchpv("Storable::drop_utf8", GV_ADDMULTI, SVt_PV); +#ifdef DEBUGME + /* Only disable the used only once warning if we are in debugging mode. */ + gv_fetchpv("Storable::DEBUGME", GV_ADDMULTI, SVt_PV); +#endif +#ifdef USE_56_INTERWORK_KLUDGE + gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV); +#endif + +void +init_perinterp() int pstore(f,obj) @@ -5418,4 +5966,3 @@ is_storing() int is_retrieving() -