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