Blame Storable.xs

Packit 14c646
/* -*-  c-basic-offset: 4 -*-
Packit 14c646
 *
Packit 14c646
 *  Fast store and retrieve mechanism.
Packit 14c646
 *
Packit 14c646
 *  Copyright (c) 1995-2000, Raphael Manfredi
Packit 14c646
 *  Copyright (c) 2016, 2017 cPanel Inc
Packit 14c646
 *  Copyright (c) 2017 Reini Urban
Packit 14c646
 *
Packit 14c646
 *  You may redistribute only under the same terms as Perl 5, as specified
Packit 14c646
 *  in the README file that comes with the distribution.
Packit 14c646
 *
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define PERL_NO_GET_CONTEXT     /* we want efficiency */
Packit 14c646
#include <EXTERN.h>
Packit 14c646
#include <perl.h>
Packit 14c646
#include <XSUB.h>
Packit 14c646
Packit 14c646
#ifndef PATCHLEVEL
Packit 14c646
#include <patchlevel.h>		/* Perl's one, needed since 5.6 */
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#if !defined(PERL_VERSION) || PERL_VERSION < 10 || (PERL_VERSION == 10 && PERL_SUBVERSION < 1)
Packit 14c646
#define NEED_PL_parser
Packit 14c646
#define NEED_sv_2pv_flags
Packit 14c646
#define NEED_load_module
Packit 14c646
#define NEED_vload_module
Packit 14c646
#define NEED_newCONSTSUB
Packit 14c646
#define NEED_newSVpvn_flags
Packit 14c646
#define NEED_newRV_noinc
Packit 14c646
#include "ppport.h"             /* handle old perls */
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifdef DEBUGGING
Packit 14c646
#define DEBUGME /* Debug mode, turns assertions on as well */
Packit 14c646
#define DASSERT /* Assertion mode */
Packit 14c646
#endif
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined
Packit 14c646
 * Provide them with the necessary defines so they can build with pre-5.004.
Packit 14c646
 */
Packit 14c646
#ifndef USE_PERLIO
Packit 14c646
#ifndef PERLIO_IS_STDIO
Packit 14c646
#define PerlIO FILE
Packit 14c646
#define PerlIO_getc(x) getc(x)
Packit 14c646
#define PerlIO_putc(f,x) putc(x,f)
Packit 14c646
#define PerlIO_read(x,y,z) fread(y,1,z,x)
Packit 14c646
#define PerlIO_write(x,y,z) fwrite(y,1,z,x)
Packit 14c646
#define PerlIO_stdoutf printf
Packit 14c646
#endif	/* PERLIO_IS_STDIO */
Packit 14c646
#endif	/* USE_PERLIO */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Earlier versions of perl might be used, we can't assume they have the latest!
Packit 14c646
 */
Packit 14c646
Packit 14c646
#ifndef HvSHAREKEYS_off
Packit 14c646
#define HvSHAREKEYS_off(hv)	/* Ignore */
Packit 14c646
#endif
Packit 14c646
Packit 14c646
/* perl <= 5.8.2 needs this */
Packit 14c646
#ifndef SvIsCOW
Packit 14c646
# define SvIsCOW(sv) 0
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifndef HvRITER_set
Packit 14c646
#  define HvRITER_set(hv,r)	(HvRITER(hv) = r)
Packit 14c646
#endif
Packit 14c646
#ifndef HvEITER_set
Packit 14c646
#  define HvEITER_set(hv,r)	(HvEITER(hv) = r)
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifndef HvRITER_get
Packit 14c646
#  define HvRITER_get           HvRITER
Packit 14c646
#endif
Packit 14c646
#ifndef HvEITER_get
Packit 14c646
#  define HvEITER_get           HvEITER
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifndef HvPLACEHOLDERS_get
Packit 14c646
#  define HvPLACEHOLDERS_get    HvPLACEHOLDERS
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifndef HvTOTALKEYS
Packit 14c646
#  define HvTOTALKEYS(hv)	HvKEYS(hv)
Packit 14c646
#endif
Packit 14c646
/* 5.6 */
Packit 14c646
#ifndef HvUSEDKEYS
Packit 14c646
#  define HvUSEDKEYS(hv)	HvKEYS(hv)
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifdef SVf_IsCOW
Packit 14c646
#  define SvTRULYREADONLY(sv)	SvREADONLY(sv)
Packit 14c646
#else
Packit 14c646
#  define SvTRULYREADONLY(sv)	(SvREADONLY(sv) && !SvIsCOW(sv))
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifndef SvPVCLEAR
Packit 14c646
#  define SvPVCLEAR(sv) sv_setpvs(sv, "")
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifndef strEQc
Packit 14c646
#  define strEQc(s,c) memEQ(s, ("" c ""), sizeof(c))
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifdef DEBUGME
Packit 14c646
Packit 14c646
#ifndef DASSERT
Packit 14c646
#define DASSERT
Packit 14c646
#endif
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * TRACEME() will only output things when the $Storable::DEBUGME is true,
Packit 14c646
 * using the value traceme cached in the context.
Packit 14c646
 *
Packit 14c646
 *
Packit 14c646
 * TRACEMED() directly looks at the variable, for use before traceme has been
Packit 14c646
 * updated.
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define TRACEME(x)                                            \
Packit 14c646
    STMT_START {					      \
Packit 14c646
        if (cxt->traceme)				      \
Packit 14c646
            { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); }       \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define TRACEMED(x)                                           \
Packit 14c646
    STMT_START {                                              \
Packit 14c646
        if (SvTRUE(get_sv("Storable::DEBUGME", GV_ADD)))      \
Packit 14c646
            { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); }       \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define INIT_TRACEME							\
Packit 14c646
    STMT_START {							\
Packit 14c646
	cxt->traceme = SvTRUE(get_sv("Storable::DEBUGME", GV_ADD));	\
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#else
Packit 14c646
#define TRACEME(x)
Packit 14c646
#define TRACEMED(x)
Packit 14c646
#define INIT_TRACEME
Packit 14c646
#endif	/* DEBUGME */
Packit 14c646
Packit 14c646
#ifdef DASSERT
Packit 14c646
#define ASSERT(x,y)                                              \
Packit 14c646
    STMT_START {                                                 \
Packit 14c646
        if (!(x)) {                                              \
Packit 14c646
            PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ",  \
Packit 14c646
                           __FILE__, (int)__LINE__);             \
Packit 14c646
            PerlIO_stdoutf y; PerlIO_stdoutf("\n");              \
Packit 14c646
        }                                                        \
Packit 14c646
    } STMT_END
Packit 14c646
#else
Packit 14c646
#define ASSERT(x,y)
Packit 14c646
#endif
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Type markers.
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define C(x) ((char) (x))	/* For markers with dynamic retrieval handling */
Packit 14c646
Packit 14c646
#define SX_OBJECT	C(0)	/* Already stored object */
Packit 14c646
#define SX_LSCALAR	C(1)	/* Scalar (large binary) follows (length, data) */
Packit 14c646
#define SX_ARRAY	C(2)	/* Array forthcoming (size, item list) */
Packit 14c646
#define SX_HASH		C(3)	/* Hash forthcoming (size, key/value pair list) */
Packit 14c646
#define SX_REF		C(4)	/* Reference to object forthcoming */
Packit 14c646
#define SX_UNDEF	C(5)	/* Undefined scalar */
Packit 14c646
#define SX_INTEGER	C(6)	/* Integer forthcoming */
Packit 14c646
#define SX_DOUBLE	C(7)	/* Double forthcoming */
Packit 14c646
#define SX_BYTE		C(8)	/* (signed) byte forthcoming */
Packit 14c646
#define SX_NETINT	C(9)	/* Integer in network order forthcoming */
Packit 14c646
#define SX_SCALAR	C(10)	/* Scalar (binary, small) follows (length, data) */
Packit 14c646
#define SX_TIED_ARRAY	C(11)	/* Tied array forthcoming */
Packit 14c646
#define SX_TIED_HASH	C(12)	/* Tied hash forthcoming */
Packit 14c646
#define SX_TIED_SCALAR	C(13)	/* Tied scalar forthcoming */
Packit 14c646
#define SX_SV_UNDEF	C(14)	/* Perl's immortal PL_sv_undef */
Packit 14c646
#define SX_SV_YES	C(15)	/* Perl's immortal PL_sv_yes */
Packit 14c646
#define SX_SV_NO	C(16)	/* Perl's immortal PL_sv_no */
Packit 14c646
#define SX_BLESS	C(17)	/* Object is blessed */
Packit 14c646
#define SX_IX_BLESS	C(18)	/* Object is blessed, classname given by index */
Packit 14c646
#define SX_HOOK		C(19)	/* Stored via hook, user-defined */
Packit 14c646
#define SX_OVERLOAD	C(20)	/* Overloaded reference */
Packit 14c646
#define SX_TIED_KEY	C(21)	/* Tied magic key forthcoming */
Packit 14c646
#define SX_TIED_IDX	C(22)	/* Tied magic index forthcoming */
Packit 14c646
#define SX_UTF8STR	C(23)	/* UTF-8 string forthcoming (small) */
Packit 14c646
#define SX_LUTF8STR	C(24)	/* UTF-8 string forthcoming (large) */
Packit 14c646
#define SX_FLAG_HASH	C(25)	/* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */
Packit 14c646
#define SX_CODE         C(26)   /* Code references as perl source code */
Packit 14c646
#define SX_WEAKREF	C(27)	/* Weak reference to object forthcoming */
Packit 14c646
#define SX_WEAKOVERLOAD	C(28)	/* Overloaded weak reference */
Packit 14c646
#define SX_VSTRING	C(29)	/* vstring forthcoming (small) */
Packit 14c646
#define SX_LVSTRING	C(30)	/* vstring forthcoming (large) */
Packit 14c646
#define SX_SVUNDEF_ELEM	C(31)	/* array element set to &PL_sv_undef */
Packit 14c646
#define SX_REGEXP	C(32)	/* Regexp */
Packit 14c646
#define SX_LOBJECT	C(33)	/* Large object: string, array or hash (size >2G) */
Packit 14c646
#define SX_LAST		C(34)	/* invalid. marker only */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Those are only used to retrieve "old" pre-0.6 binary images.
Packit 14c646
 */
Packit 14c646
#define SX_ITEM		'i'	/* An array item introducer */
Packit 14c646
#define SX_IT_UNDEF	'I'	/* Undefined array item */
Packit 14c646
#define SX_KEY		'k'	/* A hash key introducer */
Packit 14c646
#define SX_VALUE	'v'	/* A hash value introducer */
Packit 14c646
#define SX_VL_UNDEF	'V'	/* Undefined hash value */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Those are only used to retrieve "old" pre-0.7 binary images
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define SX_CLASS	'b'	/* Object is blessed, class name length <255 */
Packit 14c646
#define SX_LG_CLASS	'B'	/* Object is blessed, class name length >255 */
Packit 14c646
#define SX_STORED	'X'	/* End of object */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Limits between short/long length representation.
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define LG_SCALAR	255	/* Large scalar length limit */
Packit 14c646
#define LG_BLESS	127	/* Large classname bless limit */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Operation types
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define ST_STORE	0x1	/* Store operation */
Packit 14c646
#define ST_RETRIEVE	0x2	/* Retrieval operation */
Packit 14c646
#define ST_CLONE	0x4	/* Deep cloning operation */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * The following structure is used for hash table key retrieval. Since, when
Packit 14c646
 * retrieving objects, we'll be facing blessed hash references, it's best
Packit 14c646
 * to pre-allocate that buffer once and resize it as the need arises, never
Packit 14c646
 * freeing it (keys will be saved away someplace else anyway, so even large
Packit 14c646
 * keys are not enough a motivation to reclaim that space).
Packit 14c646
 *
Packit 14c646
 * This structure is also used for memory store/retrieve operations which
Packit 14c646
 * happen in a fixed place before being malloc'ed elsewhere if persistence
Packit 14c646
 * is required. Hence the aptr pointer.
Packit 14c646
 */
Packit 14c646
struct extendable {
Packit 14c646
    char *arena;	/* Will hold hash key strings, resized as needed */
Packit 14c646
    STRLEN asiz;	/* Size of aforementioned buffer */
Packit 14c646
    char *aptr;		/* Arena pointer, for in-place read/write ops */
Packit 14c646
    char *aend;		/* First invalid address */
Packit 14c646
};
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * At store time:
Packit 14c646
 * A hash table records the objects which have already been stored.
Packit 14c646
 * Those are referred to as SX_OBJECT in the file, and their "tag" (i.e.
Packit 14c646
 * an arbitrary sequence number) is used to identify them.
Packit 14c646
 *
Packit 14c646
 * At retrieve time:
Packit 14c646
 * An array table records the objects which have already been retrieved,
Packit 14c646
 * as seen by the tag determined by counting the objects themselves. The
Packit 14c646
 * reference to that retrieved object is kept in the table, and is returned
Packit 14c646
 * when an SX_OBJECT is found bearing that same tag.
Packit 14c646
 *
Packit 14c646
 * The same processing is used to record "classname" for blessed objects:
Packit 14c646
 * indexing by a hash at store time, and via an array at retrieve time.
Packit 14c646
 */
Packit 14c646
Packit 14c646
typedef unsigned long stag_t;	/* Used by pre-0.6 binary format */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Make the tag type 64-bit on 64-bit platforms.
Packit 14c646
 *
Packit 14c646
 * If the tag number is low enough it's stored as a 32-bit value, but
Packit 14c646
 * with very large arrays and hashes it's possible to go over 2**32
Packit 14c646
 * scalars.
Packit 14c646
 */
Packit 14c646
Packit 14c646
typedef STRLEN ntag_t;
Packit 14c646
Packit 14c646
/* used for where_is_undef - marks an unset value */
Packit 14c646
#define UNSET_NTAG_T (~(ntag_t)0)
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * The following "thread-safe" related defines were contributed by
Packit 14c646
 * Murray Nesbitt <murray@activestate.com> and integrated by RAM, who
Packit 14c646
 * only renamed things a little bit to ensure consistency with surrounding
Packit 14c646
 * code.	-- RAM, 14/09/1999
Packit 14c646
 *
Packit 14c646
 * The original patch suffered from the fact that the stcxt_t structure
Packit 14c646
 * was global.  Murray tried to minimize the impact on the code as much as
Packit 14c646
 * possible.
Packit 14c646
 *
Packit 14c646
 * Starting with 0.7, Storable can be re-entrant, via the STORABLE_xxx hooks
Packit 14c646
 * on objects.  Therefore, the notion of context needs to be generalized,
Packit 14c646
 * threading or not.
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define MY_VERSION "Storable(" XS_VERSION ")"
Packit 14c646
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Conditional UTF8 support.
Packit 14c646
 *
Packit 14c646
 */
Packit 14c646
#ifdef SvUTF8_on
Packit 14c646
#define STORE_UTF8STR(pv, len)	STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR)
Packit 14c646
#define HAS_UTF8_SCALARS
Packit 14c646
#ifdef HeKUTF8
Packit 14c646
#define HAS_UTF8_HASHES
Packit 14c646
#define HAS_UTF8_ALL
Packit 14c646
#else
Packit 14c646
/* 5.6 perl has utf8 scalars but not hashes */
Packit 14c646
#endif
Packit 14c646
#else
Packit 14c646
#define SvUTF8(sv) 0
Packit 14c646
#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl"))
Packit 14c646
#endif
Packit 14c646
#ifndef HAS_UTF8_ALL
Packit 14c646
#define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl"))
Packit 14c646
#endif
Packit 14c646
#ifndef SvWEAKREF
Packit 14c646
#define WEAKREF_CROAK() CROAK(("Cannot retrieve weak references in this perl"))
Packit 14c646
#endif
Packit 14c646
#ifndef SvVOK
Packit 14c646
#define VSTRING_CROAK() CROAK(("Cannot retrieve vstring in this perl"))
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifdef HvPLACEHOLDERS
Packit 14c646
#define HAS_RESTRICTED_HASHES
Packit 14c646
#else
Packit 14c646
#define HVhek_PLACEHOLD	0x200
Packit 14c646
#define RESTRICTED_HASH_CROAK() CROAK(("Cannot retrieve restricted hash"))
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifdef HvHASKFLAGS
Packit 14c646
#define HAS_HASH_KEY_FLAGS
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifdef ptr_table_new
Packit 14c646
#define USE_PTR_TABLE
Packit 14c646
#endif
Packit 14c646
Packit 14c646
/* do we need/want to clear padding on NVs? */
Packit 14c646
#if defined(LONG_DOUBLEKIND) && defined(USE_LONG_DOUBLE)
Packit 14c646
#  if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
Packit 14c646
      LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
Packit 14c646
#    define NV_PADDING (NVSIZE - 10)
Packit 14c646
#  else
Packit 14c646
#    define NV_PADDING 0
Packit 14c646
#  endif
Packit 14c646
#else
Packit 14c646
/* This is kind of a guess - it means we'll get an unneeded clear on 128-bit NV
Packit 14c646
   but an upgraded perl will fix that
Packit 14c646
*/
Packit 14c646
#  if NVSIZE > 8
Packit 14c646
#    define NV_CLEAR
Packit 14c646
#  endif
Packit 14c646
#  define NV_PADDING 0
Packit 14c646
#endif
Packit 14c646
Packit 14c646
typedef union {
Packit 14c646
    NV nv;
Packit 14c646
    U8 bytes[sizeof(NV)];
Packit 14c646
} NV_bytes;
Packit 14c646
Packit 14c646
/* Needed for 32bit with lengths > 2G - 4G, and 64bit */
Packit 14c646
#if PTRSIZE > 4
Packit 14c646
#define HAS_U64
Packit 14c646
#endif
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include
Packit 14c646
 * files remap tainted and dirty when threading is enabled.  That's bad for
Packit 14c646
 * perl to remap such common words.	-- RAM, 29/09/00
Packit 14c646
 */
