static long sv_to_dimension(pTHX_ SV *sv, const char *member)
{
SV *warning;
const char *value = NULL;
assert(sv != NULL);
SvGETMAGIC(sv);
if (SvOK(sv) && !SvROK(sv))
{
if (looks_like_number(sv))
{
return SvIV(sv);
}
value = SvPV_nolen(sv);
}
warning = newSVpvn("", 0);
if (value) sv_catpvf(warning, " ('%s')", value);
if (member) sv_catpvf(warning, " in '%s'", member);
WARN((aTHX_ "Cannot use %s%s as dimension", identify_sv(sv), SvPV_nolen(warning)));
SvREFCNT_dec(warning);
return 0;
}
/* T_CVREF */
CV *
tm_input_cvref(pTHX_ SV * const arg)
{
HV *st;
GV *gvp;
SvGETMAGIC(arg);
return sv_2cv(arg, &st, &gvp, 0);
}
// rv getters
char *swiftperl_reftype(void *vp) {
SvGETMAGIC((SV *)vp);
if (SvROK((SV *)vp)) {
return (char *)sv_reftype(SvRV((SV *)vp), 0);
} else {
return "";
}
}
/* T_HVREF */
HV *
tm_input_hvref(pTHX_ SV * const arg)
{
SvGETMAGIC(arg);
if (LIKELY( SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVHV ))
return (HV *)SvRV(arg);
else
return NULL;
}
/* T_SVREF */
SV *
tm_input_svref(pTHX_ SV * const arg)
{
SV *var;
SvGETMAGIC(arg);
if ( !SvROK(arg) )
return NULL;
var = SvRV(arg);
return var;
}
/* Entry point for serialization. Dumps generic SVs and delegates
* to more specialized functions for RVs, etc. */
void
ddl_dump_sv(pTHX_ ddl_encoder_t *enc, SV *src)
{
SvGETMAGIC(src);
/* dump strings */
if (SvPOKp(src)) {
STRLEN len;
char *str = SvPV(src, len);
BUF_SIZE_ASSERT(enc, 2 + len);
ddl_dump_pv(aTHX_ enc, str, len, SvUTF8(src));
}
/* dump floats */
else if (SvNOKp(src)) {
BUF_SIZE_ASSERT(enc, NV_DIG + 32);
Gconvert(SvNVX(src), NV_DIG, 0, enc->pos);
enc->pos += strlen(enc->pos);
}
/* dump ints */
else if (SvIOKp(src)) {
/* we assume we can always read an IV as a UV and vice versa
* we assume two's complement
* we assume no aliasing issues in the union */
if (SvIsUV(src) ? SvUVX(src) <= 59000
: SvIVX(src) <= 59000 && SvIVX(src) >= -59000)
{
/* optimise the "small number case"
* code will likely be branchless and use only a single multiplication
* works for numbers up to 59074 */
I32 i = SvIVX(src);
U32 u;
char digit, nz = 0;
BUF_SIZE_ASSERT(enc, 6);
*enc->pos = '-'; enc->pos += i < 0 ? 1 : 0;
u = i < 0 ? -i : i;
/* convert to 4.28 fixed-point representation */
u *= ((0xfffffff + 10000) / 10000); /* 10**5, 5 fractional digits */
/* now output digit by digit, each time masking out the integer part
* and multiplying by 5 while moving the decimal point one to the right,
* resulting in a net multiplication by 10.
* we always write the digit to memory but conditionally increment
* the pointer, to enable the use of conditional move instructions. */
digit = u >> 28; *enc->pos = digit + '0'; enc->pos += (nz = nz || digit); u = (u & 0xfffffffUL) * 5;
digit = u >> 27; *enc->pos = digit + '0'; enc->pos += (nz = nz || digit); u = (u & 0x7ffffffUL) * 5;
digit = u >> 26; *enc->pos = digit + '0'; enc->pos += (nz = nz || digit); u = (u & 0x3ffffffUL) * 5;
digit = u >> 25; *enc->pos = digit + '0'; enc->pos += (nz = nz || digit); u = (u & 0x1ffffffUL) * 5;
digit = u >> 24; *enc->pos = digit + '0'; enc->pos += 1; /* correctly generate '0' */
}
else {
getdns_return_t net_getdns_hostname(Net__GetDNS__XS__Context * context, Net__GetDNS__XS__Dict * address, Net__GetDNS__XS__Dict * extensions, SV * userarg, getdns_transaction_t * transaction_id, SV * callbackfn)
{
struct __callback * cb = 0;
if (!callbackfn) {
return GETDNS_RETURN_GENERIC_ERROR;
}
if (!SvOK(callbackfn)) {
return GETDNS_RETURN_GENERIC_ERROR;
}
Newxz(cb, 1, struct __callback);
if (!cb) return GETDNS_RETURN_MEMORY_ERROR;
if (SvOK(userarg)) {
SvGETMAGIC(userarg);
cb->userarg = userarg;
}
SvGETMAGIC(callbackfn);
cb->callbackfn = SvREFCNT_inc(newSVsv(callbackfn));
return getdns_hostname(context, address, extensions, cb, transaction_id, __getdns_callback);
}
void handle_string_list(pTHX_ const char *option, LinkedList list, SV *sv, SV **rval)
{
const char *str;
if (sv)
{
LL_flush(list, (LLDestroyFunc) string_delete);
if (SvROK(sv))
{
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVAV)
{
AV *av = (AV *) sv;
SV **pSV;
int i, max = av_len(av);
for (i = 0; i <= max; i++)
{
if ((pSV = av_fetch(av, i, 0)) != NULL)
{
SvGETMAGIC(*pSV);
LL_push(list, string_new_fromSV(aTHX_ *pSV));
}
else
fatal("NULL returned by av_fetch() in handle_string_list()");
}
}
else
Perl_croak(aTHX_ "%s wants an array reference", option);
}
else
Perl_croak(aTHX_ "%s wants a reference to an array of strings", option);
}
if (rval)
{
ListIterator li;
AV *av = newAV();
LL_foreach(str, li, list)
av_push(av, newSVpv(CONST_CHAR(str), 0));
*rval = newRV_noinc((SV *) av);
}
}
/*
NOTE: mouse_tc_check() handles GETMAGIC
*/
int
mouse_tc_check(pTHX_ SV* const tc_code, SV* const sv) {
CV* const cv = (CV*)SvRV(tc_code);
assert(SvTYPE(cv) == SVt_PVCV);
if(CvXSUB(cv) == XS_Mouse_constraint_check){ /* built-in type constraints */
MAGIC* const mg = (MAGIC*)CvXSUBANY(cv).any_ptr;
assert(CvXSUBANY(cv).any_ptr != NULL);
assert(mg->mg_ptr != NULL);
SvGETMAGIC(sv);
/* call the check function directly, skipping call_sv() */
return CALL_FPTR((check_fptr_t)mg->mg_ptr)(aTHX_ mg->mg_obj, sv);
}
else { /* custom */
int ok;
dSP;
dMY_CXT;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv);
if( MY_CXT.tc_extra_args ) {
AV* const av = MY_CXT.tc_extra_args;
I32 const len = AvFILLp(av) + 1;
int i;
for(i = 0; i < len; i++) {
XPUSHs( AvARRAY(av)[i] );
}
}
PUTBACK;
call_sv(tc_code, G_SCALAR);
SPAGAIN;
ok = sv_true(POPs);
PUTBACK;
FREETMPS;
LEAVE;
return ok;
}
}
void
Perl_save_list(pTHX_ SV **sarg, I32 maxsarg)
{
I32 i;
PERL_ARGS_ASSERT_SAVE_LIST;
for (i = 1; i <= maxsarg; i++) {
SV *sv;
SvGETMAGIC(sarg[i]);
sv = newSV(0);
sv_setsv_nomg(sv,sarg[i]);
SSCHECK(3);
SSPUSHPTR(sarg[i]); /* remember the pointer */
SSPUSHPTR(sv); /* remember the value */
SSPUSHUV(SAVEt_ITEM);
}
}
IV
PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
PerlIO_funcs * tab)
{
IV code;
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
/* If called (normally) via open() then arg is ref to scalar we are
* using, otherwise arg (from binmode presumably) is either NULL
* or the _name_ of the scalar
*/
if (arg) {
if (SvROK(arg)) {
if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
s->var = SvREFCNT_inc(SvRV(arg));
SvGETMAGIC(s->var);
if (!SvPOK(s->var) && SvOK(s->var))
(void)SvPV_nomg_const_nolen(s->var);
}
else {
s->var =
SvREFCNT_inc(perl_get_sv
(SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
}
}
else {
s->var = newSVpvn("", 0);
}
SvUPGRADE(s->var, SVt_PV);
code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
SvCUR_set(s->var, 0);
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
s->posn = SvCUR(s->var);
else
s->posn = 0;
return code;
}
static void xs_getaddrinfo(pTHX_ CV *cv)
{
dVAR;
dXSARGS;
SV *host;
SV *service;
SV *hints;
char *hostname = NULL;
char *servicename = NULL;
STRLEN len;
struct addrinfo hints_s;
struct addrinfo *res;
struct addrinfo *res_iter;
int err;
int n_res;
if(items > 3)
croak_xs_usage(cv, "host, service, hints");
SP -= items;
if(items < 1)
host = &PL_sv_undef;
else
host = ST(0);
if(items < 2)
service = &PL_sv_undef;
else
service = ST(1);
if(items < 3)
hints = NULL;
else
hints = ST(2);
SvGETMAGIC(host);
if(SvOK(host)) {
hostname = SvPV_nomg(host, len);
if (!len)
hostname = NULL;
}
SvGETMAGIC(service);
if(SvOK(service)) {
servicename = SvPV_nomg(service, len);
if (!len)
servicename = NULL;
}
Zero(&hints_s, sizeof hints_s, char);
hints_s.ai_family = PF_UNSPEC;
if(hints && SvOK(hints)) {
HV *hintshash;
SV **valp;
if(!SvROK(hints) || SvTYPE(SvRV(hints)) != SVt_PVHV)
croak("hints is not a HASH reference");
hintshash = (HV*)SvRV(hints);
if((valp = hv_fetch(hintshash, "flags", 5, 0)) != NULL)
hints_s.ai_flags = SvIV(*valp);
if((valp = hv_fetch(hintshash, "family", 6, 0)) != NULL)
hints_s.ai_family = SvIV(*valp);
if((valp = hv_fetch(hintshash, "socktype", 8, 0)) != NULL)
hints_s.ai_socktype = SvIV(*valp);
if((valp = hv_fetch(hintshash, "protocol", 8, 0)) != NULL)
hints_s.ai_protocol = SvIV(*valp);
}
err = getaddrinfo(hostname, servicename, &hints_s, &res);
XPUSHs(err_to_SV(aTHX_ err));
if(err)
XSRETURN(1);
n_res = 0;
for(res_iter = res; res_iter; res_iter = res_iter->ai_next) {
HV *res_hv = newHV();
(void)hv_stores(res_hv, "family", newSViv(res_iter->ai_family));
(void)hv_stores(res_hv, "socktype", newSViv(res_iter->ai_socktype));
(void)hv_stores(res_hv, "protocol", newSViv(res_iter->ai_protocol));
(void)hv_stores(res_hv, "addr", newSVpvn((char*)res_iter->ai_addr, res_iter->ai_addrlen));
if(res_iter->ai_canonname)
(void)hv_stores(res_hv, "canonname", newSVpv(res_iter->ai_canonname, 0));
else
(void)hv_stores(res_hv, "canonname", newSV(0));
XPUSHs(sv_2mortal(newRV_noinc((SV*)res_hv)));
n_res++;
}
freeaddrinfo(res);
XSRETURN(1 + n_res);
}
Hash::Temp Interpreter::hash(const char* name) const {
HV* const ret = get_hv(name, true);
SvGETMAGIC(reinterpret_cast<SV*>(ret));
return Hash::Temp(raw_interp.get(), ret, false);
}
static void disabled_keywords(pTHX_ LinkedList *current, SV *sv, SV **rval,
u_32 *pKeywordMask)
{
const char *str;
LinkedList keyword_list = NULL;
if (sv)
{
if (SvROK(sv))
{
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVAV)
{
AV *av = (AV *) sv;
SV **pSV;
int i, max = av_len(av);
u_32 keywords = HAS_ALL_KEYWORDS;
keyword_list = LL_new();
for (i = 0; i <= max; i++)
{
if ((pSV = av_fetch(av, i, 0)) != NULL)
{
SvGETMAGIC(*pSV);
str = SvPV_nolen(*pSV);
#include "token/t_keywords.c"
success:
LL_push(keyword_list, string_new(str));
}
else
fatal("NULL returned by av_fetch() in disabled_keywords()");
}
if (pKeywordMask != NULL)
*pKeywordMask = keywords;
if (current != NULL)
{
LL_destroy(*current, (LLDestroyFunc) string_delete);
*current = keyword_list;
}
}
else
Perl_croak(aTHX_ "DisabledKeywords wants an array reference");
}
else
Perl_croak(aTHX_ "DisabledKeywords wants a reference to "
"an array of strings");
}
if (rval)
{
ListIterator li;
AV *av = newAV();
LL_foreach (str, li, *current)
av_push(av, newSVpv(CONST_CHAR(str), 0));
*rval = newRV_noinc((SV *) av);
}
return;
unknown:
LL_destroy(keyword_list, (LLDestroyFunc) string_delete);
Perl_croak(aTHX_ "Cannot disable unknown keyword '%s'", str);
}
Array::Temp Interpreter::array(const char* name) const {
AV* const ret = get_av(name, true);
SvGETMAGIC(reinterpret_cast<SV*>(ret));
return Array::Temp(raw_interp.get(), ret, false);
}
void _mpack_item(SV *res, SV *o)
{
size_t len, res_len, new_len;
char *s, *res_s;
res_s = SvPVbyte(res, res_len);
unsigned i;
if (!SvOK(o)) {
new_len = res_len + mp_sizeof_nil();
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_nil(res_s + res_len);
return;
}
if (SvROK(o)) {
o = SvRV(o);
if (SvOBJECT(o)) {
SvGETMAGIC(o);
HV *stash = SvSTASH(o);
GV *mtd = gv_fetchmethod_autoload(stash, "msgpack", 0);
if (!mtd)
croak("Object has no method 'msgpack'");
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs (sv_bless (sv_2mortal (newRV_inc(o)), stash));
PUTBACK;
call_sv((SV *)GvCV(mtd), G_SCALAR);
SPAGAIN;
SV *pkt = POPs;
if (!SvOK(pkt))
croak("O->msgpack returned undef");
s = SvPV(pkt, len);
new_len = res_len + len;
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
memcpy(res_s + res_len, s, len);
PUTBACK;
FREETMPS;
LEAVE;
return;
}
switch(SvTYPE(o)) {
case SVt_PVAV: {
AV *a = (AV *)o;
len = av_len(a) + 1;
new_len = res_len + mp_sizeof_array(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_array(res_s + res_len, len);
for (i = 0; i < len; i++) {
SV **item = av_fetch(a, i, 0);
if (!item)
_mpack_item(res, 0);
else
_mpack_item(res, *item);
}
break;
}
case SVt_PVHV: {
HV *h = (HV *)o;
len = hv_iterinit(h);
new_len = res_len + mp_sizeof_map(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_map(res_s + res_len, len);
for (;;) {
HE * iter = hv_iternext(h);
if (!iter)
break;
SV *k = hv_iterkeysv(iter);
SV *v = HeVAL(iter);
_mpack_item(res, k);
_mpack_item(res, v);
}
break;
}
default:
croak("Can't serialize reference");
}
return;
}
switch(SvTYPE(o)) {
case SVt_PV:
case SVt_PVIV:
case SVt_PVNV:
case SVt_PVMG:
case SVt_REGEXP:
if (!looks_like_number(o)) {
s = SvPV(o, len);
new_len = res_len + mp_sizeof_str(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_str(res_s + res_len, s, len);
break;
}
case SVt_NV: {
NV v = SvNV(o);
IV iv = (IV)v;
if (v != iv) {
new_len = res_len + mp_sizeof_double(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_double(res_s + res_len, v);
break;
}
}
case SVt_IV: {
IV v = SvIV(o);
if (v >= 0) {
new_len = res_len + mp_sizeof_uint(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_uint(res_s + res_len, v);
} else {
new_len = res_len + mp_sizeof_int(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_int(res_s + res_len, v);
}
break;
}
default:
croak("Internal msgpack error %d", SvTYPE(o));
}
}
// This function reads the various JavaBin datatypes and returns a Perl SV.
// Different datatypes are jumped to view a lookup in an array of computed gotos.
//
// The first group (undef to enum) use the entire tag for the index of the type.
//
// The second are matched by taking the tag byte, shifting it by 5 so to only read
// the first 3 bits of the tag byte, giving it a range or 0-7 inclusive.
//
// To store both in one array the second group have 18 added to them. See DISPATCH.
//
// The remaining 5 bits can then be used to store the size of the datatype, e.g. how
// many chars in a string, this therefore has a range of 0-31, if the size exceeds or
// matches this then an additional vint is added.
//
// The overview of the tag byte is therefore TTTSSSSS with T and S being type and size.
static SV* read_sv(pTHX) {
void* dispatch[] = {
&&read_undef,
&&read_bool,
&&read_bool,
&&read_byte,
&&read_short,
&&read_double,
&&read_int,
&&read_long,
&&read_float,
&&read_date,
&&read_map,
&&read_solr_doc,
&&read_solr_doc_list,
&&read_byte_array,
&&read_iterator,
NULL,
NULL,
NULL,
&&read_enum,
&&read_string,
&&read_small_int,
&&read_small_long,
&&read_array,
&&read_map,
&&read_map,
};
in++;
goto *dispatch[in[-1] >> 5 ? (in[-1] >> 5) + 18 : in[-1]];
read_undef:
return &PL_sv_undef;
read_bool: {
SV *rv = newSV_type(SVt_IV), *sv = in[-1] == 1 ? bool_true : bool_false;
SvREFCNT(sv)++;
SvROK_on(rv);
SvRV_set(rv, sv);
return rv;
}
read_byte:
return newSViv((int8_t) *in++);
read_short: {
const int16_t s = in[0] << 8 | in[1];
in += 2;
return newSViv(s);
}
read_double: {
// For perls with double length NVs this conversion is simple.
// Read 8 bytes, cast to double, return. For long double perls
// more magic is used, see read_float for more details.
const int_double u = { (uint64_t) in[0] << 56 |
(uint64_t) in[1] << 48 |
(uint64_t) in[2] << 40 |
(uint64_t) in[3] << 32 |
(uint64_t) in[4] << 24 |
(uint64_t) in[5] << 16 |
(uint64_t) in[6] << 8 |
(uint64_t) in[7] };
in += 8;
#ifdef USE_LONG_DOUBLE
char *str = alloca(snprintf(NULL, 0, "%.14f", u.d));
sprintf(str, "%.14f", u.d);
return newSVnv(strtold(str, NULL));
#else
return newSVnv(u.d);
#endif
}
read_int: {
const int32_t i = in[0] << 24 | in[1] << 16 | in[2] << 8 | in[3];
in += 4;
return newSViv(i);
}
read_long: {
const int64_t l = (uint64_t) in[0] << 56 |
(uint64_t) in[1] << 48 |
(uint64_t) in[2] << 40 |
(uint64_t) in[3] << 32 |
(uint64_t) in[4] << 24 |
(uint64_t) in[5] << 16 |
(uint64_t) in[6] << 8 |
(uint64_t) in[7];
in += 8;
return newSViv(l);
}
read_float: {
// JavaBin has a 4byte float format, NVs in perl are double or long double,
// therefore a little magic is required. Read the 4 bytes into an int in the
// correct endian order. Re-read these bits as a float, stringify this float,
// then finally numify the string into a double or long double.
const int_float u = { in[0] << 24 | in[1] << 16 | in[2] << 8 | in[3] };
in += 4;
char *str = alloca(snprintf(NULL, 0, "%f", u.f));
sprintf(str, "%f", u.f);
#ifdef USE_LONG_DOUBLE
return newSVnv(strtold(str, NULL));
#else
return newSVnv(strtod(str, NULL));
#endif
}
read_date: {
const int64_t date_ms = (uint64_t) in[0] << 56 |
(uint64_t) in[1] << 48 |
(uint64_t) in[2] << 40 |
(uint64_t) in[3] << 32 |
(uint64_t) in[4] << 24 |
(uint64_t) in[5] << 16 |
(uint64_t) in[6] << 8 |
(uint64_t) in[7];
in += 8;
const time_t date = date_ms / 1000;
const struct tm *t = gmtime(&date);
char date_str[25];
sprintf(date_str, "%u-%02u-%02uT%02u:%02u:%02u.%03uZ", t->tm_year + 1900,
t->tm_mon + 1,
t->tm_mday,
t->tm_hour,
t->tm_min,
t->tm_sec,
(uint32_t) (date_ms % 1000));
return newSVpvn(date_str, 24);
}
read_solr_doc:
in++; // Assume a solr doc is a map.
read_map: {
HV *hv = (HV*)newSV_type(SVt_PVHV);
uint32_t len = in[-1] >> 5 ? READ_LEN : read_v_int();
while (len--) {
cached_key key;
in++;
const uint32_t i = READ_LEN;
if (i)
key = cached_keys[i];
else {
in++;
cached_keys[++cache_pos] = key = (cached_key){ (char*)in, 0, READ_LEN };
uint8_t *key_str = in;
in += key.len;
// Set the UTF8 flag if we hit a high byte.
while (key_str != in) {
if (*key_str++ & 128) {
key.flags = HVhek_UTF8;
break;
}
}
}
hv_common(hv, NULL, key.key, key.len, key.flags, HV_FETCH_ISSTORE, read_sv(aTHX), 0);
}
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, (SV*)hv);
return rv;
}
read_solr_doc_list: {
HV *hv = (HV*)newSV_type(SVt_PVHV);
// Assume values are in an array, skip tag & read_sv.
in++;
hv_set(hv, "numFound", read_sv(aTHX), numFound);
hv_set(hv, "start", read_sv(aTHX), start);
hv_set(hv, "maxScore", read_sv(aTHX), maxScore);
hv_set(hv, "docs", read_sv(aTHX), docs);
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, (SV*)hv);
return rv;
}
read_byte_array: {
AV *av = (AV*)newSV_type(SVt_PVAV);
SSize_t len = read_v_int();
SV **ary = safemalloc(len * sizeof(SV*));
AvALLOC(av) = AvARRAY(av) = ary;
AvFILLp(av) = AvMAX(av) = len - 1;
while (len--)
*ary++ = newSViv((int8_t) *in++);
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, (SV*)av);
return rv;
}
read_iterator: {
AV *av = (AV*)newSV_type(SVt_PVAV);
uint32_t len = 0;
while (*in != 15)
av_store(av, len++, read_sv(aTHX));
in++;
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, (SV*)av);
return rv;
}
read_enum: {
SV *sv = read_sv(aTHX); // small_int if +ve, int otherwise.
sv_upgrade(sv, SVt_PVMG);
in++;
const STRLEN len = READ_LEN;
char *str = sv_grow(sv, len + 1);
memcpy(str, in, len);
in += len;
str[len] = '\0';
SvCUR(sv) = len;
SvFLAGS(sv) = SVf_IOK | SVp_IOK | SVs_OBJECT | SVf_POK | SVp_POK | SVt_PVMG | SVf_UTF8;
HV *stash = CALL(gv_stashpvn, STR_WITH_LEN("JavaBin::Enum"), 0);
SvREFCNT(stash)++;
SvSTASH_set(sv, stash);
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, sv);
return rv;
}
read_string: {
const STRLEN len = READ_LEN;
SV *sv = newSV_type(SVt_PV);
char *str = SvPVX(sv) = (char*)safemalloc(len);
memcpy(str, in, len);
SvCUR(sv) = SvLEN(sv) = len;
SvFLAGS(sv) |= SVf_POK | SVp_POK | SVf_UTF8;
in += len;
return sv;
}
read_small_int: {
uint32_t result = in[-1] & 15;
if (in[-1] & 16)
result |= read_v_int() << 4;
return newSViv(result);
}
read_small_long: {
uint64_t result = in[-1] & 15;
// Inlined variable-length +ve long code, see read_v_int().
if (in[-1] & 16) {
uint8_t shift = 4;
do result |= (*in++ & 127) << shift;
while (in[-1] & 128 && (shift += 7));
}
return newSViv(result);
}
read_array: {
AV *av = (AV*)newSV_type(SVt_PVAV);
SSize_t len = READ_LEN;
SV **ary = safemalloc(len * sizeof(SV*));
AvALLOC(av) = AvARRAY(av) = ary;
AvFILLp(av) = AvMAX(av) = len - 1;
while (len--)
*ary++ = read_sv(aTHX);
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV(rv) = (SV*)av;
return rv;
}
}
static void grow_out(pTHX_ const STRLEN want) {
const STRLEN len = out_buf - (uint8_t *)SvPVX(out_sv);
// If we want more than we have, realloc the string.
if (len + want >= SvLEN(out_sv)) {
sv_grow(out_sv, len + want);
out_buf = (uint8_t *)SvPVX(out_sv) + len;
}
}
static void write_v_int(uint32_t i) {
while (i & ~127) {
*out_buf++ = (i & 127) | 128;
i >>= 7;
}
*out_buf++ = i;
}
static void write_shifted_tag(uint8_t tag, uint32_t len) {
if (len < 31)
*out_buf++ = tag | len;
else {
*out_buf++ = tag | 31;
write_v_int(len - 31);
}
}
static void write_sv(pTHX_ SV *sv) {
SvGETMAGIC(sv);
if (SvPOKp(sv)) {
const STRLEN len = SvCUR(sv);
grow_out(aTHX_ len + 5);
write_shifted_tag(32, len);
memcpy(out_buf, SvPVX(sv), len);
out_buf += len;
}
else if (SvNOKp(sv)) {
const int_double u = { .d = SvNV(sv) };
grow_out(aTHX_ 9);
*out_buf++ = 5;
*out_buf++ = u.i >> 56;
*out_buf++ = u.i >> 48;
*out_buf++ = u.i >> 40;
*out_buf++ = u.i >> 32;
*out_buf++ = u.i >> 24;
*out_buf++ = u.i >> 16;
*out_buf++ = u.i >> 8;
*out_buf++ = u.i;
}
else if (SvIOKp(sv)) {
/* Converts perl values to equivalent JS values */
JSBool
PJS_ReflectPerl2JS(
pTHX_
JSContext *cx,
JSObject *pobj,
SV *ref,
jsval *rval
) {
PJS_Context *pcx = PJS_GET_CONTEXT(cx);
JSObject *newobj = NULL;
if(++pcx->svconv % 2000 == 0) {
JSErrorReporter older;
ENTER; SAVETMPS; /* Scope for finalizers */
older = JS_SetErrorReporter(cx, NULL);
if(pcx->svconv > 10000) {
JS_GC(cx);
pcx->svconv = 0;
} else JS_MaybeGC(cx);
JS_SetErrorReporter(cx, older);
FREETMPS; LEAVE;
}
if(SvROK(ref)) {
MAGIC *mg;
/* First check old jsvisitors */
if((newobj = PJS_IsPerlVisitor(aTHX_ pcx, SvRV(ref)))) {
PJS_DEBUG("Old jsvisitor returns\n");
*rval = OBJECT_TO_JSVAL(newobj);
return JS_TRUE;
}
if(SvMAGICAL(SvRV(ref)) && (mg = mg_find(SvRV(ref), PERL_MAGIC_tied))
&& mg->mg_obj && sv_derived_from(mg->mg_obj, PJS_BOXED_PACKAGE)) {
PJS_DEBUG1("A magical ref %s, shortcircuit!\n", SvPV_nolen((SV*)mg->mg_obj));
ref = mg->mg_obj;
}
if(sv_derived_from(ref, PJS_BOXED_PACKAGE)) {
SV **fref = av_fetch((AV *)SvRV(SvRV(ref)), 2, 0);
assert(sv_derived_from(*fref, PJS_RAW_JSVAL));
*rval = (jsval)SvIV(SvRV(*fref));
return JS_TRUE;
}
if(sv_derived_from(ref, PJS_BOOLEAN)) {
*rval = SvTRUE(SvRV(ref)) ? JSVAL_TRUE : JSVAL_FALSE;
return JS_TRUE;
}
if(sv_isobject(ref)) {
newobj = PJS_NewPerlObject(aTHX_ cx, pobj, ref);
if(newobj) {
*rval = OBJECT_TO_JSVAL(newobj);
return JS_TRUE;
}
return JS_FALSE;
}
}
SvGETMAGIC(ref);
if(!SvOK(ref)) /* undef */
*rval = JSVAL_VOID;
else if(SvIOK(ref) || SvIOKp(ref)) {
if(SvIV(ref) <= JSVAL_INT_MAX)
*rval = INT_TO_JSVAL(SvIV(ref));
else JS_NewDoubleValue(cx, (double) SvIV(ref), rval);
}
else if(SvNOK(ref))
JS_NewDoubleValue(cx, SvNV(ref), rval);
else if(SvPOK(ref) || SvPOKp(ref)) {
STRLEN len;
char *str;
SV *temp=NULL;
if(SvREADONLY(ref)) {
temp = newSVsv(ref);
str = PJS_SvPV(temp, len);
} else str = PJS_SvPV(ref, len);
JSString *jstr = ((int)len >= 0)
? JS_NewStringCopyN(cx, str, len)
: JS_NewUCStringCopyN(cx, (jschar *)str, -(int)len);
sv_free(temp);
if(!jstr) return JS_FALSE;
*rval = STRING_TO_JSVAL(jstr);
}
else if(SvROK(ref)) { /* Plain reference */
I32 type = SvTYPE(SvRV(ref));
if(type == SVt_PVHV)
newobj = PJS_NewPerlHash(aTHX_ cx, pobj, ref);
else if(type == SVt_PVAV)
newobj = PJS_NewPerlArray(aTHX_ cx, pobj, ref);
else if(type == SVt_PVCV)
newobj = PJS_NewPerlSub(aTHX_ cx, pobj, ref);
else
newobj = PJS_NewPerlScalar(aTHX_ cx, pobj, ref);
if(!newobj) return JS_FALSE;
*rval = OBJECT_TO_JSVAL(newobj);
}
else {
warn("I have no idea what perl send us (it's of type %i), I'll pretend it's undef", SvTYPE(ref));
*rval = JSVAL_VOID;
}
return JS_TRUE;
}
static long dimension_from_member(pTHX_ const char *member, HV *parent)
{
MemberExprWalker walker;
int success = 1;
SV *sv = NULL;
dTHR;
dXCPT;
assert(member != NULL);
if (parent == NULL)
{
WARN((aTHX_ "Missing parent to look up '%s'", member));
return 0;
}
CT_DEBUG(MAIN, ("trying to get dimension from member, walking \"%s\"", member));
walker = member_expr_walker_new(aTHX_ member, 0);
XCPT_TRY_START
{
for (;;)
{
struct me_walk_info mei;
member_expr_walker_walk(aTHX_ walker, &mei);
if (mei.retval == MERV_END)
{
break;
lookup_failed:
success = 0;
break;
}
switch (mei.retval)
{
case MERV_COMPOUND_MEMBER:
{
const char *name = mei.u.compound_member.name;
HV *hv = parent;
SV **psv;
CT_DEBUG(MAIN, ("found compound member \"%s\"", name));
if (sv)
{
SV *hash;
if (SvROK(sv) && SvTYPE(hash = SvRV(sv)) == SVt_PVHV)
{
hv = (HV *) hash;
}
else
{
WARN((aTHX_ "Expected a hash reference to look up member '%s'"
" in '%s', not %s", name, member, identify_sv(sv)));
goto lookup_failed;
}
}
psv = hv_fetch(hv, name, mei.u.compound_member.name_length, 0);
if (psv)
{
SvGETMAGIC(*psv);
sv = *psv;
}
else
{
WARN((aTHX_ "Cannot find member '%s' in hash (in '%s')", name, member));
goto lookup_failed;
}
}
break;
case MERV_ARRAY_INDEX:
{
long last, index = mei.u.array_index;
AV *av;
SV *array;
SV **psv;
assert(sv != NULL);
CT_DEBUG(MAIN, ("found array index \"%ld\"", index));
if (SvROK(sv) && SvTYPE(array = SvRV(sv)) == SVt_PVAV)
{
av = (AV *) array;
}
else
{
WARN((aTHX_ "Expected an array reference to look up index '%ld'"
" in '%s', not %s", index, member, identify_sv(sv)));
goto lookup_failed;
}
last = (long) av_len(av);
if (index > last)
{
WARN((aTHX_ "Cannot lookup index '%ld' in array of size"
" '%ld' (in '%s')", index, last + 1, member));
goto lookup_failed;
}
psv = av_fetch(av, index, 0);
if (psv == NULL)
{
fatal("cannot find index '%ld' in array of size '%ld' (in '%s')",
index, last + 1, member);
}
SvGETMAGIC(*psv);
sv = *psv;
}
break;
default:
fatal("unexpected return value (%d) in dimension_from_member('%s')",
(int) mei.retval, member);
break;
}
}
}
XCPT_TRY_END
member_expr_walker_delete(aTHX_ walker);
XCPT_CATCH
{
XCPT_RETHROW;
}
if (success)
{
assert(sv != NULL);
return sv_to_dimension(aTHX_ sv, member);
}
return 0;
}
