*
*/
+#define PERL_NO_GET_CONTEXT /* we want efficiency */
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
+#include "ppport.h" /* handle old perls */
+
#ifndef PATCHLEVEL
# include <patchlevel.h> /* Perl's one, needed since 5.6 */
# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
SvRV(ref) = 0; \
SvREFCNT_dec(ref); \
} STMT_END
+/*
+ * sort (used in store_hash) - conditionally use qsort when
+ * sortsv is not available ( <= 5.6.1 ).
+ */
+
+#if (PATCHLEVEL <= 6)
+
+#if defined(USE_ITHREADS)
+
+#define STORE_HASH_SORT \
+ ENTER; { \
+ PerlInterpreter *orig_perl = PERL_GET_CONTEXT; \
+ SAVESPTR(orig_perl); \
+ PERL_SET_CONTEXT(aTHX); \
+ qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); \
+ } LEAVE;
+
+#else /* ! USE_ITHREADS */
-static int store();
-static SV *retrieve(stcxt_t *cxt, char *cname);
+#define STORE_HASH_SORT \
+ qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);
+
+#endif /* USE_ITHREADS */
+
+#else /* PATCHLEVEL > 6 */
+
+#define STORE_HASH_SORT \
+ sortsv(AvARRAY(av), len, Perl_sv_cmp);
+
+#endif /* PATCHLEVEL <= 6 */
+
+static int store(pTHX_ stcxt_t *cxt, SV *sv);
+static SV *retrieve(pTHX_ stcxt_t *cxt, char *cname);
/*
* Dynamic dispatching table for SV store.
*/
-static int store_ref(stcxt_t *cxt, SV *sv);
-static int store_scalar(stcxt_t *cxt, SV *sv);
-static int store_array(stcxt_t *cxt, AV *av);
-static int store_hash(stcxt_t *cxt, HV *hv);
-static int store_tied(stcxt_t *cxt, SV *sv);
-static int store_tied_item(stcxt_t *cxt, SV *sv);
-static int store_code(stcxt_t *cxt, CV *cv);
-static int store_other(stcxt_t *cxt, SV *sv);
-static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg);
-
-static int (*sv_store[])(stcxt_t *cxt, SV *sv) = {
+static int store_ref(pTHX_ stcxt_t *cxt, SV *sv);
+static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv);
+static int store_array(pTHX_ stcxt_t *cxt, AV *av);
+static int store_hash(pTHX_ stcxt_t *cxt, HV *hv);
+static int store_tied(pTHX_ stcxt_t *cxt, SV *sv);
+static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv);
+static int store_code(pTHX_ stcxt_t *cxt, CV *cv);
+static int store_other(pTHX_ stcxt_t *cxt, SV *sv);
+static int store_blessed(pTHX_ stcxt_t *cxt, SV *sv, int type, HV *pkg);
+
+static int (*sv_store[])(pTHX_ stcxt_t *cxt, SV *sv) = {
store_ref, /* svis_REF */
store_scalar, /* svis_SCALAR */
- (int (*)(stcxt_t *cxt, SV *sv)) store_array, /* svis_ARRAY */
- (int (*)(stcxt_t *cxt, SV *sv)) store_hash, /* svis_HASH */
+ (int (*)(pTHX_ stcxt_t *cxt, SV *sv)) store_array, /* svis_ARRAY */
+ (int (*)(pTHX_ stcxt_t *cxt, SV *sv)) store_hash, /* svis_HASH */
store_tied, /* svis_TIED */
store_tied_item, /* svis_TIED_ITEM */
- (int (*)(stcxt_t *cxt, SV *sv)) store_code, /* svis_CODE */
+ (int (*)(pTHX_ stcxt_t *cxt, SV *sv)) store_code, /* svis_CODE */
store_other, /* svis_OTHER */
};
* Dynamic dispatching tables for SV retrieval.
*/
-static SV *retrieve_lscalar(stcxt_t *cxt, char *cname);
-static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname);
-static SV *old_retrieve_array(stcxt_t *cxt, char *cname);
-static SV *old_retrieve_hash(stcxt_t *cxt, char *cname);
-static SV *retrieve_ref(stcxt_t *cxt, char *cname);
-static SV *retrieve_undef(stcxt_t *cxt, char *cname);
-static SV *retrieve_integer(stcxt_t *cxt, char *cname);
-static SV *retrieve_double(stcxt_t *cxt, char *cname);
-static SV *retrieve_byte(stcxt_t *cxt, char *cname);
-static SV *retrieve_netint(stcxt_t *cxt, char *cname);
-static SV *retrieve_scalar(stcxt_t *cxt, char *cname);
-static SV *retrieve_utf8str(stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_array(stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname);
-static SV *retrieve_other(stcxt_t *cxt, char *cname);
-
-static SV *(*sv_old_retrieve[])(stcxt_t *cxt, char *cname) = {
+static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, char *cname);
+static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, char *cname);
+static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_ref(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_undef(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_integer(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_double(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_byte(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_netint(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_other(pTHX_ stcxt_t *cxt, char *cname);
+
+static SV *(*sv_old_retrieve[])(pTHX_ stcxt_t *cxt, char *cname) = {
0, /* SX_OBJECT -- entry unused dynamically */
retrieve_lscalar, /* SX_LSCALAR */
old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */
retrieve_other, /* SX_ERROR */
};
-static SV *retrieve_array(stcxt_t *cxt, char *cname);
-static SV *retrieve_hash(stcxt_t *cxt, char *cname);
-static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname);
-static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname);
-static SV *retrieve_sv_no(stcxt_t *cxt, char *cname);
-static SV *retrieve_blessed(stcxt_t *cxt, char *cname);
-static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname);
-static SV *retrieve_hook(stcxt_t *cxt, char *cname);
-static SV *retrieve_overloaded(stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_key(stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname);
-static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname);
-static SV *retrieve_code(stcxt_t *cxt, char *cname);
-
-static SV *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = {
+static SV *retrieve_array(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_hash(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_hook(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve_code(pTHX_ stcxt_t *cxt, char *cname);
+
+static SV *(*sv_retrieve[])(pTHX_ stcxt_t *cxt, char *cname) = {
0, /* SX_OBJECT -- entry unused dynamically */
retrieve_lscalar, /* SX_LSCALAR */
retrieve_array, /* SX_ARRAY */
#define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)])
-static SV *mbuf2sv(void);
+static SV *mbuf2sv(pTHX);
/***
*** Context management.
*
* Called once per "thread" (interpreter) to initialize some global context.
*/
-static void init_perinterp(void)
+static void init_perinterp(pTHX)
{
INIT_STCXT;
* Initialize a new store context for real recursion.
*/
static void init_store_context(
+ pTHX_
stcxt_t *cxt,
PerlIO *f,
int optype,
*
* Clean store context by
*/
-static void clean_store_context(stcxt_t *cxt)
+static void clean_store_context(pTHX_ stcxt_t *cxt)
{
HE *he;
*
* Initialize a new retrieve context for real recursion.
*/
-static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted)
+static void init_retrieve_context(pTHX_ stcxt_t *cxt, int optype, int is_tainted)
{
TRACEME(("init_retrieve_context"));
*
* Clean retrieve context by
*/
-static void clean_retrieve_context(stcxt_t *cxt)
+static void clean_retrieve_context(pTHX_ stcxt_t *cxt)
{
TRACEME(("clean_retrieve_context"));
*
* A workaround for the CROAK bug: cleanup the last context.
*/
-static void clean_context(stcxt_t *cxt)
+static void clean_context(pTHX_ stcxt_t *cxt)
{
TRACEME(("clean_context"));
ASSERT(!cxt->membuf_ro, ("mbase is not read-only"));
if (cxt->optype & ST_RETRIEVE)
- clean_retrieve_context(cxt);
+ clean_retrieve_context(aTHX_ cxt);
else if (cxt->optype & ST_STORE)
- clean_store_context(cxt);
+ clean_store_context(aTHX_ cxt);
else
reset_context(cxt);
* Allocate a new context and push it on top of the parent one.
* This new context is made globally visible via SET_STCXT().
*/
-static stcxt_t *allocate_context(parent_cxt)
-stcxt_t *parent_cxt;
+static stcxt_t *allocate_context(pTHX_ stcxt_t *parent_cxt)
{
stcxt_t *cxt;
* Free current context, which cannot be the "root" one.
* Make the context underneath globally visible via SET_STCXT().
*/
-static void free_context(cxt)
-stcxt_t *cxt;
+static void free_context(pTHX_ stcxt_t *cxt)
{
stcxt_t *prev = (stcxt_t *)(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0);
*
* Tells whether we're in the middle of a store operation.
*/
-int is_storing(void)
+int is_storing(pTHX)
{
dSTCXT;
*
* Tells whether we're in the middle of a retrieve operation.
*/
-int is_retrieving(void)
+int is_retrieving(pTHX)
{
dSTCXT;
* This is typically out-of-band information that might prove useful
* to people wishing to convert native to network order data when used.
*/
-int last_op_in_netorder(void)
+int last_op_in_netorder(pTHX)
{
dSTCXT;
* nor its ancestors know about the method.
*/
static SV *pkg_fetchmeth(
+ pTHX_
HV *cache,
HV *pkg,
char *method)
* Force cached value to be undef: hook ignored even if present.
*/
static void pkg_hide(
+ pTHX_
HV *cache,
HV *pkg,
char *method)
* Discard cached value: a whole fetch loop will be retried at next lookup.
*/
static void pkg_uncache(
+ pTHX_
HV *cache,
HV *pkg,
char *method)
* know about the method.
*/
static SV *pkg_can(
+ pTHX_
HV *cache,
HV *pkg,
char *method)
}
TRACEME(("not cached yet"));
- return pkg_fetchmeth(cache, pkg, method); /* Fetch and cache */
+ return pkg_fetchmeth(aTHX_ cache, pkg, method); /* Fetch and cache */
}
/*
* Propagates the single returned value if not called in void context.
*/
static SV *scalar_call(
+ pTHX_
SV *obj,
SV *hook,
int cloning,
* Returns the list of returned values in an array.
*/
static AV *array_call(
+ pTHX_
SV *obj,
SV *hook,
int cloning)
* Return true if the class was known, false if the ID was just generated.
*/
static int known_class(
+ pTHX_
stcxt_t *cxt,
char *name, /* Class name */
int len, /* Name length */
* Store a reference.
* Layout is SX_REF <object> or SX_OVERLOAD <object>.
*/
-static int store_ref(stcxt_t *cxt, SV *sv)
+static int store_ref(pTHX_ stcxt_t *cxt, SV *sv)
{
TRACEME(("store_ref (0x%"UVxf")", PTR2UV(sv)));
} else
PUTMARK(SX_REF);
- return store(cxt, sv);
+ return store(aTHX_ cxt, sv);
}
/*
* If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>.
* Small integers (within [-127, +127]) are stored as SX_BYTE <byte>.
*/
-static int store_scalar(stcxt_t *cxt, SV *sv)
+static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
{
IV iv;
char *pv;
* Layout is SX_ARRAY <size> followed by each item, in increading index order.
* Each item is stored as <object>.
*/
-static int store_array(stcxt_t *cxt, AV *av)
+static int store_array(pTHX_ stcxt_t *cxt, AV *av)
{
SV **sav;
I32 len = av_len(av) + 1;
continue;
}
TRACEME(("(#%d) item", i));
- if ((ret = store(cxt, *sav))) /* Extra () for -Wall, grr... */
+ if ((ret = store(aTHX_ cxt, *sav))) /* Extra () for -Wall, grr... */
return ret;
}
return 0;
}
+
+#if (PATCHLEVEL <= 6)
+
/*
* sortcmp
*
static int
sortcmp(const void *a, const void *b)
{
- return sv_cmp(*(SV * const *) a, *(SV * const *) b);
+#if defined(USE_ITHREADS)
+ dTHX;
+#endif /* USE_ITHREADS */
+ return sv_cmp(*(SV * const *) a, *(SV * const *) b);
}
+#endif /* PATCHLEVEL <= 6 */
/*
* store_hash
* Currently the only hash flag is "restriced"
* Key flags are as for hv.h
*/
-static int store_hash(stcxt_t *cxt, HV *hv)
+static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
{
I32 len =
#ifdef HAS_RESTRICTED_HASHES
av_store(av, AvFILLp(av)+1, key); /* av_push(), really */
}
- qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);
+ STORE_HASH_SORT;
for (i = 0; i < len; i++) {
#ifdef HAS_RESTRICTED_HASHES
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
- if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */
+ if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */
goto out;
/*
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
- if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */
+ if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */
goto out;
TRACEME(("(#%d) key '%s'", i, key));
}
if (flags & SHV_K_ISSV) {
- store(cxt, key_sv);
+ store(aTHX_ cxt, key_sv);
} else {
WLEN(len);
if (len)
* Layout is SX_CODE <length> followed by a scalar containing the perl
* source code of the code reference.
*/
-static int store_code(stcxt_t *cxt, CV *cv)
+static int store_code(pTHX_ stcxt_t *cxt, CV *cv)
{
#if PERL_VERSION < 6
/*
* retrieve_code does not work with perl 5.005 or less
*/
- return store_other(cxt, (SV*)cv);
+ return store_other(aTHX_ cxt, (SV*)cv);
#else
dSP;
I32 len;
(cxt->deparse < 0 && !(cxt->deparse =
SvTRUE(perl_get_sv("Storable::Deparse", TRUE)) ? 1 : 0))
) {
- return store_other(cxt, (SV*)cv);
+ return store_other(aTHX_ cxt, (SV*)cv);
}
/*
* dealing with a tied hash, we store SX_TIED_HASH <hash object>, where
* <hash object> stands for the serialization of the tied hash.
*/
-static int store_tied(stcxt_t *cxt, SV *sv)
+static int store_tied(pTHX_ stcxt_t *cxt, SV *sv)
{
MAGIC *mg;
SV *obj = NULL;
/* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */
obj = mg->mg_obj ? mg->mg_obj : newSV(0);
- if ((ret = store(cxt, obj)))
+ if ((ret = store(aTHX_ cxt, obj)))
return ret;
TRACEME(("ok (tied)"));
* SX_TIED_KEY <object> <key>
* SX_TIED_IDX <object> <index>
*/
-static int store_tied_item(stcxt_t *cxt, SV *sv)
+static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv)
{
MAGIC *mg;
int ret;
PUTMARK(SX_TIED_KEY);
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
- if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
+ if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
return ret;
TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr)));
- if ((ret = store(cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */
+ if ((ret = store(aTHX_ cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */
return ret;
} else {
I32 idx = mg->mg_len;
PUTMARK(SX_TIED_IDX);
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
- if ((ret = store(cxt, mg->mg_obj))) /* Idem, for -Wall */
+ if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Idem, for -Wall */
return ret;
TRACEME(("store_tied_item: storing IDX %d", idx));
* any other tied variable.
*/
static int store_hook(
+ pTHX_
stcxt_t *cxt,
SV *sv,
int type,
TRACEME(("about to call STORABLE_freeze on class %s", class));
ref = newRV_noinc(sv); /* Temporary reference */
- av = array_call(ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */
+ av = array_call(aTHX_ ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */
SvRV(ref) = 0;
SvREFCNT_dec(ref); /* Reclaim temporary reference */
CROAK(("Too late to ignore hooks for %s class \"%s\"",
(cxt->optype & ST_CLONE) ? "cloning" : "storing", class));
- pkg_hide(cxt->hook, pkg, "STORABLE_freeze");
+ pkg_hide(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
- ASSERT(!pkg_can(cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible"));
+ ASSERT(!pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible"));
TRACEME(("ignoring STORABLE_freeze in class \"%s\"", class));
- return store_blessed(cxt, sv, type, pkg);
+ return store_blessed(aTHX_ cxt, sv, type, pkg);
}
/*
} else
PUTMARK(flags);
- if ((ret = store(cxt, xsv))) /* Given by hook for us to store */
+ if ((ret = store(aTHX_ cxt, xsv))) /* Given by hook for us to store */
return ret;
svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
* proposed the right fix. -- RAM, 15/09/2000
*/
- if (!known_class(cxt, class, len, &classnum)) {
+ if (!known_class(aTHX_ cxt, class, len, &classnum)) {
TRACEME(("first time we see class %s, ID = %d", class, classnum));
classnum = -1; /* Mark: we must store classname */
} else {
* [<magic object>]
*/
- if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
+ if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
return ret;
}
* on the high-order bit in flag (same encoding as above for <len>).
*/
static int store_blessed(
+ pTHX_
stcxt_t *cxt,
SV *sv,
int type,
* if needed.
*/
- hook = pkg_can(cxt->hook, pkg, "STORABLE_freeze");
+ hook = pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
if (hook)
- return store_hook(cxt, sv, type, pkg, hook);
+ return store_hook(aTHX_ cxt, sv, type, pkg, hook);
/*
* This is a blessed SV without any serialization hook.
* used).
*/
- if (known_class(cxt, class, len, &classnum)) {
+ if (known_class(aTHX_ cxt, class, len, &classnum)) {
TRACEME(("already seen class %s, ID = %d", class, classnum));
PUTMARK(SX_IX_BLESS);
if (classnum <= LG_BLESS) {
* Now emit the <object> part.
*/
- return SV_STORE(type)(cxt, sv);
+ return SV_STORE(type)(aTHX_ cxt, sv);
}
/*
* true value, then don't croak, just warn, and store a placeholder string
* instead.
*/
-static int store_other(stcxt_t *cxt, SV *sv)
+static int store_other(pTHX_ stcxt_t *cxt, SV *sv)
{
I32 len;
static char buf[80];
* Returns the type of the SV, identified by an integer. That integer
* may then be used to index the dynamic routine dispatch table.
*/
-static int sv_type(SV *sv)
+static int sv_type(pTHX_ SV *sv)
{
switch (SvTYPE(sv)) {
case SVt_NULL:
* object (one for which storage has started -- it may not be over if we have
* a self-referenced structure). This data set forms a stored <object>.
*/
-static int store(stcxt_t *cxt, SV *sv)
+static int store(pTHX_ stcxt_t *cxt, SV *sv)
{
SV **svh;
int ret;
* Abort immediately if we get a non-zero status back.
*/
- type = sv_type(sv);
+ type = sv_type(aTHX_ sv);
undef_special_case:
TRACEME(("storing 0x%"UVxf" tag #%d, type %d...",
if (SvOBJECT(sv)) {
HV *pkg = SvSTASH(sv);
- ret = store_blessed(cxt, sv, type, pkg);
+ ret = store_blessed(aTHX_ cxt, sv, type, pkg);
} else
- ret = SV_STORE(type)(cxt, sv);
+ ret = SV_STORE(type)(aTHX_ cxt, sv);
TRACEME(("%s (stored 0x%"UVxf", refcnt=%d, %s)",
ret ? "FAILED" : "ok", PTR2UV(sv),
* Note that no byte ordering info is emitted when <network> is true, since
* integers will be emitted in network order in that case.
*/
-static int magic_write(stcxt_t *cxt)
+static int magic_write(pTHX_ stcxt_t *cxt)
{
/*
* Starting with 0.6, the "use_network_order" byte flag is also used to
* dclone() and store() is performed to memory.
*/
static int do_store(
+ pTHX_
PerlIO *f,
SV *sv,
int optype,
*/
if (cxt->s_dirty)
- clean_context(cxt);
+ clean_context(aTHX_ cxt);
/*
* Now that STORABLE_xxx hooks exist, it is possible that they try to
*/
if (cxt->entry)
- cxt = allocate_context(cxt);
+ cxt = allocate_context(aTHX_ cxt);
cxt->entry++;
/*
* Ensure sv is actually a reference. From perl, we called something
* like:
- * pstore(FILE, \@array);
+ * pstore(aTHX_ FILE, \@array);
* so we must get the scalar value behing that reference.
*/
* Prepare context and emit headers.
*/
- init_store_context(cxt, f, optype, network_order);
+ init_store_context(aTHX_ cxt, f, optype, network_order);
- if (-1 == magic_write(cxt)) /* Emit magic and ILP info */
+ if (-1 == magic_write(aTHX_ cxt)) /* Emit magic and ILP info */
return 0; /* Error */
/*
ASSERT(is_storing(), ("within store operation"));
- status = store(cxt, sv); /* Just do it! */
+ status = store(aTHX_ cxt, sv); /* Just do it! */
/*
* If they asked for a memory store and they provided an SV pointer,
*/
if (!cxt->fio && res)
- *res = mbuf2sv();
+ *res = mbuf2sv(aTHX);
/*
* Final cleanup.
* about to enter do_retrieve...
*/
- clean_store_context(cxt);
+ clean_store_context(aTHX_ cxt);
if (cxt->prev && !(cxt->optype & ST_CLONE))
- free_context(cxt);
+ free_context(aTHX_ cxt);
TRACEME(("do_store returns %d", status));
* Store the transitive data closure of given object to disk.
* Returns 0 on error, a true value otherwise.
*/
-int pstore(PerlIO *f, SV *sv)
+int pstore(pTHX_ PerlIO *f, SV *sv)
{
TRACEME(("pstore"));
- return do_store(f, sv, 0, FALSE, (SV**) 0);
+ return do_store(aTHX_ f, sv, 0, FALSE, (SV**) 0);
}
* Same as pstore(), but network order is used for integers and doubles are
* emitted as strings.
*/
-int net_pstore(PerlIO *f, SV *sv)
+int net_pstore(pTHX_ PerlIO *f, SV *sv)
{
TRACEME(("net_pstore"));
- return do_store(f, sv, 0, TRUE, (SV**) 0);
+ return do_store(aTHX_ f, sv, 0, TRUE, (SV**) 0);
}
/***
*
* Build a new SV out of the content of the internal memory buffer.
*/
-static SV *mbuf2sv(void)
+static SV *mbuf2sv(pTHX)
{
dSTCXT;
* Store the transitive data closure of given object to memory.
* Returns undef on error, a scalar value containing the data otherwise.
*/
-SV *mstore(SV *sv)
+SV *mstore(pTHX_ SV *sv)
{
SV *out;
TRACEME(("mstore"));
- if (!do_store((PerlIO*) 0, sv, 0, FALSE, &out))
+ if (!do_store(aTHX_ (PerlIO*) 0, sv, 0, FALSE, &out))
return &PL_sv_undef;
return out;
* Same as mstore(), but network order is used for integers and doubles are
* emitted as strings.
*/
-SV *net_mstore(SV *sv)
+SV *net_mstore(pTHX_ SV *sv)
{
SV *out;
TRACEME(("net_mstore"));
- if (!do_store((PerlIO*) 0, sv, 0, TRUE, &out))
+ if (!do_store(aTHX_ (PerlIO*) 0, sv, 0, TRUE, &out))
return &PL_sv_undef;
return out;
* Return an error via croak, since it is not possible that we get here
* under normal conditions, when facing a file produced via pstore().
*/
-static SV *retrieve_other(stcxt_t *cxt, char *cname)
+static SV *retrieve_other(pTHX_ stcxt_t *cxt, char *cname)
{
if (
cxt->ver_major != STORABLE_BIN_MAJOR &&
* Layout is SX_IX_BLESS <index> <object> with SX_IX_BLESS already read.
* <index> can be coded on either 1 or 5 bytes.
*/
-static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname)
+static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, char *cname)
{
I32 idx;
char *class;
* Retrieve object and bless it.
*/
- sv = retrieve(cxt, class); /* First SV which is SEEN will be blessed */
+ sv = retrieve(aTHX_ cxt, class); /* First SV which is SEEN will be blessed */
return sv;
}
* Layout is SX_BLESS <len> <classname> <object> with SX_BLESS already read.
* <len> can be coded on either 1 or 5 bytes.
*/
-static SV *retrieve_blessed(stcxt_t *cxt, char *cname)
+static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, char *cname)
{
I32 len;
SV *sv;
* Retrieve object and bless it.
*/
- sv = retrieve(cxt, class); /* First SV which is SEEN will be blessed */
+ sv = retrieve(aTHX_ cxt, class); /* First SV which is SEEN will be blessed */
if (class != buf)
Safefree(class);
* processing (since we won't have seen the magic object by the time the hook
* is called). See comments below for why it was done that way.
*/
-static SV *retrieve_hook(stcxt_t *cxt, char *cname)
+static SV *retrieve_hook(pTHX_ stcxt_t *cxt, char *cname)
{
I32 len;
char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */
mtype = 'P';
break;
default:
- return retrieve_other(cxt, 0); /* Let it croak */
+ return retrieve_other(aTHX_ cxt, 0); /* Let it croak */
}
break;
default:
- return retrieve_other(cxt, 0); /* Let it croak */
+ return retrieve_other(aTHX_ cxt, 0); /* Let it croak */
}
SEEN(sv, 0, 0); /* Don't bless yet */
while (flags & SHF_NEED_RECURSE) {
TRACEME(("retrieve_hook recursing..."));
- rv = retrieve(cxt, 0);
+ rv = retrieve(aTHX_ cxt, 0);
if (!rv)
return (SV *) 0;
SvREFCNT_dec(rv);
*/
BLESS(sv, class);
- hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+ hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw");
if (!hook) {
/*
* Hook not found. Maybe they did not require the module where this
* the lookup again.
*/
- pkg_uncache(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
- hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+ pkg_uncache(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+ hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw");
if (!hook)
CROAK(("No STORABLE_thaw defined for objects of class %s "
class, PTR2UV(sv), (IV) AvFILLp(av) + 1));
rv = newRV(sv);
- (void) scalar_call(rv, hook, clone, av, G_SCALAR|G_DISCARD);
+ (void) scalar_call(aTHX_ rv, hook, clone, av, G_SCALAR|G_DISCARD);
SvREFCNT_dec(rv);
/*
TRACEME(("retrieving magic object for 0x%"UVxf"...", PTR2UV(sv)));
- rv = retrieve(cxt, 0); /* Retrieve <magic object> */
+ rv = retrieve(aTHX_ cxt, 0); /* Retrieve <magic object> */
TRACEME(("restoring the magic object 0x%"UVxf" part of 0x%"UVxf,
PTR2UV(rv), PTR2UV(sv)));
* Retrieve reference to some other scalar.
* Layout is SX_REF <object>, with SX_REF already read.
*/
-static SV *retrieve_ref(stcxt_t *cxt, char *cname)
+static SV *retrieve_ref(pTHX_ stcxt_t *cxt, char *cname)
{
SV *rv;
SV *sv;
rv = NEWSV(10002, 0);
SEEN(rv, cname, 0); /* Will return if rv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* Retrieve reference to some other scalar with overloading.
* Layout is SX_OVERLOAD <object>, with SX_OVERLOAD already read.
*/
-static SV *retrieve_overloaded(stcxt_t *cxt, char *cname)
+static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, char *cname)
{
SV *rv;
SV *sv;
rv = NEWSV(10002, 0);
SEEN(rv, cname, 0); /* Will return if rv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* Retrieve tied array
* Layout is SX_TIED_ARRAY <object>, with SX_TIED_ARRAY already read.
*/
-static SV *retrieve_tied_array(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, char *cname)
{
SV *tv;
SV *sv;
tv = NEWSV(10002, 0);
SEEN(tv, cname, 0); /* Will return if tv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* Retrieve tied hash
* Layout is SX_TIED_HASH <object>, with SX_TIED_HASH already read.
*/
-static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, char *cname)
{
SV *tv;
SV *sv;
tv = NEWSV(10002, 0);
SEEN(tv, cname, 0); /* Will return if tv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* Retrieve tied scalar
* Layout is SX_TIED_SCALAR <object>, with SX_TIED_SCALAR already read.
*/
-static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, char *cname)
{
SV *tv;
SV *sv, *obj = NULL;
tv = NEWSV(10002, 0);
SEEN(tv, cname, 0); /* Will return if rv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv) {
return (SV *) 0; /* Failed */
}
* Retrieve reference to value in a tied hash.
* Layout is SX_TIED_KEY <object> <key>, with SX_TIED_KEY already read.
*/
-static SV *retrieve_tied_key(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, char *cname)
{
SV *tv;
SV *sv;
tv = NEWSV(10002, 0);
SEEN(tv, cname, 0); /* Will return if tv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
- key = retrieve(cxt, 0); /* Retrieve <key> */
+ key = retrieve(aTHX_ cxt, 0); /* Retrieve <key> */
if (!key)
return (SV *) 0; /* Failed */
* Retrieve reference to value in a tied array.
* Layout is SX_TIED_IDX <object> <idx>, with SX_TIED_IDX already read.
*/
-static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, char *cname)
{
SV *tv;
SV *sv;
tv = NEWSV(10002, 0);
SEEN(tv, cname, 0); /* Will return if tv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* The scalar is "long" in that <length> is larger than LG_SCALAR so it
* was not stored on a single byte.
*/
-static SV *retrieve_lscalar(stcxt_t *cxt, char *cname)
+static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, char *cname)
{
I32 len;
SV *sv;
* The scalar is "short" so <length> is single byte. If it is 0, there
* is no <data> section.
*/
-static SV *retrieve_scalar(stcxt_t *cxt, char *cname)
+static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, char *cname)
{
int len;
SV *sv;
* Like retrieve_scalar(), but tag result as utf8.
* If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
*/
-static SV *retrieve_utf8str(stcxt_t *cxt, char *cname)
+static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, char *cname)
{
SV *sv;
TRACEME(("retrieve_utf8str"));
- sv = retrieve_scalar(cxt, cname);
+ sv = retrieve_scalar(aTHX_ cxt, cname);
if (sv) {
#ifdef HAS_UTF8_SCALARS
SvUTF8_on(sv);
* Like retrieve_lscalar(), but tag result as utf8.
* If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
*/
-static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname)
+static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, char *cname)
{
SV *sv;
TRACEME(("retrieve_lutf8str"));
- sv = retrieve_lscalar(cxt, cname);
+ sv = retrieve_lscalar(aTHX_ cxt, cname);
if (sv) {
#ifdef HAS_UTF8_SCALARS
SvUTF8_on(sv);
* Retrieve defined integer.
* Layout is SX_INTEGER <data>, whith SX_INTEGER already read.
*/
-static SV *retrieve_integer(stcxt_t *cxt, char *cname)
+static SV *retrieve_integer(pTHX_ stcxt_t *cxt, char *cname)
{
SV *sv;
IV iv;
* Retrieve defined integer in network order.
* Layout is SX_NETINT <data>, whith SX_NETINT already read.
*/
-static SV *retrieve_netint(stcxt_t *cxt, char *cname)
+static SV *retrieve_netint(pTHX_ stcxt_t *cxt, char *cname)
{
SV *sv;
I32 iv;
* Retrieve defined double.
* Layout is SX_DOUBLE <data>, whith SX_DOUBLE already read.
*/
-static SV *retrieve_double(stcxt_t *cxt, char *cname)
+static SV *retrieve_double(pTHX_ stcxt_t *cxt, char *cname)
{
SV *sv;
NV nv;
* Retrieve defined byte (small integer within the [-128, +127] range).
* Layout is SX_BYTE <data>, whith SX_BYTE already read.
*/
-static SV *retrieve_byte(stcxt_t *cxt, char *cname)
+static SV *retrieve_byte(pTHX_ stcxt_t *cxt, char *cname)
{
SV *sv;
int siv;
*
* Return the undefined value.
*/
-static SV *retrieve_undef(stcxt_t *cxt, char *cname)
+static SV *retrieve_undef(pTHX_ stcxt_t *cxt, char *cname)
{
SV* sv;
*
* Return the immortal undefined value.
*/
-static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname)
+static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, char *cname)
{
SV *sv = &PL_sv_undef;
*
* Return the immortal yes value.
*/
-static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname)
+static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, char *cname)
{
SV *sv = &PL_sv_yes;
*
* Return the immortal no value.
*/
-static SV *retrieve_sv_no(stcxt_t *cxt, char *cname)
+static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, char *cname)
{
SV *sv = &PL_sv_no;
*
* When we come here, SX_ARRAY has been read already.
*/
-static SV *retrieve_array(stcxt_t *cxt, char *cname)
+static SV *retrieve_array(pTHX_ stcxt_t *cxt, char *cname)
{
I32 len;
I32 i;
for (i = 0; i < len; i++) {
TRACEME(("(#%d) item", i));
- sv = retrieve(cxt, 0); /* Retrieve item */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
if (!sv)
return (SV *) 0;
if (av_store(av, i, sv) == 0)
*
* When we come here, SX_HASH has been read already.
*/
-static SV *retrieve_hash(stcxt_t *cxt, char *cname)
+static SV *retrieve_hash(pTHX_ stcxt_t *cxt, char *cname)
{
I32 len;
I32 size;
*/
TRACEME(("(#%d) value", i));
- sv = retrieve(cxt, 0);
+ sv = retrieve(aTHX_ cxt, 0);
if (!sv)
return (SV *) 0;
*
* When we come here, SX_HASH has been read already.
*/
-static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname)
+static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, char *cname)
{
I32 len;
I32 size;
*/
TRACEME(("(#%d) value", i));
- sv = retrieve(cxt, 0);
+ sv = retrieve(aTHX_ cxt, 0);
if (!sv)
return (SV *) 0;
*/
SV *keysv;
TRACEME(("(#%d) keysv, flags=%d", i, flags));
- keysv = retrieve(cxt, 0);
+ keysv = retrieve(aTHX_ cxt, 0);
if (!keysv)
return (SV *) 0;
*
* Return a code reference.
*/
-static SV *retrieve_code(stcxt_t *cxt, char *cname)
+static SV *retrieve_code(pTHX_ stcxt_t *cxt, char *cname)
{
#if PERL_VERSION < 6
CROAK(("retrieve_code does not work with perl 5.005 or less\n"));
GETMARK(type);
switch (type) {
case SX_SCALAR:
- text = retrieve_scalar(cxt, cname);
+ text = retrieve_scalar(aTHX_ cxt, cname);
break;
case SX_LSCALAR:
- text = retrieve_lscalar(cxt, cname);
+ text = retrieve_lscalar(aTHX_ cxt, cname);
break;
default:
CROAK(("Unexpected type %d in retrieve_code\n", type));
*
* When we come here, SX_ARRAY has been read already.
*/
-static SV *old_retrieve_array(stcxt_t *cxt, char *cname)
+static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, char *cname)
{
I32 len;
I32 i;
continue; /* av_extend() already filled us with undef */
}
if (c != SX_ITEM)
- (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */
+ (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */
TRACEME(("(#%d) item", i));
- sv = retrieve(cxt, 0); /* Retrieve item */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
if (!sv)
return (SV *) 0;
if (av_store(av, i, sv) == 0)
*
* When we come here, SX_HASH has been read already.
*/
-static SV *old_retrieve_hash(stcxt_t *cxt, char *cname)
+static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, char *cname)
{
I32 len;
I32 size;
sv = SvREFCNT_inc(sv_h_undef);
} else if (c == SX_VALUE) {
TRACEME(("(#%d) value", i));
- sv = retrieve(cxt, 0);
+ sv = retrieve(aTHX_ cxt, 0);
if (!sv)
return (SV *) 0;
} else
- (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */
+ (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */
/*
* Get key.
GETMARK(c);
if (c != SX_KEY)
- (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */
+ (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */
RLEN(size); /* Get key size */
KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */
if (size)
* Note that there's no byte ordering info emitted when network order was
* used at store time.
*/
-static SV *magic_check(stcxt_t *cxt)
+static SV *magic_check(pTHX_ stcxt_t *cxt)
{
/* The worst case for a malicious header would be old magic (which is
longer), major, minor, byteorder length byte of 255, 255 bytes of
* root SV (which may be an AV or an HV for what we care).
* Returns null if there is a problem.
*/
-static SV *retrieve(stcxt_t *cxt, char *cname)
+static SV *retrieve(pTHX_ stcxt_t *cxt, char *cname)
{
int type;
SV **svh;
* Okay, first time through for this one.
*/
- sv = RETRIEVE(cxt, type)(cxt, cname);
+ sv = RETRIEVE(cxt, type)(aTHX_ cxt, cname);
if (!sv)
return (SV *) 0; /* Failed */
* Common routine for pretrieve and mretrieve.
*/
static SV *do_retrieve(
+ pTHX_
PerlIO *f,
SV *in,
int optype)
*/
if (cxt->s_dirty)
- clean_context(cxt);
+ clean_context(aTHX_ cxt);
/*
* Now that STORABLE_xxx hooks exist, it is possible that they try to
*/
if (cxt->entry)
- cxt = allocate_context(cxt);
+ cxt = allocate_context(aTHX_ cxt);
cxt->entry++;
cxt->fio = f; /* Where I/O are performed */
- if (!magic_check(cxt))
+ if (!magic_check(aTHX_ cxt))
CROAK(("Magic number checking on storable %s failed",
cxt->fio ? "file" : "string"));
is_tainted = f ? 1 : (in ? SvTAINTED(in) : cxt->s_tainted);
TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted"));
- init_retrieve_context(cxt, optype, is_tainted);
+ init_retrieve_context(aTHX_ cxt, optype, is_tainted);
ASSERT(is_retrieving(), ("within retrieve operation"));
- sv = retrieve(cxt, 0); /* Recursively retrieve object, get root SV */
+ sv = retrieve(aTHX_ cxt, 0); /* Recursively retrieve object, get root SV */
/*
* Final cleanup.
* The "root" context is never freed.
*/
- clean_retrieve_context(cxt);
+ clean_retrieve_context(aTHX_ cxt);
if (cxt->prev) /* This context was stacked */
- free_context(cxt); /* It was not the "root" context */
+ free_context(aTHX_ cxt); /* It was not the "root" context */
/*
* Prepare returned value.
if (pre_06_fmt) { /* Was not handling overloading by then */
SV *rv;
TRACEME(("fixing for old formats -- pre 0.6"));
- if (sv_type(sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) {
+ if (sv_type(aTHX_ sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) {
TRACEME(("ended do_retrieve() with an object -- pre 0.6"));
return sv;
}
*
* Retrieve data held in file and return the root object, undef on error.
*/
-SV *pretrieve(PerlIO *f)
+SV *pretrieve(pTHX_ PerlIO *f)
{
TRACEME(("pretrieve"));
- return do_retrieve(f, Nullsv, 0);
+ return do_retrieve(aTHX_ f, Nullsv, 0);
}
/*
*
* Retrieve data held in scalar and return the root object, undef on error.
*/
-SV *mretrieve(SV *sv)
+SV *mretrieve(pTHX_ SV *sv)
{
TRACEME(("mretrieve"));
- return do_retrieve((PerlIO*) 0, sv, 0);
+ return do_retrieve(aTHX_ (PerlIO*) 0, sv, 0);
}
/***
* there. Not that efficient, but it should be faster than doing it from
* pure perl anyway.
*/
-SV *dclone(SV *sv)
+SV *dclone(pTHX_ SV *sv)
{
dSTCXT;
int size;
*/
if (cxt->s_dirty)
- clean_context(cxt);
+ clean_context(aTHX_ cxt);
/*
* do_store() optimizes for dclone by not freeing its context, should
* we need to allocate one because we're deep cloning from a hook.
*/
- if (!do_store((PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0))
+ if (!do_store(aTHX_ (PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0))
return &PL_sv_undef; /* Error during store */
/*
*/
cxt->s_tainted = SvTAINTED(sv);
- out = do_retrieve((PerlIO*) 0, Nullsv, ST_CLONE);
+ out = do_retrieve(aTHX_ (PerlIO*) 0, Nullsv, ST_CLONE);
TRACEME(("dclone returns 0x%"UVxf, PTR2UV(out)));
PROTOTYPES: ENABLE
BOOT:
- init_perinterp();
+ init_perinterp(aTHX);
gv_fetchpv("Storable::drop_utf8", GV_ADDMULTI, SVt_PV);
#ifdef DEBUGME
/* Only disable the used only once warning if we are in debugging mode. */
void
init_perinterp()
+ CODE:
+ init_perinterp(aTHX);
int
pstore(f,obj)
OutputStream f
SV * obj
+ CODE:
+ RETVAL = pstore(aTHX_ f, obj);
+ OUTPUT:
+ RETVAL
int
net_pstore(f,obj)
OutputStream f
SV * obj
+ CODE:
+ RETVAL = net_pstore(aTHX_ f, obj);
+ OUTPUT:
+ RETVAL
SV *
mstore(obj)
SV * obj
+ CODE:
+ RETVAL = mstore(aTHX_ obj);
+ OUTPUT:
+ RETVAL
SV *
net_mstore(obj)
SV * obj
+ CODE:
+ RETVAL = net_mstore(aTHX_ obj);
+ OUTPUT:
+ RETVAL
SV *
pretrieve(f)
InputStream f
+ CODE:
+ RETVAL = pretrieve(aTHX_ f);
+ OUTPUT:
+ RETVAL
SV *
mretrieve(sv)
SV * sv
+ CODE:
+ RETVAL = mretrieve(aTHX_ sv);
+ OUTPUT:
+ RETVAL
SV *
dclone(sv)
SV * sv
+ CODE:
+ RETVAL = dclone(aTHX_ sv);
+ OUTPUT:
+ RETVAL
int
last_op_in_netorder()
+ CODE:
+ RETVAL = last_op_in_netorder(aTHX);
+ OUTPUT:
+ RETVAL
int
is_storing()
+ CODE:
+ RETVAL = is_storing(aTHX);
+ OUTPUT:
+ RETVAL
int
is_retrieving()
+ CODE:
+ RETVAL = is_retrieving(aTHX);
+ OUTPUT:
+ RETVAL
--- /dev/null
+
+/* ppport.h -- Perl/Pollution/Portability Version 2.011_01
+ *
+ * Automatically Created by Devel::PPPort on Thu Mar 18 11:06:48 2004
+ *
+ * Do NOT edit this file directly! -- Edit PPPort.pm instead.
+ *
+ * Version 2.x, Copyright (C) 2001, Paul Marquess.
+ * Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
+ * This code may be used and distributed under the same license as any
+ * version of Perl.
+ *
+ * This version of ppport.h is designed to support operation with Perl
+ * installations back to 5.004, and has been tested up to 5.8.1.
+ *
+ * If this version of ppport.h is failing during the compilation of this
+ * module, please check if a newer version of Devel::PPPort is available
+ * on CPAN before sending a bug report.
+ *
+ * If you are using the latest version of Devel::PPPort and it is failing
+ * during compilation of this module, please send a report to perlbug@perl.com
+ *
+ * Include all following information:
+ *
+ * 1. The complete output from running "perl -V"
+ *
+ * 2. This file.
+ *
+ * 3. The name & version of the module you were trying to build.
+ *
+ * 4. A full log of the build that failed.
+ *
+ * 5. Any other information that you think could be relevant.
+ *
+ *
+ * For the latest version of this code, please retreive the Devel::PPPort
+ * module from CPAN.
+ *
+ */
+
+/*
+ * In order for a Perl extension module to be as portable as possible
+ * across differing versions of Perl itself, certain steps need to be taken.
+ * Including this header is the first major one, then using dTHR is all the
+ * appropriate places and using a PL_ prefix to refer to global Perl
+ * variables is the second.
+ *
+ */
+
+
+/* If you use one of a few functions that were not present in earlier
+ * versions of Perl, please add a define before the inclusion of ppport.h
+ * for a static include, or use the GLOBAL request in a single module to
+ * produce a global definition that can be referenced from the other
+ * modules.
+ *
+ * Function: Static define: Extern define:
+ * newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
+ *
+ */
+
+
+/* To verify whether ppport.h is needed for your module, and whether any
+ * special defines should be used, ppport.h can be run through Perl to check
+ * your source code. Simply say:
+ *
+ * perl -x ppport.h *.c *.h *.xs foo/bar*.c [etc]
+ *
+ * The result will be a list of patches suggesting changes that should at
+ * least be acceptable, if not necessarily the most efficient solution, or a
+ * fix for all possible problems. It won't catch where dTHR is needed, and
+ * doesn't attempt to account for global macro or function definitions,
+ * nested includes, typemaps, etc.
+ *
+ * In order to test for the need of dTHR, please try your module under a
+ * recent version of Perl that has threading compiled-in.
+ *
+ */
+
+
+/*
+#!/usr/bin/perl
+@ARGV = ("*.xs") if !@ARGV;
+%badmacros = %funcs = %macros = (); $replace = 0;
+foreach (<DATA>) {
+ $funcs{$1} = 1 if /Provide:\s+(\S+)/;
+ $macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/;
+ $replace = $1 if /Replace:\s+(\d+)/;
+ $badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/;
+ $badmacros{$1}=$2 if /Replace (\S+) with (\S+)/;
+}
+foreach $filename (map(glob($_),@ARGV)) {
+ unless (open(IN, "<$filename")) {
+ warn "Unable to read from $file: $!\n";
+ next;
+ }
+ print "Scanning $filename...\n";
+ $c = ""; while (<IN>) { $c .= $_; } close(IN);
+ $need_include = 0; %add_func = (); $changes = 0;
+ $has_include = ($c =~ /#.*include.*ppport/m);
+
+ foreach $func (keys %funcs) {
+ if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) {
+ if ($c !~ /\b$func\b/m) {
+ print "If $func isn't needed, you don't need to request it.\n" if
+ $changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m);
+ } else {
+ print "Uses $func\n";
+ $need_include = 1;
+ }
+ } else {
+ if ($c =~ /\b$func\b/m) {
+ $add_func{$func} =1 ;
+ print "Uses $func\n";
+ $need_include = 1;
+ }
+ }
+ }
+
+ if (not $need_include) {
+ foreach $macro (keys %macros) {
+ if ($c =~ /\b$macro\b/m) {
+ print "Uses $macro\n";
+ $need_include = 1;
+ }
+ }
+ }
+
+ foreach $badmacro (keys %badmacros) {
+ if ($c =~ /\b$badmacro\b/m) {
+ $changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm);
+ print "Uses $badmacros{$badmacro} (instead of $badmacro)\n";
+ $need_include = 1;
+ }
+ }
+
+ if (scalar(keys %add_func) or $need_include != $has_include) {
+ if (!$has_include) {
+ $inc = join('',map("#define NEED_$_\n", sort keys %add_func)).
+ "#include \"ppport.h\"\n";
+ $c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m;
+ } elsif (keys %add_func) {
+ $inc = join('',map("#define NEED_$_\n", sort keys %add_func));
+ $c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m;
+ }
+ if (!$need_include) {
+ print "Doesn't seem to need ppport.h.\n";
+ $c =~ s/^.*#.*include.*ppport.*\n//m;
+ }
+ $changes++;
+ }
+
+ if ($changes) {
+ open(OUT,"ppport.h.$$");
+ print OUT $c;
+ close(OUT);
+ open(DIFF, "diff -u $filename ppport.h.$$|");
+ while (<DIFF>) { s!ppport\.h\.$$!$filename.patched!; print STDOUT; }
+ close(DIFF);
+ unlink("ppport.h.$$");
+ } else {
+ print "Looks OK\n";
+ }
+}
+__DATA__
+*/
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+#ifndef PERL_REVISION
+# ifndef __PATCHLEVEL_H_INCLUDED__
+# define PERL_PATCHLEVEL_H_IMPLICIT
+# include <patchlevel.h>
+# endif
+# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
+# include <could_not_find_Perl_patchlevel.h>
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
+
+/* It is very unlikely that anyone will try to use this with Perl 6
+ (or greater), but who knows.
+ */
+#if PERL_REVISION != 5
+# error ppport.h only works with Perl version 5
+#endif /* PERL_REVISION != 5 */
+
+#ifndef ERRSV
+# define ERRSV perl_get_sv("@",FALSE)
+#endif
+
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
+/* Replace: 1 */
+# define PL_Sv Sv
+# define PL_compiling compiling
+# define PL_copline copline
+# define PL_curcop curcop
+# define PL_curstash curstash
+# define PL_defgv defgv
+# define PL_dirty dirty
+# define PL_dowarn dowarn
+# define PL_hints hints
+# define PL_na na
+# define PL_perldb perldb
+# define PL_rsfp_filters rsfp_filters
+# define PL_rsfpv rsfp
+# define PL_stdingv stdingv
+# define PL_sv_no sv_no
+# define PL_sv_undef sv_undef
+# define PL_sv_yes sv_yes
+/* Replace: 0 */
+#endif
+
+#ifdef HASATTRIBUTE
+# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
+# define PERL_UNUSED_DECL
+# else
+# define PERL_UNUSED_DECL __attribute__((unused))
+# endif
+#else
+# define PERL_UNUSED_DECL
+#endif
+
+#ifndef dNOOP
+# define NOOP (void)0
+# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
+
+#ifndef dTHR
+# define dTHR dNOOP
+#endif
+
+#ifndef dTHX
+# define dTHX dNOOP
+# define dTHXa(x) dNOOP
+# define dTHXoa(x) dNOOP
+#endif
+
+#ifndef pTHX
+# define pTHX void
+# define pTHX_
+# define aTHX
+# define aTHX_
+#endif
+
+#ifndef dAX
+# define dAX I32 ax = MARK - PL_stack_base + 1
+#endif
+#ifndef dITEMS
+# define dITEMS I32 items = SP - MARK
+#endif
+
+/* IV could also be a quad (say, a long long), but Perls
+ * capable of those should have IVSIZE already. */
+#if !defined(IVSIZE) && defined(LONGSIZE)
+# define IVSIZE LONGSIZE
+#endif
+#ifndef IVSIZE
+# define IVSIZE 4 /* A bold guess, but the best we can make. */
+#endif
+
+#ifndef UVSIZE
+# define UVSIZE IVSIZE
+#endif
+
+#ifndef NVTYPE
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
+# define NVTYPE long double
+# else
+# define NVTYPE double
+# endif
+typedef NVTYPE NV;
+#endif
+
+#ifndef INT2PTR
+
+#if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
+# define PTRV UV
+# define INT2PTR(any,d) (any)(d)
+#else
+# if PTRSIZE == LONGSIZE
+# define PTRV unsigned long
+# else
+# define PTRV unsigned
+# endif
+# define INT2PTR(any,d) (any)(PTRV)(d)
+#endif
+#define NUM2PTR(any,d) (any)(PTRV)(d)
+#define PTR2IV(p) INT2PTR(IV,p)
+#define PTR2UV(p) INT2PTR(UV,p)
+#define PTR2NV(p) NUM2PTR(NV,p)
+#if PTRSIZE == LONGSIZE
+# define PTR2ul(p) (unsigned long)(p)
+#else
+# define PTR2ul(p) INT2PTR(unsigned long,p)
+#endif
+
+#endif /* !INT2PTR */
+
+#ifndef boolSV
+# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+#endif
+
+#ifndef gv_stashpvn
+# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+#endif
+
+#ifndef newSVpvn
+# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
+#endif
+
+#ifndef newRV_inc
+/* Replace: 1 */
+# define newRV_inc(sv) newRV(sv)
+/* Replace: 0 */
+#endif
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(PL_defgv)
+#endif
+
+#ifndef SAVE_DEFSV
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif
+
+#ifndef newRV_noinc
+# ifdef __GNUC__
+# define newRV_noinc(sv) \
+ ({ \
+ SV *nsv = (SV*)newRV(sv); \
+ SvREFCNT_dec(sv); \
+ nsv; \
+ })
+# else
+# if defined(USE_THREADS)
+static SV * newRV_noinc (SV * sv)
+{
+ SV *nsv = (SV*)newRV(sv);
+ SvREFCNT_dec(sv);
+ return nsv;
+}
+# else
+# define newRV_noinc(sv) \
+ (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
+# endif
+# endif
+#endif
+
+/* Provide: newCONSTSUB */
+
+/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
+
+#if defined(NEED_newCONSTSUB)
+static
+#else
+extern void newCONSTSUB(HV * stash, char * name, SV *sv);
+#endif
+
+#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
+void
+newCONSTSUB(stash,name,sv)
+HV *stash;
+char *name;
+SV *sv;
+{
+ U32 oldhints = PL_hints;
+ HV *old_cop_stash = PL_curcop->cop_stash;
+ HV *old_curstash = PL_curstash;
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ if (stash)
+ PL_curstash = PL_curcop->cop_stash = stash;
+
+ newSUB(
+
+#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
+ /* before 5.003_22 */
+ start_subparse(),
+#else
+# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
+ /* 5.003_22 */
+ start_subparse(0),
+# else
+ /* 5.003_23 onwards */
+ start_subparse(FALSE, 0),
+# endif
+#endif
+
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ PL_hints = oldhints;
+ PL_curcop->cop_stash = old_cop_stash;
+ PL_curstash = old_curstash;
+ PL_curcop->cop_line = oldline;
+}
+#endif
+
+#endif /* newCONSTSUB */
+
+#ifndef START_MY_CXT
+
+/*
+ * Boilerplate macros for initializing and accessing interpreter-local
+ * data from C. All statics in extensions should be reworked to use
+ * this, if you want to make the extension thread-safe. See ext/re/re.xs
+ * for an example of the use of these macros.
+ *
+ * Code that uses these macros is responsible for the following:
+ * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
+ * 2. Declare a typedef named my_cxt_t that is a structure that contains
+ * all the data that needs to be interpreter-local.
+ * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
+ * 4. Use the MY_CXT_INIT macro such that it is called exactly once
+ * (typically put in the BOOT: section).
+ * 5. Use the members of the my_cxt_t structure everywhere as
+ * MY_CXT.member.
+ * 6. Use the dMY_CXT macro (a declaration) in all the functions that
+ * access MY_CXT.
+ */
+
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
+ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT
+
+#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
+/* Fetches the SV that keeps the per-interpreter data. */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
+#else /* >= perl5.004_68 */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
+ sizeof(MY_CXT_KEY)-1, TRUE)
+#endif /* < perl5.004_68 */
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ dMY_CXT_SV; \
+ /* newSV() allocates one more than needed */ \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Zero(my_cxtp, 1, my_cxt_t); \
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+
+/* This macro must be used to access members of the my_cxt_t structure.
+ * e.g. MYCXT.some_data */
+#define MY_CXT (*my_cxtp)
+
+/* Judicious use of these macros can reduce the number of times dMY_CXT
+ * is used. Use is similar to pTHX, aTHX etc. */
+#define pMY_CXT my_cxt_t *my_cxtp
+#define pMY_CXT_ pMY_CXT,
+#define _pMY_CXT ,pMY_CXT
+#define aMY_CXT my_cxtp
+#define aMY_CXT_ aMY_CXT,
+#define _aMY_CXT ,aMY_CXT
+
+#else /* single interpreter */
+
+#define START_MY_CXT static my_cxt_t my_cxt;
+#define dMY_CXT_SV dNOOP
+#define dMY_CXT dNOOP
+#define MY_CXT_INIT NOOP
+#define MY_CXT my_cxt
+
+#define pMY_CXT void
+#define pMY_CXT_
+#define _pMY_CXT
+#define aMY_CXT
+#define aMY_CXT_
+#define _aMY_CXT
+
+#endif
+
+#endif /* START_MY_CXT */
+
+#ifndef IVdf
+# if IVSIZE == LONGSIZE
+# define IVdf "ld"
+# define UVuf "lu"
+# define UVof "lo"
+# define UVxf "lx"
+# define UVXf "lX"
+# else
+# if IVSIZE == INTSIZE
+# define IVdf "d"
+# define UVuf "u"
+# define UVof "o"
+# define UVxf "x"
+# define UVXf "X"
+# endif
+# endif
+#endif
+
+#ifndef NVef
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
+ defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
+# define NVef PERL_PRIeldbl
+# define NVff PERL_PRIfldbl
+# define NVgf PERL_PRIgldbl
+# else
+# define NVef "e"
+# define NVff "f"
+# define NVgf "g"
+# endif
+#endif
+
+#ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */
+# define AvFILLp AvFILL
+#endif
+
+#ifdef SvPVbyte
+# if PERL_REVISION == 5 && PERL_VERSION < 7
+ /* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */
+# undef SvPVbyte
+# define SvPVbyte(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : my_sv_2pvbyte(aTHX_ sv, &lp))
+ static char *
+ my_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
+ {
+ sv_utf8_downgrade(sv,0);
+ return SvPV(sv,*lp);
+ }
+# endif
+#else
+# define SvPVbyte SvPV
+#endif
+
+#ifndef SvPV_nolen
+# define SvPV_nolen(sv) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? SvPVX(sv) : sv_2pv_nolen(sv))
+ static char *
+ sv_2pv_nolen(pTHX_ register SV *sv)
+ {
+ STRLEN n_a;
+ return sv_2pv(sv, &n_a);
+ }
+#endif
+
+#ifndef get_cv
+# define get_cv(name,create) perl_get_cv(name,create)
+#endif
+
+#ifndef get_sv
+# define get_sv(name,create) perl_get_sv(name,create)
+#endif
+
+#ifndef get_av
+# define get_av(name,create) perl_get_av(name,create)
+#endif
+
+#ifndef get_hv
+# define get_hv(name,create) perl_get_hv(name,create)
+#endif
+
+#ifndef call_argv
+# define call_argv perl_call_argv
+#endif
+
+#ifndef call_method
+# define call_method perl_call_method
+#endif
+
+#ifndef call_pv
+# define call_pv perl_call_pv
+#endif
+
+#ifndef call_sv
+# define call_sv perl_call_sv
+#endif
+
+#ifndef eval_pv
+# define eval_pv perl_eval_pv
+#endif
+
+#ifndef eval_sv
+# define eval_sv perl_eval_sv
+#endif
+
+#ifndef PERL_SCAN_GREATER_THAN_UV_MAX
+# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
+#endif
+
+#ifndef PERL_SCAN_SILENT_ILLDIGIT
+# define PERL_SCAN_SILENT_ILLDIGIT 0x04
+#endif
+
+#ifndef PERL_SCAN_ALLOW_UNDERSCORES
+# define PERL_SCAN_ALLOW_UNDERSCORES 0x01
+#endif
+
+#ifndef PERL_SCAN_DISALLOW_PREFIX
+# define PERL_SCAN_DISALLOW_PREFIX 0x02
+#endif
+
+#if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
+#define I32_CAST
+#else
+#define I32_CAST (I32*)
+#endif
+
+#ifndef grok_hex
+static UV _grok_hex (pTHX_ char *string, STRLEN *len, I32 *flags, NV *result) {
+ NV r = scan_hex(string, *len, I32_CAST len);
+ if (r > UV_MAX) {
+ *flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result) *result = r;
+ return UV_MAX;
+ }
+ return (UV)r;
+}
+
+# define grok_hex(string, len, flags, result) \
+ _grok_hex(pTHX_ (string), (len), (flags), (result))
+#endif
+
+#ifndef grok_oct
+static UV _grok_oct (pTHX_ char *string, STRLEN *len, I32 *flags, NV *result) {
+ NV r = scan_oct(string, *len, I32_CAST len);
+ if (r > UV_MAX) {
+ *flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result) *result = r;
+ return UV_MAX;
+ }
+ return (UV)r;
+}
+
+# define grok_oct(string, len, flags, result) \
+ _grok_oct(pTHX_ (string), (len), (flags), (result))
+#endif
+
+#if !defined(grok_bin) && defined(scan_bin)
+static UV _grok_bin (pTHX_ char *string, STRLEN *len, I32 *flags, NV *result) {
+ NV r = scan_bin(string, *len, I32_CAST len);
+ if (r > UV_MAX) {
+ *flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result) *result = r;
+ return UV_MAX;
+ }
+ return (UV)r;
+}
+
+# define grok_bin(string, len, flags, result) \
+ _grok_bin(pTHX_ (string), (len), (flags), (result))
+#endif
+
+#ifndef IN_LOCALE
+# define IN_LOCALE \
+ (PL_curcop == &PL_compiling ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
+#endif
+
+#ifndef IN_LOCALE_RUNTIME
+# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
+#endif
+
+#ifndef IN_LOCALE_COMPILETIME
+# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
+#endif
+
+
+#ifndef IS_NUMBER_IN_UV
+# define IS_NUMBER_IN_UV 0x01
+# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
+# define IS_NUMBER_NOT_INT 0x04
+# define IS_NUMBER_NEG 0x08
+# define IS_NUMBER_INFINITY 0x10
+# define IS_NUMBER_NAN 0x20
+#endif
+
+#ifndef grok_numeric_radix
+# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(aTHX_ sp, send)
+
+#define grok_numeric_radix Perl_grok_numeric_radix
+
+static
+bool
+Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
+{
+#ifdef USE_LOCALE_NUMERIC
+#if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
+ if (PL_numeric_radix_sv && IN_LOCALE) {
+ STRLEN len;
+ char* radix = SvPV(PL_numeric_radix_sv, len);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+#else
+ /* pre5.6.0 perls don't have PL_numeric_radix_sv so the radix
+ * must manually be requested from locale.h */
+#include <locale.h>
+ struct lconv *lc = localeconv();
+ char *radix = lc->decimal_point;
+ if (radix && IN_LOCALE) {
+ STRLEN len = strlen(radix);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+#endif /* PERL_VERSION */
+#endif /* USE_LOCALE_NUMERIC */
+ /* always try "." if numeric radix didn't match because
+ * we may have data from different locales mixed */
+ if (*sp < send && **sp == '.') {
+ ++*sp;
+ return TRUE;
+ }
+ return FALSE;
+}
+#endif /* grok_numeric_radix */
+
+#ifndef grok_number
+
+#define grok_number Perl_grok_number
+
+static
+int
+Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
+{
+ const char *s = pv;
+ const char *send = pv + len;
+ const UV max_div_10 = UV_MAX / 10;
+ const char max_mod_10 = UV_MAX % 10;
+ int numtype = 0;
+ int sawinf = 0;
+ int sawnan = 0;
+
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s == send) {
+ return 0;
+ } else if (*s == '-') {
+ s++;
+ numtype = IS_NUMBER_NEG;
+ }
+ else if (*s == '+')
+ s++;
+
+ if (s == send)
+ return 0;
+
+ /* next must be digit or the radix separator or beginning of infinity */
+ if (isDIGIT(*s)) {
+ /* UVs are at least 32 bits, so the first 9 decimal digits cannot
+ overflow. */
+ UV value = *s - '0';
+ /* This construction seems to be more optimiser friendly.
+ (without it gcc does the isDIGIT test and the *s - '0' separately)
+ With it gcc on arm is managing 6 instructions (6 cycles) per digit.
+ In theory the optimiser could deduce how far to unroll the loop
+ before checking for overflow. */
+ if (++s < send) {
+ int digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ /* Now got 9 digits, so need to check
+ each time for overflow. */
+ digit = *s - '0';
+ while (digit >= 0 && digit <= 9
+ && (value < max_div_10
+ || (value == max_div_10
+ && digit <= max_mod_10))) {
+ value = value * 10 + digit;
+ if (++s < send)
+ digit = *s - '0';
+ else
+ break;
+ }
+ if (digit >= 0 && digit <= 9
+ && (s < send)) {
+ /* value overflowed.
+ skip the remaining digits, don't
+ worry about setting *valuep. */
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ numtype |=
+ IS_NUMBER_GREATER_THAN_UV_MAX;
+ goto skip_value;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ numtype |= IS_NUMBER_IN_UV;
+ if (valuep)
+ *valuep = value;
+
+ skip_value:
+ if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT;
+ while (s < send && isDIGIT(*s)) /* optional digits after the radix */
+ s++;
+ }
+ }
+ else if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
+ /* no digits before the radix means we need digits after it */
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ if (valuep) {
+ /* integer approximation is valid - it's 0. */
+ *valuep = 0;
+ }
+ }
+ else
+ return 0;
+ } else if (*s == 'I' || *s == 'i') {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
+ s++; if (s < send && (*s == 'I' || *s == 'i')) {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
+ s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
+ s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
+ s++;
+ }
+ sawinf = 1;
+ } else if (*s == 'N' || *s == 'n') {
+ /* XXX TODO: There are signaling NaNs and quiet NaNs. */
+ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++;
+ sawnan = 1;
+ } else
+ return 0;
+
+ if (sawinf) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
+ } else if (sawnan) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
+ } else if (s < send) {
+ /* we can have an optional exponent part */
+ if (*s == 'e' || *s == 'E') {
+ /* The only flag we keep is sign. Blow away any "it's UV" */
+ numtype &= IS_NUMBER_NEG;
+ numtype |= IS_NUMBER_NOT_INT;
+ s++;
+ if (s < send && (*s == '-' || *s == '+'))
+ s++;
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
+ }
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s >= send)
+ return numtype;
+ if (len == 10 && memEQ(pv, "0 but true", 10)) {
+ if (valuep)
+ *valuep = 0;
+ return IS_NUMBER_IN_UV;
+ }
+ return 0;
+}
+#endif /* grok_number */
+
+#ifndef PERL_MAGIC_sv
+# define PERL_MAGIC_sv '\0'
+#endif
+
+#ifndef PERL_MAGIC_overload
+# define PERL_MAGIC_overload 'A'
+#endif
+
+#ifndef PERL_MAGIC_overload_elem
+# define PERL_MAGIC_overload_elem 'a'
+#endif
+
+#ifndef PERL_MAGIC_overload_table
+# define PERL_MAGIC_overload_table 'c'
+#endif
+
+#ifndef PERL_MAGIC_bm
+# define PERL_MAGIC_bm 'B'
+#endif
+
+#ifndef PERL_MAGIC_regdata
+# define PERL_MAGIC_regdata 'D'
+#endif
+
+#ifndef PERL_MAGIC_regdatum
+# define PERL_MAGIC_regdatum 'd'
+#endif
+
+#ifndef PERL_MAGIC_env
+# define PERL_MAGIC_env 'E'
+#endif
+
+#ifndef PERL_MAGIC_envelem
+# define PERL_MAGIC_envelem 'e'
+#endif
+
+#ifndef PERL_MAGIC_fm
+# define PERL_MAGIC_fm 'f'
+#endif
+
+#ifndef PERL_MAGIC_regex_global
+# define PERL_MAGIC_regex_global 'g'
+#endif
+
+#ifndef PERL_MAGIC_isa
+# define PERL_MAGIC_isa 'I'
+#endif
+
+#ifndef PERL_MAGIC_isaelem
+# define PERL_MAGIC_isaelem 'i'
+#endif
+
+#ifndef PERL_MAGIC_nkeys
+# define PERL_MAGIC_nkeys 'k'
+#endif
+
+#ifndef PERL_MAGIC_dbfile
+# define PERL_MAGIC_dbfile 'L'
+#endif
+
+#ifndef PERL_MAGIC_dbline
+# define PERL_MAGIC_dbline 'l'
+#endif
+
+#ifndef PERL_MAGIC_mutex
+# define PERL_MAGIC_mutex 'm'
+#endif
+
+#ifndef PERL_MAGIC_shared
+# define PERL_MAGIC_shared 'N'
+#endif
+
+#ifndef PERL_MAGIC_shared_scalar
+# define PERL_MAGIC_shared_scalar 'n'
+#endif
+
+#ifndef PERL_MAGIC_collxfrm
+# define PERL_MAGIC_collxfrm 'o'
+#endif
+
+#ifndef PERL_MAGIC_tied
+# define PERL_MAGIC_tied 'P'
+#endif
+
+#ifndef PERL_MAGIC_tiedelem
+# define PERL_MAGIC_tiedelem 'p'
+#endif
+
+#ifndef PERL_MAGIC_tiedscalar
+# define PERL_MAGIC_tiedscalar 'q'
+#endif
+
+#ifndef PERL_MAGIC_qr
+# define PERL_MAGIC_qr 'r'
+#endif
+
+#ifndef PERL_MAGIC_sig
+# define PERL_MAGIC_sig 'S'
+#endif
+
+#ifndef PERL_MAGIC_sigelem
+# define PERL_MAGIC_sigelem 's'
+#endif
+
+#ifndef PERL_MAGIC_taint
+# define PERL_MAGIC_taint 't'
+#endif
+
+#ifndef PERL_MAGIC_uvar
+# define PERL_MAGIC_uvar 'U'
+#endif
+
+#ifndef PERL_MAGIC_uvar_elem
+# define PERL_MAGIC_uvar_elem 'u'
+#endif
+
+#ifndef PERL_MAGIC_vstring
+# define PERL_MAGIC_vstring 'V'
+#endif
+
+#ifndef PERL_MAGIC_vec
+# define PERL_MAGIC_vec 'v'
+#endif
+
+#ifndef PERL_MAGIC_utf8
+# define PERL_MAGIC_utf8 'w'
+#endif
+
+#ifndef PERL_MAGIC_substr
+# define PERL_MAGIC_substr 'x'
+#endif
+
+#ifndef PERL_MAGIC_defelem
+# define PERL_MAGIC_defelem 'y'
+#endif
+
+#ifndef PERL_MAGIC_glob
+# define PERL_MAGIC_glob '*'
+#endif
+
+#ifndef PERL_MAGIC_arylen
+# define PERL_MAGIC_arylen '#'
+#endif
+
+#ifndef PERL_MAGIC_pos
+# define PERL_MAGIC_pos '.'
+#endif
+
+#ifndef PERL_MAGIC_backref
+# define PERL_MAGIC_backref '<'
+#endif
+
+#ifndef PERL_MAGIC_ext
+# define PERL_MAGIC_ext '~'
+#endif
+
+#endif /* _P_P_PORTABILITY_H_ */
+
+/* End of File ppport.h */
projects / platform / upstream / perl.git / commitdiff