[Orca-checkins] r291 - in trunk/orca: . packages/Storable-2.11 packages/Storable-2.12 packages/Storable-2.12/t
Blair Zajac
blair at orcaware.com
Wed Mar 24 22:09:01 PST 2004
Author: blair
Date: Wed Mar 24 22:07:43 2004
New Revision: 291
Added:
trunk/orca/packages/Storable-2.12/
- copied from r290, trunk/orca/packages/Storable-2.11/
trunk/orca/packages/Storable-2.12/ppport.h
trunk/orca/packages/Storable-2.12/t/HAS_HOOK.pm
trunk/orca/packages/Storable-2.12/t/HAS_OVERLOAD.pm
Removed:
trunk/orca/packages/Storable-2.11/
Modified:
trunk/orca/INSTALL
trunk/orca/configure.in
trunk/orca/packages/Storable-2.12/ChangeLog
trunk/orca/packages/Storable-2.12/MANIFEST
trunk/orca/packages/Storable-2.12/README
trunk/orca/packages/Storable-2.12/Storable.pm
trunk/orca/packages/Storable-2.12/Storable.xs
trunk/orca/packages/Storable-2.12/t/blessed.t
trunk/orca/packages/Storable-2.12/t/overload.t
Log:
Upgrade Storable from 2.11 to 2.12 and require the new version for
Orca.
* configure.in:
Bump Storable's version number to 2.12.
* INSTALL (Determine which Perl modules need compiling and installing):
Update all references to Storable's version number from 2.11 to
2.12.
* packages/Storable-2.12:
Renamed from packages/Storable-2.11. Directory contents updated
from Storable-2.12.tar.gz.
Modified: trunk/orca/INSTALL
==============================================================================
--- trunk/orca/INSTALL (original)
+++ trunk/orca/INSTALL Wed Mar 24 22:07:43 2004
@@ -176,7 +176,7 @@
Digest::MD5 >= 2.33 >= 2.33 2.33
Math::IntervalSearch >= 1.05 >= 1.05 1.05
RRDs >= 1.000461 >= 1.0.46 1.0.46
- Storable >= 2.11 >= 2.11 2.11
+ Storable >= 2.12 >= 2.12 2.12
Time::HiRes Not required by Orca 1.55
All seven of these modules are included with the Orca distribution
@@ -267,10 +267,10 @@
Storable
- http://www.perl.com/CPAN/authors/id/A/AM/AMS/Storable-2.11.tar.gz
+ http://www.perl.com/CPAN/authors/id/A/AM/AMS/Storable-2.12.tar.gz
- % gunzip -c Storable-2.11.tar.gz | tar xvf -
- % cd Storable-2.11
+ % gunzip -c Storable-2.12.tar.gz | tar xvf -
+ % cd Storable-2.12
% perl Makefile.PL
% make
% make test
Modified: trunk/orca/configure.in
==============================================================================
--- trunk/orca/configure.in (original)
+++ trunk/orca/configure.in Wed Mar 24 22:07:43 2004
@@ -39,8 +39,8 @@
MATH_INTERVALSEARCH_VER=1.05
RRDTOOL_DIR=rrdtool-1.0.46
RRDTOOL_VER=1.000461
-STORABLE_DIR=Storable-2.11
-STORABLE_VER=2.11
+STORABLE_DIR=Storable-2.12
+STORABLE_VER=2.12
TIME_HIRES_DIR=Time-HiRes-1.55
TIME_HIRES_VER=1.55
Modified: trunk/orca/packages/Storable-2.12/ChangeLog
==============================================================================
--- trunk/orca/packages/Storable-2.11/ChangeLog (original)
+++ trunk/orca/packages/Storable-2.12/ChangeLog Wed Mar 24 22:07:43 2004
@@ -1,3 +1,11 @@
+Wed Mar 17 15:40:29 GMT 2004 Nicholas Clark <nick at ccl4.org>
+
+ Version 2.12
+
+ 1. Add regression tests for the auto-require of STORABLE_thaw
+ 2. Add auto-require of modules to restore overloading (and tests)
+ 3. Change to no context (should give speedup with ithreads)
+
Sat Mar 13 20:11:03 GMT 2004 Nicholas Clark <nick at ccl4.org>
Version 2.11
Modified: trunk/orca/packages/Storable-2.12/MANIFEST
==============================================================================
--- trunk/orca/packages/Storable-2.11/MANIFEST (original)
+++ trunk/orca/packages/Storable-2.12/MANIFEST Wed Mar 24 22:07:43 2004
@@ -5,6 +5,9 @@
Storable.xs The C side of Storable
ChangeLog Changes since baseline
hints/linux.pl Hint file to drop gcc to -O2
+ppport.h Compatibility header
+t/HAS_HOOK.pm For auto-requiring of modules for STORABLE_thaw
+t/HAS_OVERLOAD.pm For auto-requiring of mdoules for overload
t/blessed.t See if Storable works
t/canonical.t See if Storable works
t/code.t Test (de)serialization of code references
Modified: trunk/orca/packages/Storable-2.12/README
==============================================================================
--- trunk/orca/packages/Storable-2.11/README (original)
+++ trunk/orca/packages/Storable-2.12/README Wed Mar 24 22:07:43 2004
@@ -1,4 +1,4 @@
- Storable 2.09
+ Storable 2.12
Copyright (c) 1995-2000, Raphael Manfredi
Copyright (c) 2001-2004, Larry Wall
Modified: trunk/orca/packages/Storable-2.12/Storable.pm
==============================================================================
--- trunk/orca/packages/Storable-2.11/Storable.pm (original)
+++ trunk/orca/packages/Storable-2.12/Storable.pm Wed Mar 24 22:07:43 2004
@@ -21,7 +21,7 @@
use AutoLoader;
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.11';
+$VERSION = '2.12';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
Modified: trunk/orca/packages/Storable-2.12/Storable.xs
==============================================================================
--- trunk/orca/packages/Storable-2.11/Storable.xs (original)
+++ trunk/orca/packages/Storable-2.12/Storable.xs Wed Mar 24 22:07:43 2004
@@ -8,6 +8,7 @@
*
*/
+#define PERL_NO_GET_CONTEXT /* we want efficiency */
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
@@ -19,6 +20,10 @@
# endif
#endif
+#if PERL_VERSION < 8
+#include "ppport.h" /* handle old perls */
+#endif
+
#ifndef NETWARE
#if 0
#define DEBUGME /* Debug mode, turns assertions on as well */
@@ -974,32 +979,62 @@
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 */
+
+#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);
-static int store();
-static SV *retrieve(stcxt_t *cxt, char *cname);
+#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 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[])(stcxt_t *cxt, SV *sv) = {
+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 */
};
@@ -1009,24 +1044,24 @@
* 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 *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[])(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 */
@@ -1057,21 +1092,21 @@
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 *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[])(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 */
@@ -1104,7 +1139,7 @@
#define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)])
-static SV *mbuf2sv(void);
+static SV *mbuf2sv(pTHX);
/***
*** Context management.
@@ -1115,7 +1150,7 @@
*
* Called once per "thread" (interpreter) to initialize some global context.
*/
-static void init_perinterp(void)
+static void init_perinterp(pTHX)
{
INIT_STCXT;
@@ -1142,6 +1177,7 @@
* Initialize a new store context for real recursion.
*/
static void init_store_context(
+ pTHX_
stcxt_t *cxt,
PerlIO *f,
int optype,
@@ -1236,7 +1272,7 @@
*
* Clean store context by
*/
-static void clean_store_context(stcxt_t *cxt)
+static void clean_store_context(pTHX_ stcxt_t *cxt)
{
HE *he;
@@ -1314,7 +1350,7 @@
*
* 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"));
@@ -1361,7 +1397,7 @@
*
* 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"));
@@ -1412,7 +1448,7 @@
*
* 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"));
@@ -1424,9 +1460,9 @@
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);
@@ -1440,8 +1476,7 @@
* 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;
@@ -1464,8 +1499,7 @@
* 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);
@@ -1489,7 +1523,7 @@
*
* Tells whether we're in the middle of a store operation.
*/
-int is_storing(void)
+int is_storing(pTHX)
{
dSTCXT;
@@ -1501,7 +1535,7 @@
*
* Tells whether we're in the middle of a retrieve operation.
*/
-int is_retrieving(void)
+int is_retrieving(pTHX)
{
dSTCXT;
@@ -1516,7 +1550,7 @@
* 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;
@@ -1536,6 +1570,7 @@
* nor its ancestors know about the method.
*/
static SV *pkg_fetchmeth(
+ pTHX_
HV *cache,
HV *pkg,
char *method)
@@ -1573,6 +1608,7 @@
* Force cached value to be undef: hook ignored even if present.
*/
static void pkg_hide(
+ pTHX_
HV *cache,
HV *pkg,
char *method)
@@ -1587,6 +1623,7 @@
* Discard cached value: a whole fetch loop will be retried at next lookup.
*/
static void pkg_uncache(
+ pTHX_
HV *cache,
HV *pkg,
char *method)
@@ -1603,6 +1640,7 @@
* know about the method.
*/
static SV *pkg_can(
+ pTHX_
HV *cache,
HV *pkg,
char *method)
@@ -1634,7 +1672,7 @@
}
TRACEME(("not cached yet"));
- return pkg_fetchmeth(cache, pkg, method); /* Fetch and cache */
+ return pkg_fetchmeth(aTHX_ cache, pkg, method); /* Fetch and cache */
}
/*
@@ -1644,6 +1682,7 @@
* Propagates the single returned value if not called in void context.
*/
static SV *scalar_call(
+ pTHX_
SV *obj,
SV *hook,
int cloning,
@@ -1700,6 +1739,7 @@
* Returns the list of returned values in an array.
*/
static AV *array_call(
+ pTHX_
SV *obj,
SV *hook,
int cloning)
@@ -1745,6 +1785,7 @@
* 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 */
@@ -1788,7 +1829,7 @@
* 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)));
@@ -1808,7 +1849,7 @@
} else
PUTMARK(SX_REF);
- return store(cxt, sv);
+ return store(aTHX_ cxt, sv);
}
/*
@@ -1822,7 +1863,7 @@
* 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;
@@ -2028,7 +2069,7 @@
* 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;
@@ -2057,7 +2098,7 @@
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;
}
@@ -2066,6 +2107,9 @@
return 0;
}
+
+#if (PATCHLEVEL <= 6)
+
/*
* sortcmp
*
@@ -2075,9 +2119,13 @@
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
@@ -2101,7 +2149,7 @@
* 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
@@ -2188,7 +2236,7 @@
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
@@ -2236,7 +2284,7 @@
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;
/*
@@ -2355,7 +2403,7 @@
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;
@@ -2402,7 +2450,7 @@
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)
@@ -2428,13 +2476,13 @@
* 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;
@@ -2448,14 +2496,14 @@
(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);
}
/*
* Require B::Deparse. At least B::Deparse 0.61 is needed for
* blessed code references.
*/
- /* XXX sv_2mortal seems to be evil here. why? */
+ /* Ownership of both SVs is passed to load_module, which frees them. */
load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("B::Deparse",10), newSVnv(0.61));
ENTER;
@@ -2532,7 +2580,7 @@
* 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;
@@ -2583,7 +2631,7 @@
/* [#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)"));
@@ -2603,7 +2651,7 @@
* 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;
@@ -2622,12 +2670,12 @@
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;
@@ -2636,7 +2684,7 @@
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));
@@ -2695,6 +2743,7 @@
* any other tied variable.
*/
static int store_hook(
+ pTHX_
stcxt_t *cxt,
SV *sv,
int type,
@@ -2789,7 +2838,7 @@
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 */
@@ -2814,12 +2863,12 @@
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);
}
/*
@@ -2883,7 +2932,7 @@
} 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);
@@ -2933,7 +2982,7 @@
* 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 {
@@ -3060,7 +3109,7 @@
* [<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;
}
@@ -3092,6 +3141,7 @@
* 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,
@@ -3109,9 +3159,9 @@
* 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.
@@ -3130,7 +3180,7 @@
* 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) {
@@ -3159,7 +3209,7 @@
* Now emit the <object> part.
*/
- return SV_STORE(type)(cxt, sv);
+ return SV_STORE(type)(aTHX_ cxt, sv);
}
/*
@@ -3172,7 +3222,7 @@
* 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];
@@ -3219,7 +3269,7 @@
* 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:
@@ -3279,7 +3329,7 @@
* 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;
@@ -3315,7 +3365,7 @@
*/
/* Need to jump past the next hv_store, because on the
second store of undef the old hash value will be
- SV_REFCNT_DEC()ed, and as Storable cheats horribly
+ SvREFCNT_dec()ed, and as Storable cheats horribly
by storing non-SVs in the hash a SEGV will ensure.
Need to increase the tag number so that the
receiver has no idea what games we're up to. This
@@ -3364,7 +3414,7 @@
* 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...",
@@ -3372,9 +3422,9 @@
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),
@@ -3394,7 +3444,7 @@
* 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
@@ -3491,6 +3541,7 @@
* dclone() and store() is performed to memory.
*/
static int do_store(
+ pTHX_
PerlIO *f,
SV *sv,
int optype,
@@ -3514,7 +3565,7 @@
*/
if (cxt->s_dirty)
- clean_context(cxt);
+ clean_context(aTHX_ cxt);
/*
* Now that STORABLE_xxx hooks exist, it is possible that they try to
@@ -3522,7 +3573,7 @@
*/
if (cxt->entry)
- cxt = allocate_context(cxt);
+ cxt = allocate_context(aTHX_ cxt);
cxt->entry++;
@@ -3532,7 +3583,7 @@
/*
* 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.
*/
@@ -3551,9 +3602,9 @@
* 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 */
/*
@@ -3562,7 +3613,7 @@
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,
@@ -3574,7 +3625,7 @@
*/
if (!cxt->fio && res)
- *res = mbuf2sv();
+ *res = mbuf2sv(aTHX);
/*
* Final cleanup.
@@ -3592,9 +3643,9 @@
* 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));
@@ -3607,10 +3658,10 @@
* 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);
}
@@ -3620,10 +3671,10 @@
* 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);
}
/***
@@ -3635,7 +3686,7 @@
*
* Build a new SV out of the content of the internal memory buffer.
*/
-static SV *mbuf2sv(void)
+static SV *mbuf2sv(pTHX)
{
dSTCXT;
@@ -3648,13 +3699,13 @@
* 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;
@@ -3666,13 +3717,13 @@
* 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;
@@ -3688,7 +3739,7 @@
* 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 &&
@@ -3713,7 +3764,7 @@
* 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;
@@ -3743,7 +3794,7 @@
* 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;
}
@@ -3754,7 +3805,7 @@
* 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;
@@ -3793,7 +3844,7 @@
* 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);
@@ -3820,7 +3871,7 @@
* 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 */
@@ -3886,11 +3937,11 @@
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 */
@@ -3908,7 +3959,7 @@
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);
@@ -4054,7 +4105,7 @@
*/
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
@@ -4079,8 +4130,8 @@
* 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 "
@@ -4118,7 +4169,7 @@
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);
/*
@@ -4141,7 +4192,7 @@
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)));
@@ -4196,7 +4247,7 @@
* 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;
@@ -4214,7 +4265,7 @@
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 */
@@ -4257,7 +4308,7 @@
* 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;
@@ -4271,7 +4322,7 @@
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 */
@@ -4286,14 +4337,32 @@
/*
* Restore overloading magic.
*/
- if (!SvTYPE(sv)
- || !(stash = (HV *) SvSTASH (sv))
- || !Gv_AMG(stash))
+
+ stash = SvTYPE(sv) ? (HV *) SvSTASH (sv) : 0;
+ if (!stash) {
CROAK(("Cannot restore overloading on %s(0x%"UVxf
- ") (package %s)",
+ ") (package <unknown>)",
sv_reftype(sv, FALSE),
- PTR2UV(sv),
- stash ? HvNAME(stash) : "<unknown>"));
+ PTR2UV(sv)));
+ }
+ if (!Gv_AMG(stash)) {
+ SV *psv = newSVpvn("require ", 8);
+ const char *package = HvNAME(stash);
+ sv_catpv(psv, package);
+
+ TRACEME(("No overloading defined for package %s", package));
+ TRACEME(("Going to require module '%s' with '%s'", package, SvPVX(psv)));
+
+ perl_eval_sv(psv, G_DISCARD);
+ sv_free(psv);
+ if (!Gv_AMG(stash)) {
+ CROAK(("Cannot restore overloading on %s(0x%"UVxf
+ ") (package %s) (even after a \"require %s;\")",
+ sv_reftype(sv, FALSE),
+ PTR2UV(sv),
+ package, package));
+ }
+ }
SvAMAGIC_on(rv);
@@ -4308,7 +4377,7 @@
* 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;
@@ -4317,7 +4386,7 @@
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 */
@@ -4337,7 +4406,7 @@
* 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;
@@ -4346,7 +4415,7 @@
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 */
@@ -4365,7 +4434,7 @@
* 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;
@@ -4374,7 +4443,7 @@
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 */
}
@@ -4401,7 +4470,7 @@
* 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;
@@ -4411,11 +4480,11 @@
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 */
@@ -4433,7 +4502,7 @@
* 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;
@@ -4443,7 +4512,7 @@
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 */
@@ -4466,7 +4535,7 @@
* 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;
@@ -4512,7 +4581,7 @@
* 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;
@@ -4571,13 +4640,13 @@
* 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);
@@ -4600,13 +4669,13 @@
* 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);
@@ -4628,7 +4697,7 @@
* 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;
@@ -4651,7 +4720,7 @@
* 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;
@@ -4679,7 +4748,7 @@
* 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;
@@ -4702,7 +4771,7 @@
* 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;
@@ -4727,7 +4796,7 @@
*
* 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;
@@ -4744,7 +4813,7 @@
*
* 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;
@@ -4765,7 +4834,7 @@
*
* 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;
@@ -4780,7 +4849,7 @@
*
* 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;
@@ -4799,7 +4868,7 @@
*
* 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;
@@ -4827,7 +4896,7 @@
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)
@@ -4850,7 +4919,7 @@
*
* 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;
@@ -4882,7 +4951,7 @@
*/
TRACEME(("(#%d) value", i));
- sv = retrieve(cxt, 0);
+ sv = retrieve(aTHX_ cxt, 0);
if (!sv)
return (SV *) 0;
@@ -4924,7 +4993,7 @@
*
* 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;
@@ -4970,7 +5039,7 @@
*/
TRACEME(("(#%d) value", i));
- sv = retrieve(cxt, 0);
+ sv = retrieve(aTHX_ cxt, 0);
if (!sv)
return (SV *) 0;
@@ -4987,7 +5056,7 @@
*/
SV *keysv;
TRACEME(("(#%d) keysv, flags=%d", i, flags));
- keysv = retrieve(cxt, 0);
+ keysv = retrieve(aTHX_ cxt, 0);
if (!keysv)
return (SV *) 0;
@@ -5060,7 +5129,7 @@
*
* 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"));
@@ -5091,10 +5160,10 @@
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));
@@ -5181,7 +5250,7 @@
*
* 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;
@@ -5215,9 +5284,9 @@
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)
@@ -5241,7 +5310,7 @@
*
* 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;
@@ -5287,11 +5356,11 @@
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.
@@ -5302,7 +5371,7 @@
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)
@@ -5338,7 +5407,7 @@
* 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
@@ -5513,7 +5582,7 @@
* 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;
@@ -5622,7 +5691,7 @@
* 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 */
@@ -5673,6 +5742,7 @@
* Common routine for pretrieve and mretrieve.
*/
static SV *do_retrieve(
+ pTHX_
PerlIO *f,
SV *in,
int optype)
@@ -5703,7 +5773,7 @@
*/
if (cxt->s_dirty)
- clean_context(cxt);
+ clean_context(aTHX_ cxt);
/*
* Now that STORABLE_xxx hooks exist, it is possible that they try to
@@ -5711,7 +5781,7 @@
*/
if (cxt->entry)
- cxt = allocate_context(cxt);
+ cxt = allocate_context(aTHX_ cxt);
cxt->entry++;
@@ -5741,7 +5811,7 @@
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"));
@@ -5760,11 +5830,11 @@
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.
@@ -5779,9 +5849,9 @@
* 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.
@@ -5822,7 +5892,7 @@
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;
}
@@ -5866,10 +5936,10 @@
*
* 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);
}
/*
@@ -5877,10 +5947,10 @@
*
* 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);
}
/***
@@ -5896,7 +5966,7 @@
* 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;
@@ -5911,14 +5981,14 @@
*/
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 */
/*
@@ -5949,7 +6019,7 @@
*/
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)));
@@ -5996,7 +6066,7 @@
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. */
@@ -6008,42 +6078,84 @@
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
Added: trunk/orca/packages/Storable-2.12/ppport.h
==============================================================================
--- (empty file)
+++ trunk/orca/packages/Storable-2.12/ppport.h Wed Mar 24 22:07:43 2004
@@ -0,0 +1,1098 @@
+
+/* ppport.h -- Perl/Pollution/Portability Version 2.011_02
+ *
+ * Automatically Created by Devel::PPPort on Wed Mar 24 08:27:46 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 at 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
+ at 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($_), at 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 */
Added: trunk/orca/packages/Storable-2.12/t/HAS_HOOK.pm
==============================================================================
--- (empty file)
+++ trunk/orca/packages/Storable-2.12/t/HAS_HOOK.pm Wed Mar 24 22:07:43 2004
@@ -0,0 +1,9 @@
+package HAS_HOOK;
+
+sub STORABLE_thaw {
+ ++$thawed_count;
+}
+
+++$loaded_count;
+
+1;
Added: trunk/orca/packages/Storable-2.12/t/HAS_OVERLOAD.pm
==============================================================================
--- (empty file)
+++ trunk/orca/packages/Storable-2.12/t/HAS_OVERLOAD.pm Wed Mar 24 22:07:43 2004
@@ -0,0 +1,14 @@
+package HAS_OVERLOAD;
+
+use overload
+ '""' => sub { ${$_[0]} }, fallback => 1;
+
+sub make {
+ my $package = shift;
+ my $value = shift;
+ bless \$value, $package;
+}
+
+++$loaded_count;
+
+1;
Modified: trunk/orca/packages/Storable-2.12/t/blessed.t
==============================================================================
--- trunk/orca/packages/Storable-2.11/t/blessed.t (original)
+++ trunk/orca/packages/Storable-2.12/t/blessed.t Wed Mar 24 22:07:43 2004
@@ -32,7 +32,7 @@
);
my $test = 12;
-my $tests = $test + 2 * 6 * keys %::immortals;
+my $tests = $test + 6 + 2 * 6 * keys %::immortals;
print "1..$tests\n";
package SHORT_NAME;
@@ -158,3 +158,43 @@
ok ++$test, 1;
}
}
+
+# Test automatic require of packages to find thaw hook.
+
+package HAS_HOOK;
+
+$loaded_count = 0;
+$thawed_count = 0;
+
+sub make {
+ bless [];
+}
+
+sub STORABLE_freeze {
+ my $self = shift;
+ return '';
+}
+
+package main;
+
+my $f = freeze (HAS_HOOK->make);
+
+ok ++$test, $HAS_HOOK::loaded_count == 0;
+ok ++$test, $HAS_HOOK::thawed_count == 0;
+
+my $t = thaw $f;
+ok ++$test, $HAS_HOOK::loaded_count == 1;
+ok ++$test, $HAS_HOOK::thawed_count == 1;
+ok ++$test, $t;
+ok ++$test, ref $t eq 'HAS_HOOK';
+
+# Can't do this because the method is still cached by UNIVERSAL::can
+# delete $INC{"HAS_HOOK.pm"};
+# undef &HAS_HOOK::STORABLE_thaw;
+#
+# warn HAS_HOOK->can('STORABLE_thaw');
+# $t = thaw $f;
+# ok ++$test, $HAS_HOOK::loaded_count == 2;
+# ok ++$test, $HAS_HOOK::thawed_count == 2;
+# ok ++$test, $t;
+# ok ++$test, ref $t eq 'HAS_HOOK';
Modified: trunk/orca/packages/Storable-2.12/t/overload.t
==============================================================================
--- trunk/orca/packages/Storable-2.11/t/overload.t (original)
+++ trunk/orca/packages/Storable-2.12/t/overload.t Wed Mar 24 22:07:43 2004
@@ -25,7 +25,7 @@
use Storable qw(freeze thaw);
-print "1..12\n";
+print "1..16\n";
package OVERLOADED;
@@ -87,5 +87,15 @@
ok 11, "$b->{ref}->{over}" eq "$b";
ok 12, $b + $b == 314;
-1;
+# nfreeze data generated by make_overload.pl
+my $f = unpack 'u', q{7!084$0Q(05-?3U9%4DQ/040*!'-N;W<`};
+# see note at the end of do_retrieve in Storable.xs about why this test has to
+# use a reference to an overloaded reference, rather than just a reference.
+my $t = eval {thaw $f};
+print "# $@" if $@;
+ok 13, $@ eq "";
+ok 14, ref ($t) eq 'REF';
+ok 15, ref ($$t) eq 'HAS_OVERLOAD';
+ok 16, $$$t eq 'snow';
+1;
More information about the Orca-checkins
mailing list