Packit 14c646
Packit 14c646
struct stcxt;
Packit 14c646
typedef struct stcxt {
Packit 14c646
    int entry;		/* flags recursion */
Packit 14c646
    int optype;		/* type of traversal operation */
Packit 14c646
    /* which objects have been seen, store time.
Packit 14c646
       tags are numbers, which are cast to (SV *) and stored directly */
Packit 14c646
#ifdef USE_PTR_TABLE
Packit 14c646
    /* use pseen if we have ptr_tables. We have to store tag+1, because
Packit 14c646
       tag numbers start at 0, and we can't store (SV *) 0 in a ptr_table
Packit 14c646
       without it being confused for a fetch lookup failure.  */
Packit 14c646
    struct ptr_tbl *pseen;
Packit 14c646
    /* Still need hseen for the 0.6 file format code. */
Packit 14c646
#endif
Packit 14c646
    HV *hseen;
Packit 14c646
    AV *hook_seen;		/* which SVs were returned by STORABLE_freeze() */
Packit 14c646
    AV *aseen;			/* which objects have been seen, retrieve time */
Packit 14c646
    ntag_t where_is_undef;		/* index in aseen of PL_sv_undef */
Packit 14c646
    HV *hclass;			/* which classnames have been seen, store time */
Packit 14c646
    AV *aclass;			/* which classnames have been seen, retrieve time */
Packit 14c646
    HV *hook;			/* cache for hook methods per class name */
Packit 14c646
    IV tagnum;			/* incremented at store time for each seen object */
Packit 14c646
    IV classnum;		/* incremented at store time for each seen classname */
Packit 14c646
    int netorder;		/* true if network order used */
Packit 14c646
    int s_tainted;		/* true if input source is tainted, at retrieve time */
Packit 14c646
    int forgive_me;		/* whether to be forgiving... */
Packit 14c646
    int deparse;		/* whether to deparse code refs */
Packit 14c646
    SV *eval;			/* whether to eval source code */
Packit 14c646
    int canonical;		/* whether to store hashes sorted by key */
Packit 14c646
#ifndef HAS_RESTRICTED_HASHES
Packit 14c646
    int derestrict;		/* whether to downgrade restricted hashes */
Packit 14c646
#endif
Packit 14c646
#ifndef HAS_UTF8_ALL
Packit 14c646
    int use_bytes;		/* whether to bytes-ify utf8 */
Packit 14c646
#endif
Packit 14c646
    int accept_future_minor;	/* croak immediately on future minor versions?  */
Packit 14c646
    int s_dirty;		/* context is dirty due to CROAK() -- can be cleaned */
Packit 14c646
    int membuf_ro;		/* true means membuf is read-only and msaved is rw */
Packit 14c646
    struct extendable keybuf;	/* for hash key retrieval */
Packit 14c646
    struct extendable membuf;	/* for memory store/retrieve operations */
Packit 14c646
    struct extendable msaved;	/* where potentially valid mbuf is saved */
Packit 14c646
    PerlIO *fio;		/* where I/O are performed, NULL for memory */
Packit 14c646
    int ver_major;		/* major of version for retrieved object */
Packit 14c646
    int ver_minor;		/* minor of version for retrieved object */
Packit 14c646
    SV *(**retrieve_vtbl)(pTHX_ struct stcxt *, const char *);	/* retrieve dispatch table */
Packit 14c646
    SV *prev;			/* contexts chained backwards in real recursion */
Packit 14c646
    SV *my_sv;			/* the blessed scalar who's SvPVX() I am */
Packit 14c646
    SV *recur_sv;               /* check only one recursive SV */
Packit 14c646
    int in_retrieve_overloaded; /* performance hack for retrieving overloaded objects */
Packit 14c646
    int flags;			/* controls whether to bless or tie objects */
Packit 14c646
    IV recur_depth;        	/* avoid stack overflows RT #97526 */
Packit 14c646
    IV max_recur_depth;        /* limit for recur_depth */
Packit 14c646
    IV max_recur_depth_hash;   /* limit for recur_depth for hashes */
Packit 14c646
#ifdef DEBUGME
Packit 14c646
    int traceme;                /* TRACEME() produces output */
Packit 14c646
#endif
Packit 14c646
} stcxt_t;
Packit 14c646
Packit 14c646
#define RECURSION_TOO_DEEP() \
Packit 14c646
    (cxt->max_recur_depth != -1 && ++cxt->recur_depth > cxt->max_recur_depth)
Packit 14c646
#define RECURSION_TOO_DEEP_HASH() \
Packit 14c646
    (cxt->max_recur_depth_hash != -1 && ++cxt->recur_depth > cxt->max_recur_depth_hash)
Packit 14c646
#define MAX_DEPTH_ERROR "Max. recursion depth with nested structures exceeded"
Packit 14c646
Packit 14c646
static int storable_free(pTHX_ SV *sv, MAGIC* mg);
Packit 14c646
Packit 14c646
static MGVTBL vtbl_storable = {
Packit 14c646
    NULL, /* get */
Packit 14c646
    NULL, /* set */
Packit 14c646
    NULL, /* len */
Packit 14c646
    NULL, /* clear */
Packit 14c646
    storable_free,
Packit 14c646
#ifdef MGf_COPY
Packit 14c646
    NULL, /* copy */
Packit 14c646
#endif
Packit 14c646
#ifdef MGf_DUP
Packit 14c646
    NULL, /* dup */
Packit 14c646
#endif
Packit 14c646
#ifdef MGf_LOCAL
Packit 14c646
    NULL /* local */
Packit 14c646
#endif
Packit 14c646
};
Packit 14c646
Packit 14c646
/* From Digest::MD5.  */
Packit 14c646
#ifndef sv_magicext
Packit 14c646
# define sv_magicext(sv, obj, type, vtbl, name, namlen)         \
Packit 14c646
    THX_sv_magicext(aTHX_ sv, obj, type, vtbl, name, namlen)
Packit 14c646
static MAGIC *THX_sv_magicext(pTHX_
Packit 14c646
	SV *sv, SV *obj, int type,
Packit 14c646
	MGVTBL const *vtbl, char const *name, I32 namlen)
