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; }