/*
* convert partition_info_t to perl HV
*/
int
partition_info_to_hv(partition_info_t *part_info, HV *hv)
{
if (part_info->allow_alloc_nodes)
STORE_FIELD(hv, part_info, allow_alloc_nodes, charp);
if (part_info->allow_groups)
STORE_FIELD(hv, part_info, allow_groups, charp);
if (part_info->alternate)
STORE_FIELD(hv, part_info, alternate, charp);
if (part_info->cr_type)
STORE_FIELD(hv, part_info, cr_type, uint16_t);
if (part_info->def_mem_per_cpu)
STORE_FIELD(hv, part_info, def_mem_per_cpu, uint32_t);
STORE_FIELD(hv, part_info, default_time, uint32_t);
if (part_info->deny_accounts)
STORE_FIELD(hv, part_info, deny_accounts, charp);
if (part_info->deny_qos)
STORE_FIELD(hv, part_info, deny_qos, charp);
STORE_FIELD(hv, part_info, flags, uint16_t);
if (part_info->grace_time)
STORE_FIELD(hv, part_info, grace_time, uint32_t);
if (part_info->max_cpus_per_node)
STORE_FIELD(hv, part_info, max_cpus_per_node, uint32_t);
if (part_info->max_mem_per_cpu)
STORE_FIELD(hv, part_info, max_mem_per_cpu, uint32_t);
STORE_FIELD(hv, part_info, max_nodes, uint32_t);
STORE_FIELD(hv, part_info, max_share, uint16_t);
STORE_FIELD(hv, part_info, max_time, uint32_t);
STORE_FIELD(hv, part_info, min_nodes, uint32_t);
if (part_info->name)
STORE_FIELD(hv, part_info, name, charp);
else {
Perl_warn(aTHX_ "partition name missing in partition_info_t");
return -1;
}
/* no store for int pointers yet */
if (part_info->node_inx) {
int j;
AV* av = newAV();
for(j = 0; ; j += 2) {
if(part_info->node_inx[j] == -1)
break;
av_store(av, j, newSVuv(part_info->node_inx[j]));
av_store(av, j+1, newSVuv(part_info->node_inx[j+1]));
}
hv_store_sv(hv, "node_inx", newRV_noinc((SV*)av));
}
if (part_info->nodes)
STORE_FIELD(hv, part_info, nodes, charp);
STORE_FIELD(hv, part_info, preempt_mode, uint16_t);
STORE_FIELD(hv, part_info, priority, uint16_t);
if (part_info->qos_char)
STORE_FIELD(hv, part_info, qos_char, charp);
STORE_FIELD(hv, part_info, state_up, uint16_t);
STORE_FIELD(hv, part_info, total_cpus, uint32_t);
STORE_FIELD(hv, part_info, total_nodes, uint32_t);
return 0;
}
static html_valid_status_t
html_valid_tag_information (HV * hv)
{
int i;
// n_html_tags is defined in html-tidy5.h as part of the "extra"
// material.
html_valid_tag_t tags[n_html_tags];
TagInformation (tags);
for (i = 0; i < n_html_tags; i++) {
int name_len;
AV * constants;
SV * constants_ref;
constants = newAV ();
// Store the ID for reverse lookup of attributes.
av_push (constants, newSVuv (i));
av_push (constants, newSVuv (tags[i].versions));
av_push (constants, newSVuv (tags[i].model));
constants_ref = newRV_inc ((SV *) constants);
name_len = strlen (tags[i].name);
/*
fprintf (stderr, "Storing %s (%d) into hash.\n",
tags[i].name, name_len);
*/
(void) hv_store (hv, tags[i].name, name_len, constants_ref, 0 /* no hash value */);
}
return html_valid_ok;
}
void
__getdns_callback(Net__GetDNS__XS__Context * context,
getdns_callback_type_t callback_type, Net__GetDNS__XS__Dict * response,
void * userarg, getdns_transaction_t transaction_id)
{
dSP;
struct __callback * cb;
if (!userarg) return;
cb = (struct __callback *)userarg;
if (!cb->callbackfn) return;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(sv_setref_pv(newSV(0), "Net::GetDNS::XS::ContextPtr", (void *)context)));
XPUSHs(sv_2mortal(newSVuv(callback_type)));
XPUSHs(sv_2mortal(sv_setref_pv(newSV(0), "Net::GetDNS::XS::DictPtr", (void *)response)));
XPUSHs(sv_2mortal(newSVsv(cb->userarg)));
XPUSHs(sv_2mortal(newSVuv(transaction_id)));
PUTBACK;
call_sv((SV*)(cb->callbackfn), G_VOID);
FREETMPS;
LEAVE;
SvREFCNT_dec(cb->callbackfn);
Safefree(cb);
}
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 ) );
}
SV *
PLCB__viewhandle_new(PLCB_t *parent,
const char *ddoc, const char *view, const char *options, int flags)
{
AV *req = NULL;
SV *blessed;
lcb_CMDVIEWQUERY cmd = { 0 };
lcb_VIEWHANDLE vh = NULL;
lcb_error_t rc;
req = newAV();
rowreq_init_common(parent, req);
blessed = newRV_noinc((SV*)req);
sv_bless(blessed, parent->view_stash);
lcb_view_query_initcmd(&cmd, ddoc, view, options, viewrow_callback);
cmd.cmdflags = flags; /* Trust lcb on this */
cmd.handle = &vh;
rc = lcb_view_query(parent->instance, req, &cmd);
if (rc != LCB_SUCCESS) {
SvREFCNT_dec(blessed);
die("Couldn't issue view query: (0x%x): %s", rc, lcb_strerror(NULL, rc));
} else {
SvREFCNT_inc(req); /* For the callback */
av_store(req, PLCB_VHIDX_VHANDLE, newSVuv(PTR2UV(vh)));
}
return blessed;
}
static inline void attr_delete_from_vhash(SV *self, SV *value)
{
hrattr_simple *attr = attr_from_sv(SvRV((self)));
//UN_del_action(value, SvRV(self));
SV *vaddr = newSVuv((UV)SvRV(value));
SV *rlookup;
SV *vhash;
char *astr = attr_strkey(attr, attr_getsize(attr));
get_hashes((HR_Table_t)attr_parent_tbl(attr),
HR_HKEY_LOOKUP_REVERSE, &rlookup, HR_HKEY_LOOKUP_NULL);
vhash = get_vhash_from_rlookup(rlookup, vaddr, 0);
U32 old_refcount = refcnt_ka_begin(value);
if(vhash) {
HR_DEBUG("vhash has %d keys", HvKEYS(REF2HASH(vhash)));
HR_DEBUG("Deleting '%s' from vhash=%p", astr, SvRV(vhash));
hv_delete(REF2HASH(vhash), astr, strlen(astr), G_DISCARD);
if(!HvKEYS(REF2HASH(vhash))) {
HR_DEBUG("Vhash empty");
HR_PL_del_action_container(value, rlookup);
hv_delete_ent(REF2HASH(rlookup), vaddr, G_DISCARD, 0);
} else {
HR_DEBUG("Vhash still has %d keys", HvKEYS(REF2HASH(vhash)));
}
}
refcnt_ka_end(value, old_refcount);
}
static void define_symbolic_value(const char *ev_name,
const char *field_name,
const char *field_value,
const char *field_str)
{
unsigned long long value;
dSP;
value = eval_flag(field_value);
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(ev_name, 0)));
XPUSHs(sv_2mortal(newSVpv(field_name, 0)));
XPUSHs(sv_2mortal(newSVuv(value)));
XPUSHs(sv_2mortal(newSVpv(field_str, 0)));
PUTBACK;
if (get_cv("main::define_symbolic_value", 0))
call_pv("main::define_symbolic_value", G_SCALAR);
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
}
int
_wavpack_parse_sample_rate(wvpinfo *wvp, uint32_t size)
{
uint32_t samplerate = buffer_get_int24_le(wvp->buf);
my_hv_store( wvp->info, "samplerate", newSVuv(samplerate) );
return 1;
}
static void push_thread(pTHX, mthread* thread) {
{
dSP;
SV* to_push = newRV_noinc(newSVuv(thread->id));
sv_bless(to_push, gv_stashpv("threads::lite::tid", FALSE));
XPUSHs(to_push);
PUTBACK;
}
}
/*
* Return a new Catalog object - only accepts an integer catalog value.
* Use this purely for speed when creating Catalog objects from other XS code.
* All other Catalog object creation should be done with the perl new() method.
*/
SV*
new_catalog(uint32_t cat)
{
SV *iv, *ref;
iv = newSVuv(cat);
ref = newRV_noinc(iv);
sv_bless(ref, Sun_Solaris_Exacct_Catalog_stash);
SvREADONLY_on(iv);
return (ref);
}
static SV *eca_new_sv(char *name, ECAtype type, SV *value, SV *check,
bool is_ro, SV *inject) {
dTHX;
ECAslot *slot = eca_init(name, type, value, check, is_ro, inject);
SV *result_sv = newSVuv(PTR2UV(slot));
MAGIC *mg =
sv_magicext(result_sv, result_sv, PERL_MAGIC_ext, &ECA_TBL, NULL, 0);
mg->mg_flags |= MGf_DUP; // to invoke attrs_dup
return result_sv;
}
int preprocessAndRun(struct collectionFormat *collection, struct cargsF *cargs, char execute[], char *error, int errorlength) {
//antar at rutiner som ikke returnerer noe mislykkes. Dette kan for eks skje hvis vi kaller die, eller ikke trenger retur koden
char perlfile[PATH_MAX];
snprintf(perlfile,sizeof(perlfile),"%s/main.pm",collection->crawlLibInfo->resourcepath);
bblog(DEBUGINFO, "cargs %p\n",cargs);
#ifdef DEBUG
//printer ut pekere til colection info, og alle rutinene
bblog(DEBUGINFO, "collection %p, documentExist %p, documentAdd %p, documentError %p, documentContinue %p",cargs->collection,cargs->documentExist,cargs->documentAdd,cargs->documentError,cargs->documentContinue);
#endif
HV *obj_attr = newHV();
hv_store(obj_attr, "ptr", strlen("ptr"), sv_2mortal(newSViv(PTR2IV(cargs))), 0);
HV *hv = newHV();
//sendes altid med
hv_store(hv, "last_crawl", strlen("last_crawl"), sv_2mortal(newSVuv(collection->lastCrawl)), 0);
//sendes bare med hvis vi har verdi
if (collection->resource != NULL)
hv_store(hv, "resource", strlen("resource"), sv_2mortal(newSVpv(collection->resource, 0)), 0);
if (collection->connector != NULL)
hv_store(hv, "connector", strlen("connector"), sv_2mortal(newSVpv(collection->connector, 0)), 0);
if (collection->password != NULL)
hv_store(hv, "password", strlen("password"), sv_2mortal(newSVpv(collection->password, 0)), 0);
if (collection->query1 != NULL)
hv_store(hv, "query1", strlen("query1"), sv_2mortal(newSVpv(collection->query1, 0)), 0);
if (collection->query2 != NULL)
hv_store(hv, "query2", strlen("query2"), sv_2mortal(newSVpv(collection->query2, 0)), 0);
if (collection->collection_name != NULL)
hv_store(hv, "collection_name", strlen("collection_name"), sv_2mortal(newSVpv(collection->collection_name, 0)), 0);
if (collection->user != NULL)
hv_store(hv, "user", strlen("user"), sv_2mortal(newSVpv(collection->user, 0)), 0);
if (collection->userprefix != NULL)
hv_store(hv, "userprefix", strlen("userprefix"), sv_2mortal(newSVpv(collection->userprefix, 0)), 0);
if (collection->extra != NULL)
hv_store(hv, "extra", strlen("extra"), sv_2mortal(newSVpv(collection->extra, 0)), 0);
if (collection->test_file_prefix != NULL)
hv_store(hv, "test_file_prefix", strlen("test_file_prefix"), sv_2mortal(newSVpv(collection->test_file_prefix, 0)), 0);
// Add custom params to hash.
ht_to_perl_ht(hv, collection->params);
return perl_embed_run(perlfile, execute, hv, "Perlcrawl", obj_attr, error, errorlength);
}
static SV *
newSVGtkStockItem (GtkStockItem * item)
{
HV * hv = newHV();
gperl_hv_take_sv_s (hv, "stock_id", newSVGChar (item->stock_id));
gperl_hv_take_sv_s (hv, "label", newSVGChar (item->label));
gperl_hv_take_sv_s (hv, "modifier", newSVGdkModifierType (item->modifier));
gperl_hv_take_sv_s (hv, "keyval", newSVuv (item->keyval));
if (item->translation_domain)
gperl_hv_take_sv_s (hv, "translation_domain", newSVGChar (item->translation_domain));
return newRV_noinc ((SV *) hv);
}
void
_parse_aiff_comm(Buffer *buf, uint32_t chunk_size, HV *info)
{
uint16_t channels = buffer_get_short(buf);
uint32_t frames = buffer_get_int(buf);
uint16_t bits_per_sample = buffer_get_short(buf);
double samplerate = buffer_get_ieee_float(buf);
my_hv_store( info, "channels", newSVuv(channels) );
my_hv_store( info, "bits_per_sample", newSVuv(bits_per_sample) );
my_hv_store( info, "samplerate", newSVuv(samplerate) );
my_hv_store( info, "bitrate", newSVuv( samplerate * channels * bits_per_sample ) );
my_hv_store( info, "song_length_ms", newSVuv( ((frames * 1.0) / samplerate) * 1000 ) );
my_hv_store( info, "block_align", newSVuv( channels * bits_per_sample / 8 ) );
if (chunk_size > 18) {
// AIFC extra data
my_hv_store( info, "compression_type", newSVpvn( buffer_ptr(buf), 4 ) );
buffer_consume(buf, 4);
my_hv_store( info, "compression_name", newSVpvn( buffer_ptr(buf), chunk_size - 22 ) );
buffer_consume(buf, chunk_size - 22);
}
}
static void modify_timer_perl(PLCBA_t *async,
PLCBA_c_event *cevent,
uint32_t usecs,
PLCBA_evaction_t action)
{
//warn("Calling cv_timermod");
plcb_call_sv_with_args_noret(async->cv_timermod,
1,
3,
newRV_inc( (SV*)cevent->pl_event ),
newSViv(action),
newSVuv(usecs));
}
/*
* convert reserve_info_t to perl HV
*/
int
reserve_info_to_hv(reserve_info_t *reserve_info, HV *hv)
{
if (reserve_info->accounts)
STORE_FIELD(hv, reserve_info, accounts, charp);
STORE_FIELD(hv, reserve_info, end_time, time_t);
if (reserve_info->features)
STORE_FIELD(hv, reserve_info, features, charp);
STORE_FIELD(hv, reserve_info, flags, uint16_t);
if (reserve_info->licenses)
STORE_FIELD(hv, reserve_info, licenses, charp);
if (reserve_info->name)
STORE_FIELD(hv, reserve_info, name, charp);
STORE_FIELD(hv, reserve_info, node_cnt, uint32_t);
if (reserve_info->node_list)
STORE_FIELD(hv, reserve_info, node_list, charp);
/* no store for int pointers yet */
if (reserve_info->node_inx) {
int j;
AV *av = newAV();
for(j = 0; ; j += 2) {
if(reserve_info->node_inx[j] == -1)
break;
av_store(av, j, newSVuv(reserve_info->node_inx[j]));
av_store(av, j+1,
newSVuv(reserve_info->node_inx[j+1]));
}
hv_store_sv(hv, "node_inx", newRV_noinc((SV*)av));
}
if (reserve_info->partition)
STORE_FIELD(hv, reserve_info, partition, charp);
STORE_FIELD(hv, reserve_info, start_time, time_t);
if (reserve_info->users)
STORE_FIELD(hv, reserve_info, users, charp);
return 0;
}
static void
tie_it(pTHX_ const char name, UV flag, HV *const stash)
{
GV *const gv = gv_fetchpvn(&name, 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PVHV);
HV *const hv = GvHV(gv);
SV *rv = newSV_type(SVt_RV);
SvRV_set(rv, newSVuv(flag));
SvROK_on(rv);
sv_bless(rv, stash);
sv_unmagic((SV *)hv, PERL_MAGIC_tied);
sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
SvREFCNT_dec(rv); /* As sv_magic increased it by one. */
}
void
Perl_mro_register(pTHX_ const struct mro_alg *mro) {
SV *wrapper = newSVuv(PTR2UV(mro));
PERL_ARGS_ASSERT_MRO_REGISTER;
if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
mro->name, mro->length, mro->kflags,
HV_FETCH_ISSTORE, wrapper, mro->hash)) {
SvREFCNT_dec(wrapper);
Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
"for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
}
}
static inline void attr_delete_value_from_attrhash(SV *self, SV *value)
{
hrattr_simple *attr = attr_from_sv(SvRV((self)));
SV *vaddr = newSVuv((UV)SvRV(value));
SV *attrhash_ref;
RV_Newtmp(attrhash_ref, (SV*)attr->attrhash);
HR_DEBUG("Deleting action vobj=%p :: attrhash=%p",
SvRV(value), SvRV(attrhash_ref));
HR_PL_del_action_container(value, attrhash_ref);
hv_delete_ent(attr->attrhash, vaddr, G_DISCARD, 0);
RV_Freetmp(attrhash_ref);
SvREFCNT_dec(vaddr);
HR_DEBUG("Done!");
}
static void
call_helper(AV *resobj, int cbtype, const lcb_RESPBASE *resp)
{
dSP;
const char *methname;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc((SV*)resobj)));
if (cbtype == LCB_CALLBACK_STATS) {
const lcb_RESPSTATS *sresp = (const void *)resp;
/** Call as statshelper($doc,$server,$key,$value); */
XPUSHs(sv_2mortal(newSVpv(sresp->server, 0)));
XPUSHs(sv_2mortal(newSVpvn(sresp->key, sresp->nkey)));
if (sresp->value) {
XPUSHs(sv_2mortal(newSVpvn(sresp->value, sresp->nvalue)));
}
methname = PLCB_STATS_PLHELPER;
} else if (cbtype == LCB_CALLBACK_OBSERVE) {
const lcb_RESPOBSERVE *oresp = (const void *)resp;
/** Call as obshelper($doc,$status,$cas,$ismaster) */
XPUSHs(sv_2mortal(newSVuv(oresp->status)));
XPUSHs(sv_2mortal(plcb_sv_from_u64_new(&oresp->cas)));
XPUSHs(oresp->ismaster ? &PL_sv_yes : &PL_sv_no);
methname = PLCB_OBS_PLHELPER;
} else {
return;
}
PUTBACK;
call_pv(methname, G_DISCARD|G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
warn("Got error in %s: %s", methname, SvPV_nolen(ERRSV));
}
FREETMPS;
LEAVE;
}
void HRXSATTR_ithread_predup(SV *self, SV *table, HV *ptr_map)
{
hrattr_simple *attr = attr_from_sv(SvRV(self));
/*Make sure our attribute hash is visible to perl space*/
SV *attrhash_ref;
RV_Newtmp(attrhash_ref, (SV*)attr->attrhash);
hr_dup_store_rv(ptr_map, attrhash_ref);
RV_Freetmp(attrhash_ref);
char *ktmp;
I32 tmplen;
SV *vtmp;
SV *rlookup;
get_hashes(REF2TABLE(table),
HR_HKEY_LOOKUP_REVERSE, &rlookup,
HR_HKEY_LOOKUP_NULL);
hv_iterinit(attr->attrhash);
while( (vtmp = hv_iternextsv(attr->attrhash, &ktmp, &tmplen))) {
HR_Dup_Vinfo *vi = hr_dup_get_vinfo(ptr_map, SvRV(vtmp), 1);
if(!vi->vhash) {
SV *vaddr = newSVuv((UV)SvRV(vtmp));
SV *vhash = get_vhash_from_rlookup(rlookup, vaddr, 0);
vi->vhash = vhash;
SvREFCNT_dec(vaddr);
}
}
if(attr->encap) {
hrattr_encap *aencap = attr_encap_cast(attr);
hr_dup_store_rv(ptr_map, aencap->obj_rv);
char *ai = (char*)hr_dup_store_kinfo(
ptr_map, HR_DUPKEY_AENCAP, aencap->obj_paddr, 1);
if(SvWEAKREF(aencap->obj_rv)) {
*ai = HRK_DUP_WEAK_ENCAP;
} else {
*ai = 0;
}
}
}
int
_wavpack_parse_channel_info(wvpinfo *wvp, uint32_t size)
{
uint32_t channels;
unsigned char *bptr = buffer_ptr(wvp->buf);
if (size == 6) {
channels = (bptr[0] | ((bptr[2] & 0xf) << 8)) + 1;
}
else {
channels = bptr[0];
}
my_hv_store( wvp->info, "channels", newSVuv(channels) );
buffer_consume(wvp->buf, size);
return 1;
}
void store_self(pTHX, mthread* thread) {
SV *thread_sv, *self;
AV* message_cache;
thread_sv = newSV_type(SVt_PV);
SvPVX(thread_sv) = (char*) thread;
SvCUR(thread_sv) = sizeof(mthread);
SvLEN(thread_sv) = 0;
SvPOK_only(thread_sv);
SvREADONLY_on(thread_sv);
hv_store(PL_modglobal, "threads::lite::thread", 21, thread_sv, 0);
self = newRV_noinc(newSVuv(thread->id));
sv_bless(self, gv_stashpv("threads::lite::tid", TRUE));
hv_store(PL_modglobal, "threads::lite::self", 19, self, 0);
message_cache = newAV();
hv_store(PL_modglobal, "threads::lite::message_cache", 28, (SV*)message_cache, 0);
thread->cache = message_cache;
}
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 char* proxenet_perl_execute_function(char* fname, long rid, char* request_str, size_t* request_size, char* uri)
{
char *res, *data;
int nb_res;
size_t len;
SV* sv = NULL;
res = data = NULL;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVuv(rid)));
XPUSHs(sv_2mortal(newSVpvn(request_str, *request_size)));
XPUSHs(sv_2mortal(newSVpvn(uri, strlen(uri))));
PUTBACK;
nb_res = call_pv(fname, G_EVAL | G_SCALAR);
SPAGAIN;
if (nb_res != 1) {
xlog_perl(LOG_ERROR, "Unexpected number of response (got %d, expected 1)\n", nb_res);
} else if (SvTRUE(ERRSV)) {
xlog_perl(LOG_ERROR, "call_pv() error for '%s': %s\n", fname, SvPV_nolen(ERRSV));
} else {
sv = POPs;
res = SvPV(sv, len);
data = (char*) proxenet_xmalloc(len+1);
memcpy(data, res, len);
*request_size = len;
}
PUTBACK;
FREETMPS;
LEAVE;
return data;
}
static char* proxenet_perl_execute_function(plugin_t* plugin, const char* fname, long rid, char* request_str, size_t* request_size)
{
dSP;
char *res, *data;
int nb_res;
size_t len;
SV* sv = NULL;
res = data = NULL;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVuv(rid)));
XPUSHs(sv_2mortal(newSVpvn(request_str, *request_size)));
PUTBACK;
nb_res = call_pv(fname, G_SCALAR);
SPAGAIN;
if (nb_res != 1) {
xlog(LOG_ERROR, "[Perl] Invalid number of response returned (got %d, expected 1)\n", nb_res);
data = NULL;
} else {
sv = POPs;
res = SvPV(sv, len);
data = (char*) proxenet_xmalloc(len+1);
memcpy(data, res, len);
*request_size = len;
}
PUTBACK;
FREETMPS;
LEAVE;
return data;
}
static SV *
custom_convert(AV *docav, SV *meth, SV *input, uint32_t *flags, int direction)
{
dSP;
SV *ret;
SV *flags_rv;
SV *input_rv;
int callflags;
ENTER; SAVETMPS;
PUSHMARK(SP);
input_rv = sv_2mortal(newRV_inc(input));
flags_rv = sv_2mortal(newRV_noinc(newSVuv(*flags)));
XPUSHs(sv_2mortal(newRV_inc( (SV *)docav)));
XPUSHs(input_rv);
XPUSHs(flags_rv);
PUTBACK;
callflags = G_VOID|G_DISCARD;
if (direction == CONVERT_OUT) {
callflags |= G_EVAL;
}
call_sv(meth, callflags);
SPAGAIN;
if (SvTRUE(ERRSV)) {
ret = input;
} else {
warn("Conversion function failed");
ret = SvRV(input_rv);
*flags = SvUV(SvRV(flags_rv));
}
SvREFCNT_inc(ret);
return ret;
}
void
define_constants(const char *pkg, constval_t *cvp)
{
HV *stash;
char *name;
AV *constants;
/* Create the new perl @_Constants variable. */
stash = gv_stashpv(pkg, TRUE);
name = New(0, name, strlen(pkg) + sizeof (CONST_NAME), char);
PERL_ASSERT(name != NULL);
strcpy(name, pkg);
strcat(name, CONST_NAME);
constants = perl_get_av(name, TRUE);
Safefree(name);
/* Populate @_Constants from the contents of the generated array. */
for (; cvp->name != NULL; cvp++) {
newCONSTSUB(stash, (char *)cvp->name, newSVuv(cvp->value));
av_push(constants, newSVpvn((char *)cvp->name, cvp->len));
}
}
void
_parse_wav_fmt(Buffer *buf, uint32_t chunk_size, HV *info)
{
uint16_t format = buffer_get_short_le(buf);
my_hv_store( info, "format", newSVuv(format) );
my_hv_store( info, "channels", newSVuv( buffer_get_short_le(buf) ) );
my_hv_store( info, "samplerate", newSVuv( buffer_get_int_le(buf) ) );
my_hv_store( info, "bitrate", newSVuv( buffer_get_int_le(buf) * 8 ) );
my_hv_store( info, "block_align", newSVuv( buffer_get_short_le(buf) ) );
my_hv_store( info, "bits_per_sample", newSVuv( buffer_get_short_le(buf) ) );
if ( chunk_size > 16 ) {
uint16_t extra_len = buffer_get_short_le(buf);
// Bug 14462, a WAV file with only an 18-byte fmt chunk should ignore extra_len bytes
if (extra_len && chunk_size > 18) {
DEBUG_TRACE(" skipping extra_len bytes in fmt: %d\n", extra_len);
buffer_consume(buf, extra_len);
}
}
}
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;
}