Packit 14c646
{
Packit 14c646
    MAGIC *mg;
Packit 14c646
    if (obj || namlen)
Packit 14c646
        /* exceeded intended usage of this reserve implementation */
Packit 14c646
        return NULL;
Packit 14c646
    Newxz(mg, 1, MAGIC);
Packit 14c646
    mg->mg_virtual = (MGVTBL*)vtbl;
Packit 14c646
    mg->mg_type = type;
Packit 14c646
    mg->mg_ptr = (char *)name;
Packit 14c646
    mg->mg_len = -1;
Packit 14c646
    (void) SvUPGRADE(sv, SVt_PVMG);
Packit 14c646
    mg->mg_moremagic = SvMAGIC(sv);
Packit 14c646
    SvMAGIC_set(sv, mg);
Packit 14c646
    SvMAGICAL_off(sv);
Packit 14c646
    mg_magical(sv);
Packit 14c646
    return mg;
Packit 14c646
}
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#define NEW_STORABLE_CXT_OBJ(cxt)				\
Packit 14c646
    STMT_START {						\
Packit 14c646
        SV *self = newSV(sizeof(stcxt_t) - 1);                  \
Packit 14c646
        SV *my_sv = newRV_noinc(self);                          \
Packit 14c646
        sv_magicext(self, NULL, PERL_MAGIC_ext, &vtbl_storable, NULL, 0); \
Packit 14c646
        cxt = (stcxt_t *)SvPVX(self);                           \
Packit 14c646
        Zero(cxt, 1, stcxt_t);                                  \
Packit 14c646
        cxt->my_sv = my_sv;                                     \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
Packit 14c646
Packit 14c646
#if (PATCHLEVEL <= 4) && (SUBVERSION < 68)
Packit 14c646
#define dSTCXT_SV                                               \
Packit 14c646
    SV *perinterp_sv = get_sv(MY_VERSION, 0)
Packit 14c646
#else	/* >= perl5.004_68 */
Packit 14c646
#define dSTCXT_SV						\
Packit 14c646
    SV *perinterp_sv = *hv_fetch(PL_modglobal,                  \
Packit 14c646
				 MY_VERSION, sizeof(MY_VERSION)-1, TRUE)
Packit 14c646
#endif	/* < perl5.004_68 */
Packit 14c646
Packit 14c646
#define dSTCXT_PTR(T,name)					\
Packit 14c646
    T name = ((perinterp_sv                                     \
Packit 14c646
               && SvIOK(perinterp_sv) && SvIVX(perinterp_sv)    \
Packit 14c646
               ? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0))
Packit 14c646
#define dSTCXT					\
Packit 14c646
    dSTCXT_SV;                                  \
Packit 14c646
    dSTCXT_PTR(stcxt_t *, cxt)
Packit 14c646
Packit 14c646
#define INIT_STCXT					\
Packit 14c646
    dSTCXT;                                             \
Packit 14c646
    NEW_STORABLE_CXT_OBJ(cxt);                          \
Packit 14c646
    assert(perinterp_sv);				\
Packit 14c646
    sv_setiv(perinterp_sv, PTR2IV(cxt->my_sv))
Packit 14c646
Packit 14c646
#define SET_STCXT(x)					\
Packit 14c646
    STMT_START {					\
Packit 14c646
        dSTCXT_SV;                                      \
Packit 14c646
        sv_setiv(perinterp_sv, PTR2IV(x->my_sv));       \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */
Packit 14c646
Packit 14c646
static stcxt_t *Context_ptr = NULL;
Packit 14c646
#define dSTCXT			stcxt_t *cxt = Context_ptr
Packit 14c646
#define SET_STCXT(x)		Context_ptr = x
Packit 14c646
#define INIT_STCXT				\
Packit 14c646
    dSTCXT;                                     \
Packit 14c646
    NEW_STORABLE_CXT_OBJ(cxt);                  \
Packit 14c646
    SET_STCXT(cxt)
Packit 14c646
Packit 14c646
Packit 14c646
#endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * KNOWN BUG:
Packit 14c646
 *   Croaking implies a memory leak, since we don't use setjmp/longjmp
Packit 14c646
 *   to catch the exit and free memory used during store or retrieve
Packit 14c646
 *   operations.  This is not too difficult to fix, but I need to understand
Packit 14c646
 *   how Perl does it, and croaking is exceptional anyway, so I lack the
Packit 14c646
 *   motivation to do it.
Packit 14c646
 *
Packit 14c646
 * The current workaround is to mark the context as dirty when croaking,
Packit 14c646
 * so that data structures can be freed whenever we renter Storable code
Packit 14c646
 * (but only *then*: it's a workaround, not a fix).
Packit 14c646
 *
Packit 14c646
 * This is also imperfect, because we don't really know how far they trapped
Packit 14c646
 * the croak(), and when we were recursing, we won't be able to clean anything
Packit 14c646
 * but the topmost context stacked.
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define CROAK(x)	STMT_START { cxt->s_dirty = 1; croak x; } STMT_END
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * End of "thread-safe" related definitions.
Packit 14c646
 */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * LOW_32BITS
Packit 14c646
 *
Packit 14c646
 * Keep only the low 32 bits of a pointer (used for tags, which are not
Packit 14c646
 * really pointers).
Packit 14c646
 */
Packit 14c646
Packit 14c646
#if PTRSIZE <= 4
Packit 14c646
#define LOW_32BITS(x)	((I32) (x))
Packit 14c646
#else
Packit 14c646
#define LOW_32BITS(x)	((I32) ((STRLEN) (x) & 0xffffffffUL))
Packit 14c646
#endif
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * PTR2TAG(x)
Packit 14c646
 *
Packit 14c646
 * Convert a pointer into an ntag_t.
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define PTR2TAG(x) ((ntag_t)(x))
Packit 14c646
Packit 14c646
#define TAG2PTR(x, type) ((y)(x))
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * oI, oS, oC
Packit 14c646
 *
Packit 14c646
 * Hack for Crays, where sizeof(I32) == 8, and which are big-endians.
Packit 14c646
 * Used in the WLEN and RLEN macros.
Packit 14c646
 */
Packit 14c646
Packit 14c646
#if INTSIZE > 4
Packit 14c646
#define oI(x)	((I32 *) ((char *) (x) + 4))
Packit 14c646
#define oS(x)	((x) - 4)
Packit 14c646
#define oL(x)	(x)
Packit 14c646
#define oC(x)	(x = 0)
Packit 14c646
#define CRAY_HACK
Packit 14c646
#else
Packit 14c646
#define oI(x)	(x)
Packit 14c646
#define oS(x)	(x)
Packit 14c646
#define oL(x)	(x)
Packit 14c646
#define oC(x)
Packit 14c646
#endif
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * key buffer handling
Packit 14c646
 */
Packit 14c646
#define kbuf	(cxt->keybuf).arena
Packit 14c646
#define ksiz	(cxt->keybuf).asiz
Packit 14c646
#define KBUFINIT()							\
Packit 14c646
    STMT_START {							\
Packit 14c646
        if (!kbuf) {                                                    \
Packit 14c646
            TRACEME(("** allocating kbuf of 128 bytes"));               \
Packit 14c646
            New(10003, kbuf, 128, char);                                \
Packit 14c646
            ksiz = 128;                                                 \
Packit 14c646
        }                                                               \
Packit 14c646
    } STMT_END
Packit 14c646
#define KBUFCHK(x)							\
Packit 14c646
    STMT_START {							\
Packit 14c646
        if (x >= ksiz) {                                                \
Packit 14c646
            if (x >= I32_MAX)                                           \
Packit 14c646
                CROAK(("Too large size > I32_MAX"));                    \
Packit 14c646
            TRACEME(("** extending kbuf to %d bytes (had %d)",          \
Packit 14c646
                     (int)(x+1), (int)ksiz));                           \
Packit 14c646
            Renew(kbuf, x+1, char);                                     \
Packit 14c646
            ksiz = x+1;                                                 \
Packit 14c646
        }                                                               \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * memory buffer handling
Packit 14c646
 */
Packit 14c646
#define mbase	(cxt->membuf).arena
Packit 14c646
#define msiz	(cxt->membuf).asiz
Packit 14c646
#define mptr	(cxt->membuf).aptr
Packit 14c646
#define mend	(cxt->membuf).aend
Packit 14c646
Packit 14c646
#define MGROW	(1 << 13)
Packit 14c646
#define MMASK	(MGROW - 1)
Packit 14c646
Packit 14c646
#define round_mgrow(x)	\
Packit 14c646
    ((STRLEN) (((STRLEN) (x) + MMASK) & ~MMASK))
Packit 14c646
#define trunc_int(x)	\
Packit 14c646
    ((STRLEN) ((STRLEN) (x) & ~(sizeof(int)-1)))
Packit 14c646
#define int_aligned(x)	\
Packit 14c646
    ((STRLEN)(x) == trunc_int(x))
Packit 14c646
Packit 14c646
#define MBUF_INIT(x)							\
Packit 14c646
    STMT_START {							\
Packit 14c646
        if (!mbase) {                                                   \
Packit 14c646
            TRACEME(("** allocating mbase of %d bytes", MGROW));        \
Packit 14c646
            New(10003, mbase, (int)MGROW, char);                        \
Packit 14c646
            msiz = (STRLEN)MGROW;                                       \
Packit 14c646
        }                                                               \
Packit 14c646
        mptr = mbase;                                                   \
Packit 14c646
        if (x)                                                          \
Packit 14c646
            mend = mbase + x;                                           \
Packit 14c646
        else                                                            \
Packit 14c646
            mend = mbase + msiz;                                        \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define MBUF_TRUNC(x)	mptr = mbase + x
Packit 14c646
#define MBUF_SIZE()	(mptr - mbase)
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * MBUF_SAVE_AND_LOAD
Packit 14c646
 * MBUF_RESTORE
Packit 14c646
 *
Packit 14c646
 * Those macros are used in do_retrieve() to save the current memory
Packit 14c646
 * buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve
Packit 14c646
 * data from a string.
Packit 14c646
 */
Packit 14c646
#define MBUF_SAVE_AND_LOAD(in)						\
Packit 14c646
    STMT_START {							\
Packit 14c646
        ASSERT(!cxt->membuf_ro, ("mbase not already saved"));           \
Packit 14c646
        cxt->membuf_ro = 1;                                             \
Packit 14c646
        TRACEME(("saving mbuf"));                                       \
Packit 14c646
        StructCopy(&cxt->membuf, &cxt->msaved, struct extendable);      \
Packit 14c646
        MBUF_LOAD(in);                                                  \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define MBUF_RESTORE()							\
Packit 14c646
    STMT_START {							\
Packit 14c646
        ASSERT(cxt->membuf_ro, ("mbase is read-only"));                 \
Packit 14c646
        cxt->membuf_ro = 0;                                             \
Packit 14c646
        TRACEME(("restoring mbuf"));                                    \
Packit 14c646
        StructCopy(&cxt->msaved, &cxt->membuf, struct extendable);      \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Use SvPOKp(), because SvPOK() fails on tainted scalars.
Packit 14c646
 * See store_scalar() for other usage of this workaround.
Packit 14c646
 */
Packit 14c646
#define MBUF_LOAD(v)						\
Packit 14c646
    STMT_START {						\
Packit 14c646
        ASSERT(cxt->membuf_ro, ("mbase is read-only"));         \
Packit 14c646
        if (!SvPOKp(v))                                         \
Packit 14c646
            CROAK(("Not a scalar string"));                     \
Packit 14c646
        mptr = mbase = SvPV(v, msiz);                           \
Packit 14c646
        mend = mbase + msiz;                                    \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define MBUF_XTEND(x)						\
Packit 14c646
    STMT_START {						\
Packit 14c646
        STRLEN nsz = (STRLEN) round_mgrow((x)+msiz);            \
Packit 14c646
        STRLEN offset = mptr - mbase;                           \
Packit 14c646
        ASSERT(!cxt->membuf_ro, ("mbase is not read-only"));    \
Packit 14c646
        TRACEME(("** extending mbase from %ld to %ld bytes (wants %ld new)", \
Packit 14c646
                 (long)msiz, nsz, (long)(x)));                  \
Packit 14c646
        Renew(mbase, nsz, char);                                \
Packit 14c646
        msiz = nsz;                                             \
Packit 14c646
        mptr = mbase + offset;                                  \
Packit 14c646
        mend = mbase + nsz;                                     \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define MBUF_CHK(x)				\
Packit 14c646
    STMT_START {				\
Packit 14c646
        if ((mptr + (x)) > mend)                \
Packit 14c646
            MBUF_XTEND(x);                      \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define MBUF_GETC(x)				\
Packit 14c646
    STMT_START {				\
Packit 14c646
        if (mptr < mend)                        \
Packit 14c646
            x = (int) (unsigned char) *mptr++;  \
Packit 14c646
        else                                    \
Packit 14c646
            return (SV *) 0;                    \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#ifdef CRAY_HACK
Packit 14c646
#define MBUF_GETINT(x)				\
Packit 14c646
    STMT_START {				\
Packit 14c646
        oC(x);                                  \
Packit 14c646
        if ((mptr + 4) <= mend) {               \
Packit 14c646
            memcpy(oI(&x), mptr, 4);            \
Packit 14c646
            mptr += 4;                          \
Packit 14c646
        } else                                  \
Packit 14c646
            return (SV *) 0;                    \
Packit 14c646
    } STMT_END
Packit 14c646
#else
Packit 14c646
#define MBUF_GETINT(x)				\
Packit 14c646
    STMT_START {				\
Packit 14c646
        if ((mptr + sizeof(int)) <= mend) {     \
Packit 14c646
            if (int_aligned(mptr))              \
Packit 14c646
                x = *(int *) mptr;              \
Packit 14c646
            else                                \
Packit 14c646
                memcpy(&x, mptr, sizeof(int));  \
Packit 14c646
            mptr += sizeof(int);                \
Packit 14c646
        } else                                  \
Packit 14c646
            return (SV *) 0;                    \
Packit 14c646
    } STMT_END
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#define MBUF_READ(x,s)				\
Packit 14c646
    STMT_START {				\
Packit 14c646
        if ((mptr + (s)) <= mend) {             \
Packit 14c646
            memcpy(x, mptr, s);                 \
Packit 14c646
            mptr += s;                          \
Packit 14c646
        } else                                  \
Packit 14c646
            return (SV *) 0;                    \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define MBUF_SAFEREAD(x,s,z)			\
Packit 14c646
    STMT_START {				\
Packit 14c646
        if ((mptr + (s)) <= mend) {             \
Packit 14c646
            memcpy(x, mptr, s);                 \
Packit 14c646
            mptr += s;                          \
Packit 14c646
        } else {                                \
Packit 14c646
            sv_free(z);                         \
Packit 14c646
            return (SV *) 0;                    \
Packit 14c646
        }                                       \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define MBUF_SAFEPVREAD(x,s,z)			\
Packit 14c646
    STMT_START {				\
Packit 14c646
        if ((mptr + (s)) <= mend) {             \
Packit 14c646
            memcpy(x, mptr, s);                 \
Packit 14c646
            mptr += s;                          \
Packit 14c646
        } else {                                \
Packit 14c646
            Safefree(z);                        \
Packit 14c646
            return (SV *) 0;                    \
Packit 14c646
        }                                       \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define MBUF_PUTC(c)				\
Packit 14c646
    STMT_START {				\
Packit 14c646
        if (mptr < mend)                        \
Packit 14c646
            *mptr++ = (char) c;                 \
Packit 14c646
        else {                                  \
Packit 14c646
            MBUF_XTEND(1);                      \
Packit 14c646
            *mptr++ = (char) c;                 \
Packit 14c646
        }                                       \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#ifdef CRAY_HACK
Packit 14c646
#define MBUF_PUTINT(i)				\
Packit 14c646
    STMT_START {				\
Packit 14c646
        MBUF_CHK(4);                            \
Packit 14c646
        memcpy(mptr, oI(&i), 4);                \
Packit 14c646
        mptr += 4;                              \
Packit 14c646
    } STMT_END
Packit 14c646
#else
Packit 14c646
#define MBUF_PUTINT(i) 				\
Packit 14c646
    STMT_START {				\
Packit 14c646
        MBUF_CHK(sizeof(int));                  \
Packit 14c646
        if (int_aligned(mptr))                  \
Packit 14c646
            *(int *) mptr = i;                  \
Packit 14c646
        else                                    \
Packit 14c646
            memcpy(mptr, &i, sizeof(int));      \
Packit 14c646
        mptr += sizeof(int);                    \
Packit 14c646
    } STMT_END
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#define MBUF_PUTLONG(l)				\
Packit 14c646
    STMT_START {				\
Packit 14c646
        MBUF_CHK(8);                            \
Packit 14c646
        memcpy(mptr, &l, 8);                    \
Packit 14c646
        mptr += 8;                              \
Packit 14c646
    } STMT_END
Packit 14c646
#define MBUF_WRITE(x,s)				\
Packit 14c646
    STMT_START {				\
Packit 14c646
        MBUF_CHK(s);                            \
Packit 14c646
        memcpy(mptr, x, s);                     \
Packit 14c646
        mptr += s;                              \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Possible return values for sv_type().
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define svis_REF		0
Packit 14c646
#define svis_SCALAR		1
Packit 14c646
#define svis_ARRAY		2
Packit 14c646
#define svis_HASH		3
Packit 14c646
#define svis_TIED		4
Packit 14c646
#define svis_TIED_ITEM		5
Packit 14c646
#define svis_CODE		6
Packit 14c646
#define svis_REGEXP		7
Packit 14c646
#define svis_OTHER		8
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Flags for SX_HOOK.
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define SHF_TYPE_MASK		0x03
Packit 14c646
#define SHF_LARGE_CLASSLEN	0x04
Packit 14c646
#define SHF_LARGE_STRLEN	0x08
Packit 14c646
#define SHF_LARGE_LISTLEN	0x10
Packit 14c646
#define SHF_IDX_CLASSNAME	0x20
Packit 14c646
#define SHF_NEED_RECURSE	0x40
Packit 14c646
#define SHF_HAS_LIST		0x80
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Types for SX_HOOK (last 2 bits in flags).
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define SHT_SCALAR		0
Packit 14c646
#define SHT_ARRAY		1
Packit 14c646
#define SHT_HASH		2
Packit 14c646
#define SHT_EXTRA		3	/* Read extra byte for type */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * The following are held in the "extra byte"...
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define SHT_TSCALAR		4	/* 4 + 0 -- tied scalar */
Packit 14c646
#define SHT_TARRAY		5	/* 4 + 1 -- tied array */
Packit 14c646
#define SHT_THASH		6	/* 4 + 2 -- tied hash */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * per hash flags for flagged hashes
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define SHV_RESTRICTED		0x01
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * per key flags for flagged hashes
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define SHV_K_UTF8		0x01
Packit 14c646
#define SHV_K_WASUTF8		0x02
Packit 14c646
#define SHV_K_LOCKED		0x04
Packit 14c646
#define SHV_K_ISSV		0x08
Packit 14c646
#define SHV_K_PLACEHOLDER	0x10
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * flags to allow blessing and/or tieing data the data we load
Packit 14c646
 */
Packit 14c646
#define FLAG_BLESS_OK 2
Packit 14c646
#define FLAG_TIE_OK   4
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Flags for SX_REGEXP.
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define SHR_U32_RE_LEN		0x01
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Before 0.6, the magic string was "perl-store" (binary version number 0).
Packit 14c646
 *
Packit 14c646
 * Since 0.6 introduced many binary incompatibilities, the magic string has
Packit 14c646
 * been changed to "pst0" to allow an old image to be properly retrieved by
Packit 14c646
 * a newer Storable, but ensure a newer image cannot be retrieved with an
Packit 14c646
 * older version.
Packit 14c646
 *
Packit 14c646
 * At 0.7, objects are given the ability to serialize themselves, and the
Packit 14c646
 * set of markers is extended, backward compatibility is not jeopardized,
Packit 14c646
 * so the binary version number could have remained unchanged.  To correctly
Packit 14c646
 * spot errors if a file making use of 0.7-specific extensions is given to
Packit 14c646
 * 0.6 for retrieval, the binary version was moved to "2".  And I'm introducing
Packit 14c646
 * a "minor" version, to better track this kind of evolution from now on.
Packit 14c646
 * 
Packit 14c646
 */
Packit 14c646
static const char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */
Packit 14c646
static const char magicstr[] = "pst0";		 /* Used as a magic number */
Packit 14c646
Packit 14c646
#define MAGICSTR_BYTES  'p','s','t','0'
Packit 14c646
#define OLDMAGICSTR_BYTES  'p','e','r','l','-','s','t','o','r','e'
Packit 14c646
Packit 14c646
/* 5.6.x introduced the ability to have IVs as long long.
Packit 14c646
   However, Configure still defined BYTEORDER based on the size of a long.
Packit 14c646
   Storable uses the BYTEORDER value as part of the header, but doesn't
Packit 14c646
   explicitly store sizeof(IV) anywhere in the header.  Hence on 5.6.x built
Packit 14c646
   with IV as long long on a platform that uses Configure (ie most things
Packit 14c646
   except VMS and Windows) headers are identical for the different IV sizes,
Packit 14c646
   despite the files containing some fields based on sizeof(IV)
Packit 14c646
   Erk. Broken-ness.
Packit 14c646
   5.8 is consistent - the following redefinition kludge is only needed on
Packit 14c646
   5.6.x, but the interwork is needed on 5.8 while data survives in files
Packit 14c646
   with the 5.6 header.
Packit 14c646
Packit 14c646
*/
Packit 14c646
Packit 14c646
#if defined (IVSIZE) && (IVSIZE == 8) && (LONGSIZE == 4)
Packit 14c646
#ifndef NO_56_INTERWORK_KLUDGE
Packit 14c646
#define USE_56_INTERWORK_KLUDGE
Packit 14c646
#endif
Packit 14c646
#if BYTEORDER == 0x1234
Packit 14c646
#undef BYTEORDER
Packit 14c646
#define BYTEORDER 0x12345678
Packit 14c646
#else
Packit 14c646
#if BYTEORDER == 0x4321
Packit 14c646
#undef BYTEORDER
Packit 14c646
#define BYTEORDER 0x87654321
Packit 14c646
#endif
Packit 14c646
#endif
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#if BYTEORDER == 0x1234
Packit 14c646
#define BYTEORDER_BYTES  '1','2','3','4'
Packit 14c646
#else
Packit 14c646
#if BYTEORDER == 0x12345678
Packit 14c646
#define BYTEORDER_BYTES  '1','2','3','4','5','6','7','8'
Packit 14c646
#ifdef USE_56_INTERWORK_KLUDGE
Packit 14c646
#define BYTEORDER_BYTES_56  '1','2','3','4'
Packit 14c646
#endif
Packit 14c646
#else
Packit 14c646
#if BYTEORDER == 0x87654321
Packit 14c646
#define BYTEORDER_BYTES  '8','7','6','5','4','3','2','1'
Packit 14c646
#ifdef USE_56_INTERWORK_KLUDGE
Packit 14c646
#define BYTEORDER_BYTES_56  '4','3','2','1'
Packit 14c646
#endif
Packit 14c646
#else
Packit 14c646
#if BYTEORDER == 0x4321
Packit 14c646
#define BYTEORDER_BYTES  '4','3','2','1'
Packit 14c646
#else
Packit 14c646
#error Unknown byteorder. Please append your byteorder to Storable.xs
Packit 14c646
#endif
Packit 14c646
#endif
Packit 14c646
#endif
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#ifndef INT32_MAX
Packit 14c646
# define INT32_MAX 2147483647
Packit 14c646
#endif
Packit 14c646
#if IVSIZE > 4 && !defined(INT64_MAX)
Packit 14c646
# define INT64_MAX 9223372036854775807LL
Packit 14c646
#endif
Packit 14c646
Packit 14c646
static const char byteorderstr[] = {BYTEORDER_BYTES, 0};
Packit 14c646
#ifdef USE_56_INTERWORK_KLUDGE
Packit 14c646
static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#define STORABLE_BIN_MAJOR	2		/* Binary major "version" */
Packit 14c646
#define STORABLE_BIN_MINOR	11		/* Binary minor "version" */
Packit 14c646
Packit 14c646
#if (PATCHLEVEL <= 5)
Packit 14c646
#define STORABLE_BIN_WRITE_MINOR	4
Packit 14c646
#elif !defined (SvVOK)
Packit 14c646
/*
Packit 14c646
 * Perl 5.6.0-5.8.0 can do weak references, but not vstring magic.
Packit 14c646
*/
Packit 14c646
#define STORABLE_BIN_WRITE_MINOR	8
Packit 14c646
#elif PATCHLEVEL >= 19
Packit 14c646
/* Perl 5.19 takes away the special meaning of PL_sv_undef in arrays. */
Packit 14c646
/* With 3.x we added LOBJECT */
Packit 14c646
#define STORABLE_BIN_WRITE_MINOR	11
Packit 14c646
#else
Packit 14c646
#define STORABLE_BIN_WRITE_MINOR	9
Packit 14c646
#endif /* (PATCHLEVEL <= 5) */
Packit 14c646
Packit 14c646
#if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1))
Packit 14c646
#define PL_sv_placeholder PL_sv_undef
Packit 14c646
#endif
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Useful store shortcuts...
Packit 14c646
 */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Note that if you put more than one mark for storing a particular
Packit 14c646
 * type of thing, *and* in the retrieve_foo() function you mark both
Packit 14c646
 * the thingy's you get off with SEEN(), you *must* increase the
Packit 14c646
 * tagnum with cxt->tagnum++ along with this macro!
Packit 14c646
 *     - samv 20Jan04
Packit 14c646
 */
Packit 14c646
#define PUTMARK(x) 					\
Packit 14c646
    STMT_START {					\
Packit 14c646
        if (!cxt->fio)                                  \
Packit 14c646
            MBUF_PUTC(x);                               \
Packit 14c646
        else if (PerlIO_putc(cxt->fio, x) == EOF)       \
Packit 14c646
            return -1;                                  \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define WRITE_I32(x)						\
Packit 14c646
    STMT_START {						\
Packit 14c646
        ASSERT(sizeof(x) == sizeof(I32), ("writing an I32"));   \
Packit 14c646
        if (!cxt->fio)                                          \
Packit 14c646
            MBUF_PUTINT(x);                                     \
Packit 14c646
        else if (PerlIO_write(cxt->fio, oI(&x),                 \
Packit 14c646
                              oS(sizeof(x))) != oS(sizeof(x)))  \
Packit 14c646
            return -1;                                          \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define WRITE_U64(x)							\
Packit 14c646
    STMT_START {							\
Packit 14c646
        ASSERT(sizeof(x) == sizeof(UV), ("writing an UV"));		\
Packit 14c646
        if (!cxt->fio)                                                  \
Packit 14c646
            MBUF_PUTLONG(x);                                            \
Packit 14c646
        else if (PerlIO_write(cxt->fio, oL(&x),                         \
Packit 14c646
                              oS(sizeof(x))) != oS(sizeof(x)))          \
Packit 14c646
            return -1;                                                  \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#ifdef HAS_HTONL
Packit 14c646
#define WLEN(x)                                                         \
Packit 14c646
    STMT_START {							\
Packit 14c646
        ASSERT(sizeof(x) == sizeof(int), ("WLEN writing an int"));      \
Packit 14c646
        if (cxt->netorder) {                                            \
Packit 14c646
            int y = (int) htonl(x);                                     \
Packit 14c646
            if (!cxt->fio)                                              \
Packit 14c646
                MBUF_PUTINT(y);                                         \
Packit 14c646
            else if (PerlIO_write(cxt->fio,oI(&y),oS(sizeof(y))) != oS(sizeof(y))) \
Packit 14c646
                return -1;                                              \
Packit 14c646
        } else {                                                        \
Packit 14c646
            if (!cxt->fio)                                              \
Packit 14c646
                MBUF_PUTINT(x);                                         \
Packit 14c646
            else if (PerlIO_write(cxt->fio,oI(&x),                      \
Packit 14c646
                                  oS(sizeof(x))) != oS(sizeof(x)))      \
Packit 14c646
                return -1;                                              \
Packit 14c646
        }                                                               \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#  ifdef HAS_U64
Packit 14c646
Packit 14c646
#define W64LEN(x)							\
Packit 14c646
    STMT_START {							\
Packit 14c646
        ASSERT(sizeof(x) == 8, ("W64LEN writing a U64"));               \
Packit 14c646
        if (cxt->netorder) {                                            \
Packit 14c646
            U32 buf[2];      						\
Packit 14c646
            buf[1] = htonl(x & 0xffffffffUL);                           \
Packit 14c646
            buf[0] = htonl(x >> 32);                                    \
Packit 14c646
            if (!cxt->fio)                                              \
Packit 14c646
                MBUF_PUTLONG(buf);                                      \
Packit 14c646
            else if (PerlIO_write(cxt->fio, buf,                        \
Packit 14c646
                                  sizeof(buf)) != sizeof(buf))          \
Packit 14c646
                return -1;                                              \
Packit 14c646
        } else {                                                        \
Packit 14c646
            if (!cxt->fio)                                              \
Packit 14c646
                MBUF_PUTLONG(x);                                        \
Packit 14c646
            else if (PerlIO_write(cxt->fio,oI(&x),                      \
Packit 14c646
                                  oS(sizeof(x))) != oS(sizeof(x)))      \
Packit 14c646
                return -1;                                              \
Packit 14c646
        }                                                               \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#  else
Packit 14c646
Packit 14c646
#define W64LEN(x) CROAK(("No 64bit UVs"))
Packit 14c646
Packit 14c646
#  endif
Packit 14c646
Packit 14c646
#else
Packit 14c646
#define WLEN(x)	WRITE_I32(x)
Packit 14c646
#ifdef HAS_U64
Packit 14c646
#define W64LEN(x) WRITE_U64(x)
Packit 14c646
#else
Packit 14c646
#define W64LEN(x) CROAK(("no 64bit UVs"))
Packit 14c646
#endif
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#define WRITE(x,y) 							\
Packit 14c646
    STMT_START {							\
Packit 14c646
        if (!cxt->fio)                                                  \
Packit 14c646
            MBUF_WRITE(x,y);                                            \
Packit 14c646
        else if (PerlIO_write(cxt->fio, x, y) != (SSize_t)y)            \
Packit 14c646
            return -1;                                                  \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define STORE_PV_LEN(pv, len, small, large)			\
Packit 14c646
    STMT_START {						\
Packit 14c646
        if (len <= LG_SCALAR) {                                 \
Packit 14c646
            int ilen = (int) len;                               \
Packit 14c646
            unsigned char clen = (unsigned char) len;           \
Packit 14c646
            PUTMARK(small);                                     \
Packit 14c646
            PUTMARK(clen);                                      \
Packit 14c646
            if (len)                                            \
Packit 14c646
                WRITE(pv, ilen);                                \
Packit 14c646
        } else if (sizeof(len) > 4 && len > INT32_MAX) {        \
Packit 14c646
            PUTMARK(SX_LOBJECT);                                \
Packit 14c646
            PUTMARK(large);                                     \
Packit 14c646
            W64LEN(len);                                        \
Packit 14c646
            WRITE(pv, len);                                     \
Packit 14c646
        } else {                                                \
Packit 14c646
            int ilen = (int) len;                               \
Packit 14c646
            PUTMARK(large);                                     \
Packit 14c646
            WLEN(ilen);                                         \
Packit 14c646
            WRITE(pv, ilen);                                    \
Packit 14c646
        }                                                       \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define STORE_SCALAR(pv, len)	STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR)
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Store &PL_sv_undef in arrays without recursing through store().  We
Packit 14c646
 * actually use this to represent nonexistent elements, for historical
Packit 14c646
 * reasons.
Packit 14c646
 */
Packit 14c646
#define STORE_SV_UNDEF() 					\
Packit 14c646
    STMT_START {                                                \
Packit 14c646
	cxt->tagnum++;						\
Packit 14c646
	PUTMARK(SX_SV_UNDEF);					\
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Useful retrieve shortcuts...
Packit 14c646
 */
Packit 14c646
Packit 14c646
#define GETCHAR() \
Packit 14c646
    (cxt->fio ? PerlIO_getc(cxt->fio)                   \
Packit 14c646
              : (mptr >= mend ? EOF : (int) *mptr++))
Packit 14c646
Packit 14c646
#define GETMARK(x)							\
Packit 14c646
    STMT_START {							\
Packit 14c646
        if (!cxt->fio)                                                  \
Packit 14c646
            MBUF_GETC(x);                                               \
Packit 14c646
        else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF)              \
Packit 14c646
            return (SV *) 0;                                            \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define READ_I32(x)							\
Packit 14c646
    STMT_START {							\
Packit 14c646
        ASSERT(sizeof(x) == sizeof(I32), ("reading an I32"));           \
Packit 14c646
        oC(x);                                                          \
Packit 14c646
        if (!cxt->fio)                                                  \
Packit 14c646
            MBUF_GETINT(x);                                             \
Packit 14c646
        else if (PerlIO_read(cxt->fio, oI(&x),                          \
Packit 14c646
                                 oS(sizeof(x))) != oS(sizeof(x)))       \
Packit 14c646
            return (SV *) 0;                                            \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#ifdef HAS_NTOHL
Packit 14c646
#define RLEN(x)                                                         \
Packit 14c646
    STMT_START {							\
Packit 14c646
        oC(x);                                                          \
Packit 14c646
        if (!cxt->fio)                                                  \
Packit 14c646
            MBUF_GETINT(x);                                             \
Packit 14c646
        else if (PerlIO_read(cxt->fio, oI(&x),                          \
Packit 14c646
                                 oS(sizeof(x))) != oS(sizeof(x)))       \
Packit 14c646
            return (SV *) 0;                                            \
Packit 14c646
        if (cxt->netorder)                                              \
Packit 14c646
            x = (int) ntohl(x);                                         \
Packit 14c646
    } STMT_END
Packit 14c646
#else
Packit 14c646
#define RLEN(x) READ_I32(x)
Packit 14c646
#endif
Packit 14c646
Packit 14c646
#define READ(x,y) 							\
Packit 14c646
    STMT_START {							\
Packit 14c646
	if (!cxt->fio)							\
Packit 14c646
            MBUF_READ(x, y);                                            \
Packit 14c646
	else if (PerlIO_read(cxt->fio, x, y) != (SSize_t)y)             \
Packit 14c646
            return (SV *) 0;                                            \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define SAFEREAD(x,y,z)                                                 \
Packit 14c646
    STMT_START {							\
Packit 14c646
        if (!cxt->fio)                                                  \
Packit 14c646
            MBUF_SAFEREAD(x,y,z);                                       \
Packit 14c646
        else if (PerlIO_read(cxt->fio, x, y) != (SSize_t)y) {           \
Packit 14c646
            sv_free(z);                                                 \
Packit 14c646
            return (SV *) 0;                                            \
Packit 14c646
        }                                                               \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define SAFEPVREAD(x,y,z)					\
Packit 14c646
    STMT_START {						\
Packit 14c646
        if (!cxt->fio)                                          \
Packit 14c646
            MBUF_SAFEPVREAD(x,y,z);                             \
Packit 14c646
        else if (PerlIO_read(cxt->fio, x, y) != y) {            \
Packit 14c646
            Safefree(z);                                        \
Packit 14c646
            return (SV *) 0;                                    \
Packit 14c646
        }                                                       \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#ifdef HAS_U64
Packit 14c646
Packit 14c646
#  if defined(HAS_NTOHL)
Packit 14c646
#    define Sntohl(x) ntohl(x)
Packit 14c646
#  elif BYTEORDER == 0x87654321 || BYTEORDER == 0x4321
Packit 14c646
#    define Sntohl(x) (x)
Packit 14c646
#  else
Packit 14c646
static U32 Sntohl(U32 x) {
Packit 14c646
    return ((x & 0xFF) << 24) + ((x * 0xFF00) << 8)
Packit 14c646
	+ ((x & 0xFF0000) >> 8) + ((x & 0xFF000000) >> 24);
Packit 14c646
}
Packit 14c646
#  endif
Packit 14c646
Packit 14c646
#  define READ_U64(x)                                                       \
Packit 14c646
    STMT_START {                                                          \
Packit 14c646
	ASSERT(sizeof(x) == 8, ("R64LEN reading a U64"));                 \
Packit 14c646
	if (cxt->netorder) {                                              \
Packit 14c646
	    U32 buf[2];                                                   \
Packit 14c646
	    READ((void *)buf, sizeof(buf));                               \
Packit 14c646
	    (x) = ((UV)Sntohl(buf[0]) << 32) + Sntohl(buf[1]);		\
Packit 14c646
	}                                                                 \
Packit 14c646
	else {                                                            \
Packit 14c646
	    READ(&(x), sizeof(x));                                        \
Packit 14c646
	}                                                                 \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#endif
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * SEEN() is used at retrieve time, to remember where object 'y', bearing a
Packit 14c646
 * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker,
Packit 14c646
 * we'll therefore know where it has been retrieved and will be able to
Packit 14c646
 * share the same reference, as in the original stored memory image.
Packit 14c646
 *
Packit 14c646
 * We also need to bless objects ASAP for hooks (which may compute "ref $x"
Packit 14c646
 * on the objects given to STORABLE_thaw and expect that to be defined), and
Packit 14c646
 * also for overloaded objects (for which we might not find the stash if the
Packit 14c646
 * object is not blessed yet--this might occur for overloaded objects that
Packit 14c646
 * refer to themselves indirectly: if we blessed upon return from a sub
Packit 14c646
 * retrieve(), the SX_OBJECT marker we'd found could not have overloading
Packit 14c646
 * restored on it because the underlying object would not be blessed yet!).
Packit 14c646
 *
Packit 14c646
 * To achieve that, the class name of the last retrieved object is passed down
Packit 14c646
 * recursively, and the first SEEN() call for which the class name is not NULL
Packit 14c646
 * will bless the object.
Packit 14c646
 *
Packit 14c646
 * i should be true iff sv is immortal (ie PL_sv_yes, PL_sv_no or PL_sv_undef)
Packit 14c646
 *
Packit 14c646
 * SEEN0() is a short-cut where stash is always NULL.
Packit 14c646
 *
Packit 14c646
 * The _NN variants dont check for y being null
Packit 14c646
 */
Packit 14c646
#define SEEN0_NN(y,i)							\
Packit 14c646
    STMT_START {							\
Packit 14c646
        if (av_store(cxt->aseen, cxt->tagnum++, i ? (SV*)(y)            \
Packit 14c646
                     : SvREFCNT_inc(y)) == 0)                           \
Packit 14c646
            return (SV *) 0;                                            \
Packit 14c646
        TRACEME(("aseen(#%d) = 0x%" UVxf " (refcnt=%d)",                \
Packit 14c646
                 (int)cxt->tagnum-1,                                    \
Packit 14c646
                 PTR2UV(y), (int)SvREFCNT(y)-1));                       \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define SEEN0(y,i)							\
Packit 14c646
    STMT_START {							\
Packit 14c646
        if (!y)                                                         \
Packit 14c646
            return (SV *) 0;                                            \
Packit 14c646
        SEEN0_NN(y,i);                                                  \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define SEEN_NN(y,stash,i)						\
Packit 14c646
    STMT_START {							\
Packit 14c646
        SEEN0_NN(y,i);                                                  \
Packit 14c646
        if (stash)							\
Packit 14c646
            BLESS((SV *)(y), (HV *)(stash));                            \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
#define SEEN(y,stash,i)							\
Packit 14c646
    STMT_START {                                                	\
Packit 14c646
        if (!y)                                                         \
Packit 14c646
            return (SV *) 0;                                            \
Packit 14c646
        SEEN_NN(y,stash, i);                                            \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Bless 's' in 'p', via a temporary reference, required by sv_bless().
Packit 14c646
 * "A" magic is added before the sv_bless for overloaded classes, this avoids
Packit 14c646
 * an expensive call to S_reset_amagic in sv_bless.
Packit 14c646
 */
Packit 14c646
#define BLESS(s,stash)							\
Packit 14c646
    STMT_START {							\
Packit 14c646
        SV *ref;                                                        \
Packit 14c646
        if (cxt->flags & FLAG_BLESS_OK) {                               \
Packit 14c646
            TRACEME(("blessing 0x%" UVxf " in %s", PTR2UV(s),           \
Packit 14c646
                     HvNAME_get(stash)));                               \
Packit 14c646
            ref = newRV_noinc(s);                                       \
Packit 14c646
            if (cxt->in_retrieve_overloaded && Gv_AMG(stash)) {         \
Packit 14c646
                cxt->in_retrieve_overloaded = 0;                        \
Packit 14c646
                SvAMAGIC_on(ref);                                       \
Packit 14c646
            }                                                           \
Packit 14c646
            (void) sv_bless(ref, stash);                                \
Packit 14c646
            SvRV_set(ref, NULL);                                        \
Packit 14c646
            SvREFCNT_dec(ref);                                          \
Packit 14c646
        }                                                               \
Packit 14c646
        else {                                                          \
Packit 14c646
            TRACEME(("not blessing 0x%" UVxf " in %s", PTR2UV(s),       \
Packit 14c646
                     (HvNAME_get(stash))));                             \
Packit 14c646
        }                                                               \
Packit 14c646
    } STMT_END
Packit 14c646
/*
Packit 14c646
 * sort (used in store_hash) - conditionally use qsort when
Packit 14c646
 * sortsv is not available ( <= 5.6.1 ).
Packit 14c646
 */
Packit 14c646
Packit 14c646
#if (PATCHLEVEL <= 6)
Packit 14c646
Packit 14c646
#if defined(USE_ITHREADS)
Packit 14c646
Packit 14c646
#define STORE_HASH_SORT						\
Packit 14c646
    ENTER; {                                                    \
Packit 14c646
        PerlInterpreter *orig_perl = PERL_GET_CONTEXT;          \
Packit 14c646
        SAVESPTR(orig_perl);                                    \
Packit 14c646
        PERL_SET_CONTEXT(aTHX);                                 \
Packit 14c646
        qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);\
Packit 14c646
    } LEAVE;
Packit 14c646
Packit 14c646
#else /* ! USE_ITHREADS */
Packit 14c646
Packit 14c646
#define STORE_HASH_SORT					\
Packit 14c646
    qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);
Packit 14c646
Packit 14c646
#endif  /* USE_ITHREADS */
Packit 14c646
Packit 14c646
#else /* PATCHLEVEL > 6 */
Packit 14c646
Packit 14c646
#define STORE_HASH_SORT \
Packit 14c646
    sortsv(AvARRAY(av), len, Perl_sv_cmp);
Packit 14c646
Packit 14c646
#endif /* PATCHLEVEL <= 6 */
Packit 14c646
Packit 14c646
static int store(pTHX_ stcxt_t *cxt, SV *sv);
Packit 14c646
static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
Packit 14c646
#define UNSEE()			\
Packit 14c646
    STMT_START {			\
Packit 14c646
        av_pop(cxt->aseen);             \
Packit 14c646
        cxt->tagnum--;                  \
Packit 14c646
    } STMT_END
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Dynamic dispatching table for SV store.
Packit 14c646
 */
Packit 14c646
Packit 14c646
static int store_ref(pTHX_ stcxt_t *cxt, SV *sv);
Packit 14c646
static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv);
Packit 14c646
static int store_array(pTHX_ stcxt_t *cxt, AV *av);
Packit 14c646
static int store_hash(pTHX_ stcxt_t *cxt, HV *hv);
Packit 14c646
static int store_tied(pTHX_ stcxt_t *cxt, SV *sv);
Packit 14c646
static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv);
Packit 14c646
static int store_code(pTHX_ stcxt_t *cxt, CV *cv);
Packit 14c646
static int store_regexp(pTHX_ stcxt_t *cxt, SV *sv);
Packit 14c646
static int store_other(pTHX_ stcxt_t *cxt, SV *sv);
Packit 14c646
static int store_blessed(pTHX_ stcxt_t *cxt, SV *sv, int type, HV *pkg);
Packit 14c646
Packit 14c646
typedef int (*sv_store_t)(pTHX_ stcxt_t *cxt, SV *sv);
Packit 14c646
Packit 14c646
static const sv_store_t sv_store[] = {
Packit 14c646
    (sv_store_t)store_ref,	/* svis_REF */
Packit 14c646
    (sv_store_t)store_scalar,	/* svis_SCALAR */
Packit 14c646
    (sv_store_t)store_array,	/* svis_ARRAY */
Packit 14c646
    (sv_store_t)store_hash,	/* svis_HASH */
Packit 14c646
    (sv_store_t)store_tied,	/* svis_TIED */
Packit 14c646
    (sv_store_t)store_tied_item,/* svis_TIED_ITEM */
Packit 14c646
    (sv_store_t)store_code,	/* svis_CODE */
Packit 14c646
    (sv_store_t)store_regexp,	/* svis_REGEXP */
Packit 14c646
    (sv_store_t)store_other,	/* svis_OTHER */
Packit 14c646
};
Packit 14c646
Packit 14c646
#define SV_STORE(x)	(*sv_store[x])
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * Dynamic dispatching tables for SV retrieval.
Packit 14c646
 */
Packit 14c646
Packit 14c646
static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_lobject(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
Packit 14c646
/* helpers for U64 lobjects */
Packit 14c646
Packit 14c646
static SV *get_lstring(pTHX_ stcxt_t *cxt, UV len, int isutf8, const char *cname);
Packit 14c646
#ifdef HAS_U64
Packit 14c646
static SV *get_larray(pTHX_ stcxt_t *cxt, UV len, const char *cname);
Packit 14c646
static SV *get_lhash(pTHX_ stcxt_t *cxt, UV len, int hash_flags, const char *cname);
Packit 14c646
static int store_lhash(pTHX_ stcxt_t *cxt, HV *hv, unsigned char hash_flags);
Packit 14c646
#endif
Packit 14c646
static int store_hentry(pTHX_ stcxt_t *cxt, HV* hv, UV i, HE *he, unsigned char hash_flags);
Packit 14c646
Packit 14c646
typedef SV* (*sv_retrieve_t)(pTHX_ stcxt_t *cxt, const char *name);
Packit 14c646
Packit 14c646
static const sv_retrieve_t sv_old_retrieve[] = {
Packit 14c646
    0,					/* SX_OBJECT -- entry unused dynamically */
Packit 14c646
    (sv_retrieve_t)retrieve_lscalar,	/* SX_LSCALAR */
Packit 14c646
    (sv_retrieve_t)old_retrieve_array,	/* SX_ARRAY -- for pre-0.6 binaries */
Packit 14c646
    (sv_retrieve_t)old_retrieve_hash,	/* SX_HASH -- for pre-0.6 binaries */
Packit 14c646
    (sv_retrieve_t)retrieve_ref,	/* SX_REF */
Packit 14c646
    (sv_retrieve_t)retrieve_undef,	/* SX_UNDEF */
Packit 14c646
    (sv_retrieve_t)retrieve_integer,	/* SX_INTEGER */
Packit 14c646
    (sv_retrieve_t)retrieve_double,	/* SX_DOUBLE */
Packit 14c646
    (sv_retrieve_t)retrieve_byte,	/* SX_BYTE */
Packit 14c646
    (sv_retrieve_t)retrieve_netint,	/* SX_NETINT */
Packit 14c646
    (sv_retrieve_t)retrieve_scalar,	/* SX_SCALAR */
Packit 14c646
    (sv_retrieve_t)retrieve_tied_array,	/* SX_TIED_ARRAY */
Packit 14c646
    (sv_retrieve_t)retrieve_tied_hash,	/* SX_TIED_HASH */
Packit 14c646
    (sv_retrieve_t)retrieve_tied_scalar,/* SX_TIED_SCALAR */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_SV_UNDEF not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_SV_YES not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_SV_NO not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_BLESS not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_IX_BLESS not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_HOOK not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_OVERLOADED not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_TIED_KEY not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_TIED_IDX not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_UTF8STR not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_LUTF8STR not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_FLAG_HASH not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_CODE not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_WEAKREF not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_WEAKOVERLOAD not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_VSTRING not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_LVSTRING not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_SVUNDEF_ELEM not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,	/* SX_REGEXP */
Packit 14c646
    (sv_retrieve_t)retrieve_other,  	/* SX_LOBJECT not supported */
Packit 14c646
    (sv_retrieve_t)retrieve_other,  	/* SX_LAST */
Packit 14c646
};
Packit 14c646
Packit 14c646
static SV *retrieve_hook_common(pTHX_ stcxt_t *cxt, const char *cname, int large);
Packit 14c646
Packit 14c646
static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname);
Packit 14c646
Packit 14c646
static const sv_retrieve_t sv_retrieve[] = {
Packit 14c646
    0,					/* SX_OBJECT -- entry unused dynamically */
Packit 14c646
    (sv_retrieve_t)retrieve_lscalar,	/* SX_LSCALAR */
Packit 14c646
    (sv_retrieve_t)retrieve_array,	/* SX_ARRAY */
Packit 14c646
    (sv_retrieve_t)retrieve_hash,	/* SX_HASH */
Packit 14c646
    (sv_retrieve_t)retrieve_ref,	/* SX_REF */
Packit 14c646
    (sv_retrieve_t)retrieve_undef,	/* SX_UNDEF */
Packit 14c646
    (sv_retrieve_t)retrieve_integer,	/* SX_INTEGER */
Packit 14c646
    (sv_retrieve_t)retrieve_double,	/* SX_DOUBLE */
Packit 14c646
    (sv_retrieve_t)retrieve_byte,	/* SX_BYTE */
Packit 14c646
    (sv_retrieve_t)retrieve_netint,	/* SX_NETINT */
Packit 14c646
    (sv_retrieve_t)retrieve_scalar,	/* SX_SCALAR */
Packit 14c646
    (sv_retrieve_t)retrieve_tied_array,	/* SX_TIED_ARRAY */
Packit 14c646
    (sv_retrieve_t)retrieve_tied_hash,	/* SX_TIED_HASH */
Packit 14c646
    (sv_retrieve_t)retrieve_tied_scalar,/* SX_TIED_SCALAR */
Packit 14c646
    (sv_retrieve_t)retrieve_sv_undef,	/* SX_SV_UNDEF */
Packit 14c646
    (sv_retrieve_t)retrieve_sv_yes,	/* SX_SV_YES */
Packit 14c646
    (sv_retrieve_t)retrieve_sv_no,	/* SX_SV_NO */
Packit 14c646
    (sv_retrieve_t)retrieve_blessed,	/* SX_BLESS */
Packit 14c646
    (sv_retrieve_t)retrieve_idx_blessed,/* SX_IX_BLESS */
Packit 14c646
    (sv_retrieve_t)retrieve_hook,	/* SX_HOOK */
Packit 14c646
    (sv_retrieve_t)retrieve_overloaded,	/* SX_OVERLOAD */
Packit 14c646
    (sv_retrieve_t)retrieve_tied_key,	/* SX_TIED_KEY */
Packit 14c646
    (sv_retrieve_t)retrieve_tied_idx,	/* SX_TIED_IDX */
Packit 14c646
    (sv_retrieve_t)retrieve_utf8str,	/* SX_UTF8STR  */
Packit 14c646
    (sv_retrieve_t)retrieve_lutf8str,	/* SX_LUTF8STR */
Packit 14c646
    (sv_retrieve_t)retrieve_flag_hash,	/* SX_HASH */
Packit 14c646
    (sv_retrieve_t)retrieve_code,	/* SX_CODE */
Packit 14c646
    (sv_retrieve_t)retrieve_weakref,	/* SX_WEAKREF */
Packit 14c646
    (sv_retrieve_t)retrieve_weakoverloaded,/* SX_WEAKOVERLOAD */
Packit 14c646
    (sv_retrieve_t)retrieve_vstring,	/* SX_VSTRING */
Packit 14c646
    (sv_retrieve_t)retrieve_lvstring,	/* SX_LVSTRING */
Packit 14c646
    (sv_retrieve_t)retrieve_svundef_elem,/* SX_SVUNDEF_ELEM */
Packit 14c646
    (sv_retrieve_t)retrieve_regexp,	/* SX_REGEXP */
Packit 14c646
    (sv_retrieve_t)retrieve_lobject,	/* SX_LOBJECT */
Packit 14c646
    (sv_retrieve_t)retrieve_other,  	/* SX_LAST */
Packit 14c646
};
Packit 14c646
Packit 14c646
#define RETRIEVE(c,x) ((x) >= SX_LAST ? retrieve_other : *(c)->retrieve_vtbl[x])
Packit 14c646
Packit 14c646
static SV *mbuf2sv(pTHX);
Packit 14c646
Packit 14c646
/***
Packit 14c646
 *** Context management.
Packit 14c646
 ***/
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * init_perinterp
Packit 14c646
 *
Packit 14c646
 * Called once per "thread" (interpreter) to initialize some global context.
Packit 14c646
 */
Packit 14c646
static void init_perinterp(pTHX)
Packit 14c646
{
Packit 14c646
    INIT_STCXT;
Packit 14c646
    INIT_TRACEME;
Packit 14c646
    cxt->netorder = 0;		/* true if network order used */
Packit 14c646
    cxt->forgive_me = -1;	/* whether to be forgiving... */
Packit 14c646
    cxt->accept_future_minor = -1; /* would otherwise occur too late */
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * reset_context
Packit 14c646
 *
Packit 14c646
 * Called at the end of every context cleaning, to perform common reset
Packit 14c646
 * operations.
Packit 14c646
 */
Packit 14c646
static void reset_context(stcxt_t *cxt)
Packit 14c646
{
Packit 14c646
    cxt->entry = 0;
Packit 14c646
    cxt->s_dirty = 0;
Packit 14c646
    cxt->recur_sv = NULL;
Packit 14c646
    cxt->recur_depth = 0;
Packit 14c646
    cxt->optype &= ~(ST_STORE|ST_RETRIEVE);	/* Leave ST_CLONE alone */
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * init_store_context
Packit 14c646
 *
Packit 14c646
 * Initialize a new store context for real recursion.
Packit 14c646
 */
Packit 14c646
static void init_store_context(pTHX_
Packit 14c646
	stcxt_t *cxt,
Packit 14c646
        PerlIO *f,
Packit 14c646
        int optype,
Packit 14c646
        int network_order)
Packit 14c646
{
Packit 14c646
    INIT_TRACEME;
Packit 14c646
Packit 14c646
    TRACEME(("init_store_context"));
Packit 14c646
Packit 14c646
    cxt->netorder = network_order;
Packit 14c646
    cxt->forgive_me = -1;		/* Fetched from perl if needed */
Packit 14c646
    cxt->deparse = -1;			/* Idem */
Packit 14c646
    cxt->eval = NULL;			/* Idem */
Packit 14c646
    cxt->canonical = -1;		/* Idem */
Packit 14c646
    cxt->tagnum = -1;			/* Reset tag numbers */
Packit 14c646
    cxt->classnum = -1;			/* Reset class numbers */
Packit 14c646
    cxt->fio = f;			/* Where I/O are performed */
Packit 14c646
    cxt->optype = optype;		/* A store, or a deep clone */
Packit 14c646
    cxt->entry = 1;			/* No recursion yet */
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * The 'hseen' table is used to keep track of each SV stored and their
Packit 14c646
     * associated tag numbers is special. It is "abused" because the
Packit 14c646
     * values stored are not real SV, just integers cast to (SV *),
Packit 14c646
     * which explains the freeing below.
Packit 14c646
     *
Packit 14c646
     * It is also one possible bottleneck to achieve good storing speed,
Packit 14c646
     * so the "shared keys" optimization is turned off (unlikely to be
Packit 14c646
     * of any use here), and the hash table is "pre-extended". Together,
Packit 14c646
     * those optimizations increase the throughput by 12%.
Packit 14c646
     */
Packit 14c646
Packit 14c646
#ifdef USE_PTR_TABLE
Packit 14c646
    cxt->pseen = ptr_table_new();
Packit 14c646
    cxt->hseen = 0;
Packit 14c646
#else
Packit 14c646
    cxt->hseen = newHV();	/* Table where seen objects are stored */
Packit 14c646
    HvSHAREKEYS_off(cxt->hseen);
Packit 14c646
#endif
Packit 14c646
    /*
Packit 14c646
     * The following does not work well with perl5.004_04, and causes
Packit 14c646
     * a core dump later on, in a completely unrelated spot, which
Packit 14c646
     * makes me think there is a memory corruption going on.
Packit 14c646
     *
Packit 14c646
     * Calling hv_ksplit(hseen, HBUCKETS) instead of manually hacking
Packit 14c646
     * it below does not make any difference. It seems to work fine
Packit 14c646
     * with perl5.004_68 but given the probable nature of the bug,
Packit 14c646
     * that does not prove anything.
Packit 14c646
     *
Packit 14c646
     * It's a shame because increasing the amount of buckets raises
Packit 14c646
     * store() throughput by 5%, but until I figure this out, I can't
Packit 14c646
     * allow for this to go into production.
Packit 14c646
     *
Packit 14c646
     * It is reported fixed in 5.005, hence the #if.
Packit 14c646
     */
Packit 14c646
#if PERL_VERSION >= 5
Packit 14c646
#define HBUCKETS	4096		/* Buckets for %hseen */
Packit 14c646
#ifndef USE_PTR_TABLE
Packit 14c646
    HvMAX(cxt->hseen) = HBUCKETS - 1;	/* keys %hseen = $HBUCKETS; */
Packit 14c646
#endif
Packit 14c646
#endif
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * The 'hclass' hash uses the same settings as 'hseen' above, but it is
Packit 14c646
     * used to assign sequential tags (numbers) to class names for blessed
Packit 14c646
     * objects.
Packit 14c646
     *
Packit 14c646
     * We turn the shared key optimization on.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    cxt->hclass = newHV();		/* Where seen classnames are stored */
Packit 14c646
Packit 14c646
#if PERL_VERSION >= 5
Packit 14c646
    HvMAX(cxt->hclass) = HBUCKETS - 1;	/* keys %hclass = $HBUCKETS; */
Packit 14c646
#endif
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * The 'hook' hash table is used to keep track of the references on
Packit 14c646
     * the STORABLE_freeze hook routines, when found in some class name.
Packit 14c646
     *
Packit 14c646
     * It is assumed that the inheritance tree will not be changed during
Packit 14c646
     * storing, and that no new method will be dynamically created by the
Packit 14c646
     * hooks.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    cxt->hook = newHV();		/* Table where hooks are cached */
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * The 'hook_seen' array keeps track of all the SVs returned by
Packit 14c646
     * STORABLE_freeze hooks for us to serialize, so that they are not
Packit 14c646
     * reclaimed until the end of the serialization process.  Each SV is
Packit 14c646
     * only stored once, the first time it is seen.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    cxt->hook_seen = newAV(); /* Lists SVs returned by STORABLE_freeze */
Packit 14c646
Packit 14c646
    cxt->max_recur_depth = SvIV(get_sv("Storable::recursion_limit", GV_ADD));
Packit 14c646
    cxt->max_recur_depth_hash = SvIV(get_sv("Storable::recursion_limit_hash", GV_ADD));
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * clean_store_context
Packit 14c646
 *
Packit 14c646
 * Clean store context by
Packit 14c646
 */
Packit 14c646
static void clean_store_context(pTHX_ stcxt_t *cxt)
Packit 14c646
{
Packit 14c646
    HE *he;
Packit 14c646
Packit 14c646
    TRACEMED(("clean_store_context"));
Packit 14c646
Packit 14c646
    ASSERT(cxt->optype & ST_STORE, ("was performing a store()"));
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * Insert real values into hashes where we stored faked pointers.
Packit 14c646
     */
Packit 14c646
Packit 14c646
#ifndef USE_PTR_TABLE
Packit 14c646
    if (cxt->hseen) {
Packit 14c646
        hv_iterinit(cxt->hseen);
Packit 14c646
        while ((he = hv_iternext(cxt->hseen)))	/* Extra () for -Wall */
Packit 14c646
            HeVAL(he) = &PL_sv_undef;
Packit 14c646
    }
Packit 14c646
#endif
Packit 14c646
Packit 14c646
    if (cxt->hclass) {
Packit 14c646
        hv_iterinit(cxt->hclass);
Packit 14c646
        while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall */
Packit 14c646
            HeVAL(he) = &PL_sv_undef;
Packit 14c646
    }
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * And now dispose of them...
Packit 14c646
     *
Packit 14c646
     * The surrounding if() protection has been added because there might be
Packit 14c646
     * some cases where this routine is called more than once, during
Packit 14c646
     * exceptional events.  This was reported by Marc Lehmann when Storable
Packit 14c646
     * is executed from mod_perl, and the fix was suggested by him.
Packit 14c646
     * 		-- RAM, 20/12/2000
Packit 14c646
     */
Packit 14c646
Packit 14c646
#ifdef USE_PTR_TABLE
Packit 14c646
    if (cxt->pseen) {
Packit 14c646
        struct ptr_tbl *pseen = cxt->pseen;
Packit 14c646
        cxt->pseen = 0;
Packit 14c646
        ptr_table_free(pseen);
Packit 14c646
    }
Packit 14c646
    assert(!cxt->hseen);
Packit 14c646
#else
Packit 14c646
    if (cxt->hseen) {
Packit 14c646
        HV *hseen = cxt->hseen;
Packit 14c646
        cxt->hseen = 0;
Packit 14c646
        hv_undef(hseen);
Packit 14c646
        sv_free((SV *) hseen);
Packit 14c646
    }
Packit 14c646
#endif
Packit 14c646
Packit 14c646
    if (cxt->hclass) {
Packit 14c646
        HV *hclass = cxt->hclass;
Packit 14c646
        cxt->hclass = 0;
Packit 14c646
        hv_undef(hclass);
Packit 14c646
        sv_free((SV *) hclass);
Packit 14c646
    }
Packit 14c646
Packit 14c646
    if (cxt->hook) {
Packit 14c646
        HV *hook = cxt->hook;
Packit 14c646
        cxt->hook = 0;
Packit 14c646
        hv_undef(hook);
Packit 14c646
        sv_free((SV *) hook);
Packit 14c646
    }
Packit 14c646
Packit 14c646
    if (cxt->hook_seen) {
Packit 14c646
        AV *hook_seen = cxt->hook_seen;
Packit 14c646
        cxt->hook_seen = 0;
Packit 14c646
        av_undef(hook_seen);
Packit 14c646
        sv_free((SV *) hook_seen);
Packit 14c646
    }
Packit 14c646
Packit 14c646
    cxt->forgive_me = -1;	/* Fetched from perl if needed */
Packit 14c646
    cxt->deparse = -1;		/* Idem */
Packit 14c646
    if (cxt->eval) {
Packit 14c646
        SvREFCNT_dec(cxt->eval);
Packit 14c646
    }
Packit 14c646
    cxt->eval = NULL;		/* Idem */
Packit 14c646
    cxt->canonical = -1;	/* Idem */
Packit 14c646
Packit 14c646
    reset_context(cxt);
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * init_retrieve_context
Packit 14c646
 *
Packit 14c646
 * Initialize a new retrieve context for real recursion.
Packit 14c646
 */
Packit 14c646
static void init_retrieve_context(pTHX_
Packit 14c646
	stcxt_t *cxt, int optype, int is_tainted)
Packit 14c646
{
Packit 14c646
    INIT_TRACEME;
Packit 14c646
Packit 14c646
    TRACEME(("init_retrieve_context"));
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * The hook hash table is used to keep track of the references on
Packit 14c646
     * the STORABLE_thaw hook routines, when found in some class name.
Packit 14c646
     *
Packit 14c646
     * It is assumed that the inheritance tree will not be changed during
Packit 14c646
     * storing, and that no new method will be dynamically created by the
Packit 14c646
     * hooks.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    cxt->hook  = newHV();			/* Caches STORABLE_thaw */
Packit 14c646
Packit 14c646
#ifdef USE_PTR_TABLE
Packit 14c646
    cxt->pseen = 0;
Packit 14c646
#endif
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * If retrieving an old binary version, the cxt->retrieve_vtbl variable
Packit 14c646
     * was set to sv_old_retrieve. We'll need a hash table to keep track of
Packit 14c646
     * the correspondence between the tags and the tag number used by the
Packit 14c646
     * new retrieve routines.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    cxt->hseen = (((void*)cxt->retrieve_vtbl == (void*)sv_old_retrieve)
Packit 14c646
                  ? newHV() : 0);
Packit 14c646
Packit 14c646
    cxt->aseen = newAV();	/* Where retrieved objects are kept */
Packit 14c646
    cxt->where_is_undef = UNSET_NTAG_T;	/* Special case for PL_sv_undef */
Packit 14c646
    cxt->aclass = newAV();	/* Where seen classnames are kept */
Packit 14c646
    cxt->tagnum = 0;		/* Have to count objects... */
Packit 14c646
    cxt->classnum = 0;		/* ...and class names as well */
Packit 14c646
    cxt->optype = optype;
Packit 14c646
    cxt->s_tainted = is_tainted;
Packit 14c646
    cxt->entry = 1;		/* No recursion yet */
Packit 14c646
#ifndef HAS_RESTRICTED_HASHES
Packit 14c646
    cxt->derestrict = -1;	/* Fetched from perl if needed */
Packit 14c646
#endif
Packit 14c646
#ifndef HAS_UTF8_ALL
Packit 14c646
    cxt->use_bytes = -1;	/* Fetched from perl if needed */
Packit 14c646
#endif
Packit 14c646
    cxt->accept_future_minor = -1;/* Fetched from perl if needed */
Packit 14c646
    cxt->in_retrieve_overloaded = 0;
Packit 14c646
Packit 14c646
    cxt->max_recur_depth = SvIV(get_sv("Storable::recursion_limit", GV_ADD));
Packit 14c646
    cxt->max_recur_depth_hash = SvIV(get_sv("Storable::recursion_limit_hash", GV_ADD));
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * clean_retrieve_context
Packit 14c646
 *
Packit 14c646
 * Clean retrieve context by
Packit 14c646
 */
Packit 14c646
static void clean_retrieve_context(pTHX_ stcxt_t *cxt)
Packit 14c646
{
Packit 14c646
    TRACEMED(("clean_retrieve_context"));
Packit 14c646
Packit 14c646
    ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()"));
Packit 14c646
Packit 14c646
    if (cxt->aseen) {
Packit 14c646
        AV *aseen = cxt->aseen;
Packit 14c646
        cxt->aseen = 0;
Packit 14c646
        av_undef(aseen);
Packit 14c646
        sv_free((SV *) aseen);
Packit 14c646
    }
Packit 14c646
    cxt->where_is_undef = UNSET_NTAG_T;
Packit 14c646
Packit 14c646
    if (cxt->aclass) {
Packit 14c646
        AV *aclass = cxt->aclass;
Packit 14c646
        cxt->aclass = 0;
Packit 14c646
        av_undef(aclass);
Packit 14c646
        sv_free((SV *) aclass);
Packit 14c646
    }
Packit 14c646
Packit 14c646
    if (cxt->hook) {
Packit 14c646
        HV *hook = cxt->hook;
Packit 14c646
        cxt->hook = 0;
Packit 14c646
        hv_undef(hook);
Packit 14c646
        sv_free((SV *) hook);
Packit 14c646
    }
Packit 14c646
Packit 14c646
    if (cxt->hseen) {
Packit 14c646
        HV *hseen = cxt->hseen;
Packit 14c646
        cxt->hseen = 0;
Packit 14c646
        hv_undef(hseen);
Packit 14c646
        sv_free((SV *) hseen);	/* optional HV, for backward compat. */
Packit 14c646
    }
Packit 14c646
Packit 14c646
#ifndef HAS_RESTRICTED_HASHES
Packit 14c646
    cxt->derestrict = -1;		/* Fetched from perl if needed */
Packit 14c646
#endif
Packit 14c646
#ifndef HAS_UTF8_ALL
Packit 14c646
    cxt->use_bytes = -1;		/* Fetched from perl if needed */
Packit 14c646
#endif
Packit 14c646
    cxt->accept_future_minor = -1;	/* Fetched from perl if needed */
Packit 14c646
Packit 14c646
    cxt->in_retrieve_overloaded = 0;
Packit 14c646
    reset_context(cxt);
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * clean_context
Packit 14c646
 *
Packit 14c646
 * A workaround for the CROAK bug: cleanup the last context.
Packit 14c646
 */
Packit 14c646
static void clean_context(pTHX_ stcxt_t *cxt)
Packit 14c646
{
Packit 14c646
    TRACEMED(("clean_context"));
Packit 14c646
Packit 14c646
    ASSERT(cxt->s_dirty, ("dirty context"));
Packit 14c646
Packit 14c646
    if (cxt->membuf_ro)
Packit 14c646
        MBUF_RESTORE();
Packit 14c646
Packit 14c646
    ASSERT(!cxt->membuf_ro, ("mbase is not read-only"));
Packit 14c646
Packit 14c646
    if (cxt->optype & ST_RETRIEVE)
Packit 14c646
        clean_retrieve_context(aTHX_ cxt);
Packit 14c646
    else if (cxt->optype & ST_STORE)
Packit 14c646
        clean_store_context(aTHX_ cxt);
Packit 14c646
    else
Packit 14c646
        reset_context(cxt);
Packit 14c646
Packit 14c646
    ASSERT(!cxt->s_dirty, ("context is clean"));
Packit 14c646
    ASSERT(cxt->entry == 0, ("context is reset"));
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * allocate_context
Packit 14c646
 *
Packit 14c646
 * Allocate a new context and push it on top of the parent one.
Packit 14c646
 * This new context is made globally visible via SET_STCXT().
Packit 14c646
 */
Packit 14c646
static stcxt_t *allocate_context(pTHX_ stcxt_t *parent_cxt)
Packit 14c646
{
Packit 14c646
    stcxt_t *cxt;
Packit 14c646
Packit 14c646
    ASSERT(!parent_cxt->s_dirty, ("parent context clean"));
Packit 14c646
Packit 14c646
    NEW_STORABLE_CXT_OBJ(cxt);
Packit 14c646
    TRACEMED(("allocate_context"));
Packit 14c646
Packit 14c646
    cxt->prev = parent_cxt->my_sv;
Packit 14c646
    SET_STCXT(cxt);
Packit 14c646
Packit 14c646
    ASSERT(!cxt->s_dirty, ("clean context"));
Packit 14c646
Packit 14c646
    return cxt;
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * free_context
Packit 14c646
 *
Packit 14c646
 * Free current context, which cannot be the "root" one.
Packit 14c646
 * Make the context underneath globally visible via SET_STCXT().
Packit 14c646
 */
Packit 14c646
static void free_context(pTHX_ stcxt_t *cxt)
Packit 14c646
{
Packit 14c646
    stcxt_t *prev = (stcxt_t *)(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0);
Packit 14c646
Packit 14c646
    TRACEMED(("free_context"));
Packit 14c646
Packit 14c646
    ASSERT(!cxt->s_dirty, ("clean context"));
Packit 14c646
    ASSERT(prev, ("not freeing root context"));
Packit 14c646
    assert(prev);
Packit 14c646
Packit 14c646
    SvREFCNT_dec(cxt->my_sv);
Packit 14c646
    SET_STCXT(prev);
Packit 14c646
Packit 14c646
    ASSERT(cxt, ("context not void"));
Packit 14c646
}
Packit 14c646
Packit 14c646
/***
Packit 14c646
 *** Predicates.
Packit 14c646
 ***/
Packit 14c646
Packit 14c646
/* these two functions are currently only used within asserts */
Packit 14c646
#ifdef DASSERT
Packit 14c646
/*
Packit 14c646
 * is_storing
Packit 14c646
 *
Packit 14c646
 * Tells whether we're in the middle of a store operation.
Packit 14c646
 */
Packit 14c646
static int is_storing(pTHX)
Packit 14c646
{
Packit 14c646
    dSTCXT;
Packit 14c646
Packit 14c646
    return cxt->entry && (cxt->optype & ST_STORE);
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * is_retrieving
Packit 14c646
 *
Packit 14c646
 * Tells whether we're in the middle of a retrieve operation.
Packit 14c646
 */
Packit 14c646
static int is_retrieving(pTHX)
Packit 14c646
{
Packit 14c646
    dSTCXT;
Packit 14c646
Packit 14c646
    return cxt->entry && (cxt->optype & ST_RETRIEVE);
Packit 14c646
}
Packit 14c646
#endif
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * last_op_in_netorder
Packit 14c646
 *
Packit 14c646
 * Returns whether last operation was made using network order.
Packit 14c646
 *
Packit 14c646
 * This is typically out-of-band information that might prove useful
Packit 14c646
 * to people wishing to convert native to network order data when used.
Packit 14c646
 */
Packit 14c646
static int last_op_in_netorder(pTHX)
Packit 14c646
{
Packit 14c646
    dSTCXT;
Packit 14c646
Packit 14c646
    assert(cxt);
Packit 14c646
    return cxt->netorder;
Packit 14c646
}
Packit 14c646
Packit 14c646
/***
Packit 14c646
 *** Hook lookup and calling routines.
Packit 14c646
 ***/
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * pkg_fetchmeth
Packit 14c646
 *
Packit 14c646
 * A wrapper on gv_fetchmethod_autoload() which caches results.
Packit 14c646
 *
Packit 14c646
 * Returns the routine reference as an SV*, or null if neither the package
Packit 14c646
 * nor its ancestors know about the method.
Packit 14c646
 */
Packit 14c646
static SV *pkg_fetchmeth(pTHX_
Packit 14c646
	HV *cache,
Packit 14c646
	HV *pkg,
Packit 14c646
	const char *method)
Packit 14c646
{
Packit 14c646
    GV *gv;
Packit 14c646
    SV *sv;
Packit 14c646
    const char *hvname = HvNAME_get(pkg);
Packit 14c646
#ifdef DEBUGME
Packit 14c646
    dSTCXT;
Packit 14c646
#endif
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * The following code is the same as the one performed by UNIVERSAL::can
Packit 14c646
     * in the Perl core.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    gv = gv_fetchmethod_autoload(pkg, method, FALSE);
Packit 14c646
    if (gv && isGV(gv)) {
Packit 14c646
        sv = newRV_inc((SV*) GvCV(gv));
Packit 14c646
        TRACEME(("%s->%s: 0x%" UVxf, hvname, method, PTR2UV(sv)));
Packit 14c646
    } else {
Packit 14c646
        sv = newSVsv(&PL_sv_undef);
Packit 14c646
        TRACEME(("%s->%s: not found", hvname, method));
Packit 14c646
    }
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * Cache the result, ignoring failure: if we can't store the value,
Packit 14c646
     * it just won't be cached.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    (void) hv_store(cache, hvname, strlen(hvname), sv, 0);
Packit 14c646
Packit 14c646
    return SvOK(sv) ? sv : (SV *) 0;
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * pkg_hide
Packit 14c646
 *
Packit 14c646
 * Force cached value to be undef: hook ignored even if present.
Packit 14c646
 */
Packit 14c646
static void pkg_hide(pTHX_
Packit 14c646
	HV *cache,
Packit 14c646
	HV *pkg,
Packit 14c646
	const char *method)
Packit 14c646
{
Packit 14c646
    const char *hvname = HvNAME_get(pkg);
Packit 14c646
    PERL_UNUSED_ARG(method);
Packit 14c646
    (void) hv_store(cache,
Packit 14c646
                    hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0);
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * pkg_uncache
Packit 14c646
 *
Packit 14c646
 * Discard cached value: a whole fetch loop will be retried at next lookup.
Packit 14c646
 */
Packit 14c646
static void pkg_uncache(pTHX_
Packit 14c646
	HV *cache,
Packit 14c646
	HV *pkg,
Packit 14c646
	const char *method)
Packit 14c646
{
Packit 14c646
    const char *hvname = HvNAME_get(pkg);
Packit 14c646
    PERL_UNUSED_ARG(method);
Packit 14c646
    (void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD);
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * pkg_can
Packit 14c646
 *
Packit 14c646
 * Our own "UNIVERSAL::can", which caches results.
Packit 14c646
 *
Packit 14c646
 * Returns the routine reference as an SV*, or null if the object does not
Packit 14c646
 * know about the method.
Packit 14c646
 */
Packit 14c646
static SV *pkg_can(pTHX_
Packit 14c646
	HV *cache,
Packit 14c646
	HV *pkg,
Packit 14c646
	const char *method)
Packit 14c646
{
Packit 14c646
    SV **svh;
Packit 14c646
    SV *sv;
Packit 14c646
    const char *hvname = HvNAME_get(pkg);
Packit 14c646
#ifdef DEBUGME
Packit 14c646
    dSTCXT;
Packit 14c646
#endif
Packit 14c646
Packit 14c646
    TRACEME(("pkg_can for %s->%s", hvname, method));
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * Look into the cache to see whether we already have determined
Packit 14c646
     * where the routine was, if any.
Packit 14c646
     *
Packit 14c646
     * NOTA BENE: we don't use 'method' at all in our lookup, since we know
Packit 14c646
     * that only one hook (i.e. always the same) is cached in a given cache.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    svh = hv_fetch(cache, hvname, strlen(hvname), FALSE);
Packit 14c646
    if (svh) {
Packit 14c646
        sv = *svh;
Packit 14c646
        if (!SvOK(sv)) {
Packit 14c646
            TRACEME(("cached %s->%s: not found", hvname, method));
Packit 14c646
            return (SV *) 0;
Packit 14c646
        } else {
Packit 14c646
            TRACEME(("cached %s->%s: 0x%" UVxf,
Packit 14c646
                     hvname, method, PTR2UV(sv)));
Packit 14c646
            return sv;
Packit 14c646
        }
Packit 14c646
    }
Packit 14c646
Packit 14c646
    TRACEME(("not cached yet"));
Packit 14c646
    return pkg_fetchmeth(aTHX_ cache, pkg, method);	/* Fetch and cache */
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * scalar_call
Packit 14c646
 *
Packit 14c646
 * Call routine as obj->hook(av) in scalar context.
Packit 14c646
 * Propagates the single returned value if not called in void context.
Packit 14c646
 */
Packit 14c646
static SV *scalar_call(pTHX_
Packit 14c646
	SV *obj,
Packit 14c646
	SV *hook,
Packit 14c646
	int cloning,
Packit 14c646
	AV *av,
Packit 14c646
	I32 flags)
Packit 14c646
{
Packit 14c646
    dSP;
Packit 14c646
    int count;
Packit 14c646
    SV *sv = 0;
Packit 14c646
#ifdef DEBUGME
Packit 14c646
    dSTCXT;
Packit 14c646
#endif
Packit 14c646
Packit 14c646
    TRACEME(("scalar_call (cloning=%d)", cloning));
Packit 14c646
Packit 14c646
    ENTER;
Packit 14c646
    SAVETMPS;
Packit 14c646
Packit 14c646
    PUSHMARK(sp);
Packit 14c646
    XPUSHs(obj);
Packit 14c646
    XPUSHs(sv_2mortal(newSViv(cloning)));		/* Cloning flag */
Packit 14c646
    if (av) {
Packit 14c646
        SV **ary = AvARRAY(av);
Packit 14c646
        SSize_t cnt = AvFILLp(av) + 1;
Packit 14c646
        SSize_t i;
Packit 14c646
        XPUSHs(ary[0]);					/* Frozen string */
Packit 14c646
        for (i = 1; i < cnt; i++) {
Packit 14c646
            TRACEME(("pushing arg #%d (0x%" UVxf ")...",
Packit 14c646
                     (int)i, PTR2UV(ary[i])));
Packit 14c646
            XPUSHs(sv_2mortal(newRV_inc(ary[i])));
Packit 14c646
        }
Packit 14c646
    }
Packit 14c646
    PUTBACK;
Packit 14c646
Packit 14c646
    TRACEME(("calling..."));
Packit 14c646
    count = call_sv(hook, flags);	/* Go back to Perl code */
Packit 14c646
    TRACEME(("count = %d", count));
Packit 14c646
Packit 14c646
    SPAGAIN;
Packit 14c646
Packit 14c646
    if (count) {
Packit 14c646
        sv = POPs;
Packit 14c646
        SvREFCNT_inc(sv); /* We're returning it, must stay alive! */
Packit 14c646
    }
Packit 14c646
Packit 14c646
    PUTBACK;
Packit 14c646
    FREETMPS;
Packit 14c646
    LEAVE;
Packit 14c646
Packit 14c646
    return sv;
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * array_call
Packit 14c646
 *
Packit 14c646
 * Call routine obj->hook(cloning) in list context.
Packit 14c646
 * Returns the list of returned values in an array.
Packit 14c646
 */
Packit 14c646
static AV *array_call(pTHX_
Packit 14c646
	SV *obj,
Packit 14c646
	SV *hook,
Packit 14c646
	int cloning)
Packit 14c646
{
Packit 14c646
    dSP;
Packit 14c646
    int count;
Packit 14c646
    AV *av;
Packit 14c646
    int i;
Packit 14c646
#ifdef DEBUGME
Packit 14c646
    dSTCXT;
Packit 14c646
#endif
Packit 14c646
Packit 14c646
    TRACEME(("array_call (cloning=%d)", cloning));
Packit 14c646
Packit 14c646
    ENTER;
Packit 14c646
    SAVETMPS;
Packit 14c646
Packit 14c646
    PUSHMARK(sp);
Packit 14c646
    XPUSHs(obj);				/* Target object */
Packit 14c646
    XPUSHs(sv_2mortal(newSViv(cloning)));	/* Cloning flag */
Packit 14c646
    PUTBACK;
Packit 14c646
Packit 14c646
    count = call_sv(hook, G_ARRAY);	/* Go back to Perl code */
Packit 14c646
Packit 14c646
    SPAGAIN;
Packit 14c646
Packit 14c646
    av = newAV();
Packit 14c646
    for (i = count - 1; i >= 0; i--) {
Packit 14c646
        SV *sv = POPs;
Packit 14c646
        av_store(av, i, SvREFCNT_inc(sv));
Packit 14c646
    }
Packit 14c646
Packit 14c646
    PUTBACK;
Packit 14c646
    FREETMPS;
Packit 14c646
    LEAVE;
Packit 14c646
Packit 14c646
    return av;
Packit 14c646
}
Packit 14c646
Packit 14c646
#if PERL_VERSION < 15
Packit 14c646
static void
Packit 14c646
cleanup_recursive_av(pTHX_ AV* av) {
Packit 14c646
    SSize_t i = AvFILLp(av);
Packit 14c646
    SV** arr = AvARRAY(av);
Packit 14c646
    if (SvMAGICAL(av)) return;
Packit 14c646
    while (i >= 0) {
Packit 14c646
        if (arr[i]) {
Packit 14c646
#if PERL_VERSION < 14
Packit 14c646
            arr[i] = NULL;
Packit 14c646
#else
Packit 14c646
            SvREFCNT_dec(arr[i]);
Packit 14c646
#endif
Packit 14c646
        }
Packit 14c646
        i--;
Packit 14c646
    }
Packit 14c646
}
Packit 14c646
Packit 14c646
#ifndef SvREFCNT_IMMORTAL
Packit 14c646
#ifdef DEBUGGING
Packit 14c646
   /* exercise the immortal resurrection code in sv_free2() */
Packit 14c646
#  define SvREFCNT_IMMORTAL 1000
Packit 14c646
#else
Packit 14c646
#  define SvREFCNT_IMMORTAL ((~(U32)0)/2)
Packit 14c646
#endif
Packit 14c646
#endif
Packit 14c646
Packit 14c646
static void
Packit 14c646
cleanup_recursive_hv(pTHX_ HV* hv) {
Packit 14c646
    SSize_t i = HvTOTALKEYS(hv);
Packit 14c646
    HE** arr = HvARRAY(hv);
Packit 14c646
    if (SvMAGICAL(hv)) return;
Packit 14c646
    while (i >= 0) {
Packit 14c646
        if (arr[i]) {
Packit 14c646
            SvREFCNT(HeVAL(arr[i])) = SvREFCNT_IMMORTAL;
Packit 14c646
            arr[i] = NULL; /* let it leak. too dangerous to clean it up here */
Packit 14c646
        }
Packit 14c646
        i--;
Packit 14c646
    }
Packit 14c646
#if PERL_VERSION < 8
Packit 14c646
    ((XPVHV*)SvANY(hv))->xhv_array = NULL;
Packit 14c646
#else
Packit 14c646
    HvARRAY(hv) = NULL;
Packit 14c646
#endif
Packit 14c646
    HvTOTALKEYS(hv) = 0;
Packit 14c646
}
Packit 14c646
static void
Packit 14c646
cleanup_recursive_rv(pTHX_ SV* sv) {
Packit 14c646
    if (sv && SvROK(sv))
Packit 14c646
        SvREFCNT_dec(SvRV(sv));
Packit 14c646
}
Packit 14c646
static void
Packit 14c646
cleanup_recursive_data(pTHX_ SV* sv) {
Packit 14c646
    if (SvTYPE(sv) == SVt_PVAV) {
Packit 14c646
        cleanup_recursive_av(aTHX_ (AV*)sv);
Packit 14c646
    }
Packit 14c646
    else if (SvTYPE(sv) == SVt_PVHV) {
Packit 14c646
        cleanup_recursive_hv(aTHX_ (HV*)sv);
Packit 14c646
    }
Packit 14c646
    else {
Packit 14c646
        cleanup_recursive_rv(aTHX_ sv);
Packit 14c646
    }
Packit 14c646
}
Packit 14c646
#endif
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * known_class
Packit 14c646
 *
Packit 14c646
 * Lookup the class name in the 'hclass' table and either assign it a new ID
Packit 14c646
 * or return the existing one, by filling in 'classnum'.
Packit 14c646
 *
Packit 14c646
 * Return true if the class was known, false if the ID was just generated.
Packit 14c646
 */
Packit 14c646
static int known_class(pTHX_
Packit 14c646
	stcxt_t *cxt,
Packit 14c646
	char *name,		/* Class name */
Packit 14c646
	int len,		/* Name length */
Packit 14c646
	I32 *classnum)
Packit 14c646
{
Packit 14c646
    SV **svh;
Packit 14c646
    HV *hclass = cxt->hclass;
Packit 14c646
Packit 14c646
    TRACEME(("known_class (%s)", name));
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * Recall that we don't store pointers in this hash table, but tags.
Packit 14c646
     * Therefore, we need LOW_32BITS() to extract the relevant parts.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    svh = hv_fetch(hclass, name, len, FALSE);
Packit 14c646
    if (svh) {
Packit 14c646
        *classnum = LOW_32BITS(*svh);
Packit 14c646
        return TRUE;
Packit 14c646
    }
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * Unknown classname, we need to record it.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    cxt->classnum++;
Packit 14c646
    if (!hv_store(hclass, name, len, INT2PTR(SV*, cxt->classnum), 0))
Packit 14c646
        CROAK(("Unable to record new classname"));
Packit 14c646
Packit 14c646
    *classnum = cxt->classnum;
Packit 14c646
    return FALSE;
Packit 14c646
}
Packit 14c646
Packit 14c646
/***
Packit 14c646
 *** Specific store routines.
Packit 14c646
 ***/
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * store_ref
Packit 14c646
 *
Packit 14c646
 * Store a reference.
Packit 14c646
 * Layout is SX_REF <object> or SX_OVERLOAD <object>.
Packit 14c646
 */
Packit 14c646
static int store_ref(pTHX_ stcxt_t *cxt, SV *sv)
Packit 14c646
{
Packit 14c646
    int retval;
Packit 14c646
    int is_weak = 0;
Packit 14c646
    TRACEME(("store_ref (0x%" UVxf ")", PTR2UV(sv)));
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * Follow reference, and check if target is overloaded.
Packit 14c646
     */
Packit 14c646
Packit 14c646
#ifdef SvWEAKREF
Packit 14c646
    if (SvWEAKREF(sv))
Packit 14c646
        is_weak = 1;
Packit 14c646
    TRACEME(("ref (0x%" UVxf ") is%s weak", PTR2UV(sv),
Packit 14c646
             is_weak ? "" : "n't"));
Packit 14c646
#endif
Packit 14c646
    sv = SvRV(sv);
Packit 14c646
Packit 14c646
    if (SvOBJECT(sv)) {
Packit 14c646
        HV *stash = (HV *) SvSTASH(sv);
Packit 14c646
        if (stash && Gv_AMG(stash)) {
Packit 14c646
            TRACEME(("ref (0x%" UVxf ") is overloaded", PTR2UV(sv)));
Packit 14c646
            PUTMARK(is_weak ? SX_WEAKOVERLOAD : SX_OVERLOAD);
Packit 14c646
        } else
Packit 14c646
            PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
Packit 14c646
    } else
Packit 14c646
        PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
Packit 14c646
Packit 14c646
    TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth,
Packit 14c646
             PTR2UV(cxt->recur_sv)));
Packit 14c646
    if (cxt->entry && cxt->recur_sv == sv) {
Packit 14c646
        if (RECURSION_TOO_DEEP()) {
Packit 14c646
#if PERL_VERSION < 15
Packit 14c646
            cleanup_recursive_data(aTHX_ (SV*)sv);
Packit 14c646
#endif
Packit 14c646
            CROAK((MAX_DEPTH_ERROR));
Packit 14c646
        }
Packit 14c646
    }
Packit 14c646
    cxt->recur_sv = sv;
Packit 14c646
Packit 14c646
    retval = store(aTHX_ cxt, sv);
Packit 14c646
    if (cxt->entry && cxt->recur_sv == sv && cxt->recur_depth > 0) {
Packit 14c646
        TRACEME(("recur_depth --%" IVdf, cxt->recur_depth));
Packit 14c646
        --cxt->recur_depth;
Packit 14c646
    }
Packit 14c646
    return retval;
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * store_scalar
Packit 14c646
 *
Packit 14c646
 * Store a scalar.
Packit 14c646
 *
Packit 14c646
 * Layout is SX_LSCALAR <length> <data>, SX_SCALAR <length> <data> or SX_UNDEF.
Packit 14c646
 * SX_LUTF8STR and SX_UTF8STR are used for UTF-8 strings.
Packit 14c646
 * The <data> section is omitted if <length> is 0.
Packit 14c646
 *
Packit 14c646
 * For vstrings, the vstring portion is stored first with
Packit 14c646
 * SX_LVSTRING <length> <data> or SX_VSTRING <length> <data>, followed by
Packit 14c646
 * SX_(L)SCALAR or SX_(L)UTF8STR with the actual PV.
Packit 14c646
 *
Packit 14c646
 * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>.
Packit 14c646
 * Small integers (within [-127, +127]) are stored as SX_BYTE <byte>.
Packit 14c646
 *
Packit 14c646
 * For huge strings use SX_LOBJECT SX_type SX_U64 <type> <data>
Packit 14c646
 */
Packit 14c646
static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
Packit 14c646
{
Packit 14c646
    IV iv;
Packit 14c646
    char *pv;
Packit 14c646
    STRLEN len;
Packit 14c646
    U32 flags = SvFLAGS(sv);	/* "cc -O" may put it in register */
Packit 14c646
Packit 14c646
    TRACEME(("store_scalar (0x%" UVxf ")", PTR2UV(sv)));
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * For efficiency, break the SV encapsulation by peaking at the flags
Packit 14c646
     * directly without using the Perl macros to avoid dereferencing
Packit 14c646
     * sv->sv_flags each time we wish to check the flags.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    if (!(flags & SVf_OK)) {			/* !SvOK(sv) */
Packit 14c646
        if (sv == &PL_sv_undef) {
Packit 14c646
            TRACEME(("immortal undef"));
Packit 14c646
            PUTMARK(SX_SV_UNDEF);
Packit 14c646
        } else {
Packit 14c646
            TRACEME(("undef at 0x%" UVxf, PTR2UV(sv)));
Packit 14c646
            PUTMARK(SX_UNDEF);
Packit 14c646
        }
Packit 14c646
        return 0;
Packit 14c646
    }
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * Always store the string representation of a scalar if it exists.
Packit 14c646
     * Gisle Aas provided me with this test case, better than a long speach:
Packit 14c646
     *
Packit 14c646
     *  perl -MDevel::Peek -le '$a="abc"; $a+0; Dump($a)'
Packit 14c646
     *  SV = PVNV(0x80c8520)
Packit 14c646
     *       REFCNT = 1
Packit 14c646
     *       FLAGS = (NOK,POK,pNOK,pPOK)
Packit 14c646
     *       IV = 0
Packit 14c646
     *       NV = 0
Packit 14c646
     *       PV = 0x80c83d0 "abc"\0
Packit 14c646
     *       CUR = 3
Packit 14c646
     *       LEN = 4
Packit 14c646
     *
Packit 14c646
     * Write SX_SCALAR, length, followed by the actual data.
Packit 14c646
     *
Packit 14c646
     * Otherwise, write an SX_BYTE, SX_INTEGER or an SX_DOUBLE as
Packit 14c646
     * appropriate, followed by the actual (binary) data. A double
Packit 14c646
     * is written as a string if network order, for portability.
Packit 14c646
     *
Packit 14c646
     * NOTE: instead of using SvNOK(sv), we test for SvNOKp(sv).
Packit 14c646
     * The reason is that when the scalar value is tainted, the SvNOK(sv)
Packit 14c646
     * value is false.
Packit 14c646
     *
Packit 14c646
     * The test for a read-only scalar with both POK and NOK set is meant
Packit 14c646
     * to quickly detect &PL_sv_yes and &PL_sv_no without having to pay the
Packit 14c646
     * address comparison for each scalar we store.
Packit 14c646
     */
Packit 14c646
Packit 14c646
#define SV_MAYBE_IMMORTAL (SVf_READONLY|SVf_POK|SVf_NOK)
Packit 14c646
Packit 14c646
    if ((flags & SV_MAYBE_IMMORTAL) == SV_MAYBE_IMMORTAL) {
Packit 14c646
        if (sv == &PL_sv_yes) {
Packit 14c646
            TRACEME(("immortal yes"));
Packit 14c646
            PUTMARK(SX_SV_YES);
Packit 14c646
        } else if (sv == &PL_sv_no) {
Packit 14c646
            TRACEME(("immortal no"));
Packit 14c646
            PUTMARK(SX_SV_NO);
Packit 14c646
        } else {
Packit 14c646
            pv = SvPV(sv, len);		/* We know it's SvPOK */
Packit 14c646
            goto string;			/* Share code below */
Packit 14c646
        }
Packit 14c646
    } else if (flags & SVf_POK) {
Packit 14c646
        /* public string - go direct to string read.  */
Packit 14c646
        goto string_readlen;
Packit 14c646
    } else if (
Packit 14c646
#if (PATCHLEVEL <= 6)
Packit 14c646
               /* For 5.6 and earlier NV flag trumps IV flag, so only use integer
Packit 14c646
                  direct if NV flag is off.  */
Packit 14c646
               (flags & (SVf_NOK | SVf_IOK)) == SVf_IOK
Packit 14c646
#else
Packit 14c646
               /* 5.7 rules are that if IV public flag is set, IV value is as
Packit 14c646
                  good, if not better, than NV value.  */
Packit 14c646
               flags & SVf_IOK
Packit 14c646
#endif
Packit 14c646
               ) {
Packit 14c646
        iv = SvIV(sv);
Packit 14c646
        /*
Packit 14c646
         * Will come here from below with iv set if double is an integer.
Packit 14c646
         */
Packit 14c646
    integer:
Packit 14c646
Packit 14c646
        /* Sorry. This isn't in 5.005_56 (IIRC) or earlier.  */
Packit 14c646
#ifdef SVf_IVisUV
Packit 14c646
        /* Need to do this out here, else 0xFFFFFFFF becomes iv of -1
Packit 14c646
         * (for example) and that ends up in the optimised small integer
Packit 14c646
         * case. 
Packit 14c646
         */
Packit 14c646
        if ((flags & SVf_IVisUV) && SvUV(sv) > IV_MAX) {
Packit 14c646
            TRACEME(("large unsigned integer as string, value = %" UVuf,
Packit 14c646
                     SvUV(sv)));
Packit 14c646
            goto string_readlen;
Packit 14c646
        }
Packit 14c646
#endif
Packit 14c646
        /*
Packit 14c646
         * Optimize small integers into a single byte, otherwise store as
Packit 14c646
         * a real integer (converted into network order if they asked).
Packit 14c646
         */
Packit 14c646
Packit 14c646
        if (iv >= -128 && iv <= 127) {
Packit 14c646
            unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */
Packit 14c646
            PUTMARK(SX_BYTE);
Packit 14c646
            PUTMARK(siv);
Packit 14c646
            TRACEME(("small integer stored as %d", (int)siv));
Packit 14c646
        } else if (cxt->netorder) {
Packit 14c646
#ifndef HAS_HTONL
Packit 14c646
            TRACEME(("no htonl, fall back to string for integer"));
Packit 14c646
            goto string_readlen;
Packit 14c646
#else
Packit 14c646
            I32 niv;
Packit 14c646
Packit 14c646
Packit 14c646
#if IVSIZE > 4
Packit 14c646
            if (
Packit 14c646
#ifdef SVf_IVisUV
Packit 14c646
                /* Sorry. This isn't in 5.005_56 (IIRC) or earlier.  */
Packit 14c646
                ((flags & SVf_IVisUV) && SvUV(sv) > (UV)0x7FFFFFFF) ||
Packit 14c646
#endif
Packit 14c646
                (iv > (IV)0x7FFFFFFF) || (iv < -(IV)0x80000000)) {
Packit 14c646
                /* Bigger than 32 bits.  */
Packit 14c646
                TRACEME(("large network order integer as string, value = %" IVdf, iv));
Packit 14c646
                goto string_readlen;
Packit 14c646
            }
Packit 14c646
#endif
Packit 14c646
Packit 14c646
            niv = (I32) htonl((I32) iv);
Packit 14c646
            TRACEME(("using network order"));
Packit 14c646
            PUTMARK(SX_NETINT);
Packit 14c646
            WRITE_I32(niv);
Packit 14c646
#endif
Packit 14c646
        } else {
Packit 14c646
            PUTMARK(SX_INTEGER);
Packit 14c646
            WRITE(&iv, sizeof(iv));
Packit 14c646
        }
Packit 14c646
Packit 14c646
        TRACEME(("ok (integer 0x%" UVxf ", value = %" IVdf ")", PTR2UV(sv), iv));
Packit 14c646
    } else if (flags & SVf_NOK) {
Packit 14c646
        NV_bytes nv;
Packit 14c646
#ifdef NV_CLEAR
Packit 14c646
        /* if we can't tell if there's padding, clear the whole NV and hope the
Packit 14c646
           compiler leaves the padding alone
Packit 14c646
        */
Packit 14c646
        Zero(&nv, 1, NV_bytes);
Packit 14c646
#endif
Packit 14c646
#if (PATCHLEVEL <= 6)
Packit 14c646
        nv.nv = SvNV(sv);
Packit 14c646
        /*
Packit 14c646
         * Watch for number being an integer in disguise.
Packit 14c646
         */
Packit 14c646
        if (nv.nv == (NV) (iv = I_V(nv.nv))) {
Packit 14c646
            TRACEME(("double %" NVff " is actually integer %" IVdf, nv, iv));
Packit 14c646
            goto integer;		/* Share code above */
Packit 14c646
        }
Packit 14c646
#else
Packit 14c646
Packit 14c646
        SvIV_please(sv);
Packit 14c646
        if (SvIOK_notUV(sv)) {
Packit 14c646
            iv = SvIV(sv);
Packit 14c646
            goto integer;		/* Share code above */
Packit 14c646
        }
Packit 14c646
        nv.nv = SvNV(sv);
Packit 14c646
#endif
Packit 14c646
Packit 14c646
        if (cxt->netorder) {
Packit 14c646
            TRACEME(("double %" NVff " stored as string", nv.nv));
Packit 14c646
            goto string_readlen;		/* Share code below */
Packit 14c646
        }
Packit 14c646
#if NV_PADDING
Packit 14c646
        Zero(nv.bytes + NVSIZE - NV_PADDING, NV_PADDING, char);
Packit 14c646
#endif
Packit 14c646
Packit 14c646
        PUTMARK(SX_DOUBLE);
Packit 14c646
        WRITE(&nv, sizeof(nv));
Packit 14c646
Packit 14c646
        TRACEME(("ok (double 0x%" UVxf ", value = %" NVff ")", PTR2UV(sv), nv.nv));
Packit 14c646
Packit 14c646
    } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) {
Packit 14c646
#ifdef SvVOK
Packit 14c646
        MAGIC *mg;
Packit 14c646
#endif
Packit 14c646
        UV wlen; /* For 64-bit machines */
Packit 14c646
Packit 14c646
    string_readlen:
Packit 14c646
        pv = SvPV(sv, len);
Packit 14c646
Packit 14c646
        /*
Packit 14c646
         * Will come here from above  if it was readonly, POK and NOK but
Packit 14c646
         * neither &PL_sv_yes nor &PL_sv_no.
Packit 14c646
         */
Packit 14c646
    string:
Packit 14c646
Packit 14c646
#ifdef SvVOK
Packit 14c646
        if (SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))) {
Packit 14c646
            /* The macro passes this by address, not value, and a lot of
Packit 14c646
               called code assumes that it's 32 bits without checking.  */
Packit 14c646
            const SSize_t len = mg->mg_len;
Packit 14c646
            STORE_PV_LEN((const char *)mg->mg_ptr,
Packit 14c646
                         len, SX_VSTRING, SX_LVSTRING);
Packit 14c646
        }
Packit 14c646
#endif
Packit 14c646
Packit 14c646
        wlen = (Size_t)len;
Packit 14c646
        if (SvUTF8 (sv))
Packit 14c646
            STORE_UTF8STR(pv, wlen);
Packit 14c646
        else
Packit 14c646
            STORE_SCALAR(pv, wlen);
Packit 14c646
        TRACEME(("ok (scalar 0x%" UVxf " '%s', length = %" UVuf ")",
Packit 14c646
                 PTR2UV(sv), len >= 2048 ? "<string too long>" : SvPVX(sv),
Packit 14c646
                 (UV)len));
Packit 14c646
    } else {
Packit 14c646
        CROAK(("Can't determine type of %s(0x%" UVxf ")",
Packit 14c646
               sv_reftype(sv, FALSE),
Packit 14c646
               PTR2UV(sv)));
Packit 14c646
    }
Packit 14c646
    return 0;		/* Ok, no recursion on scalars */
Packit 14c646
}
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * store_array
Packit 14c646
 *
Packit 14c646
 * Store an array.
Packit 14c646
 *
Packit 14c646
 * Layout is SX_ARRAY <size> followed by each item, in increasing index order.
Packit 14c646
 * Each item is stored as <object>.
Packit 14c646
 */
Packit 14c646
static int store_array(pTHX_ stcxt_t *cxt, AV *av)
Packit 14c646
{
Packit 14c646
    SV **sav;
Packit 14c646
    UV len = av_len(av) + 1;
Packit 14c646
    UV i;
Packit 14c646
    int ret;
Packit 14c646
Packit 14c646
    TRACEME(("store_array (0x%" UVxf ")", PTR2UV(av)));
Packit 14c646
Packit 14c646
#ifdef HAS_U64
Packit 14c646
    if (len > 0x7fffffffu) {
Packit 14c646
        /*
Packit 14c646
         * Large array by emitting SX_LOBJECT 1 U64 data
Packit 14c646
         */
Packit 14c646
        PUTMARK(SX_LOBJECT);
Packit 14c646
        PUTMARK(SX_ARRAY);
Packit 14c646
        W64LEN(len);
Packit 14c646
        TRACEME(("lobject size = %lu", (unsigned long)len));
Packit 14c646
    } else
Packit 14c646
#endif
Packit 14c646
    {
Packit 14c646
        /*
Packit 14c646
         * Normal array by emitting SX_ARRAY, followed by the array length.
Packit 14c646
         */
Packit 14c646
        I32 l = (I32)len;
Packit 14c646
        PUTMARK(SX_ARRAY);
Packit 14c646
        WLEN(l);
Packit 14c646
        TRACEME(("size = %d", (int)l));
Packit 14c646
    }
Packit 14c646
Packit 14c646
    TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth,
Packit 14c646
             PTR2UV(cxt->recur_sv)));
Packit 14c646
    if (cxt->entry && cxt->recur_sv == (SV*)av) {
Packit 14c646
        if (RECURSION_TOO_DEEP()) {
Packit 14c646
            /* with <= 5.14 it recurses in the cleanup also, needing 2x stack size */
Packit 14c646
#if PERL_VERSION < 15
Packit 14c646
            cleanup_recursive_data(aTHX_ (SV*)av);
Packit 14c646
#endif
Packit 14c646
            CROAK((MAX_DEPTH_ERROR));
Packit 14c646
        }
Packit 14c646
    }
Packit 14c646
    cxt->recur_sv = (SV*)av;
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * Now store each item recursively.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    for (i = 0; i < len; i++) {
Packit 14c646
        sav = av_fetch(av, i, 0);
Packit 14c646
        if (!sav) {
Packit 14c646
            TRACEME(("(#%d) nonexistent item", (int)i));
Packit 14c646
            STORE_SV_UNDEF();
Packit 14c646
            continue;
Packit 14c646
        }
Packit 14c646
#if PATCHLEVEL >= 19
Packit 14c646
        /* In 5.19.3 and up, &PL_sv_undef can actually be stored in
Packit 14c646
         * an array; it no longer represents nonexistent elements.
Packit 14c646
         * Historically, we have used SX_SV_UNDEF in arrays for
Packit 14c646
         * nonexistent elements, so we use SX_SVUNDEF_ELEM for
Packit 14c646
         * &PL_sv_undef itself. */
Packit 14c646
        if (*sav == &PL_sv_undef) {
Packit 14c646
            TRACEME(("(#%d) undef item", (int)i));
Packit 14c646
            cxt->tagnum++;
Packit 14c646
            PUTMARK(SX_SVUNDEF_ELEM);
Packit 14c646
            continue;
Packit 14c646
        }
Packit 14c646
#endif
Packit 14c646
        TRACEME(("(#%d) item", (int)i));
Packit 14c646
        if ((ret = store(aTHX_ cxt, *sav)))	/* Extra () for -Wall */
Packit 14c646
            return ret;
Packit 14c646
    }
Packit 14c646
Packit 14c646
    if (cxt->entry && cxt->recur_sv == (SV*)av && cxt->recur_depth > 0) {
Packit 14c646
        TRACEME(("recur_depth --%" IVdf, cxt->recur_depth));
Packit 14c646
        --cxt->recur_depth;
Packit 14c646
    }
Packit 14c646
    TRACEME(("ok (array)"));
Packit 14c646
Packit 14c646
    return 0;
Packit 14c646
}
Packit 14c646
Packit 14c646
Packit 14c646
#if (PATCHLEVEL <= 6)
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * sortcmp
Packit 14c646
 *
Packit 14c646
 * Sort two SVs
Packit 14c646
 * Borrowed from perl source file pp_ctl.c, where it is used by pp_sort.
Packit 14c646
 */
Packit 14c646
static int
Packit 14c646
sortcmp(const void *a, const void *b)
Packit 14c646
{
Packit 14c646
#if defined(USE_ITHREADS)
Packit 14c646
    dTHX;
Packit 14c646
#endif /* USE_ITHREADS */
Packit 14c646
    return sv_cmp(*(SV * const *) a, *(SV * const *) b);
Packit 14c646
}
Packit 14c646
Packit 14c646
#endif /* PATCHLEVEL <= 6 */
Packit 14c646
Packit 14c646
/*
Packit 14c646
 * store_hash
Packit 14c646
 *
Packit 14c646
 * Store a hash table.
Packit 14c646
 *
Packit 14c646
 * For a "normal" hash (not restricted, no utf8 keys):
Packit 14c646
 *
Packit 14c646
 * Layout is SX_HASH <size> followed by each key/value pair, in random order.
Packit 14c646
 * Values are stored as <object>.
Packit 14c646
 * Keys are stored as <length> <data>, the <data> section being omitted
Packit 14c646
 * if length is 0.
Packit 14c646
 *
Packit 14c646
 * For a "fancy" hash (restricted or utf8 keys):
Packit 14c646
 *
Packit 14c646
 * Layout is SX_FLAG_HASH <size> <hash flags> followed by each key/value pair,
Packit 14c646
 * in random order.
Packit 14c646
 * Values are stored as <object>.
Packit 14c646
 * Keys are stored as <flags> <length> <data>, the <data> section being omitted
Packit 14c646
 * if length is 0.
Packit 14c646
 * Currently the only hash flag is "restricted"
Packit 14c646
 * Key flags are as for hv.h
Packit 14c646
 */
Packit 14c646
static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
Packit 14c646
{
Packit 14c646
    dVAR;
Packit 14c646
    UV len = (UV)HvTOTALKEYS(hv);
Packit 14c646
    Size_t i;
Packit 14c646
    int ret = 0;
Packit 14c646
    I32 riter;
Packit 14c646
    HE *eiter;
Packit 14c646
    int flagged_hash = ((SvREADONLY(hv)
Packit 14c646
#ifdef HAS_HASH_KEY_FLAGS
Packit 14c646
                         || HvHASKFLAGS(hv)
Packit 14c646
#endif
Packit 14c646
                         ) ? 1 : 0);
Packit 14c646
    unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0);
Packit 14c646
Packit 14c646
    /* 
Packit 14c646
     * Signal hash by emitting SX_HASH, followed by the table length.
Packit 14c646
     * Max number of keys per perl version:
Packit 14c646
     *    IV            - 5.12
Packit 14c646
     *    STRLEN  5.14  - 5.24   (size_t: U32/U64)
Packit 14c646
     *    SSize_t 5.22c - 5.24c  (I32/I64)
Packit 14c646
     *    U32     5.25c -
Packit 14c646
     */
Packit 14c646
Packit 14c646
    if (len > 0x7fffffffu) { /* keys > I32_MAX */
Packit 14c646
        /* 
Packit 14c646
         * Large hash: SX_LOBJECT type hashflags? U64 data
Packit 14c646
         *
Packit 14c646
         * Stupid limitation:
Packit 14c646
         * Note that perl5 can store more than 2G keys, but only iterate
Packit 14c646
         * over 2G max. (cperl can)
Packit 14c646
         * We need to manually iterate over it then, unsorted.
Packit 14c646
         * But until perl itself cannot do that, skip that.
Packit 14c646
         */
Packit 14c646
        TRACEME(("lobject size = %lu", (unsigned long)len));
Packit 14c646
#ifdef HAS_U64
Packit 14c646
        PUTMARK(SX_LOBJECT);
Packit 14c646
        if (flagged_hash) {
Packit 14c646
            PUTMARK(SX_FLAG_HASH);
Packit 14c646
            PUTMARK(hash_flags);
Packit 14c646
        } else {
Packit 14c646
            PUTMARK(SX_HASH);
Packit 14c646
        }
Packit 14c646
        W64LEN(len);
Packit 14c646
        return store_lhash(aTHX_ cxt, hv, hash_flags);
Packit 14c646
#else
Packit 14c646
        /* <5.12 you could store larger hashes, but cannot iterate over them.
Packit 14c646
           So we reject them, it's a bug. */
Packit 14c646
        CROAK(("Cannot store large objects on a 32bit system"));
Packit 14c646
#endif
Packit 14c646
    } else {
Packit 14c646
        I32 l = (I32)len;
Packit 14c646
        if (flagged_hash) {
Packit 14c646
            TRACEME(("store_hash (0x%" UVxf ") (flags %x)", PTR2UV(hv),
Packit 14c646
                     (unsigned int)hash_flags));
Packit 14c646
            PUTMARK(SX_FLAG_HASH);
Packit 14c646
            PUTMARK(hash_flags);
Packit 14c646
        } else {
Packit 14c646
            TRACEME(("store_hash (0x%" UVxf ")", PTR2UV(hv)));
Packit 14c646
            PUTMARK(SX_HASH);
Packit 14c646
        }
Packit 14c646
        WLEN(l);
Packit 14c646
        TRACEME(("size = %d, used = %d", (int)l, (int)HvUSEDKEYS(hv)));
Packit 14c646
    }
Packit 14c646
Packit 14c646
    TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth,
Packit 14c646
             PTR2UV(cxt->recur_sv)));
Packit 14c646
    if (cxt->entry && cxt->recur_sv == (SV*)hv) {
Packit 14c646
        if (RECURSION_TOO_DEEP_HASH()) {
Packit 14c646
#if PERL_VERSION < 15
Packit 14c646
            cleanup_recursive_data(aTHX_ (SV*)hv);
Packit 14c646
#endif
Packit 14c646
            CROAK((MAX_DEPTH_ERROR));
Packit 14c646
        }
Packit 14c646
    }
Packit 14c646
    cxt->recur_sv = (SV*)hv;
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * Save possible iteration state via each() on that table.
Packit 14c646
     *
Packit 14c646
     * Note that perl as of 5.24 *can* store more than 2G keys, but *not*
Packit 14c646
     * iterate over it.
Packit 14c646
     * Lengths of hash keys are also limited to I32, which is good.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    riter = HvRITER_get(hv);
Packit 14c646
    eiter = HvEITER_get(hv);
Packit 14c646
    hv_iterinit(hv);
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * Now store each item recursively.
Packit 14c646
     *
Packit 14c646
     * If canonical is defined to some true value then store each
Packit 14c646
     * key/value pair in sorted order otherwise the order is random.
Packit 14c646
     * Canonical order is irrelevant when a deep clone operation is performed.
Packit 14c646
     *
Packit 14c646
     * Fetch the value from perl only once per store() operation, and only
Packit 14c646
     * when needed.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    if (
Packit 14c646
        !(cxt->optype & ST_CLONE)
Packit 14c646
        && (cxt->canonical == 1
Packit 14c646
            || (cxt->canonical < 0
Packit 14c646
                && (cxt->canonical =
Packit 14c646
                    (SvTRUE(get_sv("Storable::canonical", GV_ADD))
Packit 14c646
                     ? 1 : 0))))
Packit 14c646
	) {
Packit 14c646
        /*
Packit 14c646
         * Storing in order, sorted by key.
Packit 14c646
         * Run through the hash, building up an array of keys in a
Packit 14c646
         * mortal array, sort the array and then run through the
Packit 14c646
         * array.
Packit 14c646
         */
Packit 14c646
        AV *av = newAV();
Packit 14c646
        av_extend (av, len);
Packit 14c646
Packit 14c646
        TRACEME(("using canonical order"));
Packit 14c646
Packit 14c646
        for (i = 0; i < len; i++) {
Packit 14c646
#ifdef HAS_RESTRICTED_HASHES
Packit 14c646
            HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
Packit 14c646
#else
Packit 14c646
            HE *he = hv_iternext(hv);
Packit 14c646
#endif
Packit 14c646
            av_store(av, i, hv_iterkeysv(he));
Packit 14c646
        }
Packit 14c646
Packit 14c646
        STORE_HASH_SORT;
Packit 14c646
Packit 14c646
        for (i = 0; i < len; i++) {
Packit 14c646
#ifdef HAS_RESTRICTED_HASHES
Packit 14c646
            int placeholders = (int)HvPLACEHOLDERS_get(hv);
Packit 14c646
#endif
Packit 14c646
            unsigned char flags = 0;
Packit 14c646
            char *keyval;
Packit 14c646
            STRLEN keylen_tmp;
Packit 14c646
            I32 keylen;
Packit 14c646
            SV *key = av_shift(av);
Packit 14c646
            /* This will fail if key is a placeholder.
Packit 14c646
               Track how many placeholders we have, and error if we
Packit 14c646
               "see" too many.  */
Packit 14c646
            HE *he  = hv_fetch_ent(hv, key, 0, 0);
Packit 14c646
            SV *val;
Packit 14c646
Packit 14c646
            if (he) {
Packit 14c646
                if (!(val =  HeVAL(he))) {
Packit 14c646
                    /* Internal error, not I/O error */
Packit 14c646
                    return 1;
Packit 14c646
                }
Packit 14c646
            } else {
Packit 14c646
#ifdef HAS_RESTRICTED_HASHES
Packit 14c646
                /* Should be a placeholder.  */
Packit 14c646
                if (placeholders-- < 0) {
Packit 14c646
                    /* This should not happen - number of
Packit 14c646
                       retrieves should be identical to
Packit 14c646
                       number of placeholders.  */
Packit 14c646
                    return 1;
Packit 14c646
                }
Packit 14c646
                /* Value is never needed, and PL_sv_undef is
Packit 14c646
                   more space efficient to store.  */
Packit 14c646
                val = &PL_sv_undef;
Packit 14c646
                ASSERT (flags == 0,
Packit 14c646
                        ("Flags not 0 but %d", (int)flags));
Packit 14c646
                flags = SHV_K_PLACEHOLDER;
Packit 14c646
#else
Packit 14c646
                return 1;
Packit 14c646
#endif
Packit 14c646
            }
Packit 14c646
Packit 14c646
            /*
Packit 14c646
             * Store value first.
Packit 14c646
             */
Packit 14c646
Packit 14c646
            TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val)));
Packit 14c646
Packit 14c646
            if ((ret = store(aTHX_ cxt, val)))	/* Extra () for -Wall, grr... */
Packit 14c646
                goto out;
Packit 14c646
Packit 14c646
            /*
Packit 14c646
             * Write key string.
Packit 14c646
             * Keys are written after values to make sure retrieval
Packit 14c646
             * can be optimal in terms of memory usage, where keys are
Packit 14c646
             * read into a fixed unique buffer called kbuf.
Packit 14c646
             * See retrieve_hash() for details.
Packit 14c646
             */
Packit 14c646
Packit 14c646
            /* Implementation of restricted hashes isn't nicely
Packit 14c646
               abstracted:  */
Packit 14c646
            if ((hash_flags & SHV_RESTRICTED)
Packit 14c646
                && SvTRULYREADONLY(val)) {
Packit 14c646
                flags |= SHV_K_LOCKED;
Packit 14c646
            }
Packit 14c646
Packit 14c646
            keyval = SvPV(key, keylen_tmp);
Packit 14c646
            keylen = keylen_tmp;
Packit 14c646
#ifdef HAS_UTF8_HASHES
Packit 14c646
            /* If you build without optimisation on pre 5.6
Packit 14c646
               then nothing spots that SvUTF8(key) is always 0,
Packit 14c646
               so the block isn't optimised away, at which point
Packit 14c646
               the linker dislikes the reference to
Packit 14c646
               bytes_from_utf8.  */
Packit 14c646
            if (SvUTF8(key)) {
Packit 14c646
                const char *keysave = keyval;
Packit 14c646
                bool is_utf8 = TRUE;
Packit 14c646
Packit 14c646
                /* Just casting the &klen to (STRLEN) won't work
Packit 14c646
                   well if STRLEN and I32 are of different widths.
Packit 14c646
                   --jhi */
Packit 14c646
                keyval = (char*)bytes_from_utf8((U8*)keyval,
Packit 14c646
                                                &keylen_tmp,
Packit 14c646
                                                &is_utf8);
Packit 14c646
Packit 14c646
                /* If we were able to downgrade here, then than
Packit 14c646
                   means that we have  a key which only had chars
Packit 14c646
                   0-255, but was utf8 encoded.  */
Packit 14c646
Packit 14c646
                if (keyval != keysave) {
Packit 14c646
                    keylen = keylen_tmp;
Packit 14c646
                    flags |= SHV_K_WASUTF8;
Packit 14c646
                } else {
Packit 14c646
                    /* keylen_tmp can't have changed, so no need
Packit 14c646
                       to assign back to keylen.  */
Packit 14c646
                    flags |= SHV_K_UTF8;
Packit 14c646
                }
Packit 14c646
            }
Packit 14c646
#endif
Packit 14c646
Packit 14c646
            if (flagged_hash) {
Packit 14c646
                PUTMARK(flags);
Packit 14c646
                TRACEME(("(#%d) key '%s' flags %x %u", (int)i, keyval, flags, *keyval));
Packit 14c646
            } else {
Packit 14c646
                /* This is a workaround for a bug in 5.8.0
Packit 14c646
                   that causes the HEK_WASUTF8 flag to be
Packit 14c646
                   set on an HEK without the hash being
Packit 14c646
                   marked as having key flags. We just
Packit 14c646
                   cross our fingers and drop the flag.
Packit 14c646
                   AMS 20030901 */
Packit 14c646
                assert (flags == 0 || flags == SHV_K_WASUTF8);
Packit 14c646
                TRACEME(("(#%d) key '%s'", (int)i, keyval));
Packit 14c646
            }
Packit 14c646
            WLEN(keylen);
Packit 14c646
            if (keylen)
Packit 14c646
                WRITE(keyval, keylen);
Packit 14c646
            if (flags & SHV_K_WASUTF8)
Packit 14c646
                Safefree (keyval);
Packit 14c646
        }
Packit 14c646
Packit 14c646
        /* 
Packit 14c646
         * Free up the temporary array
Packit 14c646
         */
Packit 14c646
Packit 14c646
        av_undef(av);
Packit 14c646
        sv_free((SV *) av);
Packit 14c646
Packit 14c646
    } else {
Packit 14c646
Packit 14c646
        /*
Packit 14c646
         * Storing in "random" order (in the order the keys are stored
Packit 14c646
         * within the hash).  This is the default and will be faster!
Packit 14c646
         */
Packit 14c646
Packit 14c646
        for (i = 0; i < len; i++) {
Packit 14c646
#ifdef HV_ITERNEXT_WANTPLACEHOLDERS
Packit 14c646
            HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
Packit 14c646
#else
Packit 14c646
            HE *he = hv_iternext(hv);
Packit 14c646
#endif
Packit 14c646
            SV *val = (he ? hv_iterval(hv, he) : 0);
Packit 14c646
Packit 14c646
            if (val == 0)
Packit 14c646
                return 1;		/* Internal error, not I/O error */
Packit 14c646
Packit 14c646
            if ((ret = store_hentry(aTHX_ cxt, hv, i, he, hash_flags)))
Packit 14c646
                goto out;
Packit 14c646
#if 0
Packit 14c646
            /* Implementation of restricted hashes isn't nicely
Packit 14c646
               abstracted:  */
Packit 14c646
            flags = (((hash_flags & SHV_RESTRICTED)
Packit 14c646
                      && SvTRULYREADONLY(val))
Packit 14c646
                     ? SHV_K_LOCKED : 0);
Packit 14c646
Packit 14c646
            if (val == &PL_sv_placeholder) {
Packit 14c646
                flags |= SHV_K_PLACEHOLDER;
Packit 14c646
                val = &PL_sv_undef;
Packit 14c646
            }
Packit 14c646
Packit 14c646
            /*
Packit 14c646
             * Store value first.
Packit 14c646
             */
Packit 14c646
Packit 14c646
            TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val)));
Packit 14c646
Packit 14c646
            if ((ret = store(aTHX_ cxt, val)))	/* Extra () for -Wall */
Packit 14c646
                goto out;
Packit 14c646
Packit 14c646
Packit 14c646
            hek = HeKEY_hek(he);
Packit 14c646
            len = HEK_LEN(hek);
Packit 14c646
            if (len == HEf_SVKEY) {
Packit 14c646
                /* This is somewhat sick, but the internal APIs are
Packit 14c646
                 * such that XS code could put one of these in in
Packit 14c646
                 * a regular hash.
Packit 14c646
                 * Maybe we should be capable of storing one if
Packit 14c646
                 * found.
Packit 14c646
                 */
Packit 14c646
                key_sv = HeKEY_sv(he);
Packit 14c646
                flags |= SHV_K_ISSV;
Packit 14c646
            } else {
Packit 14c646
                /* Regular string key. */
Packit 14c646
#ifdef HAS_HASH_KEY_FLAGS
Packit 14c646
                if (HEK_UTF8(hek))
Packit 14c646
                    flags |= SHV_K_UTF8;
Packit 14c646
                if (HEK_WASUTF8(hek))
Packit 14c646
                    flags |= SHV_K_WASUTF8;
Packit 14c646
#endif
Packit 14c646
                key = HEK_KEY(hek);
Packit 14c646
            }
Packit 14c646
            /*
Packit 14c646
             * Write key string.
Packit 14c646
             * Keys are written after values to make sure retrieval
Packit 14c646
             * can be optimal in terms of memory usage, where keys are
Packit 14c646
             * read into a fixed unique buffer called kbuf.
Packit 14c646
             * See retrieve_hash() for details.
Packit 14c646
             */
Packit 14c646
Packit 14c646
            if (flagged_hash) {
Packit 14c646
                PUTMARK(flags);
Packit 14c646
                TRACEME(("(#%d) key '%s' flags %x", (int)i, key, flags));
Packit 14c646
            } else {
Packit 14c646
                /* This is a workaround for a bug in 5.8.0
Packit 14c646
                   that causes the HEK_WASUTF8 flag to be
Packit 14c646
                   set on an HEK without the hash being
Packit 14c646
                   marked as having key flags. We just
Packit 14c646
                   cross our fingers and drop the flag.
Packit 14c646
                   AMS 20030901 */
Packit 14c646
                assert (flags == 0 || flags == SHV_K_WASUTF8);
Packit 14c646
                TRACEME(("(#%d) key '%s'", (int)i, key));
Packit 14c646
            }
Packit 14c646
            if (flags & SHV_K_ISSV) {
Packit 14c646
                int ret;
Packit 14c646
                if ((ret = store(aTHX_ cxt, key_sv)))
Packit 14c646
                    goto out;
Packit 14c646
            } else {
Packit 14c646
                WLEN(len);
Packit 14c646
                if (len)
Packit 14c646
                    WRITE(key, len);
Packit 14c646
            }
Packit 14c646
#endif
Packit 14c646
        }
Packit 14c646
    }
Packit 14c646
Packit 14c646
    TRACEME(("ok (hash 0x%" UVxf ")", PTR2UV(hv)));
Packit 14c646
Packit 14c646
 out:
Packit 14c646
    if (cxt->entry && cxt->recur_sv == (SV*)hv && cxt->recur_depth > 0) {
Packit 14c646
        TRACEME(("recur_depth --%" IVdf , cxt->recur_depth));
Packit 14c646
        --cxt->recur_depth;
Packit 14c646
    }
Packit 14c646
    HvRITER_set(hv, riter);		/* Restore hash iterator state */
Packit 14c646
    HvEITER_set(hv, eiter);
Packit 14c646
Packit 14c646
    return ret;
Packit 14c646
}
Packit 14c646
Packit 14c646
static int store_hentry(pTHX_
Packit 14c646
	stcxt_t *cxt, HV* hv, UV i, HE *he, unsigned char hash_flags)
Packit 14c646
{
Packit 14c646
    int ret = 0;
Packit 14c646
    SV* val = hv_iterval(hv, he);
Packit 14c646
    int flagged_hash = ((SvREADONLY(hv)
Packit 14c646
#ifdef HAS_HASH_KEY_FLAGS
Packit 14c646
                         || HvHASKFLAGS(hv)
Packit 14c646
#endif
Packit 14c646
                         ) ? 1 : 0);
Packit 14c646
    unsigned char flags = (((hash_flags & SHV_RESTRICTED)
Packit 14c646
                            && SvTRULYREADONLY(val))
Packit 14c646
                           ? SHV_K_LOCKED : 0);
Packit 14c646
#ifndef DEBUGME
Packit 14c646
    PERL_UNUSED_ARG(i);
Packit 14c646
#endif
Packit 14c646
    if (val == &PL_sv_placeholder) {
Packit 14c646
        flags |= SHV_K_PLACEHOLDER;
Packit 14c646
        val = &PL_sv_undef;
Packit 14c646
    }
Packit 14c646
Packit 14c646
    /*
Packit 14c646
     * Store value first.
Packit 14c646
     */
Packit 14c646
Packit 14c646
    TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val)));
Packit 14c646
Packit 14c646
    {
Packit 14c646
        HEK* hek = HeKEY_hek(he);
Packit 14c646
        I32  len = HEK_LEN(hek);
Packit 14c646
        SV *key_sv = NULL;
Packit 14c646
        char *key = 0;
Packit 14c646
Packit 14c646
        if ((ret = store(aTHX_ cxt, val)))
Packit 14c646
            return ret;
Packit 14c646
        if (len == HEf_SVKEY) {
Packit 14c646
            key_sv = HeKEY_sv(he);
Packit 14c646
            flags |= SHV_K_ISSV;
Packit 14c646
        } else {
Packit 14c646
            /* Regular string key. */
Packit 14c646
#ifdef HAS_HASH_KEY_FLAGS
Packit 14c646
            if (HEK_UTF8(hek))
Packit 14c646
                flags |= SHV_K_UTF8;
Packit 14c646
            if (HEK_WASUTF8(hek))
Packit 14c646
                flags |= SHV_K_WASUTF8;
Packit 14c646
#endif
Packit 14c646
            key = HEK_KEY(hek);
Packit 14c646
        }
Packit 14c646
        /*
Packit 14c646
         * Write key string.
Packit 14c646
         * Keys are written after values to make sure retrieval
Packit 14c646
         * can be optimal in terms of memory usage, where keys are
Packit 14c646
         * read into a fixed unique buffer called kbuf.
Packit 14c646
         * See retrieve_hash() for details.
Packit 14c646
         */
Packit 14c646
Packit 14c646
        if (flagged_hash) {
Packit 14c646
            PUTMARK(flags);
Packit 14c646
            TRACEME(("(#%d) key '%s' flags %x", (int)i, key, flags));
Packit 14c646
        } else {
Packit 14c646
            /* This is a workaround for a bug in 5.8.0
Packit 14c646
               that causes the HEK_WASUTF8 flag to be
Packit 14c646
               set on an HEK without the hash being
Packit 14c646
               marked as having key flags. We just
Packit 14c646
               cross our fingers and drop the flag.
Packit 14c646
               AMS 20030901 */
Packit 14c646
            assert (flags == 0 || flags == SHV_K_WASUTF8);
Packit 14c646
            TRACEME(("(#%d) key '%s'", (int)i, key));
Packit 14c646
        }
Packit 14c646
        if (flags & SHV_K_ISSV) {
Packit 14c646
            if ((ret = store(aTHX_ cxt, key_sv)))
Packit 14c646
                return ret;
Packit 14c646
        } else {
Packit 14c646
            WLEN(len);
Packit 14c646
            if (len)
Packit 14c646
                WRITE(key, len);
Packit 14c646
        }
Packit 14c646
    }
Packit 14c646
    return ret;
Packit 14c646
}
Packit 14c646
Packit 14c646
Packit 14c646
#ifdef HAS_U64
Packit 14c646
/*
Packit 14c646
 * store_lhash
Packit 14c646
 *
Packit 14c646
 * Store a overlong hash table, with >2G keys, which we cannot iterate
Packit 14c646
 * over with perl5. xhv_eiter is only I32 there. (only cperl can)
Packit 14c646
 * and we also do not want to sort it.
Packit 14c646
 * So we walk the buckets and chains manually.
Packit 14c646
 *
Packit 14c646
 * type, len and flags are already written.
Packit 14c646
 */
Packit 14c646
Packit 14c646
static int store_lhash(pTHX_ stcxt_t *cxt, HV *hv, unsigned char hash_flags)
Packit 14c646
{
Packit 14c646
    dVAR;
Packit 14c646
    int ret = 0;
Packit 14c646
    Size_t i;
Packit 14c646
    UV ix = 0;
Packit 14c646
    HE** array;
Packit 14c646
#ifdef DEBUGME
Packit 14c646
    UV len = (UV)HvTOTALKEYS(hv);
Packit 14c646
#endif
Packit 14c646
    if (hash_flags) {
Packit 14c646
        TRACEME(("store_lhash (0x%" UVxf ") (flags %x)", PTR2UV(hv),
Packit 14c646
                 (int) hash_flags));
Packit 14c646
    } else {
Packit 14c646
        TRACEME(("store_lhash (0x%" UVxf ")", PTR2UV(hv)));
Packit 14c646
    }
Packit 14c646
    TRACEME(("size = %" UVuf ", used = %" UVuf, len, (UV)HvUSEDKEYS(hv)));
Packit 14c646
Packit 14c646
    TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth,
Packit 14c646
             PTR2UV(cxt->recur_sv)));
Packit 14c646
    if (cxt->entry && cxt->recur_sv == (SV*)hv) {
Packit 14c646
        if (RECURSION_TOO_DEEP_HASH()) {
Packit 14c646
#if PERL_VERSION < 15
Packit 14c646
            cleanup_recursive_data(aTHX_ (SV*)hv);
Packit 14c646
#endif
Packit 14c646
            CROAK((MAX_DEPTH_ERROR));
Packit 14c646
        }
Packit 14c646
    }
Packit 14c646
    cxt->recur_sv = (SV*)hv;
Packit 14c646
Packit 14c646
    array = HvARRAY(hv);
Packit 14c646
    for (i = 0; i <= (Size_t)HvMAX(hv); i++) {
Packit 14c646
        HE* entry = array[i];
Packit 14c646
        if (!entry) continue;
Packit 14c646
        if ((ret = store_hentry(aTHX_ cxt, hv, ix++, entry, hash_flags)))
Packit 14c646
            return ret;
Packit 14c646
        while ((entry = HeNEXT(entry))) {
Packit 14c646
            if ((ret = store_hentry(aTHX_ cxt, hv, ix++, entry, hash_flags)))
Packit 14c646
                return ret;
Packit 14c646
        }
Packit 14c646
    }
Packit 14c646
    if (cxt->entry && cxt->recur_sv == (SV*)hv && cxt->recur_depth > 0) {
Packit 14c646
        TRACEME(("recur_depth --%" IVdf, cxt->recur_depth));
Packit 14c646
        --cxt->recur_depth;
Packit