static amf0_data_t* _amf0_data(SV* sv) {
amf0_data_t* d;
if (NULL == sv || !SvOK(sv)) {
d = (amf0_data_t*)amf0_null_init();
}
else if (SvPOKp(sv)) {
STRLEN len;
char* c = SvPV(sv, len);
d = (amf0_data_t*)amf0_string_init_len(c, len);
}
else if (SvNOKp(sv)) {
d = (amf0_data_t*)amf0_number_init((double)SvNVX(sv));
}
else if (SvIOK_UV(sv)) {
d = (amf0_data_t*)amf0_number_init((double)SvUV(sv));
}
else if (SvIOKp(sv)) {
d = (amf0_data_t*)amf0_number_init((double)SvIV(sv));
}
else if (SvROK(sv)) {
d = _amf0_data_rv(SvRV(sv));
}
else {
Perl_croak(aTHX_ "Data::AMF::XS doesn't support SvTYPE: %d\n", SvTYPE(sv));
}
return d;
}
static void pe_tracevar(pe_watcher *wa, SV *sv, int got) {
/* Adapted from tkGlue.c
We are a "magic" set processor.
So we are (I think) supposed to look at "private" flags
and set the public ones if appropriate.
e.g. "chop" sets SvPOKp as a hint but not SvPOK
presumably other operators set other private bits.
Question are successive "magics" called in correct order?
i.e. if we are tracing a tied variable should we call
some magic list or be careful how we insert ourselves in the list?
*/
pe_ioevent *ev;
if (SvPOKp(sv)) SvPOK_on(sv);
if (SvNOKp(sv)) SvNOK_on(sv);
if (SvIOKp(sv)) SvIOK_on(sv);
ev = (pe_ioevent*) (*wa->vtbl->new_event)(wa);
++ev->base.hits;
ev->got |= got;
queueEvent((pe_event*) ev);
}
/* 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 {
static void perl_call_signal(PERL_SCRIPT_REC *script, SV *func,
int signal_id, gconstpointer *args)
{
dSP;
PERL_SIGNAL_ARGS_REC *rec;
SV *sv, *perlarg, *saved_args[SIGNAL_MAX_ARGUMENTS];
AV *av;
void *arg;
int n;
ENTER;
SAVETMPS;
PUSHMARK(sp);
/* push signal argument to perl stack */
rec = perl_signal_args_find(signal_id);
memset(saved_args, 0, sizeof(saved_args));
for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&
rec != NULL && rec->args[n] != NULL; n++) {
arg = (void *) args[n];
if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
/* pointer to linked list - push as AV */
GList *tmp, **ptr;
int is_iobject, is_str;
is_iobject = strcmp(rec->args[n]+9, "iobject") == 0;
is_str = strcmp(rec->args[n]+9, "char*") == 0;
av = newAV();
ptr = arg;
for (tmp = *ptr; tmp != NULL; tmp = tmp->next) {
sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :
is_str ? new_pv(tmp->data) :
irssi_bless_plain(rec->args[n]+9, tmp->data);
av_push(av, sv);
}
saved_args[n] = perlarg = newRV_noinc((SV *) av);
} else if (strcmp(rec->args[n], "int") == 0)
perlarg = newSViv((IV)arg);
else if (arg == NULL)
perlarg = &PL_sv_undef;
else if (strcmp(rec->args[n], "string") == 0)
perlarg = new_pv(arg);
else if (strcmp(rec->args[n], "ulongptr") == 0)
perlarg = newSViv(*(unsigned long *) arg);
else if (strcmp(rec->args[n], "intptr") == 0)
saved_args[n] = perlarg = newRV_noinc(newSViv(*(int *) arg));
else if (strncmp(rec->args[n], "gslist_", 7) == 0) {
/* linked list - push as AV */
GSList *tmp;
int is_iobject;
is_iobject = strcmp(rec->args[n]+7, "iobject") == 0;
av = newAV();
for (tmp = arg; tmp != NULL; tmp = tmp->next) {
sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :
irssi_bless_plain(rec->args[n]+7, tmp->data);
av_push(av, sv);
}
perlarg = newRV_noinc((SV *) av);
} else if (strcmp(rec->args[n], "iobject") == 0) {
/* "irssi object" - any struct that has
"int type; int chat_type" as it's first
variables (server, channel, ..) */
perlarg = iobject_bless((SERVER_REC *) arg);
} else if (strcmp(rec->args[n], "siobject") == 0) {
/* "simple irssi object" - any struct that has
int type; as it's first variable (dcc) */
perlarg = simple_iobject_bless((SERVER_REC *) arg);
} else {
/* blessed object */
perlarg = plain_bless(arg, rec->args[n]);
}
XPUSHs(sv_2mortal(perlarg));
}
PUTBACK;
perl_call_sv(func, G_EVAL|G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV)) {
char *error = g_strdup(SvPV_nolen(ERRSV));
signal_emit("script error", 2, script, error);
g_free(error);
rec = NULL;
}
/* restore arguments the perl script modified */
for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&
rec != NULL && rec->args[n] != NULL; n++) {
arg = (void *) args[n];
if (saved_args[n] == NULL)
continue;
if (strcmp(rec->args[n], "intptr") == 0) {
int *val = arg;
*val = SvIV(SvRV(saved_args[n]));
} else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
GList **ret = arg;
GList *out = NULL;
void *val;
int count;
av = (AV *) SvRV(saved_args[n]);
count = av_len(av);
while (count-- >= 0) {
sv = av_shift(av);
if (SvPOKp(sv))
val = g_strdup(SvPV_nolen(sv));
else
val = GINT_TO_POINTER(SvIV(sv));
out = g_list_append(out, val);
}
if (strcmp(rec->args[n]+9, "char*") == 0)
g_list_foreach(*ret, (GFunc) g_free, NULL);
g_list_free(*ret);
*ret = out;
}
}
FREETMPS;
LEAVE;
}
// 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)) {
int RPerl_SvPOKp(SV* input_sv) { return(SvPOKp(input_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;
}
