/*
Create PJS_Context structure
*/
PJS_Context * PJS_CreateContext(PJS_Runtime *rt) {
PJS_Context *pcx;
JSObject *obj;
Newz(1, pcx, 1, PJS_Context);
if (pcx == NULL) {
croak("Failed to allocate memory for PJS_Context");
}
/*
The 'stack size' param here isn't actually the stack size, it's
the "chunk size of the stack pool--an obscure memory management
tuning knob"
http://groups.google.com/group/mozilla.dev.tech.js-engine/browse_thread/thread/be9f404b623acf39
*/
pcx->cx = JS_NewContext(rt->rt, 8192);
if(pcx->cx == NULL) {
Safefree(pcx);
croak("Failed to create JSContext");
}
JS_SetOptions(pcx->cx, JSOPTION_DONT_REPORT_UNCAUGHT);
obj = JS_NewObject(pcx->cx, &global_class, NULL, NULL);
if (JS_InitStandardClasses(pcx->cx, obj) == JS_FALSE) {
PJS_DestroyContext(pcx);
croak("Standard classes not loaded properly.");
}
pcx->function_by_name = newHV();
pcx->class_by_name = newHV();
pcx->class_by_package = newHV();
if (PJS_InitPerlArrayClass(pcx, obj) == JS_FALSE) {
PJS_DestroyContext(pcx);
croak("Perl classes not loaded properly.");
}
if (PJS_InitPerlHashClass(pcx, obj) == JS_FALSE) {
PJS_DestroyContext(pcx);
croak("Perl classes not loaded properly.");
}
if (PJS_InitPerlSubClass(pcx, obj) == JS_FALSE) {
PJS_DestroyContext(pcx);
croak("Perl class 'PerlSub' not loaded properly.");
}
pcx->rt = rt;
/* Add context to context list */
pcx->next = rt->list;
rt->list = pcx;
JS_SetContextPrivate(pcx->cx, (void *) pcx);
return pcx;
}
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);
}
/* Dump this index into Perl.
* Used in testing only. */
SV* dump() const
{
HV* idx = newHV();
for (const auto& token2entries : index)
{
HV* entries = newHV();
for (const auto& id2tf : token2entries.second)
{
std::string k = std::to_string(id2tf.first);
hv_store(entries, k.c_str(), k.size(),
newSViv(id2tf.second), 0);
}
hv_store(idx, token2entries.first.c_str(), token2entries.first.size(),
newRV_noinc(reinterpret_cast<SV*>(entries)), 0);
}
HV* len = newHV();
for (const auto& id2length : lengths)
{
std::string id = std::to_string(id2length.first);
hv_store(len, id.c_str(), id.size(),
newSVpvf("%.2f", id2length.second), 0);
}
HV* dump = newHV();
hv_stores(dump, "index", newRV_noinc(reinterpret_cast<SV*>(idx)));
hv_stores(dump, "lengths", newRV_noinc(reinterpret_cast<SV*>(len)));
return newRV_noinc(reinterpret_cast<SV*>(dump));
}
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);
}
int Cache_Init (/*in*/ tApp * a)
{
epaTHX_
pProviders = newHV () ;
pCacheItems = newHV () ;
ArrayNew (a, &pCachesToRelease, 16, sizeof (tCacheItem *)) ;
/* lprintf (a, "XXXXX Cache_Init [%d/%d] pProviders=%x pCacheItems=%x pCachesToRelease=%x", _getpid(), GetCurrentThreadId(), pProviders, pCacheItems, pCachesToRelease) ; */
return ok ;
}
int
report_acct_grouping_to_hv(slurmdb_report_acct_grouping_t* rec, HV* hv)
{
AV* my_av;
HV* rh;
slurmdb_report_job_grouping_t* jgr = NULL;
slurmdb_tres_rec_t *tres_rec = NULL;
ListIterator itr = NULL;
STORE_FIELD(hv, rec, acct, charp);
STORE_FIELD(hv, rec, count, uint32_t);
STORE_FIELD(hv, rec, lft, uint32_t);
STORE_FIELD(hv, rec, rgt, uint32_t);
my_av = (AV*)sv_2mortal((SV*)newAV());
if (rec->groups) {
itr = slurm_list_iterator_create(rec->groups);
while ((jgr = slurm_list_next(itr))) {
rh = (HV*)sv_2mortal((SV*)newHV());
if (report_job_grouping_to_hv(jgr, rh) < 0) {
Perl_warn(aTHX_ "Failed to convert a report_job_grouping to a hv");
slurm_list_iterator_destroy(itr);
return -1;
} else {
av_push(my_av, newRV((SV*)rh));
}
}
slurm_list_iterator_destroy(itr);
}
hv_store_sv(hv, "groups", newRV((SV*)my_av));
my_av = (AV*)sv_2mortal((SV*)newAV());
if (rec->tres_list) {
itr = slurm_list_iterator_create(rec->tres_list);
while ((tres_rec = slurm_list_next(itr))) {
rh = (HV*)sv_2mortal((SV*)newHV());
if (tres_rec_to_hv(tres_rec, rh) < 0) {
Perl_warn(aTHX_ "Failed to convert a tres_rec to a hv");
slurm_list_iterator_destroy(itr);
return -1;
} else {
av_push(my_av, newRV((SV*)rh));
}
}
slurm_list_iterator_destroy(itr);
}
hv_store_sv(hv, "tres_list", newRV((SV*)my_av));
return 0;
}
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);
}
/*
* convert node_info_msg_t to perl HV
*/
int
node_info_msg_to_hv(node_info_msg_t *node_info_msg, HV *hv)
{
int i;
HV *hv_info;
AV *av;
STORE_FIELD(hv, node_info_msg, last_update, time_t);
STORE_FIELD(hv, node_info_msg, node_scaling, uint16_t);
/*
* node_info_msg->node_array will have node_records with NULL names for
* nodes that are hidden. They are put in the array to preserve the
* node_index which will match up with a partiton's node_inx[]. Add
* empty hashes for nodes that have NULL names -- hidden nodes.
*/
av = newAV();
for(i = 0; i < node_info_msg->record_count; i ++) {
hv_info =newHV();
if (node_info_msg->node_array[i].name &&
node_info_to_hv(node_info_msg->node_array + i,
node_info_msg->node_scaling, hv_info) < 0) {
SvREFCNT_dec((SV*)hv_info);
SvREFCNT_dec((SV*)av);
return -1;
}
av_store(av, i, newRV_noinc((SV*)hv_info));
}
hv_store_sv(hv, "node_array", newRV_noinc((SV*)av));
return 0;
}
/**
* NI_aggregate(): aggregate two IP address ranges into new object.
* @ipo1: first Net::IP::XS object.
* @ipo2: second Net::IP::XS object.
*/
SV *
NI_aggregate(SV *ipo1, SV *ipo2)
{
int version;
int res;
char buf[90];
HV *stash;
HV *hash;
SV *ref;
switch ((version = NI_hv_get_iv(ipo1, "ipversion", 9))) {
case 4: res = NI_aggregate_ipv4(ipo1, ipo2, buf); break;
case 6: res = NI_aggregate_ipv6(ipo1, ipo2, buf); break;
default: res = 0;
}
if (!res) {
return NULL;
}
hash = newHV();
ref = newRV_noinc((SV*) hash);
stash = gv_stashpv("Net::IP::XS", 1);
sv_bless(ref, stash);
res = NI_set(ref, buf, version);
if (!res) {
return NULL;
}
return ref;
}
SV * newSVGdkGCValues(GdkGCValues * v)
{
HV * h;
SV * r;
if (!v)
return newSVsv(&PL_sv_undef);
h = newHV();
r = newRV((SV*)h);
SvREFCNT_dec(h);
hv_store(h, "foreground", 10, newSVMiscRef(&v->foreground, "Gtk::Gdk::Color",0), 0);
hv_store(h, "background", 10, newSVMiscRef(&v->background, "Gtk::Gdk::Color",0), 0);
hv_store(h, "font", 4, newSVMiscRef(v->font, "Gtk::Gdk::Font",0), 0);
hv_store(h, "function", 8, newSVGdkFunction(v->function), 0);
hv_store(h, "fill", 4, newSVGdkFill(v->fill), 0);
hv_store(h, "tile", 4, newSVMiscRef(v->tile, "Gtk::Gdk::Pixmap",0), 0);
hv_store(h, "stipple", 7, newSVMiscRef(v->stipple, "Gtk::Gdk::Pixmap",0), 0);
hv_store(h, "clip_mask", 9, newSVMiscRef(v->clip_mask, "Gtk::Gdk::Pixmap",0), 0);
hv_store(h, "subwindow_mode", 14, newSVGdkSubwindowMode(v->subwindow_mode), 0);
hv_store(h, "ts_x_origin", 11, newSViv(v->ts_x_origin), 0);
hv_store(h, "ts_y_origin", 11, newSViv(v->ts_y_origin), 0);
hv_store(h, "clip_x_origin", 13, newSViv(v->clip_x_origin), 0);
hv_store(h, "clip_x_origin", 13, newSViv(v->clip_y_origin), 0);
hv_store(h, "graphics_exposures", 18, newSViv(v->graphics_exposures), 0);
hv_store(h, "line_width", 10, newSViv(v->line_width), 0);
hv_store(h, "line_style", 10, newSVGdkLineStyle(v->line_style), 0);
hv_store(h, "cap_style", 9, newSVGdkCapStyle(v->cap_style), 0);
hv_store(h, "join_style", 10, newSVGdkJoinStyle(v->join_style), 0);
return r;
}
SV * newSVGdkDeviceInfo(GdkDeviceInfo * v)
{
HV * h;
SV * r;
if (!v)
return newSVsv(&PL_sv_undef);
h = newHV();
r = newRV((SV*)h);
SvREFCNT_dec(h);
hv_store(h, "deviceid", 8, newSViv(v->deviceid), 0);
hv_store(h, "name", 4, newSVpv(v->name, 0), 0);
hv_store(h, "source", 6, newSVGdkInputSource(v->source), 0);
hv_store(h, "mode", 4, newSVGdkInputMode(v->mode), 0);
hv_store(h, "has_cursor", 10, newSViv(v->has_cursor), 0);
hv_store(h, "num_axes", 8, newSViv(v->num_axes), 0);
if (v->axes) {
int i;
AV * a = newAV();
for(i=0;i<v->num_axes;i++) {
av_push(a, newSVGdkAxisUse(v->axes[i]));
}
hv_store(h, "axes", 4, newRV((SV*)a), 0);
SvREFCNT_dec(a);
}
return r;
}
/*
* convert job_step_stat_response_msg_t to perl HV
*/
int
job_step_stat_response_msg_to_hv(job_step_stat_response_msg_t *stat_msg, HV *hv)
{
int i = 0;
ListIterator itr;
job_step_stat_t *stat;
AV *av;
HV *hv_stat;
STORE_FIELD(hv, stat_msg, job_id, uint32_t);
STORE_FIELD(hv, stat_msg, step_id, uint32_t);
av = newAV();
itr = slurm_list_iterator_create(stat_msg->stats_list);
while((stat = (job_step_stat_t *)slurm_list_next(itr))) {
hv_stat = newHV();
if(job_step_stat_to_hv(stat, hv_stat) < 0) {
Perl_warn(aTHX_ "failed to convert job_step_stat_t to hv for job_step_stat_response_msg_t");
SvREFCNT_dec(hv_stat);
SvREFCNT_dec(av);
return -1;
}
av_store(av, i++, newRV_noinc((SV*)hv_stat));
}
slurm_list_iterator_destroy(itr);
hv_store_sv(hv, "stats_list", newRV_noinc((SV*)av));
return 0;
}
static HV* build_params_hash(cfg_t *plmodule)
{
int k;
HV *params_hash;
params_hash = newHV();
if (plmodule && params_hash) {
for (k = 0; k < cfg_size(plmodule, "param"); k++) {
cfg_t *param;
char *name, *value;
SV *sv_value;
param = cfg_getnsec(plmodule, "param", k);
name = apr_pstrdup(pool, param->title);
value = apr_pstrdup(pool, cfg_getstr(param, "value"));
sv_value = newSVpv(value, 0);
if (name && sv_value) {
/* Silence "value computed is not used" warning */
(void)hv_store(params_hash, name, strlen(name), sv_value, 0);
}
}
}
return params_hash;
}
static void
dl_generic_private_init(pTHX) /* called by dl_*.xs dl_private_init() */
{
char *perl_dl_nonlazy;
MY_CXT_INIT;
MY_CXT.x_dl_last_error = newSVpvn("", 0);
dl_nonlazy = 0;
#ifdef DL_LOADONCEONLY
dl_loaded_files = Nullhv;
#endif
#ifdef DEBUGGING
{
SV *sv = get_sv("DynaLoader::dl_debug", 0);
dl_debug = sv ? SvIV(sv) : 0;
}
#endif
if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL )
dl_nonlazy = atoi(perl_dl_nonlazy);
if (dl_nonlazy)
DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n"));
#ifdef DL_LOADONCEONLY
if (!dl_loaded_files)
dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */
#endif
#ifdef DL_UNLOAD_ALL_AT_EXIT
call_atexit(&dl_unload_all_files, (void*)0);
#endif
}
static HV *
plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
int status)
{
HV *result;
result = newHV();
hv_store(result, "status", strlen("status"),
newSVpv((char *) SPI_result_code_string(status), 0), 0);
hv_store(result, "processed", strlen("processed"),
newSViv(processed), 0);
if (status == SPI_OK_SELECT)
{
AV *rows;
SV *row;
int i;
rows = newAV();
for (i = 0; i < processed; i++)
{
row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
av_push(rows, row);
}
hv_store(result, "rows", strlen("rows"),
newRV_noinc((SV *) rows), 0);
}
SPI_freetuptable(tuptable);
return result;
}
void unroll_this(pTHX_ OP* op) {
struct sljit_compiler* compiler = sljit_create_compiler();
HV* seenops = newHV();
#ifdef DEBUG
if (getenv("RUNOPS_OPTIMIZED_DEBUG")) {
CV *runcv = Perl_find_runcv(NULL);
sljit_compiler_verbose(compiler, stderr);
DEBUGf(("Unroll %s::%s cv=%p, op=%p (%s)\n", HvNAME_get(CvSTASH(runcv)),
GvENAME(CvGV(runcv)), runcv, op, sljit_get_platform_name()));
}
#endif
sljit_emit_enter(compiler, 0, 2, 1, 0);
unroll_tree(compiler, seenops, op, NULL);
fixup_jumps(compiler, needjumps, labels);
// This is needed for things that drop off the runloop without a
// return, e.g. S_sortcv. TODO: Make conditional?
sljit_emit_return(compiler, SLJIT_MEM, (sljit_w) &PL_op);
op->op_ppaddr = sljit_generate_code(compiler);
op->op_spare = 3;
DEBUGf(("Code at %p\n", op->op_ppaddr));
labels = NULL;
needjumps = NULL;
SvREFCNT_dec(seenops);
sljit_free_compiler(compiler);
}
Datum
hstore_to_plperl(PG_FUNCTION_ARGS)
{
HStore *in = PG_GETARG_HS(0);
int i;
int count = HS_COUNT(in);
char *base = STRPTR(in);
HEntry *entries = ARRPTR(in);
HV *hv;
hv = newHV();
for (i = 0; i < count; i++)
{
const char *key;
SV *value;
key = pnstrdup(HS_KEY(entries, base, i), HS_KEYLEN(entries, i));
value = HS_VALISNULL(entries, i) ? newSV(0) : cstr2sv(pnstrdup(HS_VAL(entries, base, i), HS_VALLEN(entries, i)));
(void) hv_store(hv, key, strlen(key), value, 0);
}
return PointerGetDatum(newRV((SV *) hv));
}
int
report_job_grouping_to_hv(slurmdb_report_job_grouping_t* rec, HV* hv)
{
AV* my_av;
HV* rh;
slurmdb_tres_rec_t *tres_rec = NULL;
ListIterator itr = NULL;
/* FIX ME: include the job list here (is is not NULL, as
* previously thought) */
STORE_FIELD(hv, rec, min_size, uint32_t);
STORE_FIELD(hv, rec, max_size, uint32_t);
STORE_FIELD(hv, rec, count, uint32_t);
my_av = (AV*)sv_2mortal((SV*)newAV());
if (rec->tres_list) {
itr = slurm_list_iterator_create(rec->tres_list);
while ((tres_rec = slurm_list_next(itr))) {
rh = (HV*)sv_2mortal((SV*)newHV());
if (tres_rec_to_hv(tres_rec, rh) < 0) {
Perl_warn(aTHX_ "Failed to convert a tres_rec to a hv");
slurm_list_iterator_destroy(itr);
return -1;
} else {
av_push(my_av, newRV((SV*)rh));
}
}
slurm_list_iterator_destroy(itr);
}
hv_store_sv(hv, "tres_list", newRV((SV*)my_av));
return 0;
}
SV * newSVFlagsHash(long value, char * optname, HV * o)
{
SV * target, *result;
int i;
HE * he;
SV * s;
I32 len;
char * key;
if (!pgtk_use_array)
target = (SV*)newHV();
else
target = (SV*)newAV();
hv_iterinit(o);
while((s = hv_iternextsv(o, &key, &len))) {
int val = SvIV(s);
if ((value & val) == val) {
if (!pgtk_use_array)
hv_store((HV*)target, key, len, newSViv(1), 0);
else
av_push((AV*)target, newSVpv(key, len));
value &= ~val;
}
}
result = newRV(target);
SvREFCNT_dec(target);
return result;
}
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 * newSVMiscRef(void * object, char * classname, int * newref)
{
HV * previous;
SV * result;
if (!object)
return newSVsv(&PL_sv_undef);
previous = RetrieveMisc(object);
if (previous) {
/*printf("Retriveing object %d as HV %d\n", object, previous);*/
result = newRV((SV*)previous);
if (newref)
*newref = 0;
} else {
HV * h = newHV();
hv_store(h, "_gtk", 4, newSViv((long)object), 0);
result = newRV((SV*)h);
RegisterMisc(h, object);
sv_bless(result, gv_stashpv(classname, FALSE));
SvREFCNT_dec(h);
if (newref)
*newref = 1;
/*printf("Storing object %p (%s) as HV %p (refcount: %d, %d)\n", object, classname, h, SvREFCNT(h), SvREFCNT(result));*/
}
return result;
}
SV * newSVOptFlags(long value, char * optname, struct opts * o)
{
SV * result;
if (!pgtk_use_array) {
HV * h = newHV();
int i;
result = newRV((SV*)h);
SvREFCNT_dec(h);
for(i=0;o[i].name;i++)
if ((value & o[i].value) == o[i].value) {
hv_store(h, o[i].name, strlen(o[i].name), newSViv(1), 0);
value &= ~o[i].value;
}
} else {
AV * a = newAV();
int i;
result = newRV((SV*)a);
SvREFCNT_dec(a);
for(i=0;o[i].name;i++)
if ((value & o[i].value) == o[i].value) {
av_push(a, newSVpv(o[i].name, 0));
value &= ~o[i].value;
}
}
return result;
}
SV* create_perl_object(void* cpp_obj, const char* perl_class_name, bool must_not_delete) {
HV* underlying_hash;
SV* perl_obj;
HV* perl_obj_stash;
object_link_data* link = new object_link_data;
if (cpp_obj == NULL)
return &PL_sv_undef;
// create the underlying hash and make a ref to it
underlying_hash = newHV();
perl_obj = newRV_noinc((SV*)underlying_hash);
//sv_2mortal(perl_obj);
// get the stash and bless the ref (to the underlying hash) into it
perl_obj_stash = gv_stashpv(perl_class_name, TRUE);
sv_bless(perl_obj, perl_obj_stash);
// fill in the data fields
link->cpp_object = cpp_obj;
link->perl_object = (SV*)underlying_hash;
link->can_delete_cpp_object = must_not_delete ? false : true;
link->perl_class_name = perl_class_name;
// link the data via '~' magic
// (we link to the underlying hash and not to the reference itself)
sv_magic((SV*)underlying_hash, NULL, PERL_MAGIC_ext, (const char*)link, 0); // cheat by storing data instead of a string
// check this object
DUMPME(1,perl_obj);
return perl_obj;
}
int
step_rec_to_hv(slurmdb_step_rec_t *rec, HV* hv)
{
HV* stats_hv = (HV*)sv_2mortal((SV*)newHV());
stats_to_hv(&rec->stats, stats_hv);
hv_store_sv(hv, "stats", newRV((SV*)stats_hv));
STORE_FIELD(hv, rec, elapsed, uint32_t);
STORE_FIELD(hv, rec, end, time_t);
STORE_FIELD(hv, rec, exitcode, int32_t);
STORE_FIELD(hv, rec, nnodes, uint32_t);
STORE_FIELD(hv, rec, nodes, charp);
STORE_FIELD(hv, rec, ntasks, uint32_t);
STORE_FIELD(hv, rec, pid_str, charp);
STORE_FIELD(hv, rec, req_cpufreq_min, uint32_t);
STORE_FIELD(hv, rec, req_cpufreq_max, uint32_t);
STORE_FIELD(hv, rec, req_cpufreq_gov, uint32_t);
STORE_FIELD(hv, rec, requid, uint32_t);
STORE_FIELD(hv, rec, start, time_t);
STORE_FIELD(hv, rec, state, uint32_t);
STORE_FIELD(hv, rec, stepid, uint32_t);
STORE_FIELD(hv, rec, stepname, charp);
STORE_FIELD(hv, rec, suspended, uint32_t);
STORE_FIELD(hv, rec, sys_cpu_sec, uint32_t);
STORE_FIELD(hv, rec, sys_cpu_usec, uint32_t);
STORE_FIELD(hv, rec, task_dist, uint16_t);
STORE_FIELD(hv, rec, tot_cpu_sec, uint32_t);
STORE_FIELD(hv, rec, tot_cpu_usec, uint32_t);
STORE_FIELD(hv, rec, tres_alloc_str, charp);
STORE_FIELD(hv, rec, user_cpu_sec, uint32_t);
STORE_FIELD(hv, rec, user_cpu_usec, uint32_t);
return 0;
}
HV*
Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
{
char smallbuf[256];
char *tmpbuf;
HV *stash;
GV *tmpgv;
if (namelen + 3 < sizeof smallbuf)
tmpbuf = smallbuf;
else
New(606, tmpbuf, namelen + 3, char);
Copy(name,tmpbuf,namelen,char);
tmpbuf[namelen++] = ':';
tmpbuf[namelen++] = ':';
tmpbuf[namelen] = '\0';
tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
if (!tmpgv)
return 0;
if (!GvHV(tmpgv))
GvHV(tmpgv) = newHV();
stash = GvHV(tmpgv);
if (!HvNAME(stash))
HvNAME(stash) = savepv(name);
return stash;
}
/*
* convert node_info_msg_t to perl HV
*/
int
node_info_msg_to_hv(node_info_msg_t *node_info_msg, HV *hv)
{
int i;
HV *hv_info;
AV *av;
STORE_FIELD(hv, node_info_msg, last_update, time_t);
STORE_FIELD(hv, node_info_msg, node_scaling, uint16_t);
/* record_count implied in node_array */
av = newAV();
for(i = 0; i < node_info_msg->record_count; i ++) {
if (!node_info_msg->node_array[i].name)
continue;
hv_info =newHV();
if (node_info_to_hv(node_info_msg->node_array + i,
node_info_msg->node_scaling, hv_info) < 0) {
SvREFCNT_dec((SV*)hv_info);
SvREFCNT_dec((SV*)av);
return -1;
}
av_store(av, i, newRV_noinc((SV*)hv_info));
}
hv_store_sv(hv, "node_array", newRV_noinc((SV*)av));
return 0;
}
static SV*
make_views_row(PLCB_t *parent, const lcb_RESPVIEWQUERY *resp)
{
HV *rowdata = newHV();
SV *docid = sv_from_rowdata(resp->docid, resp->ndocid);
/* Key, Value, Doc ID, Geo, Doc */
hv_stores(rowdata, "key", sv_from_rowdata(resp->key, resp->nkey));
hv_stores(rowdata, "value", sv_from_rowdata(resp->value, resp->nvalue));
hv_stores(rowdata, "geometry", sv_from_rowdata(resp->geometry, resp->ngeometry));
hv_stores(rowdata, "id", docid);
if (resp->docresp) {
const lcb_RESPGET *docresp = resp->docresp;
AV *docav = newAV();
hv_stores(rowdata, "__doc__", newRV_noinc((SV*)docav));
av_store(docav, PLCB_RETIDX_KEY, SvREFCNT_inc(docid));
plcb_doc_set_err(parent, docav, resp->rc);
if (docresp->rc == LCB_SUCCESS) {
SV *docval = plcb_convert_getresp(parent, docav, docresp);
av_store(docav, PLCB_RETIDX_VALUE, docval);
plcb_doc_set_cas(parent, docav, &docresp->cas);
}
}
return newRV_noinc((SV *)rowdata);
}
HV *
mop_get_all_package_symbols (HV *stash, type_filter_t filter)
{
HV *ret = newHV ();
mop_get_package_symbols (stash, filter, collect_all_symbols, ret);
return ret;
}
/*
* Parse a configuration section, and populate a HV.
* This function is recursively called (allows to have nested hashes.)
*/
static void perl_parse_config(CONF_SECTION *cs, int lvl, HV *rad_hv)
{
if (!cs || !rad_hv) return;
int indent_section = (lvl + 1) * 4;
int indent_item = (lvl + 2) * 4;
DEBUG("%*s%s {", indent_section, " ", cf_section_name1(cs));
CONF_ITEM *ci = NULL;
while ((ci = cf_item_next(cs, ci))) {
/*
* This is a section.
* Create a new HV, store it as a reference in current HV,
* Then recursively call perl_parse_config with this section and the new HV.
*/
if (cf_item_is_section(ci)) {
CONF_SECTION *sub_cs = cf_item_to_section(ci);
char const *key = cf_section_name1(sub_cs); /* hash key */
HV *sub_hv;
SV *ref;
if (!key) continue;
if (hv_exists(rad_hv, key, strlen(key))) {
WARN("Ignoring duplicate config section '%s'", key);
continue;
}
sub_hv = newHV();
ref = newRV_inc((SV*) sub_hv);
(void)hv_store(rad_hv, key, strlen(key), ref, 0);
perl_parse_config(sub_cs, lvl + 1, sub_hv);
} else if (cf_item_is_pair(ci)){
CONF_PAIR *cp = cf_item_to_pair(ci);
char const *key = cf_pair_attr(cp); /* hash key */
char const *value = cf_pair_value(cp); /* hash value */
if (!key || !value) continue;
/*
* This is an item.
* Store item attr / value in current HV.
*/
if (hv_exists(rad_hv, key, strlen(key))) {
WARN("Ignoring duplicate config item '%s'", key);
continue;
}
(void)hv_store(rad_hv, key, strlen(key), newSVpvn(value, strlen(value)), 0);
DEBUG("%*s%s = %s", indent_item, " ", key, value);
}
}
DEBUG("%*s}", indent_section, " ");
}
/*
* convert job_info_msg_t to perl HV
*/
int
job_info_msg_to_hv(job_info_msg_t *job_info_msg, HV *hv)
{
int i;
HV *hv_info;
AV *av;
_load_node_info();
STORE_FIELD(hv, job_info_msg, last_update, time_t);
/* record_count implied in job_array */
av = newAV();
for(i = 0; i < job_info_msg->record_count; i ++) {
hv_info = newHV();
if (job_info_to_hv(job_info_msg->job_array + i, hv_info) < 0) {
SvREFCNT_dec(hv_info);
SvREFCNT_dec(av);
return -1;
}
av_store(av, i, newRV_noinc((SV*)hv_info));
}
hv_store_sv(hv, "job_array", newRV_noinc((SV*)av));
_free_node_info();
return 0;
}
