/*
* convert perl HV to job_info_msg_t
*/
int
hv_to_job_info_msg(HV *hv, job_info_msg_t *job_info_msg)
{
SV **svp;
AV *av;
int i, n;
memset(job_info_msg, 0, sizeof(job_info_msg_t));
FETCH_FIELD(hv, job_info_msg, last_update, time_t, TRUE);
svp = hv_fetch(hv, "job_array", 9, FALSE);
if (! (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) {
Perl_warn (aTHX_ "job_array is not an arrary reference in HV for job_info_msg_t");
return -1;
}
av = (AV*)SvRV(*svp);
n = av_len(av) + 1;
job_info_msg->record_count = n;
job_info_msg->job_array = xmalloc(n * sizeof(job_info_t));
for(i = 0; i < n; i ++) {
svp = av_fetch(av, i, FALSE);
if (! (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV)) {
Perl_warn (aTHX_ "element %d in job_array is not valid", i);
return -1;
}
if (hv_to_job_info((HV*)SvRV(*svp), &job_info_msg->job_array[i]) < 0) {
Perl_warn(aTHX_ "failed to convert element %d in job_array", i);
return -1;
}
}
return 0;
}
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;
}
/*
* convert perl HV to slurm_step_launch_params_t
*/
int
hv_to_slurm_step_launch_params(HV *hv, slurm_step_launch_params_t *params)
{
int i, num_keys;
STRLEN vlen;
I32 klen;
SV **svp;
HV *environ_hv, *local_fds_hv, *fd_hv;
AV *argv_av;
SV *val;
char *env_key, *env_val;
slurm_step_launch_params_t_init(params);
if((svp = hv_fetch(hv, "argv", 4, FALSE))) {
if(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) {
argv_av = (AV*)SvRV(*svp);
params->argc = av_len(argv_av) + 1;
if (params->argc > 0) {
/* memory of params MUST be free-ed by libslurm-perl */
Newz(0, params->argv, (int32_t)(params->argc + 1), char*);
for(i = 0; i < params->argc; i ++) {
if((svp = av_fetch(argv_av, i, FALSE)))
*(params->argv + i) = (char*) SvPV_nolen(*svp);
else {
Perl_warn(aTHX_ "error fetching `argv' of job descriptor");
free_slurm_step_launch_params_memory(params);
return -1;
}
}
}
} else {
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;
}
int
hv_to_user_cond(HV* hv, slurmdb_user_cond_t* user_cond)
{
AV* element_av;
SV** svp;
char* str = NULL;
int i, elements = 0;
user_cond->admin_level = 0;
user_cond->with_assocs = 1;
user_cond->with_coords = 0;
user_cond->with_deleted = 1;
user_cond->with_wckeys = 0;
FETCH_FIELD(hv, user_cond, admin_level, uint16_t, FALSE);
FETCH_FIELD(hv, user_cond, with_assocs, uint16_t, FALSE);
FETCH_FIELD(hv, user_cond, with_coords, uint16_t, FALSE);
FETCH_FIELD(hv, user_cond, with_deleted, uint16_t, FALSE);
FETCH_FIELD(hv, user_cond, with_wckeys, uint16_t, FALSE);
if ( (svp = hv_fetch (hv, "assoc_cond", strlen("assoc_cond"), FALSE)) ) {
if(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV) {
HV* element_hv = (HV*)SvRV(*svp);
hv_to_assoc_cond(element_hv, user_cond->assoc_cond);
} else {
Perl_warn(aTHX_ "assoc_cond val is not an hash value reference");
return -1;
}
}
FETCH_LIST_FIELD(hv, user_cond, def_acct_list);
FETCH_LIST_FIELD(hv, user_cond, def_wckey_list);
return 0;
}
/*
* convert slurm_step_layout_t to perl HV
*/
int
slurm_step_layout_to_hv(slurm_step_layout_t *step_layout, HV *hv)
{
AV* av, *av2;
int i, j;
if (step_layout->front_end)
STORE_FIELD(hv, step_layout, front_end, charp);
STORE_FIELD(hv, step_layout, node_cnt, uint16_t);
if (step_layout->node_list)
STORE_FIELD(hv, step_layout, node_list, charp);
else {
Perl_warn(aTHX_ "node_list missing in slurm_step_layout_t");
return -1;
}
STORE_FIELD(hv, step_layout, plane_size, uint16_t);
av = newAV();
for (i = 0; i < step_layout->node_cnt; i ++)
av_store_uint16_t(av, i, step_layout->tasks[i]);
hv_store_sv(hv, "tasks", newRV_noinc((SV*)av));
STORE_FIELD(hv, step_layout, task_cnt, uint32_t);
STORE_FIELD(hv, step_layout, task_dist, uint16_t);
av = newAV();
for (i = 0; i < step_layout->node_cnt; i ++) {
av2 = newAV();
for (j = 0; j < step_layout->tasks[i]; j ++)
av_store_uint32_t(av2, i, step_layout->tids[i][j]);
av_store(av, i, newRV_noinc((SV*)av2));
}
hv_store_sv(hv, "tids", newRV_noinc((SV*)av));
return 0;
}
/*
* 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;
}
/*
* 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;
}
int
Perl_ithread_hook(pTHX)
{
int veto_cleanup = 0;
MUTEX_LOCK(&create_destruct_mutex);
if (aTHX == PL_curinterp && active_threads != 1) {
Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
(IV)active_threads);
veto_cleanup = 1;
}
MUTEX_UNLOCK(&create_destruct_mutex);
return veto_cleanup;
}
CV *
PerlIOVia_fetchmethod(pTHX_ PerlIOVia * s, char *method, CV ** save)
{
GV *gv = gv_fetchmeth(s->stash, method, strlen(method), 0);
#if 0
Perl_warn(aTHX_ "Lookup %s::%s => %p", HvNAME(s->stash), method, gv);
#endif
if (gv) {
return *save = GvCV(gv);
}
else {
return *save = (CV *) - 1;
}
}
mthread* S_get_self(pTHX) {
SV** self_sv = hv_fetch(PL_modglobal, "threads::lite::thread", 21, FALSE);
if (!self_sv) {
mthread* ret;
if (ckWARN(WARN_THREADS))
Perl_warn(aTHX, "Creating thread context where non existed\n");
ret = mthread_alloc(aTHX);
ret->interp = my_perl;
store_self(aTHX, ret);
return ret;
}
return (mthread*)SvPV_nolen(*self_sv);
}
STDCHAR *
PerlIOEncode_get_base(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
if (!e->base.bufsiz)
e->base.bufsiz = 1024;
if (!e->bufsv) {
e->bufsv = newSV(e->base.bufsiz);
sv_setpvn(e->bufsv, "", 0);
}
e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
if (!e->base.ptr)
e->base.ptr = e->base.buf;
if (!e->base.end)
e->base.end = e->base.buf;
if (e->base.ptr < e->base.buf
|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
e->base.buf + SvLEN(e->bufsv));
abort();
}
if (SvLEN(e->bufsv) < e->base.bufsiz) {
SSize_t poff = e->base.ptr - e->base.buf;
SSize_t eoff = e->base.end - e->base.buf;
e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz);
e->base.ptr = e->base.buf + poff;
e->base.end = e->base.buf + eoff;
}
if (e->base.ptr < e->base.buf
|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
e->base.buf + SvLEN(e->bufsv));
abort();
}
return e->base.buf;
}
/*
* convert job_step_stat_t to perl HV
*/
int
job_step_stat_to_hv(job_step_stat_t *stat, HV *hv)
{
HV *hv_pids;
STORE_PTR_FIELD(hv, stat, jobacct, "Slurm::jobacctinfo_t");
STORE_FIELD(hv, stat, num_tasks, uint32_t);
STORE_FIELD(hv, stat, return_code, uint32_t);
hv_pids = newHV();
if (job_step_pids_to_hv(stat->step_pids, hv_pids) < 0) {
Perl_warn(aTHX_ "failed to convert job_step_pids_t to hv for job_step_stat_t");
SvREFCNT_dec(hv_pids);
return -1;
}
hv_store_sv(hv, "step_pids", newRV_noinc((SV*)hv_pids));
return 0;
}
int
av_to_cluster_grouping_list(AV* av, List grouping_list)
{
SV** svp;
char* str = NULL;
int i, elements = 0;
elements = av_len(av) + 1;
for (i = 0; i < elements; i ++) {
if ((svp = av_fetch(av, i, FALSE))) {
str = slurm_xstrdup((char*)SvPV_nolen(*svp));
slurm_list_append(grouping_list, str);
} else {
Perl_warn(aTHX_ "error fetching group from grouping list");
return -1;
}
}
return 0;
}
/*
* convert job_step_create_response_msg_t to perl HV
*/
int
job_step_create_response_msg_to_hv(job_step_create_response_msg_t *resp_msg, HV *hv)
{
HV *hv;
STORE_FIELD(hv, resp_msg, job_step_id, uint32_t);
if (resp_msg->resv_ports)
STORE_FIELD(hv, resp_msg, resv_ports, charp);
hv = newHV();
if (slurm_step_layout_to_hv(resp->step_layout, hv) < 0) {
Perl_warn(aTHX_ "Failed to convert slurm_step_layout_t to hv for job_step_create_response_msg_t");
SvREFCNT_dec(hv);
return -1;
}
hv_store(hv, "step_layout", 11, newRV_noinc((SV*)hv));
STORE_PTR_FIELD(hv, resp_msg, cred, "TODO");
STORE_PTR_FIELD(hv, resp_msg, switch_job, "TODO");
return 0;
}
int
cluster_accounting_rec_to_hv(slurmdb_cluster_accounting_rec_t* ar, HV* hv)
{
HV* rh;
STORE_FIELD(hv, ar, alloc_secs, uint64_t);
STORE_FIELD(hv, ar, down_secs, uint64_t);
STORE_FIELD(hv, ar, idle_secs, uint64_t);
STORE_FIELD(hv, ar, over_secs, uint64_t);
STORE_FIELD(hv, ar, pdown_secs, uint64_t);
STORE_FIELD(hv, ar, period_start, time_t);
STORE_FIELD(hv, ar, resv_secs, uint64_t);
rh = (HV*)sv_2mortal((SV*)newHV());
if (tres_rec_to_hv(&ar->tres_rec, rh) < 0) {
Perl_warn(aTHX_ "Failed to convert a tres_rec to a hv");
return -1;
}
hv_store_sv(hv, "tres_rec", newRV((SV*)rh));
return 0;
}
int
cluster_rec_to_hv(slurmdb_cluster_rec_t* rec, HV* hv)
{
AV* my_av;
HV* rh;
ListIterator itr = NULL;
slurmdb_cluster_accounting_rec_t* ar = NULL;
my_av = (AV*)sv_2mortal((SV*)newAV());
if (rec->accounting_list) {
itr = slurm_list_iterator_create(rec->accounting_list);
while ((ar = slurm_list_next(itr))) {
rh = (HV*)sv_2mortal((SV*)newHV());
if (cluster_accounting_rec_to_hv(ar, rh) < 0) {
Perl_warn(aTHX_ "Failed to convert a cluster_accounting_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, "accounting_list", newRV((SV*)my_av));
STORE_FIELD(hv, rec, classification, uint16_t);
STORE_FIELD(hv, rec, control_host, charp);
STORE_FIELD(hv, rec, control_port, uint32_t);
STORE_FIELD(hv, rec, dimensions, uint16_t);
STORE_FIELD(hv, rec, flags, uint32_t);
STORE_FIELD(hv, rec, name, charp);
STORE_FIELD(hv, rec, nodes, charp);
STORE_FIELD(hv, rec, plugin_id_select, uint32_t);
/* slurmdb_assoc_rec_t* root_assoc; */
STORE_FIELD(hv, rec, rpc_version, uint16_t);
STORE_FIELD(hv, rec, tres_str, charp);
return 0;
}
/*
* convert perl HV to job_desc_msg_t
* return 0 on success, -1 on failure
*/
int
hv_to_job_desc_msg(HV *hv, job_desc_msg_t *job_desc)
{
SV **svp;
HV *environ_hv;
AV *argv_av;
SV *val;
char *env_key, *env_val;
I32 klen;
STRLEN vlen;
int num_keys, i;
slurm_init_job_desc_msg(job_desc);
FETCH_FIELD(hv, job_desc, account, charp, FALSE);
FETCH_FIELD(hv, job_desc, acctg_freq, charp, FALSE);
FETCH_FIELD(hv, job_desc, alloc_node, charp, FALSE);
FETCH_FIELD(hv, job_desc, alloc_resp_port, uint16_t, FALSE);
FETCH_FIELD(hv, job_desc, alloc_sid, uint32_t, FALSE);
/* argv, argc */
if((svp = hv_fetch(hv, "argv", 4, FALSE))) {
if(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) {
argv_av = (AV*)SvRV(*svp);
job_desc->argc = av_len(argv_av) + 1;
if (job_desc->argc > 0) {
Newz(0, job_desc->argv, (int32_t)(job_desc->argc + 1), char*);
for(i = 0; i < job_desc->argc; i ++) {
if((svp = av_fetch(argv_av, i, FALSE)))
*(job_desc->argv + i) = (char*) SvPV_nolen(*svp);
else {
Perl_warn(aTHX_ "error fetching `argv' of job descriptor");
free_job_desc_msg_memory(job_desc);
return -1;
}
}
}
} else {
static int
timezone_setup(void)
{
struct tm *tm_p;
if (gmtime_emulation_type == 0) {
int dstnow;
time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
/* results of calls to gmtime() and localtime() */
/* for same &base */
gmtime_emulation_type++;
if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
char off[LNM$C_NAMLENGTH+1];;
gmtime_emulation_type++;
if (!Perl_vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
gmtime_emulation_type++;
utc_offset_secs = 0;
Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
}
else { utc_offset_secs = atol(off); }
}
else { /* We've got a working gmtime() */
struct tm gmt, local;
gmt = *tm_p;
tm_p = localtime(&base);
local = *tm_p;
utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
utc_offset_secs += (local.tm_sec - gmt.tm_sec);
}
}
return 1;
}
int
report_cluster_rec_list_to_av(List list, AV* av)
{
HV* rh;
ListIterator itr = NULL;
slurmdb_report_cluster_rec_t* rec = NULL;
if (list) {
itr = slurm_list_iterator_create(list);
while ((rec = slurm_list_next(itr))) {
rh = (HV*)sv_2mortal((SV*)newHV());
if (report_cluster_rec_to_hv(rec, rh) < 0) {
Perl_warn(aTHX_ "Failed to convert a report_cluster_rec to a hv");
slurm_list_iterator_destroy(itr);
return -1;
} else {
av_push(av, newRV((SV*)rh));
}
}
slurm_list_iterator_destroy(itr);
}
return 0;
}
THREAD_RET_TYPE
Perl_ithread_run(LPVOID arg) {
#else
void*
Perl_ithread_run(void * arg) {
#endif
ithread* thread = (ithread*) arg;
dTHXa(thread->interp);
PERL_SET_CONTEXT(thread->interp);
Perl_ithread_set(aTHX_ thread);
#if 0
/* Far from clear messing with ->thr child-side is a good idea */
MUTEX_LOCK(&thread->mutex);
#ifdef WIN32
thread->thr = GetCurrentThreadId();
#else
thread->thr = pthread_self();
#endif
MUTEX_UNLOCK(&thread->mutex);
#endif
PL_perl_destruct_level = 2;
{
AV* params = (AV*) SvRV(thread->params);
I32 len = av_len(params)+1;
int i;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
for(i = 0; i < len; i++) {
XPUSHs(av_shift(params));
}
PUTBACK;
len = call_sv(thread->init_function, thread->gimme|G_EVAL);
SPAGAIN;
for (i=len-1; i >= 0; i--) {
SV *sv = POPs;
av_store(params, i, SvREFCNT_inc(sv));
}
if (SvTRUE(ERRSV)) {
Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
}
FREETMPS;
LEAVE;
SvREFCNT_dec(thread->init_function);
}
PerlIO_flush((PerlIO*)NULL);
MUTEX_LOCK(&thread->mutex);
thread->state |= PERL_ITHR_FINISHED;
if (thread->state & PERL_ITHR_DETACHED) {
MUTEX_UNLOCK(&thread->mutex);
Perl_ithread_destruct(aTHX_ thread, "detached finish");
} else {
MUTEX_UNLOCK(&thread->mutex);
}
MUTEX_LOCK(&create_destruct_mutex);
active_threads--;
assert( active_threads >= 0 );
MUTEX_UNLOCK(&create_destruct_mutex);
#ifdef WIN32
return (DWORD)0;
#else
return 0;
#endif
}
static int load_indexed_hash_module_ex(pTHX_ CBC *THIS, const char **modlist, int num)
{
const char *p = NULL;
int i;
if (THIS->ixhash != NULL)
{
/* a module has already been loaded */
return 1;
}
for (i = 0; i < num; i++)
{
if (modlist[i])
{
SV *sv = newSVpvn("require ", 8);
sv_catpv(sv, CONST_CHAR(modlist[i]));
CT_DEBUG(MAIN, ("trying to require \"%s\"", modlist[i]));
(void) eval_sv(sv, G_DISCARD);
SvREFCNT_dec(sv);
if ((sv = get_sv("@", 0)) != NULL && strEQ(SvPV_nolen(sv), ""))
{
p = modlist[i];
break;
}
if (i == 0)
{
Perl_warn(aTHX_ "Couldn't load %s for member ordering, "
"trying default modules", modlist[i]);
}
CT_DEBUG(MAIN, ("failed: \"%s\"", sv ? SvPV_nolen(sv) : "[NULL]"));
}
}
if (p == NULL)
{
SV *sv = newSVpvn("", 0);
for (i = 1; i < num; i++)
{
if (i > 1)
{
if (i == num-1)
sv_catpvn(sv, " or ", 4);
else
sv_catpvn(sv, ", ", 2);
}
sv_catpv(sv, CONST_CHAR(modlist[i]));
}
Perl_warn(aTHX_ "Couldn't load a module for member ordering "
"(consider installing %s)", SvPV_nolen(sv));
return 0;
}
CT_DEBUG(MAIN, ("using \"%s\" for member ordering", p));
THIS->ixhash = p;
return 1;
}
/*
* Clear up after thread is done with
*/
void
Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
{
PerlInterpreter *freeperl = NULL;
MUTEX_LOCK(&thread->mutex);
if (!thread->next) {
Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
}
if (thread->count != 0) {
MUTEX_UNLOCK(&thread->mutex);
return;
}
MUTEX_LOCK(&create_destruct_mutex);
/* Remove from circular list of threads */
if (thread->next == thread) {
/* last one should never get here ? */
threads = NULL;
}
else {
thread->next->prev = thread->prev;
thread->prev->next = thread->next;
if (threads == thread) {
threads = thread->next;
}
thread->next = NULL;
thread->prev = NULL;
}
known_threads--;
assert( known_threads >= 0 );
#if 0
Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
thread->tid,thread->interp,aTHX, known_threads);
#endif
MUTEX_UNLOCK(&create_destruct_mutex);
/* Thread is now disowned */
if(thread->interp) {
dTHXa(thread->interp);
ithread* current_thread;
#ifdef OEMVS
void *ptr;
#endif
PERL_SET_CONTEXT(thread->interp);
current_thread = Perl_ithread_get(aTHX);
Perl_ithread_set(aTHX_ thread);
SvREFCNT_dec(thread->params);
thread->params = Nullsv;
perl_destruct(thread->interp);
freeperl = thread->interp;
thread->interp = NULL;
}
MUTEX_UNLOCK(&thread->mutex);
MUTEX_DESTROY(&thread->mutex);
#ifdef WIN32
if (thread->handle)
CloseHandle(thread->handle);
thread->handle = 0;
#endif
PerlMemShared_free(thread);
if (freeperl)
perl_free(freeperl);
PERL_SET_CONTEXT(aTHX);
}
/*
* convert node_info_t to perl HV
*/
int
node_info_to_hv(node_info_t *node_info, uint16_t node_scaling, HV *hv)
{
uint16_t err_cpus = 0, alloc_cpus = 0;
#ifdef HAVE_BG
int cpus_per_node = 1;
if(node_scaling)
cpus_per_node = node_info->cpus / node_scaling;
#endif
if(node_info->arch)
STORE_FIELD(hv, node_info, arch, charp);
STORE_FIELD(hv, node_info, boot_time, time_t);
STORE_FIELD(hv, node_info, cores, uint16_t);
STORE_FIELD(hv, node_info, cpu_load, uint32_t);
STORE_FIELD(hv, node_info, cpus, uint16_t);
if (node_info->features)
STORE_FIELD(hv, node_info, features, charp);
if (node_info->features_act)
STORE_FIELD(hv, node_info, features_act, charp);
if (node_info->gres)
STORE_FIELD(hv, node_info, gres, charp);
if (node_info->name)
STORE_FIELD(hv, node_info, name, charp);
else {
Perl_warn (aTHX_ "node name missing in node_info_t");
return -1;
}
STORE_FIELD(hv, node_info, node_state, uint32_t);
if(node_info->os)
STORE_FIELD(hv, node_info, os, charp);
STORE_FIELD(hv, node_info, real_memory, uint64_t);
if(node_info->reason)
STORE_FIELD(hv, node_info, reason, charp);
STORE_FIELD(hv, node_info, reason_time, time_t);
STORE_FIELD(hv, node_info, reason_uid, uint32_t);
STORE_FIELD(hv, node_info, slurmd_start_time, time_t);
STORE_FIELD(hv, node_info, boards, uint16_t);
STORE_FIELD(hv, node_info, sockets, uint16_t);
STORE_FIELD(hv, node_info, threads, uint16_t);
STORE_FIELD(hv, node_info, tmp_disk, uint32_t);
slurm_get_select_nodeinfo(node_info->select_nodeinfo,
SELECT_NODEDATA_SUBCNT,
NODE_STATE_ALLOCATED,
&alloc_cpus);
#ifdef HAVE_BG
if(!alloc_cpus
&& (IS_NODE_ALLOCATED(node_info) || IS_NODE_COMPLETING(node_info)))
alloc_cpus = node_info->cpus;
else
alloc_cpus *= cpus_per_node;
#endif
slurm_get_select_nodeinfo(node_info->select_nodeinfo,
SELECT_NODEDATA_SUBCNT,
NODE_STATE_ERROR,
&err_cpus);
#ifdef HAVE_BG
err_cpus *= cpus_per_node;
#endif
hv_store_uint16_t(hv, "alloc_cpus", alloc_cpus);
hv_store_uint16_t(hv, "err_cpus", err_cpus);
STORE_PTR_FIELD(hv, node_info, select_nodeinfo, "Slurm::dynamic_plugin_data_t");
STORE_FIELD(hv, node_info, weight, uint32_t);
return 0;
}
IV
PerlIOEncode_fill(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
dSP;
IV code = 0;
PerlIO *n;
SSize_t avail;
if (PerlIO_flush(f) != 0)
return -1;
n = PerlIONext(f);
if (!PerlIO_fast_gets(n)) {
/* Things get too messy if we don't have a buffer layer
push a :perlio to do the job */
char mode[8];
n = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
if (!n) {
Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
}
}
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
retry:
avail = PerlIO_get_cnt(n);
if (avail <= 0) {
avail = PerlIO_fill(n);
if (avail == 0) {
avail = PerlIO_get_cnt(n);
}
else {
if (!PerlIO_error(n) && PerlIO_eof(n))
avail = 0;
}
}
if (avail > 0 || (e->flags & NEEDS_LINES)) {
STDCHAR *ptr = PerlIO_get_ptr(n);
SSize_t use = (avail >= 0) ? avail : 0;
SV *uni;
char *s = NULL;
STRLEN len = 0;
e->base.ptr = e->base.end = (STDCHAR *) NULL;
(void) PerlIOEncode_get_base(aTHX_ f);
if (!e->dataSV)
e->dataSV = newSV(0);
if (SvTYPE(e->dataSV) < SVt_PV) {
sv_upgrade(e->dataSV,SVt_PV);
}
if (e->flags & NEEDS_LINES) {
/* Encoding needs whole lines (e.g. iso-2022-*)
search back from end of available data for
and line marker
*/
STDCHAR *nl = ptr+use-1;
while (nl >= ptr) {
if (*nl == '\n') {
break;
}
nl--;
}
if (nl >= ptr && *nl == '\n') {
/* found a line - take up to and including that */
use = (nl+1)-ptr;
}
else if (avail > 0) {
/* No line, but not EOF - append avail to the pending data */
sv_catpvn(e->dataSV, (char*)ptr, use);
PerlIO_set_ptrcnt(n, ptr+use, 0);
goto retry;
}
else if (!SvCUR(e->dataSV)) {
goto end_of_file;
}
}
if (SvCUR(e->dataSV)) {
/* something left over from last time - create a normal
SV with new data appended
*/
if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
if (e->flags & NEEDS_LINES) {
/* Have to grow buffer */
e->base.bufsiz = use + SvCUR(e->dataSV);
PerlIOEncode_get_base(aTHX_ f);
}
else {
use = e->base.bufsiz - SvCUR(e->dataSV);
}
}
sv_catpvn(e->dataSV,(char*)ptr,use);
}
else {
/* Create a "dummy" SV to represent the available data from layer below */
if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
Safefree(SvPVX_mutable(e->dataSV));
}
if (use > (SSize_t)e->base.bufsiz) {
if (e->flags & NEEDS_LINES) {
/* Have to grow buffer */
e->base.bufsiz = use;
PerlIOEncode_get_base(aTHX_ f);
}
else {
use = e->base.bufsiz;
}
}
SvPV_set(e->dataSV, (char *) ptr);
SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */
SvCUR_set(e->dataSV,use);
SvPOK_only(e->dataSV);
}
SvUTF8_off(e->dataSV);
PUSHMARK(sp);
XPUSHs(e->enc);
XPUSHs(e->dataSV);
XPUSHs(e->chk);
PUTBACK;
if (call_method("decode", G_SCALAR) != 1) {
Perl_die(aTHX_ "panic: decode did not return a value");
}
SPAGAIN;
uni = POPs;
PUTBACK;
/* Now get translated string (forced to UTF-8) and use as buffer */
if (SvPOK(uni)) {
s = SvPVutf8(uni, len);
#ifdef PARANOID_ENCODE_CHECKS
if (len && !is_utf8_string((U8*)s,len)) {
Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
}
#endif
}
if (len > 0) {
/* Got _something */
/* if decode gave us back dataSV then data may vanish when
we do ptrcnt adjust - so take our copy now.
(The copy is a pain - need a put-it-here option for decode.)
*/
sv_setpvn(e->bufsv,s,len);
e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
e->base.end = e->base.ptr + SvCUR(e->bufsv);
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
SvUTF8_on(e->bufsv);
/* Adjust ptr/cnt not taking anything which
did not translate - not clear this is a win */
/* compute amount we took */
use -= SvCUR(e->dataSV);
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
/* and as we did not take it it isn't pending */
SvCUR_set(e->dataSV,0);
} else {
/* Got nothing - assume partial character so we need some more */
/* Make sure e->dataSV is a normal SV before re-filling as
buffer alias will change under us
*/
s = SvPV(e->dataSV,len);
sv_setpvn(e->dataSV,s,len);
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
goto retry;
}
}
else {
end_of_file:
code = -1;
if (avail == 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
else
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
}
FREETMPS;
LEAVE;
POPSTACK;
return code;
}
int
report_user_rec_to_hv(slurmdb_report_user_rec_t* rec, HV* hv)
{
AV* my_av;
HV* rh;
char* acct;
slurmdb_report_assoc_rec_t* ar = NULL;
slurmdb_tres_rec_t *tres_rec = NULL;
ListIterator itr = NULL;
my_av = (AV*)sv_2mortal((SV*)newAV());
if (rec->acct_list) {
itr = slurm_list_iterator_create(rec->acct_list);
while ((acct = slurm_list_next(itr))) {
av_push(my_av, newSVpv(acct, strlen(acct)));
}
slurm_list_iterator_destroy(itr);
}
hv_store_sv(hv, "acct_list", newRV((SV*)my_av));
my_av = (AV*)sv_2mortal((SV*)newAV());
if (rec->assoc_list) {
itr = slurm_list_iterator_create(rec->assoc_list);
while ((ar = slurm_list_next(itr))) {
rh = (HV*)sv_2mortal((SV*)newHV());
if (report_assoc_rec_to_hv(ar, rh) < 0) {
Perl_warn(aTHX_ "Failed to convert a report_assoc_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, "assoc_list", newRV((SV*)my_av));
STORE_FIELD(hv, rec, acct, charp);
STORE_FIELD(hv, rec, name, charp);
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));
STORE_FIELD(hv, rec, uid, uid_t);
return 0;
}
int
report_cluster_rec_to_hv(slurmdb_report_cluster_rec_t* rec, HV* hv)
{
AV* my_av;
HV* rh;
slurmdb_report_assoc_rec_t* ar = NULL;
slurmdb_report_user_rec_t* ur = NULL;
slurmdb_tres_rec_t *tres_rec = NULL;
ListIterator itr = NULL;
/* FIXME: do the accounting_list (add function to parse
* slurmdb_accounting_rec_t) */
my_av = (AV*)sv_2mortal((SV*)newAV());
if (rec->assoc_list) {
itr = slurm_list_iterator_create(rec->assoc_list);
while ((ar = slurm_list_next(itr))) {
rh = (HV*)sv_2mortal((SV*)newHV());
if (report_assoc_rec_to_hv(ar, rh) < 0) {
Perl_warn(aTHX_ "Failed to convert a report_assoc_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, "assoc_list", newRV((SV*)my_av));
STORE_FIELD(hv, rec, name, charp);
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));
my_av = (AV*)sv_2mortal((SV*)newAV());
if (rec->user_list) {
itr = slurm_list_iterator_create(rec->user_list);
while ((ur = slurm_list_next(itr))) {
rh = (HV*)sv_2mortal((SV*)newHV());
if (report_user_rec_to_hv(ur, rh) < 0) {
Perl_warn(aTHX_ "Failed to convert a report_user_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, "user_list", newRV((SV*)my_av));
return 0;
}