SV *radio_get_status() { have_status = dp_conc_q_rstat_try_pop_all(&_dsp_chain_rstat_queue,&lrstat); float angle, angle_lpf; HV *hash; hash = newHV(); hv_stores(hash,"have_status",newSViv(have_status)); if (have_status) { ___PERL_INSERT_HASH_COPYING_lrstat angle = 30.0 * lrstat.phase_diff; angle_lpf = 30.0 * lrstat.phase_diff_lpf; angle *= 360.0; angle_lpf *= 360.0; angle += _main_radial_calibrate; angle_lpf += _main_radial_calibrate; angle = (angle < 0) ? angle + 360.0 : (angle > 360) ? angle - 360.0 : angle; angle_lpf = (angle_lpf < 0) ? angle_lpf + 360.0 : (angle_lpf > 360) ? angle_lpf - 360.0 : angle_lpf; hv_stores(hash,"angle", newSVnv(angle)); hv_stores(hash,"angle_lpf",newSVnv(angle_lpf)); char a_bit = 0; id_instr[0] = 0; while (dp_conc_q_char_try_pop(&_dsp_chain_id_text_queue, &a_bit)) { int l = strlen(id_instr); id_instr[l] = a_bit; id_instr[l+1] = 0; } hv_stores(hash,"id_instr",newSVpv(id_instr,strlen(id_instr))); id_instr[0] = 0; } return newRV_noinc((SV *)hash); }
SV * Drawable_get_font_abc( Handle self, int first, int last, Bool unicode) { int i; AV * av; PFontABC abc; if ( first < 0) first = 0; if ( last < 0) last = 255; if ( !unicode) { if ( first > 255) first = 255; if ( last > 255) last = 255; } if ( first > last) abc = nil; else { gpARGS; gpENTER( newRV_noinc(( SV *) newAV())); abc = apc_gp_get_font_abc( self, first, last, unicode ); gpLEAVE; } av = newAV(); if ( abc != nil) { for ( i = 0; i <= last - first; i++) { av_push( av, newSVnv( abc[ i]. a)); av_push( av, newSVnv( abc[ i]. b)); av_push( av, newSVnv( abc[ i]. c)); } free( abc); } return newRV_noinc(( SV *) av); }
SV *radio_get_fft() { HV *hash; uint32_t i; uint32_t sr, fr; have_fft = dp_conc_q_peaks_try_pop_all(&_dsp_chain_peaks_queue,&pts); hash = newHV(); hv_stores(hash,"have_fft",newSViv(have_fft)); if (have_fft) { ___PERL_INSERT_HASH_COPYING_pts AV *av; av = newAV(); sr = _main_sample_rate; fr = _main_freq; /* dp_radio2832_dev_cmd(radio,GT_SR,&sr); dp_radio2832_dev_cmd(radio,GT_FREQ,&fr); */ for (i=0;i<pts.actpts;i++) { HV *h2; float f; h2 = newHV(); hv_stores(h2,"index",newSViv(pts.points[i]->bin)); hv_stores(h2,"dB",newSVnv(pts.points[i]->db)); hv_stores(h2,"abs",newSVnv(pts.points[i]->abs)); f = (float)pts.points[i]->bin / (float)pts.length; f *= (float)sr; f -= 0.5 * (float)sr; f += (float)fr; hv_stores(h2,"f",newSVnv(f)); av_push(av,newRV_noinc((SV *)h2)); } hv_stores(hash,"points",newRV_noinc((SV *)av)); } return newRV_noinc((SV *)hash); }
SV* Pointf::to_SV_pureperl() const { AV* av = newAV(); av_fill(av, 1); av_store(av, 0, newSVnv(this->x)); av_store(av, 1, newSVnv(this->y)); return newRV_noinc((SV*)av); }
void unpack1D ( SV* arg, void * var, char packtype, int n ) { /* n is the size of array var[] (n=1 for 1 element, etc.) If n=0 take var[] as having the same dimension as array referenced by arg */ int* ivar = NULL; float* fvar = NULL; double* dvar = NULL; short* svar = NULL; unsigned char* uvar = NULL; AV* array; I32 i,m; /* Note in ref to scalar case data is already changed */ if (is_scalar_ref(arg)) /* Do nothing */ return; if (packtype!='f' && packtype!='i' && packtype!= 'd' && packtype!='u' && packtype!='s') Perl_croak(aTHX_ "Programming error: invalid type conversion specified to unpack1D"); m=n; array = coerce1D( arg, m ); /* Get array ref and coerce */ if (m==0) m = av_len( array )+1; if (packtype=='i') /* Cast void array var[] to appropriate type */ ivar = (int *) var; if (packtype=='f') fvar = (float *) var; if (packtype=='d') dvar = (double *) var; if (packtype=='u') uvar = (unsigned char *) var; if (packtype=='s') svar = (short *) var; /* Unpack into the array */ for(i=0; i<m; i++) { if (packtype=='i') av_store( array, i, newSViv( (IV)ivar[i] ) ); if (packtype=='f') av_store( array, i, newSVnv( (double)fvar[i] ) ); if (packtype=='d') av_store( array, i, newSVnv( (double)dvar[i] ) ); if (packtype=='u') av_store( array, i, newSViv( (IV)uvar[i] ) ); if (packtype=='s') av_store( array, i, newSViv( (IV)svar[i] ) ); } return; }
/* Run a query and return a list of ranked results. * Call this from Perl like `$index->fetch(['water', 'jar'])`. The result * will be an arrayref, with each entry of it being an arrayref of the form * [id, rank]. They will be sorted by their rank in descending order, so the * most relevant document will be at the top. */ SV* fetch(SV* tokens) const { AV* av = reinterpret_cast<AV*>(SvRV(tokens)); std::unordered_map<std::string, int> query; for (int i = 0; i <= av_top_index(av); ++i) { std::string token = string_from_sv(*av_fetch(av, i, 0)); ++query[token]; } AV* results = newAV(); for (const auto& id2rank : search(query)) { AV* entry = newAV(); double length = lengths.find(id2rank.first)->second; av_push(entry, newSViv(id2rank.first)); av_push(entry, newSVnv(id2rank.second / length)); av_push(results, newRV_noinc(reinterpret_cast<SV*>(entry))); } sortsv(AvARRAY(results), av_top_index(results) + 1, sort_ratings); return newRV_noinc(reinterpret_cast<SV*>(results)); }
static void _parse_wav_peak(ScanData s, Buffer *buf, uint32_t chunk_size, uint8_t big_endian) { uint16_t channels = 0; AV *peaklist = newAV(); SV **entry = my_hv_fetch( info, "channels" ); if ( entry != NULL ) { channels = SvIV(*entry); } // Skip version/timestamp buffer_consume(buf, 8); while ( channels-- ) { HV *peak = newHV(); my_hv_store( peak, "value", newSVnv( big_endian ? buffer_get_float32(buf) : buffer_get_float32_le(buf) ) ); my_hv_store( peak, "position", newSVuv( big_endian ? buffer_get_int(buf) : buffer_get_int_le(buf) ) ); av_push( peaklist, newRV_noinc( (SV *)peak) ); } my_hv_store( info, "peak", newRV_noinc( (SV *)peaklist ) ); }
static SV* _amf0_sv(amf0_data_t* data) { SV* sv = NULL; SV* svh; SV* sva; HV* hv; AV* av; int i; amf0_object_t* obj; const char* key; amf0_data_t* value; switch (data->type) { case AMF0_NUMBER: sv = newSVnv(((amf0_number_t*)data)->value); break; case AMF0_BOOLEAN: sv = newSViv(((amf0_boolean_t*)data)->value); break; case AMF0_STRING: sv = newSV(0); sv_setpv(sv, ((amf0_string_t*)data)->value); break; case AMF0_OBJECT: hv = newHV(); obj = (amf0_object_t*)data; for (i = 0; i < obj->used; ++i) { key = obj->data[i]->key; value = obj->data[i]->value; svh = _amf0_sv(value); hv_store(hv, key, strlen(key), svh, 0); } sv = newRV(sv_2mortal((SV*)hv)); break; case AMF0_NULL: case AMF0_UNDEFINED: sv = newSV(0); break; case AMF0_STRICTARRAY: av = newAV(); for (i = 0; i < ((amf0_strictarray_t*)data)->used; ++i) { sva = _amf0_sv(((amf0_strictarray_t*)data)->data[i]); av_push(av, sva); } sv = newRV(sv_2mortal((SV *)av)); break; default: Perl_croak(aTHX_ "Unsupported datatype: %d\n", data->type); break; } return sv; }
SV* _org_warhound_mdi_Date2SV(CFTypeRef attrItem) { /* 978307200 is the number of seconds between 01 Jan 1970 GMT (the * Unix/Perl epoch) and 01 Jan 2001 GMT (the Core Foundation epoch) */ double perltime = 978307200; perltime += CFDateGetAbsoluteTime(attrItem); return newSVnv(perltime); }
SV *json_to_perl_variable( json_t *json ) { json_t *tmp_json; apr_array_header_t *arr; apr_hash_index_t *idx; AV *p_array; HV *hash; int i; switch ( json->type ) { case JSON_STRING: return newSVpv( json->value.string, 0 ); break; case JSON_INTEGER: return newSViv( json->value.integer ); break; case JSON_NUMBER: return newSVnv( json->value.number ); break; case JSON_OBJECT: hash = newHV(); for ( idx = apr_hash_first( NULL, json->value.object ); idx; idx = apr_hash_next( idx ) ) { apr_hash_this( idx, NULL, NULL, (void **) &tmp_json ); (void) hv_store( hash, JSON_NAME( tmp_json ), strlen( JSON_NAME( tmp_json ) ), json_to_perl_variable( tmp_json ), 0 ); } return newRV_noinc( (SV*) hash); break; case JSON_ARRAY: arr = json->value.array; p_array = newAV(); for ( i = 0; arr && i < arr->nelts; i++ ) { tmp_json = APR_ARRAY_IDX( arr, i, json_t * ); av_push( p_array, json_to_perl_variable( tmp_json ) ); } return newRV_noinc( (SV*) p_array); break; case JSON_BOOLEAN: return ( json->value.boolean ) ? &PL_sv_yes : &PL_sv_no; break; case JSON_NULL: return newSV( 0 ); break; default: return NULL; break; } }
static void forward(pTHX_ const char *function) { dXSARGS; DWORD err = GetLastError(); Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("Win32",5), newSVnv(0.27)); SetLastError(err); SPAGAIN; PUSHMARK(SP-items); call_pv(function, GIMME_V); }
SV * newSVGdkTimeCoord(GdkTimeCoord * v) { HV * h; SV * r; if (!v) return newSVsv(&PL_sv_undef); h = newHV(); r = newRV((SV*)h); SvREFCNT_dec(h); hv_store(h, "time", 4, newSViv(v->time), 0); hv_store(h, "x", 1, newSVnv(v->x), 0); hv_store(h, "y", 1, newSVnv(v->y), 0); hv_store(h, "pressure", 8, newSVnv(v->pressure), 0); hv_store(h, "xtilt", 5, newSVnv(v->xtilt), 0); hv_store(h, "ytilt", 5, newSVnv(v->ytilt), 0); return r; }
void ffi_pl_complex_float_to_perl(SV *sv, float *ptr) { if(SvOK(sv) && sv_isobject(sv) && sv_derived_from(sv, "Math::Complex")) { /* the complex variable is a Math::Complex object */ set(sv, sv_2mortal(newSVnv(ptr[0])), 0); set(sv, sv_2mortal(newSVnv(ptr[1])), 1); } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) { /* the compex variable is already an array */ AV *av = (AV*) SvRV(sv); av_store(av, 0, newSVnv(ptr[0])); av_store(av, 1, newSVnv(ptr[1])); } else { /* the complex variable is something else and an array needs to be created */ SV *values[2]; AV *av; values[0] = newSVnv(ptr[0]); values[1] = newSVnv(ptr[1]); av = av_make(2, values); sv_setsv(sv, newRV_noinc((SV*)av)); } }
inline SV *valdata(db_val_t* val) { SV *data = &PL_sv_undef; const char* stringval; switch(VAL_TYPE(val)) { case DB1_INT: data = newSViv(VAL_INT(val)); break; case DB1_BIGINT: LM_ERR("BIGINT not supported"); data = &PL_sv_undef; break; case DB1_DOUBLE: data = newSVnv(VAL_DOUBLE(val)); break; case DB1_STRING: stringval = VAL_STRING(val); if (strlen(stringval) > 0) data = newSVpv(stringval, strlen(stringval)); else data = &PL_sv_undef; break; case DB1_STR: if (VAL_STR(val).len > 0) data = newSVpv(VAL_STR(val).s, VAL_STR(val).len); else data = &PL_sv_undef; break; case DB1_DATETIME: data = newSViv((unsigned int)VAL_TIME(val)); break; case DB1_BLOB: if (VAL_BLOB(val).len > 0) data = newSVpv(VAL_BLOB(val).s, VAL_BLOB(val).len); else data = &PL_sv_undef; break; case DB1_BITMAP: data = newSViv(VAL_BITMAP(val)); break; } return data; }
SV* newSVidc(const idc_value_t* val) { switch(val->vtype) { case VT_STR: return newSVpv(val->str, 0); case VT_LONG: return newSViv(val->num); case VT_FLOAT: double nv; ph.realcvt(&nv, const_cast<ushort*>(val->e), 13); return newSVnv(nv); } // ... error: invalid vtype return NULL; }
SV* perl_sv(VCSI_CONTEXT vc, VCSI_OBJECT x) { /* basic type handling */ if(TYPEP(x,LNGNUM)) return newSViv(LNGN(x)); else if(TYPEP(x,FLTNUM)) return newSVnv(FLTN(x)); else if(TYPEP(x,STRING)) return newSVpvn(STR(x),SLEN(x)); /* everything else */ return Nullsv; }
SV *radio_get_fft() { have_fft = _dsp_chain_peaks_queue.try_pop_all(pts); HV *hash; hash = newHV(); hv_stores(hash,"have_fft",newSViv(have_fft)); if (have_fft) { ___PERL_INSERT_HASH_COPYING_pts AV *av; av = newAV(); for (uint32_t i=0;i<pts.points.size();i++) { HV *h2; h2 = newHV(); hv_stores(h2,"index",newSViv(pts.points[i].bin)); hv_stores(h2,"dB",newSVnv(pts.points[i].db)); av_push(av,newRV_noinc((SV *)h2)); } hv_stores(hash,"points",newRV_noinc((SV *)av)); } return newRV_noinc((SV *)hash); };
static SV * list_item_to_sv ( xchat_list *list, const char *const *fields ) { HV *hash = newHV(); SV *field_value; const char *field; int field_index = 0; const char *field_name; int name_len; while (fields[field_index] != NULL) { field_name = fields[field_index] + 1; name_len = strlen (field_name); switch (fields[field_index][0]) { case 's': field = xchat_list_str (ph, list, field_name); if (field != NULL) { field_value = newSVpvn (field, strlen (field)); } else { field_value = &PL_sv_undef; } break; case 'p': field_value = newSViv (PTR2IV (xchat_list_str (ph, list, field_name))); break; case 'i': field_value = newSVuv (xchat_list_int (ph, list, field_name)); break; case 't': field_value = newSVnv (xchat_list_time (ph, list, field_name)); break; default: field_value = &PL_sv_undef; } hv_store (hash, field_name, name_len, field_value, 0); field_index++; } return sv_2mortal (newRV_noinc ((SV *) hash)); }
static SV * tn_decode_payload(char *const encoded, STRLEN length, enum tn_type type) { SV *decoded = NULL; /* Everything in between is the body */ switch(type) { case tn_type_array: decoded = tn_decode_array(encoded, length); break; case tn_type_bool: if(strncmp(encoded, "true", 4) == 0) { decoded = &PL_sv_yes; } else if(strncmp(encoded, "false", 5) == 0) { decoded = &PL_sv_no; } else { croak("expected \"true\" or \"false\" but got \"%s\"", encoded); } break; case tn_type_float: decoded = newSVnv(atof(encoded)); break; case tn_type_hash: decoded = tn_decode_hash(encoded, length); break; case tn_type_null: decoded = &PL_sv_undef; break; case tn_type_integer: decoded = newSViv(atoi(encoded)); break; case tn_type_bytestring: decoded = newSVpvn(encoded, length); break; default: croak("invalid date type '%c'", type); } return decoded; }
SV * PrimJSVALToSV( pTHX_ JSContext *cx, jsval v ) { SV *sv = NULL; if(JSVAL_IS_NULL(v) || JSVAL_IS_VOID(v)) sv = newSV(0); else if(JSVAL_IS_BOOLEAN(v)) { sv = newSV(0); sv_setref_iv(sv, PJS_BOOLEAN, (IV)JSVAL_TO_BOOLEAN(v)); } else if(JSVAL_IS_INT(v)) sv = newSViv((IV)JSVAL_TO_INT(v)); else if(JSVAL_IS_DOUBLE(v)) sv = newSVnv(*JSVAL_TO_DOUBLE(v)); else if(JSVAL_IS_STRING(v)) sv = PJS_JSString2SV(aTHX_ JSVAL_TO_STRING(v)); else croak("PJS_Assert: Unknown primitive type"); return sv; }
const Number::Temp Interpreter::value_of(double value) const { return Number::Temp(raw_interp.get(), newSVnv(value), true); }
const char * _munpack_item(const char *p, size_t len, SV **res, HV *ext, int utf) { if (!len || !p) croak("Internal error: out of pointer"); const char *pe = p + len; switch(mp_typeof(*p)) { case MP_UINT: *res = newSViv( mp_decode_uint(&p) ); break; case MP_INT: *res = newSViv( mp_decode_int(&p) ); break; case MP_FLOAT: *res = newSVnv( mp_decode_float(&p) ); break; case MP_DOUBLE: *res = newSVnv( mp_decode_double(&p) ); break; case MP_STR: { const char *s; uint32_t len; s = mp_decode_str(&p, &len); *res = newSVpvn_flags(s, len, utf ? SVf_UTF8 : 0); break; } case MP_NIL: { mp_decode_nil(&p); *res = newSV(0); break; } case MP_BOOL: if (mp_decode_bool(&p)) { *res = newSViv(1); } else { *res = newSViv(0); } break; case MP_MAP: { uint32_t l, i; l = mp_decode_map(&p); HV * h = newHV(); sv_2mortal((SV *)h); for (i = 0; i < l; i++) { SV *k = 0; SV *v = 0; if (p >= pe) croak("Unexpected EOF msgunpack str"); p = _munpack_item(p, pe - p, &k, ext, utf); sv_2mortal(k); if (p >= pe) croak("Unexpected EOF msgunpack str"); p = _munpack_item(p, pe - p, &v, ext, utf); hv_store_ent(h, k, v, 0); } *res = newRV((SV *)h); break; } case MP_ARRAY: { uint32_t l, i; l = mp_decode_array(&p); AV *a = newAV(); sv_2mortal((SV *)a); for (i = 0; i < l; i++) { SV *item = 0; if (p >= pe) croak("Unexpected EOF msgunpack str"); p = _munpack_item(p, pe - p, &item, ext, utf); av_push(a, item); } *res = newRV((SV *)a); break; } case MP_EXT: { croak("Isn't defined yet"); } default: croak("Unexpected symbol 0x%02x", 0xFF & (int)(*p)); } return p; }
// 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)) {
SV * newSVGdkEvent(GdkEvent * e) { HV * h; GdkEvent * e2; SV * r; int n; if (!e) return newSVsv(&PL_sv_undef); h = newHV(); /*r = newSVMiscRef(e, "Gtk::Gdk::Event", &n);*/ /*h = (HV*)SvRV(r);*/ r = newRV((SV*)h); SvREFCNT_dec(h); sv_bless(r, gv_stashpv("Gtk::Gdk::Event", FALSE)); e2 = gdk_event_copy(e); hv_store(h, "_ptr", 4, newSViv((int)e2), 0); /*printf("Turning GdkEvent %d, type %d, into SV %d, ptr %d\n", e, e->type, r, e2);*/ hv_store(h, "type", 4, newSVGdkEventType(e->type), 0); hv_store(h, "window", 6, newSVGdkWindow(e->any.window), 0); switch (e->type) { case GDK_EXPOSE: hv_store(h, "area", 4, newSVGdkRectangle(&e->expose.area), 0); hv_store(h, "count", 5, newSViv(e->expose.count), 0); break; case GDK_MOTION_NOTIFY: hv_store(h, "is_hint", 7, newSViv(e->motion.is_hint), 0); hv_store(h, "x", 1, newSVnv(e->motion.x), 0); hv_store(h, "y", 1, newSVnv(e->motion.y), 0); hv_store(h, "pressure", 8, newSVnv(e->motion.pressure), 0); hv_store(h, "xtilt", 5, newSVnv(e->motion.xtilt), 0); hv_store(h, "ytilt", 5, newSVnv(e->motion.ytilt), 0); hv_store(h, "time", 4, newSViv(e->motion.time), 0); hv_store(h, "state", 5, newSViv(e->motion.state), 0); hv_store(h, "source", 6, newSVGdkInputSource(e->motion.source), 0); hv_store(h, "deviceid", 8, newSViv(e->motion.deviceid), 0); break; case GDK_BUTTON_PRESS: case GDK_2BUTTON_PRESS: case GDK_3BUTTON_PRESS: case GDK_BUTTON_RELEASE: hv_store(h, "x", 1, newSViv(e->button.x), 0); hv_store(h, "y", 1, newSViv(e->button.y), 0); hv_store(h, "time", 4, newSViv(e->button.time), 0); hv_store(h, "pressure", 8, newSVnv(e->motion.pressure), 0); hv_store(h, "xtilt", 5, newSVnv(e->motion.xtilt), 0); hv_store(h, "ytilt", 5, newSVnv(e->motion.ytilt), 0); hv_store(h, "state", 5, newSViv(e->button.state), 0); hv_store(h, "button", 6, newSViv(e->button.button), 0); hv_store(h, "source", 6, newSVGdkInputSource(e->motion.source), 0); hv_store(h, "deviceid", 8, newSViv(e->motion.deviceid), 0); break; case GDK_KEY_PRESS: case GDK_KEY_RELEASE: hv_store(h, "time", 4, newSViv(e->key.time), 0); hv_store(h, "state", 5, newSViv(e->key.state), 0); hv_store(h, "keyval", 6, newSViv(e->key.keyval), 0); break; case GDK_FOCUS_CHANGE: hv_store(h, "in", 2, newSViv(e->focus_change.in), 0); break; case GDK_ENTER_NOTIFY: case GDK_LEAVE_NOTIFY: hv_store(h, "window", 6, newSVGdkWindow(e->crossing.window), 0); hv_store(h, "subwindow", 9, newSVGdkWindow(e->crossing.subwindow), 0); hv_store(h, "detail", 6, newSVGdkNotifyType(e->crossing.detail), 0); break; case GDK_CONFIGURE: hv_store(h, "x", 1, newSViv(e->configure.x), 0); hv_store(h, "y", 1, newSViv(e->configure.y), 0); hv_store(h, "width", 5, newSViv(e->configure.width), 0); hv_store(h, "height", 6, newSViv(e->configure.height), 0); break; case GDK_PROPERTY_NOTIFY: hv_store(h, "time", 4, newSViv(e->property.time), 0); hv_store(h, "state", 5, newSViv(e->property.state), 0); hv_store(h, "atom", 4, newSVGdkAtom(e->property.atom), 0); break; case GDK_SELECTION_CLEAR: case GDK_SELECTION_REQUEST: case GDK_SELECTION_NOTIFY: hv_store(h, "requestor", 9, newSViv(e->selection.requestor), 0); hv_store(h, "time", 4, newSViv(e->selection.time), 0); hv_store(h, "selection", 9, newSVGdkAtom(e->selection.selection), 0); hv_store(h, "property", 8, newSVGdkAtom(e->selection.property), 0); break; case GDK_PROXIMITY_IN: case GDK_PROXIMITY_OUT: hv_store(h, "time", 4, newSViv(e->proximity.time), 0); hv_store(h, "source", 6, newSVGdkInputSource(e->motion.source), 0); hv_store(h, "deviceid", 8, newSViv(e->motion.deviceid), 0); break; } return r; }
SV * PLCB_ioprocs_new(SV *options) { plcb_IOPROCS async_s = { NULL }, *async = NULL; lcb_io_opt_t cbcio = NULL; SV *ptriv, *blessedrv; /* First make sure all the options are ok */ plcb_OPTION argopts[] = { #define X(name, t, tgt) PLCB_KWARG(name, t, &async_s.tgt), X_IOPROCS_OPTIONS(X) #undef X { NULL } }; plcb_extract_args(options, argopts); /* Verify we have at least the basic functions */ if (!async_s.cv_evmod) { die("Need event_update"); } if (!async_s.cv_timermod) { die("Need timer_update"); } if (!async_s.userdata) { async_s.userdata = &PL_sv_undef; } Newxz(cbcio, 1, struct lcb_io_opt_st); Newxz(async, 1, plcb_IOPROCS); *async = async_s; #define X(name, t, tgt) SvREFCNT_inc(async->tgt); X_IOPROCS_OPTIONS(X) #undef X ptriv = newSViv(PTR2IV(async)); blessedrv = newRV_noinc(ptriv); sv_bless(blessedrv, gv_stashpv(PLCB_IOPROCS_CLASS, GV_ADD)); async->refcount = 1; async->iops_ptr = cbcio; cbcio->v.v0.cookie = async; async->selfrv = newRV_inc(ptriv); sv_rvweaken(async->selfrv); async->action_sv = newSViv(0); SvREADONLY_on(async->action_sv); async->flags_sv = newSViv(0); SvREADONLY_on(async->flags_sv); async->usec_sv = newSVnv(0); SvREADONLY_on(async->usec_sv); async->sched_r_sv = newSViv(0); SvREADONLY_on(async->sched_r_sv); async->sched_w_sv = newSViv(0); SvREADONLY_on(async->sched_w_sv); async->stop_r_sv = newSViv(0); SvREADONLY_on(async->stop_r_sv); async->stop_w_sv = newSViv(0); SvREADONLY_on(async->stop_w_sv); /* i/o events */ cbcio->v.v0.create_event = create_event; cbcio->v.v0.destroy_event = destroy_event; cbcio->v.v0.update_event = update_event; cbcio->v.v0.delete_event = delete_event; /* timer events */ cbcio->v.v0.create_timer = create_timer; cbcio->v.v0.destroy_timer = destroy_event; cbcio->v.v0.delete_timer = delete_timer; cbcio->v.v0.update_timer = update_timer; wire_lcb_bsd_impl(cbcio); cbcio->v.v0.run_event_loop = startstop_dummy; cbcio->v.v0.stop_event_loop = startstop_dummy; cbcio->v.v0.need_cleanup = 0; /* Now all we need to do is return the blessed reference */ return blessedrv; }
SV* _org_warhound_mdi_Number2SV(CFTypeRef attrItem) { double thisnv; /* FIXME: Error check? What to do if it fails? */ CFNumberGetValue(attrItem, kCFNumberDoubleType, &thisnv); return newSVnv(thisnv); }
static SV * arg_to_sv (GIArgument * arg, GITypeInfo * info, GITransfer transfer, GPerlI11nInvocationInfo *iinfo) { GITypeTag tag = g_type_info_get_tag (info); gboolean own = transfer >= GI_TRANSFER_CONTAINER; dwarn (" arg_to_sv: info %p with type tag %d (%s)\n", info, tag, g_type_tag_to_string (tag)); switch (tag) { case GI_TYPE_TAG_VOID: { SV *sv = callback_data_to_sv (arg->v_pointer, iinfo); dwarn (" argument with no type information -> %s\n", sv ? "callback data" : "undef"); return sv ? SvREFCNT_inc (sv) : &PL_sv_undef; } case GI_TYPE_TAG_BOOLEAN: return boolSV (arg->v_boolean); case GI_TYPE_TAG_INT8: return newSViv (arg->v_int8); case GI_TYPE_TAG_UINT8: return newSVuv (arg->v_uint8); case GI_TYPE_TAG_INT16: return newSViv (arg->v_int16); case GI_TYPE_TAG_UINT16: return newSVuv (arg->v_uint16); case GI_TYPE_TAG_INT32: return newSViv (arg->v_int32); case GI_TYPE_TAG_UINT32: return newSVuv (arg->v_uint32); case GI_TYPE_TAG_INT64: return newSVGInt64 (arg->v_int64); case GI_TYPE_TAG_UINT64: return newSVGUInt64 (arg->v_uint64); case GI_TYPE_TAG_FLOAT: return newSVnv (arg->v_float); case GI_TYPE_TAG_DOUBLE: return newSVnv (arg->v_double); case GI_TYPE_TAG_UNICHAR: { SV *sv; gchar buffer[6]; gint length = g_unichar_to_utf8 (arg->v_uint32, buffer); sv = newSVpv (buffer, length); SvUTF8_on (sv); return sv; } case GI_TYPE_TAG_GTYPE: { /* GType == gsize */ const char *package = gperl_package_from_type (arg->v_size); if (!package) package = g_type_name (arg->v_size); return newSVpv (package, PL_na); } case GI_TYPE_TAG_ARRAY: return array_to_sv (info, arg->v_pointer, transfer, iinfo); case GI_TYPE_TAG_INTERFACE: return interface_to_sv (info, arg, own, iinfo); case GI_TYPE_TAG_GLIST: case GI_TYPE_TAG_GSLIST: return glist_to_sv (info, arg->v_pointer, transfer); case GI_TYPE_TAG_GHASH: return ghash_to_sv (info, arg->v_pointer, transfer); case GI_TYPE_TAG_ERROR: ccroak ("FIXME - GI_TYPE_TAG_ERROR"); break; case GI_TYPE_TAG_UTF8: { SV *sv = newSVGChar (arg->v_string); if (own) g_free (arg->v_string); return sv; } case GI_TYPE_TAG_FILENAME: { SV *sv = newSVpv (arg->v_string, PL_na); if (own) g_free (arg->v_string); return sv; } default: ccroak ("Unhandled info tag %d in arg_to_sv", tag); } return NULL; }
SV *p5_float_to_sv(PerlInterpreter *my_perl, MYNV value) { PERL_SET_CONTEXT(my_perl); return newSVnv((NV)value); }
lucy_HitDoc* lucy_DefDocReader_fetch_doc(lucy_DefaultDocReader *self, int32_t doc_id) { lucy_Schema *const schema = self->schema; lucy_InStream *const dat_in = self->dat_in; lucy_InStream *const ix_in = self->ix_in; HV *fields = newHV(); int64_t start; uint32_t num_fields; SV *field_name_sv = newSV(1); // Get data file pointer from index, read number of fields. Lucy_InStream_Seek(ix_in, (int64_t)doc_id * 8); start = Lucy_InStream_Read_U64(ix_in); Lucy_InStream_Seek(dat_in, start); num_fields = Lucy_InStream_Read_C32(dat_in); // Decode stored data and build up the doc field by field. while (num_fields--) { STRLEN field_name_len; char *field_name_ptr; SV *value_sv; lucy_FieldType *type; // Read field name. field_name_len = Lucy_InStream_Read_C32(dat_in); field_name_ptr = SvGROW(field_name_sv, field_name_len + 1); Lucy_InStream_Read_Bytes(dat_in, field_name_ptr, field_name_len); SvPOK_on(field_name_sv); SvCUR_set(field_name_sv, field_name_len); SvUTF8_on(field_name_sv); *SvEND(field_name_sv) = '\0'; // Find the Field's FieldType. lucy_ZombieCharBuf *field_name_zcb = CFISH_ZCB_WRAP_STR(field_name_ptr, field_name_len); Lucy_ZCB_Assign_Str(field_name_zcb, field_name_ptr, field_name_len); type = Lucy_Schema_Fetch_Type(schema, (lucy_CharBuf*)field_name_zcb); // Read the field value. switch (Lucy_FType_Primitive_ID(type) & lucy_FType_PRIMITIVE_ID_MASK) { case lucy_FType_TEXT: { STRLEN value_len = Lucy_InStream_Read_C32(dat_in); value_sv = newSV((value_len ? value_len : 1)); Lucy_InStream_Read_Bytes(dat_in, SvPVX(value_sv), value_len); SvCUR_set(value_sv, value_len); *SvEND(value_sv) = '\0'; SvPOK_on(value_sv); SvUTF8_on(value_sv); break; } case lucy_FType_BLOB: { STRLEN value_len = Lucy_InStream_Read_C32(dat_in); value_sv = newSV((value_len ? value_len : 1)); Lucy_InStream_Read_Bytes(dat_in, SvPVX(value_sv), value_len); SvCUR_set(value_sv, value_len); *SvEND(value_sv) = '\0'; SvPOK_on(value_sv); break; } case lucy_FType_FLOAT32: value_sv = newSVnv(Lucy_InStream_Read_F32(dat_in)); break; case lucy_FType_FLOAT64: value_sv = newSVnv(Lucy_InStream_Read_F64(dat_in)); break; case lucy_FType_INT32: value_sv = newSViv((int32_t)Lucy_InStream_Read_C32(dat_in)); break; case lucy_FType_INT64: if (sizeof(IV) == 8) { int64_t val = (int64_t)Lucy_InStream_Read_C64(dat_in); value_sv = newSViv((IV)val); } else { // (lossy) int64_t val = (int64_t)Lucy_InStream_Read_C64(dat_in); value_sv = newSVnv((double)val); } break; default: value_sv = NULL; CFISH_THROW(LUCY_ERR, "Unrecognized type: %o", type); } // Store the value. (void)hv_store_ent(fields, field_name_sv, value_sv, 0); } SvREFCNT_dec(field_name_sv); lucy_HitDoc *retval = lucy_HitDoc_new(fields, doc_id, 0.0); SvREFCNT_dec((SV*)fields); return retval; }
void FCN(int* npar,double* grad,double* fval,double* xval,int* iflag,double* futil){ SV* funname; int count,i; double* x; I32 ax ; pdl* pgrad; SV* pgradsv; pdl* pxval; SV* pxvalsv; int ndims; PDL_Indx *pdims; dSP; ENTER; SAVETMPS; /* get name of function on the Perl side */ funname = mnfunname; ndims = 1; pdims = (PDL_Indx *) PDL->smalloc( (STRLEN) ((ndims) * sizeof(*pdims)) ); pdims[0] = (PDL_Indx) ene; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("PDL", 0))); PUTBACK; perl_call_method("initialize", G_SCALAR); SPAGAIN; pxvalsv = POPs; PUTBACK; pxval = PDL->SvPDLV(pxvalsv); PDL->converttype( &pxval, PDL_D, PDL_PERM ); PDL->children_changesoon(pxval,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED); PDL->setdims (pxval,pdims,ndims); pxval->state &= ~PDL_NOMYDIMS; pxval->state |= PDL_ALLOCATED | PDL_DONTTOUCHDATA; PDL->changed(pxval,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED,0); PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("PDL", 0))); PUTBACK; perl_call_method("initialize", G_SCALAR); SPAGAIN; pgradsv = POPs; PUTBACK; pgrad = PDL->SvPDLV(pgradsv); PDL->converttype( &pgrad, PDL_D, PDL_PERM ); PDL->children_changesoon(pgrad,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED); PDL->setdims (pgrad,pdims,ndims); pgrad->state &= ~PDL_NOMYDIMS; pgrad->state |= PDL_ALLOCATED | PDL_DONTTOUCHDATA; PDL->changed(pgrad,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED,0); pxval->data = (void *) xval; pgrad->data = (void *) grad; PUSHMARK(SP); XPUSHs(sv_2mortal(newSViv(*npar))); XPUSHs(pgradsv); XPUSHs(sv_2mortal(newSVnv(*fval))); XPUSHs(pxvalsv); XPUSHs(sv_2mortal(newSViv(*iflag))); PUTBACK; count=call_sv(funname,G_ARRAY); SPAGAIN; SP -= count ; ax = (SP - PL_stack_base) + 1 ; if (count!=2) croak("error calling perl function\n"); pgradsv = ST(1); pgrad = PDL->SvPDLV(pgradsv); x = (double *) pgrad->data; for(i=0;i<ene;i++) grad[i] = x[i]; *fval = SvNV(ST(0)); PUTBACK; FREETMPS; LEAVE; }