static char*
parse_marked_section(PSTATE* p_state, char *beg, char *end, U32 utf8, SV* self)
{
dTHX;
char *s = beg;
AV* tokens = 0;
if (!p_state->marked_sections)
return 0;
FIND_NAMES:
while (isHSPACE(*s))
s++;
while (isHNAME_FIRST(*s)) {
char *name_start = s;
char *name_end;
SV *name;
s++;
while (isHNAME_CHAR(*s))
s++;
name_end = s;
while (isHSPACE(*s))
s++;
if (s == end)
goto PREMATURE;
if (!tokens)
tokens = newAV();
name = newSVpvn(name_start, name_end - name_start);
if (utf8)
SvUTF8_on(name);
av_push(tokens, sv_lower(aTHX_ name));
}
if (*s == '-') {
s++;
if (*s == '-') {
/* comment */
s++;
while (1) {
while (s < end && *s != '-')
s++;
if (s == end)
goto PREMATURE;
s++; /* skip first '-' */
if (*s == '-') {
s++;
/* comment finished */
goto FIND_NAMES;
}
}
}
else
goto FAIL;
}
if (*s == '[') {
s++;
/* yup */
if (!tokens) {
tokens = newAV();
av_push(tokens, newSVpvn("include", 7));
}
if (!p_state->ms_stack)
p_state->ms_stack = newAV();
av_push(p_state->ms_stack, newRV_noinc((SV*)tokens));
marked_section_update(p_state);
report_event(p_state, E_NONE, beg, s, utf8, 0, 0, self);
return s;
}
FAIL:
SvREFCNT_dec(tokens);
return 0; /* not yet implemented */
PREMATURE:
SvREFCNT_dec(tokens);
return beg;
}
static void disabled_keywords(pTHX_ LinkedList *current, SV *sv, SV **rval,
u_32 *pKeywordMask)
{
const char *str;
LinkedList keyword_list = NULL;
if (sv)
{
if (SvROK(sv))
{
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVAV)
{
AV *av = (AV *) sv;
SV **pSV;
int i, max = av_len(av);
u_32 keywords = HAS_ALL_KEYWORDS;
keyword_list = LL_new();
for (i = 0; i <= max; i++)
{
if ((pSV = av_fetch(av, i, 0)) != NULL)
{
SvGETMAGIC(*pSV);
str = SvPV_nolen(*pSV);
#include "token/t_keywords.c"
success:
LL_push(keyword_list, string_new(str));
}
else
fatal("NULL returned by av_fetch() in disabled_keywords()");
}
if (pKeywordMask != NULL)
*pKeywordMask = keywords;
if (current != NULL)
{
LL_destroy(*current, (LLDestroyFunc) string_delete);
*current = keyword_list;
}
}
else
Perl_croak(aTHX_ "DisabledKeywords wants an array reference");
}
else
Perl_croak(aTHX_ "DisabledKeywords wants a reference to "
"an array of strings");
}
if (rval)
{
ListIterator li;
AV *av = newAV();
LL_foreach (str, li, *current)
av_push(av, newSVpv(CONST_CHAR(str), 0));
*rval = newRV_noinc((SV *) av);
}
return;
unknown:
LL_destroy(keyword_list, (LLDestroyFunc) string_delete);
Perl_croak(aTHX_ "Cannot disable unknown keyword '%s'", str);
}
/*
* get the vps and put them in perl hash
* If one VP have multiple values it is added as array_ref
* Example for this is Cisco-AVPair that holds multiple values.
* Which will be available as array_ref in $RAD_REQUEST{'Cisco-AVPair'}
*/
static void perl_store_vps(UNUSED TALLOC_CTX *ctx, REQUEST *request, VALUE_PAIR **vps, HV *rad_hv,
const char *hash_name, const char *list_name)
{
VALUE_PAIR *vp;
hv_undef(rad_hv);
vp_cursor_t cursor;
RINDENT();
fr_pair_list_sort(vps, fr_pair_cmp_by_da_tag);
for (vp = fr_cursor_init(&cursor, vps);
vp;
vp = fr_cursor_next(&cursor)) {
VALUE_PAIR *next;
char const *name;
char namebuf[256];
char buffer[1024];
size_t len;
/*
* Tagged attributes are added to the hash with name
* <attribute>:<tag>, others just use the normal attribute
* name as the key.
*/
if (vp->da->flags.has_tag && (vp->tag != TAG_ANY)) {
snprintf(namebuf, sizeof(namebuf), "%s:%d", vp->da->name, vp->tag);
name = namebuf;
} else {
name = vp->da->name;
}
/*
* We've sorted by type, then tag, so attributes of the
* same type/tag should follow on from each other.
*/
if ((next = fr_cursor_next_peek(&cursor)) && ATTRIBUTE_EQ(vp, next)) {
int i = 0;
AV *av;
av = newAV();
perl_vp_to_svpvn_element(request, av, vp, &i, hash_name, list_name);
do {
perl_vp_to_svpvn_element(request, av, next, &i, hash_name, list_name);
fr_cursor_next(&cursor);
} while ((next = fr_cursor_next_peek(&cursor)) && ATTRIBUTE_EQ(vp, next));
(void)hv_store(rad_hv, name, strlen(name), newRV_noinc((SV *)av), 0);
continue;
}
/*
* It's a normal single valued attribute
*/
switch (vp->da->type) {
case PW_TYPE_STRING:
RDEBUG("$%s{'%s'} = &%s:%s -> '%s'", hash_name, vp->da->name, list_name,
vp->da->name, vp->vp_strvalue);
(void)hv_store(rad_hv, name, strlen(name), newSVpvn(vp->vp_strvalue, vp->vp_length), 0);
break;
default:
len = vp_prints_value(buffer, sizeof(buffer), vp, 0);
RDEBUG("$%s{'%s'} = &%s:%s -> '%s'", hash_name, vp->da->name,
list_name, vp->da->name, buffer);
(void)hv_store(rad_hv, name, strlen(name),
newSVpvn(buffer, truncate_len(len, sizeof(buffer))), 0);
break;
}
}
REXDENT();
}
/*
* convert job_info_t to perl HV
*/
int
job_info_to_hv(job_info_t *job_info, HV *hv)
{
int j;
AV *av;
if(job_info->account)
STORE_FIELD(hv, job_info, account, charp);
if(job_info->alloc_node)
STORE_FIELD(hv, job_info, alloc_node, charp);
STORE_FIELD(hv, job_info, alloc_sid, uint32_t);
STORE_FIELD(hv, job_info, assoc_id, uint32_t);
STORE_FIELD(hv, job_info, batch_flag, uint16_t);
if(job_info->command)
STORE_FIELD(hv, job_info, command, charp);
if(job_info->comment)
STORE_FIELD(hv, job_info, comment, charp);
STORE_FIELD(hv, job_info, contiguous, uint16_t);
STORE_FIELD(hv, job_info, cpus_per_task, uint16_t);
if(job_info->dependency)
STORE_FIELD(hv, job_info, dependency, charp);
STORE_FIELD(hv, job_info, derived_ec, uint32_t);
STORE_FIELD(hv, job_info, eligible_time, time_t);
STORE_FIELD(hv, job_info, end_time, time_t);
if(job_info->exc_nodes)
STORE_FIELD(hv, job_info, exc_nodes, charp);
av = newAV();
for(j = 0; ; j += 2) {
if(job_info->exc_node_inx[j] == -1)
break;
av_store(av, j, newSVuv(job_info->exc_node_inx[j]));
av_store(av, j+1, newSVuv(job_info->exc_node_inx[j+1]));
}
hv_store_sv(hv, "exc_node_inx", newRV_noinc((SV*)av));
STORE_FIELD(hv, job_info, exit_code, uint32_t);
if(job_info->features)
STORE_FIELD(hv, job_info, features, charp);
if(job_info->gres)
STORE_FIELD(hv, job_info, gres, charp);
STORE_FIELD(hv, job_info, group_id, uint32_t);
STORE_FIELD(hv, job_info, job_id, uint32_t);
STORE_FIELD(hv, job_info, job_state, uint16_t);
if(job_info->licenses)
STORE_FIELD(hv, job_info, licenses, charp);
STORE_FIELD(hv, job_info, max_cpus, uint32_t);
STORE_FIELD(hv, job_info, max_nodes, uint32_t);
STORE_FIELD(hv, job_info, sockets_per_node, uint16_t);
STORE_FIELD(hv, job_info, cores_per_socket, uint16_t);
STORE_FIELD(hv, job_info, threads_per_core, uint16_t);
if(job_info->name)
STORE_FIELD(hv, job_info, name, charp);
if(job_info->network)
STORE_FIELD(hv, job_info, network, charp);
STORE_FIELD(hv, job_info, nice, uint16_t);
if(job_info->nodes)
STORE_FIELD(hv, job_info, nodes, charp);
av = newAV();
for(j = 0; ; j += 2) {
if(job_info->node_inx[j] == -1)
break;
av_store(av, j, newSVuv(job_info->node_inx[j]));
av_store(av, j+1, newSVuv(job_info->node_inx[j+1]));
}
hv_store_sv(hv, "node_inx", newRV_noinc((SV*)av));
STORE_FIELD(hv, job_info, ntasks_per_core, uint16_t);
STORE_FIELD(hv, job_info, ntasks_per_node, uint16_t);
STORE_FIELD(hv, job_info, ntasks_per_socket, uint16_t);
#ifdef HAVE_BG
slurm_get_select_jobinfo(job_info->select_jobinfo,
SELECT_JOBDATA_NODE_CNT,
&job_info->num_nodes);
#endif
STORE_FIELD(hv, job_info, num_nodes, uint32_t);
STORE_FIELD(hv, job_info, num_cpus, uint32_t);
STORE_FIELD(hv, job_info, pn_min_memory, uint32_t);
STORE_FIELD(hv, job_info, pn_min_cpus, uint16_t);
STORE_FIELD(hv, job_info, pn_min_tmp_disk, uint32_t);
if(job_info->partition)
STORE_FIELD(hv, job_info, partition, charp);
STORE_FIELD(hv, job_info, pre_sus_time, time_t);
STORE_FIELD(hv, job_info, priority, uint32_t);
if(job_info->qos)
STORE_FIELD(hv, job_info, qos, charp);
if(job_info->req_nodes)
STORE_FIELD(hv, job_info, req_nodes, charp);
av = newAV();
for(j = 0; ; j += 2) {
if(job_info->req_node_inx[j] == -1)
break;
av_store(av, j, newSVuv(job_info->req_node_inx[j]));
av_store(av, j+1, newSVuv(job_info->req_node_inx[j+1]));
}
hv_store_sv(hv, "req_node_inx", newRV_noinc((SV*)av));
STORE_FIELD(hv, job_info, req_switch, uint32_t);
STORE_FIELD(hv, job_info, requeue, uint16_t);
STORE_FIELD(hv, job_info, resize_time, time_t);
STORE_FIELD(hv, job_info, restart_cnt, uint16_t);
if(job_info->resv_name)
STORE_FIELD(hv, job_info, resv_name, charp);
STORE_PTR_FIELD(hv, job_info, select_jobinfo, "Slurm::dynamic_plugin_data_t");
STORE_PTR_FIELD(hv, job_info, job_resrcs, "Slurm::job_resources_t");
STORE_FIELD(hv, job_info, shared, uint16_t);
STORE_FIELD(hv, job_info, show_flags, uint16_t);
STORE_FIELD(hv, job_info, start_time, time_t);
if(job_info->state_desc)
STORE_FIELD(hv, job_info, state_desc, charp);
STORE_FIELD(hv, job_info, state_reason, uint16_t);
STORE_FIELD(hv, job_info, submit_time, time_t);
STORE_FIELD(hv, job_info, suspend_time, time_t);
STORE_FIELD(hv, job_info, time_limit, uint32_t);
STORE_FIELD(hv, job_info, time_min, uint32_t);
STORE_FIELD(hv, job_info, user_id, uint32_t);
STORE_FIELD(hv, job_info, wait4switch, uint32_t);
if(job_info->wckey)
STORE_FIELD(hv, job_info, wckey, charp);
if(job_info->work_dir)
STORE_FIELD(hv, job_info, work_dir, charp);
return 0;
}
AV *
plu_table_obj_to_array(pTHX_ plu_table_t *THIS, int recursive)
{
PLU_dSTACKASSERT;
int table_stack_offset;
lua_State *L;
char *keystr;
size_t keylen;
SV *value_sv;
int dopop;
AV *RETVAL;
I32 aryidx;
L = THIS->L;
PLU_ENTER_STACKASSERT(L);
PLU_TABLE_PUSH_TO_STACK(*THIS);
RETVAL = newAV();
sv_2mortal((SV *)RETVAL);
table_stack_offset = lua_gettop(L);
lua_pushnil(L); /* first key */
while (lua_next(L, table_stack_offset) != 0) {
/* uses 'key' (at index -2) and 'value' (at index -1) */
/* Prepare key - cast to int if need be */
switch (lua_type(L, -2)) {
case LUA_TSTRING:
{
SV *tmpsv;
keystr = (char *)lua_tolstring(L, -2, &keylen);
/* Using SV is not efficient, but may cause the perl warnings we want.
* That in turn may cause Perl code to be run that can throw exceptions.
* So we need to mortalize. Grmpf. */
tmpsv = newSVpvn(keystr, (STRLEN)keylen);
sv_2mortal(tmpsv);
aryidx = (I32)SvIV(tmpsv);
SvREFCNT_dec(tmpsv);
break;
}
case LUA_TNUMBER:
{
lua_Number n = lua_tonumber(L, -2); /* Don't change its type with lua_tointeger! */
aryidx = (I32)n; /* FIXME should this warn for actual truncation? */
break;
}
case LUA_TBOOLEAN:
aryidx = lua_toboolean(L, -2);
break;
default:
croak("Unsupported Lua type '%s' for Perl array indexes", lua_typename(L, lua_type(L, 02)));
}
/* Prepare value */
value_sv = plu_luaval_to_perl(aTHX_ L, -1, &dopop);
if (recursive && SvROK(value_sv)
&& sv_derived_from(value_sv, "PLua::Table"))
{
AV *tmpa;
tmpa = plu_table_obj_to_array(aTHX_ (plu_table_t *)SvIV(SvRV(value_sv)), recursive);
SvREFCNT_dec(value_sv);
value_sv = newRV_inc((SV *)tmpa);
}
(void)av_store(RETVAL, aryidx, value_sv);
/* removes 'value' if not already done; keeps 'key' for next iteration */
if (dopop)
lua_pop(L, 1);
}
lua_pop(L, 1);
PLU_LEAVE_STACKASSERT(L);
return RETVAL;
}
SV* /* AV if want_pos or want_all, PV otherwise */
lcss(
int wide, /* s and t are in the UTF8=1 format */
const char* s, /* Format determined by utf8 parameter */
STRLEN s_len, /* Byte length of s */
const char* t, /* Format determined by utf8 parameter */
STRLEN t_len, /* Byte length of t */
int min, /* Ignore substrings shorter than this */
int want_pos, /* Return positions as well as strings */
int want_all /* Return all matches, or just one */
) {
UV found; /* Number of longest substrings */
STRLEN z; /* Length of longuest substr */
int swapped; /* If s and t were swapped */
STRLEN* pos_s; /* 1-based char pos of the start of each longest substring in s */
STRLEN* pos_t; /* 1-based char pos of the start of each longest substring in t */
size_t allocated;
STRLEN* K; /* Previous row */
STRLEN* L; /* Current row */
SV* rv;
/* To save memory */
swapped = s_len < t_len;
if (swapped) {
SWAP(const char*, s, t);
SWAP(STRLEN, s_len, t_len);
}
/* This is potentially longer than needed when wide */
CALLOC(K, STRLEN, t_len + 1);
CALLOC(L, STRLEN, t_len + 1);
z = min - 1;
found = 0;
allocated = want_all ? 256 : 1;
MALLOC(pos_s, STRLEN, allocated);
MALLOC(pos_t, STRLEN, allocated);
/* Compute matrix */
if (wide) {
STRLEN s_pos; STRLEN t_pos; /* 1-based current char pos */
const U8* s_cur; const U8* t_cur; /* Pointer to current char */
STRLEN s_rem; STRLEN t_rem; /* Bytes remaining */
UV s_ch; UV t_ch; /* Current character */
for (s_pos=1, s_cur=(const U8*)s, s_rem=s_len; s_rem; ++s_pos) {
GRAB_AND_ADVANCE_ONE(s_ch, s_cur, s_rem);
for (t_pos=1, t_cur=(const U8*)t, t_rem=t_len; t_rem; ++t_pos) {
GRAB_AND_ADVANCE_ONE(t_ch, t_cur, t_rem);
if (s_ch == t_ch) {
L[t_pos] = K[t_pos - 1] + 1;
if (L[t_pos] > z) {
z = L[t_pos];
pos_s[0] = s_pos - z;
pos_t[0] = t_pos - z;
found = 1;
} else if (want_all & L[t_pos] == z && found) {
/* Maybe we need some more space */
if (found >= allocated) {
allocated += 256;
REALLOC(pos_s, STRLEN, allocated);
REALLOC(pos_t, STRLEN, allocated);
}
pos_s[found] = s_pos - z;
pos_t[found] = t_pos - z;
++found;
}
} else {
L[t_pos] = 0;
}
}
SWAP(STRLEN*, K, L);
}
} else {
STRLEN s_pos; /* 1-based current char pos */
STRLEN t_pos;
for (s_pos = 1; s_pos <= s_len; ++s_pos) {
for (t_pos = 1; t_pos <= t_len; ++t_pos) {
if (s[s_pos - 1] == t[t_pos - 1]) {
L[t_pos] = K[t_pos - 1] + 1;
if (L[t_pos] > z) {
z = L[t_pos];
pos_s[0] = s_pos - z;
pos_t[0] = t_pos - z;
found = 1;
} else if (want_all & L[t_pos] == z && found) {
/* Maybe we need some more space */
if (found >= allocated) {
allocated += 256;
REALLOC(pos_s, STRLEN, allocated);
REALLOC(pos_t, STRLEN, allocated);
}
pos_s[found] = s_pos - z;
pos_t[found] = t_pos - z;
++found;
}
} else {
L[t_pos] = 0;
}
}
SWAP(STRLEN*, K, L);
}
}
FREE(K);
FREE(L);
if (want_all) {
AV* const av = newAV();
I32 i;
STRLEN cur_pos;
rv = (SV*)av;
av_extend(av, found-1);
for (cur_pos=0, i=0; i<found; ++i) {
AV* const inner_av = newAV();
av_store(av, i, newRV_noinc((SV*)inner_av));
av_extend(inner_av, 2);
if (wide) {
av_store(inner_av, 0, _get_utf8_str_iter((const U8**)&t, &t_len, pos_t[i]-cur_pos, z));
cur_pos = pos_t[i] + z;
} else {
av_store(inner_av, 0, newSVpvn_utf8(t+pos_t[i], z, 0));
}
if (swapped) {
av_store(inner_av, 2, newSViv(pos_s[i]));
av_store(inner_av, 1, newSViv(pos_t[i]));
} else {
av_store(inner_av, 1, newSViv(pos_s[i]));
av_store(inner_av, 2, newSViv(pos_t[i]));
}
}
}
else if (want_pos) {
AV* const av = newAV();
rv = (SV*)av;
if (found) {
av_extend(av, 2);
if (wide) {
av_store(av, 0, _get_utf8_str((const U8*)t, t_len, pos_t[0], z));
} else {
av_store(av, 0, newSVpvn_utf8(t+pos_t[0], z, 0));
}
if (swapped) {
av_store(av, 2, newSViv(pos_s[0]));
av_store(av, 1, newSViv(pos_t[0]));
} else {
av_store(av, 1, newSViv(pos_s[0]));
av_store(av, 2, newSViv(pos_t[0]));
}
}
}
else {
if (found) {
if (wide)
rv = _get_utf8_str((const U8*)t, t_len, pos_t[0], z);
else
rv = newSVpvn(t+pos_t[0], z);
}
else
rv = &PL_sv_undef;
}
FREE(pos_s);
FREE(pos_t);
return rv;
}
static int _job_resrcs_to_hv(job_info_t *job_info, HV *hv)
{
AV *av;
HV *nr_hv;
bitstr_t *cpu_bitmap;
int sock_inx, sock_reps, last, cnt = 0, i, j, k;
char tmp1[128], tmp2[128];
char *host;
job_resources_t *job_resrcs = job_info->job_resrcs;
int bit_inx, bit_reps;
int abs_node_inx, rel_node_inx;
uint64_t *last_mem_alloc_ptr = NULL;
uint64_t last_mem_alloc = NO_VAL64;
char *last_hosts;
hostlist_t hl, hl_last;
uint32_t threads;
if (!job_resrcs || !job_resrcs->core_bitmap
|| ((last = slurm_bit_fls(job_resrcs->core_bitmap)) == -1))
return 0;
if (!(hl = slurm_hostlist_create(job_resrcs->nodes)))
return 1;
if (!(hl_last = slurm_hostlist_create(NULL)))
return 1;
av = newAV();
bit_inx = 0;
i = sock_inx = sock_reps = 0;
abs_node_inx = job_info->node_inx[i];
/* tmp1[] stores the current cpu(s) allocated */
tmp2[0] = '\0'; /* stores last cpu(s) allocated */
for (rel_node_inx=0; rel_node_inx < job_resrcs->nhosts;
rel_node_inx++) {
if (sock_reps >= job_resrcs->sock_core_rep_count[sock_inx]) {
sock_inx++;
sock_reps = 0;
}
sock_reps++;
bit_reps = job_resrcs->sockets_per_node[sock_inx] *
job_resrcs->cores_per_socket[sock_inx];
host = slurm_hostlist_shift(hl);
threads = _threads_per_core(host);
cpu_bitmap = slurm_bit_alloc(bit_reps * threads);
for (j = 0; j < bit_reps; j++) {
if (slurm_bit_test(job_resrcs->core_bitmap, bit_inx)){
for (k = 0; k < threads; k++)
slurm_bit_set(cpu_bitmap,
(j * threads) + k);
}
bit_inx++;
}
slurm_bit_fmt(tmp1, sizeof(tmp1), cpu_bitmap);
FREE_NULL_BITMAP(cpu_bitmap);
/*
* If the allocation values for this host are not the same as the
* last host, print the report of the last group of hosts that had
* identical allocation values.
*/
if (strcmp(tmp1, tmp2) ||
(last_mem_alloc_ptr != job_resrcs->memory_allocated) ||
(job_resrcs->memory_allocated &&
(last_mem_alloc !=
job_resrcs->memory_allocated[rel_node_inx]))) {
if (slurm_hostlist_count(hl_last)) {
last_hosts =
slurm_hostlist_ranged_string_xmalloc(
hl_last);
nr_hv = newHV();
hv_store_charp(nr_hv, "nodes", last_hosts);
hv_store_charp(nr_hv, "cpu_ids", tmp2);
hv_store_uint64_t(nr_hv, "mem",
last_mem_alloc_ptr ?
last_mem_alloc : 0);
av_store(av, cnt++, newRV_noinc((SV*)nr_hv));
xfree(last_hosts);
slurm_hostlist_destroy(hl_last);
hl_last = slurm_hostlist_create(NULL);
}
strcpy(tmp2, tmp1);
last_mem_alloc_ptr = job_resrcs->memory_allocated;
if (last_mem_alloc_ptr)
last_mem_alloc = job_resrcs->
memory_allocated[rel_node_inx];
else
last_mem_alloc = NO_VAL64;
}
slurm_hostlist_push_host(hl_last, host);
free(host);
if (bit_inx > last)
break;
if (abs_node_inx > job_info->node_inx[i+1]) {
i += 2;
abs_node_inx = job_info->node_inx[i];
} else {
abs_node_inx++;
}
}
if (slurm_hostlist_count(hl_last)) {
last_hosts = slurm_hostlist_ranged_string_xmalloc(hl_last);
nr_hv = newHV();
hv_store_charp(nr_hv, "nodes", last_hosts);
hv_store_charp(nr_hv, "cpu_ids", tmp2);
hv_store_uint64_t(nr_hv, "mem",
last_mem_alloc_ptr ?
last_mem_alloc : 0);
av_store(av, cnt++, newRV_noinc((SV*)nr_hv));
xfree(last_hosts);
}
slurm_hostlist_destroy(hl);
slurm_hostlist_destroy(hl_last);
hv_store_sv(hv, "node_resrcs", newRV_noinc((SV*)av));
return 0;
}
static SV *
DeadCode(pTHX)
{
#ifdef PURIFY
return Nullsv;
#else
SV* sva;
SV* sv;
SV* ret = newRV_noinc((SV*)newAV());
register SV* svend;
int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) == SVt_PVCV) {
CV *cv = (CV*)sv;
AV* padlist = CvPADLIST(cv), *argav;
SV** svp;
SV** pad;
int i = 0, j, levelm, totm = 0, levelref, totref = 0;
int levels, tots = 0, levela, tota = 0, levelas, totas = 0;
int dumpit = 0;
if (CvISXSUB(sv)) {
continue; /* XSUB */
}
if (!CvGV(sv)) {
continue; /* file-level scope. */
}
if (!CvROOT(cv)) {
/* PerlIO_printf(Perl_debug_log, " no root?!\n"); */
continue; /* autoloading stub. */
}
do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv));
if (CvDEPTH(cv)) {
PerlIO_printf(Perl_debug_log, " busy\n");
continue;
}
svp = AvARRAY(padlist);
while (++i <= AvFILL(padlist)) { /* Depth. */
SV **args;
pad = AvARRAY((AV*)svp[i]);
argav = (AV*)pad[0];
if (!argav || (SV*)argav == &PL_sv_undef) {
PerlIO_printf(Perl_debug_log, " closure-template\n");
continue;
}
args = AvARRAY(argav);
levelm = levels = levelref = levelas = 0;
levela = sizeof(SV*) * (AvMAX(argav) + 1);
if (AvREAL(argav)) {
for (j = 0; j < AvFILL(argav); j++) {
if (SvROK(args[j])) {
PerlIO_printf(Perl_debug_log, " ref in args!\n");
levelref++;
}
/* else if (SvPOK(args[j]) && SvPVX(args[j])) { */
else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) {
levelas += SvLEN(args[j])/SvREFCNT(args[j]);
}
}
}
for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */
if (SvROK(pad[j])) {
levelref++;
do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
dumpit = 1;
}
/* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */
else if (SvTYPE(pad[j]) >= SVt_PVAV) {
if (!SvPADMY(pad[j])) {
levelref++;
do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
dumpit = 1;
}
}
else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) {
levels++;
levelm += SvLEN(pad[j])/SvREFCNT(pad[j]);
/* Dump(pad[j],4); */
}
}
PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n",
i, levelref, levelm, levels, levela, levelas);
totm += levelm;
tota += levela;
totas += levelas;
tots += levels;
totref += levelref;
if (dumpit)
do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0);
}
if (AvFILL(padlist) > 1) {
PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n",
totref, totm, tots, tota, totas);
}
tref += totref;
tm += totm;
ts += tots;
ta += tota;
tas += totas;
}
}
}
PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas);
return ret;
#endif /* !PURIFY */
}
void
my_xsinit(pTHX)
{
dVAR;
static const char file[] = __FILE__;
#ifdef USE_CTRLX
GV *ctrlXgv;
SV *ctrlX;
#endif
#ifdef USE_SUBFILE
if (PL_preprocess)
croak("Can't use -P with pl2exe");
#endif
#ifdef NEED_INIT_WIN32CORE
init_Win32CORE(aTHX);
#endif
#ifdef USE_ZIP
pl2exe_boot_zip(aTHX);
#endif
#ifdef NEED_PREAMBLE
newXS("ExtUtils::PerlToExe::preamble",
XS_ExtUtils_PerlToExe_preamble,
file);
if (!PL_preambleav)
PL_preambleav = newAV();
av_push(PL_preambleav,
newSVpvs("BEGIN { ExtUtils::PerlToExe::preamble() }"));
#endif
#ifdef NEED_TAINT
TAINT;
TAINT_PROPER("appended " TAINT_TYPE);
TAINT_NOT;
#endif
#ifdef USE_CTRLX
ctrlXgv = gv_fetchpvs("\030", GV_NOTQUAL, SVt_PV);
ctrlX = GvSV(ctrlXgv);
/*
* We can't reopen PL_rsfp yet as it hasn't been set (the file is
* open, it's just in an auto variable in S_parse_body). However,
* it's easier to fixup the name here, before gv_fetch_file gets
* called on it.
*/
PL_origfilename = savepv(SvPV_nolen(ctrlX));
CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, PL_origfilename);
sv_setpv(ctrlX, CTRL_X);
SvTAINTED_on(ctrlX);
#endif
#ifdef USE_ZIP
pl2exe_load_zip(aTHX_ PL_origfilename);
#endif
real_xsinit(aTHX);
}
SV *sv;
if (length < 0)
length = strlen(bytes);
sv = newSV(length);
sv_setpvn(sv,(char *)bytes,length);
return sv_maybe_utf8(sv);
}
else
return &PL_sv_undef;
}
Tcl_Obj *
Tcl_NewListObj (int objc, Tcl_Obj *CONST objv[])
{
dTHX;
AV *av = newAV();
if (objc)
{
while (objc-- > 0)
{
SV *sv = objv[objc];
if (sv)
{
/* tkConfig.c passes Tcl_NewStringObj() or LangSetDefault()
so REFCNT should be ok as-is
*/
if (SvREFCNT(sv) <= 0 || SvTEMP(sv))
{
LangDebug("%s %d:\n",__FUNCTION__, objc);
sv_dump(sv);
}
PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
SV *
blizkost_marshal_arg(BLIZKOST_NEXUS, PMC *arg) {
struct sv *result = NULL;
dBNPERL; dBNINTERP;
/* If it's a P5Scalar PMC, then we just fetch the SV from it - trivial
* round-tripping. */
if (VTABLE_isa(interp, arg, CONST_STRING(interp, "P5Scalar"))) {
GETATTR_P5Scalar_sv(interp, arg, result);
}
/* XXX At this point, we should probably wrap it up in a tied Perl 5
* scalar so we can round-trip Parrot objects to. However, that's hard,
* so for now we cheat on a few special cases and just panic otherwise. */
else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "Integer"))) {
result = sv_2mortal(newSViv(VTABLE_get_integer(interp, arg)));
}
else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "Float"))) {
result = sv_2mortal(newSVnv(VTABLE_get_number(interp, arg)));
}
else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "P5Namespace"))) {
STRING *pkg;
char *c_str;
GETATTR_P5Namespace_ns_name(interp, arg, pkg);
c_str = Parrot_str_to_cstring(interp, pkg);
result = sv_2mortal(newSVpv(c_str, strlen(c_str)));
}
else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "String"))) {
char *c_str = Parrot_str_to_cstring(interp, VTABLE_get_string(interp, arg));
result = sv_2mortal(newSVpv(c_str, strlen(c_str)));
}
else if (VTABLE_does(interp, arg, CONST_STRING(interp, "invokable"))) {
CV *wrapper = blizkost_wrap_callable(nexus, arg);
result = sv_2mortal(newRV_inc((SV*)wrapper));
}
else if ( VTABLE_does(interp, arg, CONST_STRING(interp, "array"))) {
PMC *iter;
struct av *array = newAV();
iter = VTABLE_get_iter(interp, arg);
while (VTABLE_get_bool(interp, iter)) {
PMC *item = VTABLE_shift_pmc(interp, iter);
struct sv *marshaled =
blizkost_marshal_arg(nexus, item);
av_push( array, marshaled);
}
result = newRV_inc((SV*)array);
}
else if ( VTABLE_does(interp, arg, CONST_STRING(interp, "hash"))) {
PMC *iter = VTABLE_get_iter(interp, arg);
struct hv *hash = newHV();
INTVAL n = VTABLE_elements(interp, arg);
INTVAL i;
for(i = 0; i < n; i++) {
STRING *s = VTABLE_shift_string(interp, iter);
char *c_str = Parrot_str_to_cstring(interp, s);
struct sv *val = blizkost_marshal_arg(nexus,
VTABLE_get_pmc_keyed_str(interp, arg, s));
hv_store(hash, c_str, strlen(c_str), val, 0);
}
result = newRV_inc((SV*)hash);
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, 1,
"Sorry, we do not support marshaling most things to Perl 5 yet.");
}
return result;
}
static AV*
S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
{
AV* retval;
GV** gvp;
GV* gv;
AV* isa;
const HEK* stashhek;
struct mro_meta* meta;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
assert(HvAUX(stash));
stashhek = HvNAME_HEK(stash);
if (!stashhek)
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
if (level > 100)
Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
HEK_KEY(stashhek));
meta = HvMROMETA(stash);
/* return cache if valid */
if((retval = meta->mro_linear_c3)) {
return retval;
}
/* not in cache, make a new one */
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
if ( isa && ! SvAVOK(isa) ) {
Perl_croak(aTHX_ "@ISA is not an array but %s", Ddesc((SV*)isa));
}
/* For a better idea how the rest of this works, see the much clearer
pure perl version in Algorithm::C3 0.01:
http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
(later versions go about it differently than this code for speed reasons)
*/
if(isa && AvFILLp(isa) >= 0) {
SV** seqs_ptr;
I32 seqs_items;
HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
I32* heads;
/* This builds @seqs, which is an array of arrays.
The members of @seqs are the MROs of
the members of @ISA, followed by @ISA itself.
*/
I32 items = AvFILLp(isa) + 1;
SV** isa_ptr = AvARRAY(isa);
while(items--) {
SV* const isa_item = *isa_ptr++;
if ( ! SvPVOK(isa_item) ) {
Perl_croak(aTHX_ "@ISA element which is not an plain value");
}
{
HV* const isa_item_stash = gv_stashsv(isa_item, 0);
if(!isa_item_stash) {
/* if no stash, make a temporary fake MRO
containing just itself */
AV* const isa_lin = newAV();
av_push(isa_lin, newSVsv(isa_item));
av_push(seqs, (SV*)isa_lin);
}
else {
/* recursion */
AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
av_push(seqs, SvREFCNT_inc_NN((SV*)isa_lin));
}
}
}
av_push(seqs, SvREFCNT_inc_NN((SV*)isa));
/* This builds "heads", which as an array of integer array
indices, one per seq, which point at the virtual "head"
of the seq (initially zero) */
Newxz(heads, AvFILLp(seqs)+1, I32);
/* This builds %tails, which has one key for every class
mentioned in the tail of any sequence in @seqs (tail meaning
everything after the first class, the "head"). The value
is how many times this key appears in the tails of @seqs.
*/
seqs_ptr = AvARRAY(seqs);
seqs_items = AvFILLp(seqs) + 1;
while(seqs_items--) {
AV *const seq = MUTABLE_AV(*seqs_ptr++);
I32 seq_items = AvFILLp(seq);
if(seq_items > 0) {
SV** seq_ptr = AvARRAY(seq) + 1;
while(seq_items--) {
SV* const seqitem = *seq_ptr++;
/* LVALUE fetch will create a new undefined SV if necessary
*/
HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
if(he) {
SV* const val = HeVAL(he);
/* This will increment undef to 1, which is what we
want for a newly created entry. */
sv_inc(val);
}
}
}
}
/* Initialize retval to build the return value in */
retval = newAV();
av_push(retval, newSVhek(stashhek)); /* us first */
/* This loop won't terminate until we either finish building
the MRO, or get an exception. */
while(1) {
SV* cand = NULL;
SV* winner = NULL;
int s;
/* "foreach $seq (@seqs)" */
SV** const avptr = AvARRAY(seqs);
for(s = 0; s <= AvFILLp(seqs); s++) {
SV** svp;
AV * const seq = MUTABLE_AV(avptr[s]);
SV* seqhead;
if(!seq) continue; /* skip empty seqs */
svp = av_fetch(seq, heads[s], 0);
seqhead = *svp; /* seqhead = head of this seq */
if(!winner) {
HE* tail_entry;
SV* val;
/* if we haven't found a winner for this round yet,
and this seqhead is not in tails (or the count
for it in tails has dropped to zero), then this
seqhead is our new winner, and is added to the
final MRO immediately */
cand = seqhead;
if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
&& (val = HeVAL(tail_entry))
&& (SvIV(val) > 0))
continue;
winner = newSVsv(cand);
av_push(retval, winner);
/* note however that even when we find a winner,
we continue looping over @seqs to do housekeeping */
}
if(!sv_cmp(seqhead, winner)) {
/* Once we have a winner (including the iteration
where we first found him), inc the head ptr
for any seq which had the winner as a head,
NULL out any seq which is now empty,
and adjust tails for consistency */
const int new_head = ++heads[s];
if(new_head > AvFILLp(seq)) {
SvREFCNT_dec(avptr[s]);
avptr[s] = NULL;
}
else {
HE* tail_entry;
SV* val;
/* Because we know this new seqhead used to be
a tail, we can assume it is in tails and has
a positive value, which we need to dec */
svp = av_fetch(seq, new_head, 0);
seqhead = *svp;
tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
val = HeVAL(tail_entry);
sv_dec(val);
}
}
}
/* if we found no candidates, we are done building the MRO.
!cand means no seqs have any entries left to check */
if(!cand) {
Safefree(heads);
break;
}
/* If we had candidates, but nobody won, then the @ISA
hierarchy is not C3-incompatible */
if(!winner) {
SV *errmsg;
I32 i;
errmsg = newSVpvf(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s':\n\t"
"current merge results [\n", HEK_KEY(stashhek));
for (i = 0; i <= av_len(retval); i++) {
SV **elem = av_fetch(retval, i, 0);
sv_catpvf(aTHX_ errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
}
sv_catpvf(aTHX_ errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
/* we have to do some cleanup before we croak */
AvREFCNT_dec(retval);
Safefree(heads);
croak(aTHX_ "%"SVf, SVfARG(errmsg));
}
}
}
else { /* @ISA was undefined or empty */
/* build a retval containing only ourselves */
retval = newAV();
av_push(retval, newSVhek(stashhek));
}
/* we don't want anyone modifying the cache entry but us,
and we do so by replacing it completely */
SvREADONLY_on(retval);
meta->mro_linear_c3 = retval;
return retval;
}
SV * parse_in_chunks(char * filepath, size_t filesize) {
char *buf;
size_t bytes_read = 0;
int max_buf = 1000;
char *err_msg;
int block = BLOCK_HEADER;
int cur_event_type = 0;
int event_type = 0;
char event_block = 0;
char *brnl, *breq;
AV * data;
AV * datawrapper;
AV * events;
char *line;
char * nl = "\n";
char * eq = "=";
int rewind_pos = 0;
size_t cur_fpos = 0;
SV * pbuf;
SV * pmax_buf;
AV * HANDLERS = get_av("Opsview::Utils::NDOLogsImporter::HANDLERS", 0);
AV * INPUT_DATA_TYPE = get_av("Opsview::Utils::NDOLogsImporter::INPUT_DATA_TYPE", 0);
int init_last_pos;
int init_block;
if ( first_read ) {
if ( ! ( fh = PerlIO_open( filepath, "rb" ) ) ) {
croak("Could not open file: %s\n", strerror(errno));
}
bytes_left = filesize;
init_last_pos = prev_pos = first_read = 0;
init_block = block = BLOCK_HEADER;
} else {
init_block = block = BLOCK_EVENTS;
init_last_pos = prev_pos;
}
read_begin:
brnl = NULL;
breq = NULL;
pbuf = get_sv("Opsview::Utils::NDOLogsImporter::PARSE_BUF", 0);
pmax_buf = get_sv("Opsview::Utils::NDOLogsImporter::MAX_BUF_SIZE", 0);
buf = SvPVX(pbuf);
max_buf = SvIVX(pmax_buf);
if ( max_buf < 1024 * 1024 && ! automated_tests ) {
max_buf = 1024*1024;
SvIV_set( pmax_buf, max_buf );
SvGROW( pbuf, max_buf + 1);
SvCUR_set( pbuf, max_buf);
}
if ( bytes_left > 0 ) {
bytes_read = PerlIO_read(fh, buf + prev_pos, max_buf-prev_pos);
cur_fpos = PerlIO_tell(fh);
if ( bytes_read < 0 ) {
err_msg = strerror(errno);
PerlIO_close( fh );
croak("Could not read file: %s\n", err_msg);
}
bytes_left -= bytes_read;
events = (AV *)sv_2mortal((SV *)newAV());
rewind_pos = last_999(buf+prev_pos, bytes_read);
prev_pos = bytes_read + prev_pos - rewind_pos;
buf[prev_pos] = '\0';
// avg ratio events:file_size = 0.21%
if ( prev_pos > 1000 ) {
av_extend( events, (int)(prev_pos * 0.0021) );
}
for ( line = strtok_r(buf, nl, &brnl); line != NULL; line = strtok_r(NULL, nl, &brnl) )
{
switch(block) {
case BLOCK_HEADER:
{
if ( strEQ(line, "STARTDATADUMP") ) {
block = BLOCK_EVENTS;
}
}
break;
case BLOCK_EVENTS:
{
if ( strEQ(line, "1000") ) { /* NDO_API_ENDDATADUMP */
block = BLOCK_FOOTER;
continue;
}
cur_event_type = atoi(line);
/* ignore events we are not handling */
if ( ! av_exists(HANDLERS, cur_event_type) ) {
block = BLOCK_IGNORE_EVENT;
continue;
}
event_block = BLOCK_EVENT_STARTED;
if ( cur_event_type != event_type ) {
datawrapper = (AV *)sv_2mortal((SV *)newAV());
data = (AV *)sv_2mortal((SV *)newAV());
av_push( events, newSViv( cur_event_type ) );
av_push( datawrapper, newRV( (SV *)data ) );
av_push( events, newRV( (SV *)datawrapper ) );
event_type = cur_event_type;
} else {
data = (AV *)sv_2mortal((SV *)newAV());
av_push( datawrapper, newRV( (SV *)data ) );
}
block = BLOCK_EVENT;
}
break;
case BLOCK_EVENT:
{
if ( strEQ(line, "999") ) { /* NDO_API_ENDDATA */
block = BLOCK_EVENTS;
event_block = BLOCK_EVENT_ENDED;
} else {
char *k;
char *v;
int key;
int key_type = 0;
int v_len = 0;
k = strtok_r(line, eq, &breq);
v = strtok_r(NULL, "\0", &breq);
key = atoi(k);
/* invalid key, skip parsing */
if ( key == 0 ) {
goto remove_invalid;
}
SV ** const k_type = av_fetch(INPUT_DATA_TYPE, key, 0 );
if ( k_type ) {
key_type = SvIVx( *k_type );
}
if ( v ) {
if ( key_type & 1 ) {
v_len = ndo_unescape_buffer( v );
} else {
v_len = strlen(v);
}
}
if ( key_type & 2 ) {
AV * datanstptr;
SV ** const datanst = av_fetch(data, key, 0 );
if ( datanst ) {
datanstptr = (AV *)SvRV( *datanst );
} else {
datanstptr = (AV *)sv_2mortal((SV *)newAV());
av_store( data, key, newRV( (SV *)datanstptr ) );
}
if ( v ) {
av_push( datanstptr, newSVpvn(v, v_len) );
} else {
av_push( datanstptr, newSVpvn("", 0) );
}
} else {
if ( v ) {
av_store( data, key, newSVpvn(v, v_len) );
} else {
av_store( data, key, newSVpvn("", 0) );
}
}
}
}
break;
case BLOCK_FOOTER:
{
if ( strEQ(line, "GOODBYE") ) {
block = BLOCK_HEADER;
}
}
break;
case BLOCK_IGNORE_EVENT:
{
if ( strEQ(line, "999") ) { /* NDO_API_ENDDATA */
block = BLOCK_EVENTS; // go back to EVENTS
continue;
}
}
break;
}
};
/* there were some events */
if ( event_block != BLOCK_HEADER ) {
if ( event_block != BLOCK_EVENT_ENDED ) {
remove_invalid:
av_pop( datawrapper );
}
/* remove whole block if the last block has no events */
if ( av_len( datawrapper ) == -1 ) {
av_pop( events );
av_pop( events );
}
}
if ( av_len(events) > 0 ) {
if ( rewind_pos > 0 && cur_fpos < filesize ) {
memmove(buf, buf+prev_pos+1, rewind_pos-1);
}
prev_pos = rewind_pos - 1;
return newRV_inc((SV *) events);
} else {
if ( cur_fpos < filesize && event_block != BLOCK_HEADER && event_block != BLOCK_EVENT_ENDED ) {
int new_max_buf = max_buf * 2;
SvIV_set( pmax_buf, new_max_buf );
SvGROW( pbuf, new_max_buf + 1);
SvCUR_set( pbuf, new_max_buf);
//start again as previous buffer would be tokenized already
prev_pos = 0;
block = init_block;
event_type = 0;
PerlIO_close( fh );
if ( ! ( fh = PerlIO_open( filepath, "rb" ) ) ) {
croak("Could not re-open file: %s\n", strerror(errno));
}
PerlIO_seek(fh, cur_fpos-bytes_read-init_last_pos, SEEK_SET);
bytes_left += bytes_read + init_last_pos;
goto read_begin;
}
}
}
parser_reset_iterator();
return &PL_sv_undef;
}
SV* primesieve(SV *start_sv, SV *limit_sv, int run_mode, int fd)
{
AV *ret;
uint64_t n_ret, start, limit, *primes;
size_t size, i;
int err;
#ifdef __LP64__
start = SvUV(start_sv);
limit = SvUV(limit_sv);
#else
start = strtoull(SvPV_nolen(start_sv), NULL, 10);
limit = strtoull(SvPV_nolen(limit_sv), NULL, 10);
#endif
ret = newAV(), n_ret = 0, err = 0;
//====================================================================
// Count primes, sum primes, otherwise output primes for this block.
//====================================================================
if (run_mode == MODE_COUNT) {
n_ret = primesieve_count_primes(start, limit);
}
else {
primes = primesieve_generate_primes(start, limit, &size, UINT64_PRIMES);
if (run_mode == MODE_SUM) {
for (i = 0; i < size; i++)
n_ret += primes[i];
}
else {
char *buf; int len;
buf = (char *) malloc(sizeof(char) * (FLUSH_LIMIT + 216));
len = 0;
for (i = 0; i < size; i++) {
if ((err = write_output(fd, buf, primes[i], &len)))
break;
}
if (!err)
err = flush_output(fd, buf, &len);
free((void *) buf);
buf = NULL;
}
primesieve_free(primes);
}
//====================================================================
// Return.
//====================================================================
if (run_mode == MODE_PRINT) {
av_push(ret, newSViv(err));
}
else {
#ifdef __LP64__
av_push(ret, newSVuv(n_ret));
#else
SV *n_sv; char *ptr; STRLEN len; int n_chars;
n_sv = newSVpvn("", N_MAXDIGITS);
ptr = SvPV(n_sv, len);
n_chars = sprintull(ptr, n_ret);
av_push(ret, newSVpvn(ptr, n_chars));
#endif
}
return newRV_noinc((SV *) ret);
}
int
job_rec_to_hv(slurmdb_job_rec_t* rec, HV* hv)
{
slurmdb_step_rec_t *step;
ListIterator itr = NULL;
AV* steps_av = (AV*)sv_2mortal((SV*)newAV());
HV* stats_hv = (HV*)sv_2mortal((SV*)newHV());
HV* step_hv;
stats_to_hv(&rec->stats, stats_hv);
hv_store_sv(hv, "stats", newRV((SV*)stats_hv));
if (rec->steps) {
itr = slurm_list_iterator_create(rec->steps);
while ((step = slurm_list_next(itr))) {
step_hv = (HV*)sv_2mortal((SV*)newHV());
step_rec_to_hv(step, step_hv);
av_push(steps_av, newRV((SV*)step_hv));
}
slurm_list_iterator_destroy(itr);
}
hv_store_sv(hv, "steps", newRV((SV*)steps_av));
STORE_FIELD(hv, rec, account, charp);
STORE_FIELD(hv, rec, alloc_gres, charp);
STORE_FIELD(hv, rec, alloc_nodes, uint32_t);
STORE_FIELD(hv, rec, array_job_id, uint32_t);
STORE_FIELD(hv, rec, array_max_tasks, uint32_t);
STORE_FIELD(hv, rec, array_task_id, uint32_t);
STORE_FIELD(hv, rec, array_task_str, charp);
STORE_FIELD(hv, rec, associd, uint32_t);
STORE_FIELD(hv, rec, blockid, charp);
STORE_FIELD(hv, rec, cluster, charp);
STORE_FIELD(hv, rec, derived_ec, uint32_t);
STORE_FIELD(hv, rec, derived_es, charp);
STORE_FIELD(hv, rec, elapsed, uint32_t);
STORE_FIELD(hv, rec, eligible, time_t);
STORE_FIELD(hv, rec, end, time_t);
STORE_FIELD(hv, rec, exitcode, uint32_t);
/*STORE_FIELD(hv, rec, first_step_ptr, void*);*/
STORE_FIELD(hv, rec, gid, uint32_t);
STORE_FIELD(hv, rec, jobid, uint32_t);
STORE_FIELD(hv, rec, jobname, charp);
STORE_FIELD(hv, rec, lft, uint32_t);
STORE_FIELD(hv, rec, partition, charp);
STORE_FIELD(hv, rec, nodes, charp);
STORE_FIELD(hv, rec, priority, uint32_t);
STORE_FIELD(hv, rec, qosid, uint32_t);
STORE_FIELD(hv, rec, req_cpus, uint32_t);
STORE_FIELD(hv, rec, req_gres, charp);
STORE_FIELD(hv, rec, req_mem, uint32_t);
STORE_FIELD(hv, rec, requid, uint32_t);
STORE_FIELD(hv, rec, resvid, uint32_t);
STORE_FIELD(hv, rec, resv_name, charp);
STORE_FIELD(hv, rec, show_full, uint32_t);
STORE_FIELD(hv, rec, start, time_t);
STORE_FIELD(hv, rec, state, uint32_t);
STORE_FIELD(hv, rec, submit, time_t);
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, timelimit, uint32_t);
STORE_FIELD(hv, rec, tot_cpu_sec, uint32_t);
STORE_FIELD(hv, rec, tot_cpu_usec, uint32_t);
STORE_FIELD(hv, rec, track_steps, uint16_t);
STORE_FIELD(hv, rec, tres_alloc_str, charp);
STORE_FIELD(hv, rec, uid, uint32_t);
STORE_FIELD(hv, rec, used_gres, charp);
STORE_FIELD(hv, rec, user, charp);
STORE_FIELD(hv, rec, user_cpu_sec, uint32_t);
STORE_FIELD(hv, rec, user_cpu_usec, uint32_t);
STORE_FIELD(hv, rec, wckey, charp);
STORE_FIELD(hv, rec, wckeyid, uint32_t);
return 0;
}
/*
* get the vps and put them in perl hash
* If one VP have multiple values it is added as array_ref
* Example for this is Cisco-AVPair that holds multiple values.
* Which will be available as array_ref in $RAD_REQUEST{'Cisco-AVPair'}
*/
static void perl_store_vps(VALUE_PAIR *vp, HV *rad_hv)
{
VALUE_PAIR *nvp, *vpa, *vpn;
AV *av;
const char *name;
char namebuf[256];
char buffer[1024];
int len;
hv_undef(rad_hv);
/*
* Copy the valuepair list so we can remove attributes we've
* already processed.
*/
nvp = paircopy(vp);
while (nvp != NULL) {
/*
* Tagged attributes are added to the hash with name
* <attribute>:<tag>, others just use the normal attribute
* name as the key.
*/
if (nvp->flags.has_tag && (nvp->flags.tag != 0)) {
snprintf(namebuf, sizeof(namebuf), "%s:%d",
nvp->name, nvp->flags.tag);
name = namebuf;
} else {
name = nvp->name;
}
/*
* Create a new list with all the attributes like this one
* which are in the same tag group.
*/
vpa = paircopy2(nvp, nvp->attribute, nvp->vendor, nvp->flags.tag);
/*
* Attribute has multiple values
*/
if (vpa->next) {
av = newAV();
for (vpn = vpa; vpn; vpn = vpn->next) {
len = vp_prints_value(buffer, sizeof(buffer), vpn, FALSE);
av_push(av, newSVpv(buffer, len));
}
(void)hv_store(rad_hv, name, strlen(name), newRV_noinc((SV *)av), 0);
/*
* Attribute has a single value, so its value just gets
* added to the hash.
*/
} else {
len = vp_prints_value(buffer, sizeof(buffer), vpa, FALSE);
(void)hv_store(rad_hv, name, strlen(name), newSVpv(buffer, len), 0);
}
pairfree(&vpa);
/*
* Find the next attribute which we won't have processed,
* we need to do this so we know it won't be freed on
* pairdelete.
*/
vpa = nvp->next;
while ((vpa != NULL) &&
(vpa->attribute == nvp->attribute) &&
(vpa->vendor == nvp->vendor) &&
(vpa->flags.tag == nvp->flags.tag)) {
vpa = vpa->next;
}
/*
* Finally remove all the VPs we processed from our copy
* of the list.
*/
pairdelete(&nvp, nvp->attribute, nvp->vendor, nvp->flags.tag);
nvp = vpa;
}
}
AV *p5_newAV(PerlInterpreter *my_perl) {
return newAV();
}
/*
=for apidoc mro_get_linear_isa
Returns the mro linearisation for the given stash. By default, this
will be whatever C<mro_get_linear_isa_dfs> returns unless some
other MRO is in effect for the stash. The return value is a
read-only AV*.
You are responsible for C<SvREFCNT_inc()> on the
return value if you plan to store it anywhere
semi-permanently (otherwise it might be deleted
out from under you the next time the cache is
invalidated).
=cut
*/
AV*
Perl_mro_get_linear_isa(pTHX_ HV *stash)
{
struct mro_meta* meta;
AV *isa;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
if(!SvOOK(stash))
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
meta = HvMROMETA(stash);
if (!meta->mro_which)
Perl_croak(aTHX_ "panic: invalid MRO!");
isa = meta->mro_which->resolve(aTHX_ stash, 0);
if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */
SV * const namesv =
(HvENAME(stash)||HvNAME(stash))
? newSVhek(HvENAME_HEK(stash)
? HvENAME_HEK(stash)
: HvNAME_HEK(stash))
: NULL;
if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))
{
AV * const old = isa;
SV **svp;
SV **ovp = AvARRAY(old);
SV * const * const oend = ovp + AvFILLp(old) + 1;
isa = (AV *)sv_2mortal((SV *)newAV());
av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1);
*AvARRAY(isa) = namesv;
svp = AvARRAY(isa)+1;
while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++);
}
else SvREFCNT_dec(namesv);
}
if (!meta->isa) {
HV *const isa_hash = newHV();
/* Linearisation didn't build it for us, so do it here. */
SV *const *svp = AvARRAY(isa);
SV *const *const svp_end = svp + AvFILLp(isa) + 1;
const HEK *canon_name = HvENAME_HEK(stash);
if (!canon_name) canon_name = HvNAME_HEK(stash);
while (svp < svp_end) {
(void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
}
(void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
HEK_LEN(canon_name), HEK_FLAGS(canon_name),
HV_FETCH_ISSTORE, &PL_sv_undef,
HEK_HASH(canon_name));
(void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
SvREADONLY_on(isa_hash);
meta->isa = isa_hash;
}
return isa;
}
void single_hook_fill(pTHX_ const char *hook, const char *type, SingleHook *sth,
SV *sub, U32 allowed_args)
{
if (!DEFINED(sub))
{
sth->sub = NULL;
sth->arg = NULL;
}
else if (SvROK(sub))
{
SV *sv = SvRV(sub);
switch (SvTYPE(sv))
{
case SVt_PVCV:
sth->sub = sv;
sth->arg = NULL;
break;
case SVt_PVAV:
{
AV *in = (AV *) sv;
I32 len = av_len(in);
if (len < 0)
Perl_croak(aTHX_ "Need at least a code reference in %s hook for "
"type '%s'", hook, type);
else
{
SV **pSV = av_fetch(in, 0, 0);
if (pSV == NULL || !SvROK(*pSV) ||
SvTYPE(sv = SvRV(*pSV)) != SVt_PVCV)
Perl_croak(aTHX_ "%s hook defined for '%s' is not "
"a code reference", hook, type);
else
{
I32 ix;
AV *out;
for (ix = 0; ix < len; ++ix)
{
pSV = av_fetch(in, ix+1, 0);
if (pSV == NULL)
fatal("NULL returned by av_fetch() in single_hook_fill()");
if (SvROK(*pSV) && sv_isa(*pSV, ARGTYPE_PACKAGE))
{
HookArgType argtype = (HookArgType) SvIV(SvRV(*pSV));
#define CHECK_ARG_TYPE(type) \
case HOOK_ARG_ ## type: \
if ((allowed_args & SHF_ALLOW_ARG_ ## type) == 0) \
Perl_croak(aTHX_ #type " argument not allowed"); \
break
switch (argtype)
{
CHECK_ARG_TYPE(SELF);
CHECK_ARG_TYPE(TYPE);
CHECK_ARG_TYPE(DATA);
CHECK_ARG_TYPE(HOOK);
}
#undef CHECK_ARG_TYPE
}
}
sth->sub = sv;
out = newAV();
av_extend(out, len-1);
for (ix = 0; ix < len; ++ix)
{
pSV = av_fetch(in, ix+1, 0);
if (pSV == NULL)
fatal("NULL returned by av_fetch() in single_hook_fill()");
SvREFCNT_inc(*pSV);
if (av_store(out, ix, *pSV) == NULL)
SvREFCNT_dec(*pSV);
}
sth->arg = (AV *) sv_2mortal((SV *) out);
}
}
}
break;
default:
goto not_code_or_array_ref;
}
}
else
{
not_code_or_array_ref:
Perl_croak(aTHX_ "%s hook defined for '%s' is not "
"a code or array reference", hook, type);
}
}
/*
=for apidoc mro_package_moved
Call this function to signal to a stash that it has been assigned to
another spot in the stash hierarchy. C<stash> is the stash that has been
assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
that is actually being assigned to.
This can also be called with a null first argument to
indicate that C<oldstash> has been deleted.
This function invalidates isa caches on the old stash, on all subpackages
nested inside it, and on the subclasses of all those, including
non-existent packages that have corresponding entries in C<stash>.
It also sets the effective names (C<HvENAME>) on all the stashes as
appropriate.
If the C<gv> is present and is not in the symbol table, then this function
simply returns. This checked will be skipped if C<flags & 1>.
=cut
*/
void
Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
const GV * const gv, U32 flags)
{
SV *namesv;
HEK **namep;
I32 name_count;
HV *stashes;
HE* iter;
PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
assert(stash || oldstash);
/* Determine the name(s) of the location that stash was assigned to
* or from which oldstash was removed.
*
* We cannot reliably use the name in oldstash, because it may have
* been deleted from the location in the symbol table that its name
* suggests, as in this case:
*
* $globref = \*foo::bar::;
* Symbol::delete_package("foo");
* *$globref = \%baz::;
* *$globref = *frelp::;
* # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
*
* So we get it from the gv. But, since the gv may no longer be in the
* symbol table, we check that first. The only reliable way to tell is
* to see whether its stash has an effective name and whether the gv
* resides in that stash under its name. That effective name may be
* different from what gv_fullname4 would use.
* If flags & 1, the caller has asked us to skip the check.
*/
if(!(flags & 1)) {
SV **svp;
if(
!GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
!(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) ||
*svp != (SV *)gv
) return;
}
assert(SvOOK(GvSTASH(gv)));
assert(GvNAMELEN(gv));
assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
if (!name_count) {
name_count = 1;
namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
}
else {
namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
if (name_count < 0) ++namep, name_count = -name_count - 1;
}
if (name_count == 1) {
if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
namesv = GvNAMELEN(gv) == 1
? newSVpvs_flags(":", SVs_TEMP)
: newSVpvs_flags("", SVs_TEMP);
}
else {
namesv = sv_2mortal(newSVhek(*namep));
if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
else sv_catpvs(namesv, "::");
}
if (GvNAMELEN(gv) != 1) {
sv_catpvn_flags(
namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
/* skip trailing :: */
GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
);
}
}
else {
SV *aname;
namesv = sv_2mortal((SV *)newAV());
while (name_count--) {
if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
aname = GvNAMELEN(gv) == 1
? newSVpvs(":")
: newSVpvs("");
namep++;
}
else {
aname = newSVhek(*namep++);
if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
else sv_catpvs(aname, "::");
}
if (GvNAMELEN(gv) != 1) {
sv_catpvn_flags(
aname, GvNAME(gv), GvNAMELEN(gv) - 2,
/* skip trailing :: */
GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
);
}
av_push((AV *)namesv, aname);
}
}
/* Get a list of all the affected classes. */
/* We cannot simply pass them all to mro_isa_changed_in to avoid
the list, as that function assumes that only one package has
changed. It does not work with:
@foo::ISA = qw( B B::B );
*B:: = delete $::{"A::"};
as neither B nor B::B can be updated before the other, since they
will reset caches on foo, which will see either B or B::B with the
wrong name. The names must be set on *all* affected stashes before
we do anything else. (And linearisations must be cleared, too.)
*/
stashes = (HV *) sv_2mortal((SV *)newHV());
mro_gather_and_rename(
stashes, (HV *) sv_2mortal((SV *)newHV()),
stash, oldstash, namesv
);
/* Once the caches have been wiped on all the classes, call
mro_isa_changed_in on each. */
hv_iterinit(stashes);
while((iter = hv_iternext(stashes))) {
HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
if(HvENAME(stash)) {
/* We have to restore the original meta->isa (that
mro_gather_and_rename set aside for us) this way, in case
one class in this list is a superclass of a another class
that we have already encountered. In such a case, meta->isa
from PL_isarev. */
struct mro_meta * const meta = HvMROMETA(stash);
if(meta->isa != (HV *)HeVAL(iter)) {
SvREFCNT_dec(meta->isa);
meta->isa
= HeVAL(iter) == &PL_sv_yes
? NULL
: (HV *)HeVAL(iter);
HeVAL(iter) = NULL; /* We donated our reference count. */
}
mro_isa_changed_in(stash);
}
}
}
int perl_embed_run_arr(char *file_path, char *func_name, HV *func_params, char *obj_name, HV *obj_attr, char *error, int errorlength, char ***retarray, int *retlength) {
int i;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
AV *retav = newAV();
//filnavnet
XPUSHs(sv_2mortal(newSVpv(file_path, 0) ));
//mappen, for å inkludere
//XPUSHs(sv_2mortal(newSVpv(collection->crawlLibInfo->resourcepath, 0) ));
XPUSHs(sv_2mortal(newSViv(perl_opt_cache)));
XPUSHs(sv_2mortal(newSVpv(func_name, 0)));
XPUSHs(sv_2mortal(newRV((SV *) func_params)));
if (obj_name != NULL)
XPUSHs(sv_2mortal(newSVpv(obj_name, 0)));
if (obj_attr != NULL)
XPUSHs(sv_2mortal(newRV((SV *) obj_attr)));
PUTBACK;
int retn = call_pv("Embed::Persistent::eval_file2", G_SCALAR | G_EVAL);
//antar at rutiner som ikke returnerer noe mislykkes. Dette kan for eks skje hvis vi kaller die, eller ikke trenger retur koden
SPAGAIN; //refresh stack pointer
if (SvTRUE(ERRSV)) {
fprintf(stderr, "Perl preprocessor error: %s\n", SvPV_nolen(ERRSV));
// overfører error beskjeden.
if (errorlength != 0) {
snprintf(error,errorlength,SvPV_nolen(ERRSV));
}
retn = -1;
}
else if (retn == 1) {
retav = (AV *)SvRV(POPs);
printf("retav: %p\n", retav);
printf("aaaav: %d\n", av_len(retav));
if (av_len(retav) == -1) { /* No retarray */
*retlength = 0;
*retarray = NULL;
return 1;
}
*retlength = av_len(retav)+1;
*retarray = malloc(((*retlength)+1) * sizeof(char*));
i = 0;
while (av_len(retav) != -1) {
SV *user = av_pop(retav);
STRLEN data_size;
char *suser;
suser = SvPV(user, data_size);
(*retarray)[i] = strdup(suser);
printf("suser: \"%s\"\n", suser);
i++;
}
(*retarray)[i] = NULL;
}
else {
fprintf(stderr, "perlfunc returned %i values, expected 0 or 1. Ignored.\n", retn);
retn = -1;
}
FREETMPS;
LEAVE;
printf("~perl_embed_run_att=%i\n",retn);
return retn;
}
STATIC void
S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
HV *stash, HV *oldstash, SV *namesv)
{
XPVHV* xhv;
HE *entry;
I32 riter = -1;
I32 items = 0;
const bool stash_had_name = stash && HvENAME(stash);
bool fetched_isarev = FALSE;
HV *seen = NULL;
HV *isarev = NULL;
SV **svp = NULL;
PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
/* We use the seen_stashes hash to keep track of which packages have
been encountered so far. This must be separate from the main list of
stashes, as we need to distinguish between stashes being assigned
and stashes being replaced/deleted. (A nested stash can be on both
sides of an assignment. We cannot simply skip iterating through a
stash on the right if we have seen it on the left, as it will not
get its ename assigned to it.)
To avoid allocating extra SVs, instead of a bitfield we can make
bizarre use of immortals:
&PL_sv_undef: seen on the left (oldstash)
&PL_sv_no : seen on the right (stash)
&PL_sv_yes : seen on both sides
*/
if(oldstash) {
/* Add to the big list. */
struct mro_meta * meta;
HE * const entry
= (HE *)
hv_common(
seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
);
if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
oldstash = NULL;
goto check_stash;
}
HeVAL(entry)
= HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
meta = HvMROMETA(oldstash);
(void)
hv_store(
stashes, (const char *)&oldstash, sizeof(HV *),
meta->isa
? SvREFCNT_inc_simple_NN((SV *)meta->isa)
: &PL_sv_yes,
0
);
CLEAR_LINEAR(meta);
/* Update the effective name. */
if(HvENAME_get(oldstash)) {
const HEK * const enamehek = HvENAME_HEK(oldstash);
if(SvTYPE(namesv) == SVt_PVAV) {
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
}
else {
items = 1;
svp = &namesv;
}
while (items--) {
const U32 name_utf8 = SvUTF8(*svp);
STRLEN len;
const char *name = SvPVx_const(*svp, len);
if(PL_stashcache) {
DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n",
SVfARG(*svp)));
(void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
}
++svp;
hv_ename_delete(oldstash, name, len, name_utf8);
if (!fetched_isarev) {
/* If the name deletion caused a name change, then we
* are not going to call mro_isa_changed_in with this
* name (and not at all if it has become anonymous) so
* we need to delete old isarev entries here, both
* those in the superclasses and this class's own list
* of subclasses. We simply delete the latter from
* PL_isarev, since we still need it. hv_delete morti-
* fies it for us, so sv_2mortal is not necessary. */
if(HvENAME_HEK(oldstash) != enamehek) {
if(meta->isa && HvARRAY(meta->isa))
mro_clean_isarev(meta->isa, name, len, 0, 0,
name_utf8 ? HVhek_UTF8 : 0);
isarev = (HV *)hv_delete(PL_isarev, name,
name_utf8 ? -(I32)len : (I32)len, 0);
fetched_isarev=TRUE;
}
}
}
}
}
check_stash:
if(stash) {
if(SvTYPE(namesv) == SVt_PVAV) {
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
}
else {
items = 1;
svp = &namesv;
}
while (items--) {
const U32 name_utf8 = SvUTF8(*svp);
STRLEN len;
const char *name = SvPVx_const(*svp++, len);
hv_ename_add(stash, name, len, name_utf8);
}
/* Add it to the big list if it needs
* mro_isa_changed_in called on it. That happens if it was
* detached from the symbol table (so it had no HvENAME) before
* being assigned to the spot named by the 'name' variable, because
* its cached isa linearisation is now stale (the effective name
* having changed), and subclasses will then use that cache when
* mro_package_moved calls mro_isa_changed_in. (See
* [perl #77358].)
*
* If it did have a name, then its previous name is still
* used in isa caches, and there is no need for
* mro_package_moved to call mro_isa_changed_in.
*/
entry
= (HE *)
hv_common(
seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
);
if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
stash = NULL;
else {
HeVAL(entry)
= HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
if(!stash_had_name)
{
struct mro_meta * const meta = HvMROMETA(stash);
(void)
hv_store(
stashes, (const char *)&stash, sizeof(HV *),
meta->isa
? SvREFCNT_inc_simple_NN((SV *)meta->isa)
: &PL_sv_yes,
0
);
CLEAR_LINEAR(meta);
}
}
}
if(!stash && !oldstash)
/* Both stashes have been encountered already. */
return;
/* Add all the subclasses to the big list. */
if(!fetched_isarev) {
/* If oldstash is not null, then we can use its HvENAME to look up
the isarev hash, since all its subclasses will be listed there.
It will always have an HvENAME. It the HvENAME was removed
above, then fetch_isarev will be true, and this code will not be
reached.
If oldstash is null, then this is an empty spot with no stash in
it, so subclasses could be listed in isarev hashes belonging to
any of the names, so we have to check all of them.
*/
assert(!oldstash || HvENAME(oldstash));
if (oldstash) {
/* Extra variable to avoid a compiler warning */
const HEK * const hvename = HvENAME_HEK(oldstash);
fetched_isarev = TRUE;
svp = hv_fetchhek(PL_isarev, hvename, 0);
if (svp) isarev = MUTABLE_HV(*svp);
}
else if(SvTYPE(namesv) == SVt_PVAV) {
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
}
else {
items = 1;
svp = &namesv;
}
}
if(
isarev || !fetched_isarev
) {
while (fetched_isarev || items--) {
HE *iter;
if (!fetched_isarev) {
HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
}
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct mro_meta * meta;
if(!revstash) continue;
meta = HvMROMETA(revstash);
(void)
hv_store(
stashes, (const char *)&revstash, sizeof(HV *),
meta->isa
? SvREFCNT_inc_simple_NN((SV *)meta->isa)
: &PL_sv_yes,
0
);
CLEAR_LINEAR(meta);
}
if (fetched_isarev) break;
}
}
/* This is partly based on code in hv_iternext_flags. We are not call-
ing that here, as we want to avoid resetting the hash iterator. */
/* Skip the entire loop if the hash is empty. */
if(oldstash && HvUSEDKEYS(oldstash)) {
xhv = (XPVHV*)SvANY(oldstash);
seen = (HV *) sv_2mortal((SV *)newHV());
/* Iterate through entries in the oldstash, adding them to the
list, meanwhile doing the equivalent of $seen{$key} = 1.
*/
while (++riter <= (I32)xhv->xhv_max) {
entry = (HvARRAY(oldstash))[riter];
/* Iterate through the entries in this list */
for(; entry; entry = HeNEXT(entry)) {
const char* key;
I32 len;
/* If this entry is not a glob, ignore it.
Try the next. */
if (!isGV(HeVAL(entry))) continue;
key = hv_iterkey(entry, &len);
if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
|| (len == 1 && key[0] == ':')) {
HV * const oldsubstash = GvHV(HeVAL(entry));
SV ** const stashentry
= stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
HV *substash = NULL;
/* Avoid main::main::main::... */
if(oldsubstash == oldstash) continue;
if(
(
stashentry && *stashentry && isGV(*stashentry)
&& (substash = GvHV(*stashentry))
)
|| (oldsubstash && HvENAME_get(oldsubstash))
)
{
/* Add :: and the key (minus the trailing ::)
to each name. */
SV *subname;
if(SvTYPE(namesv) == SVt_PVAV) {
SV *aname;
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
subname = sv_2mortal((SV *)newAV());
while (items--) {
aname = newSVsv(*svp++);
if (len == 1)
sv_catpvs(aname, ":");
else {
sv_catpvs(aname, "::");
sv_catpvn_flags(
aname, key, len-2,
HeUTF8(entry)
? SV_CATUTF8 : SV_CATBYTES
);
}
av_push((AV *)subname, aname);
}
}
else {
subname = sv_2mortal(newSVsv(namesv));
if (len == 1) sv_catpvs(subname, ":");
else {
sv_catpvs(subname, "::");
sv_catpvn_flags(
subname, key, len-2,
HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
);
}
}
mro_gather_and_rename(
stashes, seen_stashes,
substash, oldsubstash, subname
);
}
(void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
}
}
}
}
/* Skip the entire loop if the hash is empty. */
if (stash && HvUSEDKEYS(stash)) {
xhv = (XPVHV*)SvANY(stash);
riter = -1;
/* Iterate through the new stash, skipping $seen{$key} items,
calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
while (++riter <= (I32)xhv->xhv_max) {
entry = (HvARRAY(stash))[riter];
/* Iterate through the entries in this list */
for(; entry; entry = HeNEXT(entry)) {
const char* key;
I32 len;
/* If this entry is not a glob, ignore it.
Try the next. */
if (!isGV(HeVAL(entry))) continue;
key = hv_iterkey(entry, &len);
if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
|| (len == 1 && key[0] == ':')) {
HV *substash;
/* If this entry was seen when we iterated through the
oldstash, skip it. */
if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
/* We get here only if this stash has no corresponding
entry in the stash being replaced. */
substash = GvHV(HeVAL(entry));
if(substash) {
SV *subname;
/* Avoid checking main::main::main::... */
if(substash == stash) continue;
/* Add :: and the key (minus the trailing ::)
to each name. */
if(SvTYPE(namesv) == SVt_PVAV) {
SV *aname;
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
subname = sv_2mortal((SV *)newAV());
while (items--) {
aname = newSVsv(*svp++);
if (len == 1)
sv_catpvs(aname, ":");
else {
sv_catpvs(aname, "::");
sv_catpvn_flags(
aname, key, len-2,
HeUTF8(entry)
? SV_CATUTF8 : SV_CATBYTES
);
}
av_push((AV *)subname, aname);
}
}
else {
subname = sv_2mortal(newSVsv(namesv));
if (len == 1) sv_catpvs(subname, ":");
else {
sv_catpvs(subname, "::");
sv_catpvn_flags(
subname, key, len-2,
HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
);
}
}
mro_gather_and_rename(
stashes, seen_stashes,
substash, NULL, subname
);
}
}
}
}
}
}
AV *p5_newAV(PerlInterpreter *my_perl) {
PERL_SET_CONTEXT(my_perl);
return newAV();
}
AV* VAstEnt::newAVEnt(VAstType type) {
AV* avp = newAV();
initAVEnt(avp, type, this->castAVp());
return avp;
}
CALLER_OWN SV *owl_perlconfig_message2hashref(const owl_message *m)
{
HV *h, *stash;
SV *hr;
const char *type;
char *ptr, *utype, *blessas;
const char *f;
int i;
const owl_pair *pair;
const owl_filter *wrap;
if (!m) return &PL_sv_undef;
wrap = owl_global_get_filter(&g, "wordwrap");
if(!wrap) {
owl_function_error("wrap filter is not defined");
return &PL_sv_undef;
}
h = newHV();
#define MSG2H(h,field) (void)hv_store(h, #field, strlen(#field), \
owl_new_sv(owl_message_get_##field(m)), 0)
if (owl_message_is_type_zephyr(m) && owl_message_is_direction_in(m)) {
/* Handle zephyr-specific fields... */
AV *av_zfields = newAV();
if (owl_message_get_notice(m)) {
for (f = owl_zephyr_first_raw_field(owl_message_get_notice(m)); f != NULL;
f = owl_zephyr_next_raw_field(owl_message_get_notice(m), f)) {
ptr = owl_zephyr_field_as_utf8(owl_message_get_notice(m), f);
av_push(av_zfields, owl_new_sv(ptr));
g_free(ptr);
}
(void)hv_store(h, "auth", strlen("auth"),
owl_new_sv(owl_zephyr_get_authstr(owl_message_get_notice(m))), 0);
} else {
/* Incoming zephyrs without a ZNotice_t are pseudo-logins. To appease
* existing styles, put in bogus 'auth' and 'fields' keys. */
(void)hv_store(h, "auth", strlen("auth"), owl_new_sv("NO"), 0);
}
(void)hv_store(h, "fields", strlen("fields"), newRV_noinc((SV*)av_zfields), 0);
}
for (i = 0; i < m->attributes->len; i++) {
pair = m->attributes->pdata[i];
(void)hv_store(h, owl_pair_get_key(pair), strlen(owl_pair_get_key(pair)),
owl_new_sv(owl_pair_get_value(pair)),0);
}
MSG2H(h, type);
MSG2H(h, direction);
MSG2H(h, class);
MSG2H(h, instance);
MSG2H(h, sender);
MSG2H(h, realm);
MSG2H(h, recipient);
MSG2H(h, opcode);
MSG2H(h, hostname);
MSG2H(h, body);
MSG2H(h, login);
MSG2H(h, zsig);
MSG2H(h, zwriteline);
if (owl_message_get_header(m)) {
MSG2H(h, header);
}
(void)hv_store(h, "time", strlen("time"), owl_new_sv(owl_message_get_timestr(m)),0);
(void)hv_store(h, "unix_time", strlen("unix_time"), newSViv(m->time), 0);
(void)hv_store(h, "id", strlen("id"), newSViv(owl_message_get_id(m)),0);
(void)hv_store(h, "deleted", strlen("deleted"), newSViv(owl_message_is_delete(m)),0);
(void)hv_store(h, "private", strlen("private"), newSViv(owl_message_is_private(m)),0);
(void)hv_store(h, "should_wordwrap",
strlen("should_wordwrap"), newSViv(
owl_filter_message_match(wrap, m)),0);
type = owl_message_get_type(m);
if(!type || !*type) type = "generic";
utype = g_strdup(type);
utype[0] = toupper(type[0]);
blessas = g_strdup_printf("BarnOwl::Message::%s", utype);
hr = newRV_noinc((SV*)h);
stash = gv_stashpv(blessas,0);
if(!stash) {
owl_function_error("No such class: %s for message type %s", blessas, owl_message_get_type(m));
stash = gv_stashpv("BarnOwl::Message", 1);
}
hr = sv_bless(hr,stash);
g_free(utype);
g_free(blessas);
return hr;
}
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;
}
/*
=for apidoc mro_get_linear_isa_dfs
Returns the Depth-First Search linearization of @ISA
the given stash. The return value is a read-only AV*.
C<level> should be 0 (it is used internally in this
function's recursion).
You are responsible for C<SvREFCNT_inc()> on the
return value if you plan to store it anywhere
semi-permanently (otherwise it might be deleted
out from under you the next time the cache is
invalidated).
=cut
*/
static AV*
S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
{
AV* retval;
GV** gvp;
GV* gv;
AV* av;
const HEK* stashhek;
struct mro_meta* meta;
SV *our_name;
HV *stored = NULL;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
assert(HvAUX(stash));
stashhek = HvNAME_HEK(stash);
if (!stashhek)
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
if (level > 100)
Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
HEK_KEY(stashhek));
meta = HvMROMETA(stash);
/* return cache if valid */
if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
return retval;
}
/* not in cache, make a new one */
retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
/* We use this later in this function, but don't need a reference to it
beyond the end of this function, so reference count is fine. */
our_name = newSVhek(stashhek);
av_push(retval, our_name); /* add ourselves at the top */
/* fetch our @ISA */
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
/* "stored" is used to keep track of all of the classnames we have added to
the MRO so far, so we can do a quick exists check and avoid adding
duplicate classnames to the MRO as we go.
It's then retained to be re-used as a fast lookup for ->isa(), by adding
our own name and "UNIVERSAL" to it. */
if(av && AvFILLp(av) >= 0) {
SV **svp = AvARRAY(av);
I32 items = AvFILLp(av) + 1;
/* foreach(@ISA) */
while (items--) {
SV* const sv = *svp++;
HV* const basestash = gv_stashsv(sv, 0);
SV *const *subrv_p;
I32 subrv_items;
if (!basestash) {
/* if no stash exists for this @ISA member,
simply add it to the MRO and move on */
subrv_p = &sv;
subrv_items = 1;
}
else {
/* otherwise, recurse into ourselves for the MRO
of this @ISA member, and append their MRO to ours.
The recursive call could throw an exception, which
has memory management implications here, hence the use of
the mortal. */
const AV *const subrv
= mro_get_linear_isa_dfs(basestash, level + 1);
subrv_p = AvARRAY(subrv);
subrv_items = AvFILLp(subrv) + 1;
}
if (stored) {
while(subrv_items--) {
SV *const subsv = *subrv_p++;
/* LVALUE fetch will create a new undefined SV if necessary
*/
HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
assert(he);
if(HeVAL(he) != &PL_sv_undef) {
/* It was newly created. Steal it for our new SV, and
replace it in the hash with the "real" thing. */
SV *const val = HeVAL(he);
HEK *const key = HeKEY_hek(he);
HeVAL(he) = &PL_sv_undef;
/* Save copying by making a shared hash key scalar. We
inline this here rather than calling
Perl_newSVpvn_share because we already have the
scalar, and we already have the hash key. */
assert(SvTYPE(val) == SVt_NULL);
sv_upgrade(val, SVt_PV);
SvPV_set(val, HEK_KEY(share_hek_hek(key)));
SvCUR_set(val, HEK_LEN(key));
SvREADONLY_on(val);
SvFAKE_on(val);
SvPOK_on(val);
if (HEK_UTF8(key))
SvUTF8_on(val);
av_push(retval, val);
}
}
} else {
/* We are the first (or only) parent. We can short cut the
complexity above, because our @ISA is simply us prepended
to our parent's @ISA, and our ->isa cache is simply our
parent's, with our name added. */
/* newSVsv() is slow. This code is only faster if we can avoid
it by ensuring that SVs in the arrays are shared hash key
scalar SVs, because we can "copy" them very efficiently.
Although to be fair, we can't *ensure* this, as a reference
to the internal array is returned by mro::get_linear_isa(),
so we'll have to be defensive just in case someone faffed
with it. */
if (basestash) {
SV **svp;
stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
av_extend(retval, subrv_items);
AvFILLp(retval) = subrv_items;
svp = AvARRAY(retval);
while(subrv_items--) {
SV *const val = *subrv_p++;
*++svp = SvIsCOW_shared_hash(val)
? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
: newSVsv(val);
}
} else {
/* They have no stash. So create ourselves an ->isa cache
as if we'd copied it from what theirs should be. */
stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
(void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
av_push(retval,
newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
&PL_sv_undef, 0))));
}
}
}
} else {
/* We have no parents. */
stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
(void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
}
(void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
SvREFCNT_inc_simple_void_NN(stored);
SvTEMP_off(stored);
SvREADONLY_on(stored);
meta->isa = stored;
/* now that we're past the exception dangers, grab our own reference to
the AV we're about to use for the result. The reference owned by the
mortals' stack will be released soon, so everything will balance. */
SvREFCNT_inc_simple_void_NN(retval);
SvTEMP_off(retval);
/* we don't want anyone modifying the cache entry but us,
and we do so by replacing it completely */
SvREADONLY_on(retval);
return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
MUTABLE_SV(retval)));
}
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;
}
static int
print_cb (char *word[], void *userdata)
{
HookData *data = (HookData *) userdata;
SV *temp = NULL;
int retVal = 0;
int count = 1;
int last_index = 31;
/* must be initialized after SAVETMPS */
AV *wd = NULL;
dSP;
ENTER;
SAVETMPS;
if (data->depth)
return XCHAT_EAT_NONE;
wd = newAV ();
sv_2mortal ((SV *) wd);
/* need to scan backwards to find the index of the last element since some
events such as "DCC Timeout" can have NULL elements in between non NULL
elements */
while (last_index >= 0
&& (word[last_index] == NULL || word[last_index][0] == 0)) {
last_index--;
}
for (count = 1; count <= last_index; count++) {
if (word[count] == NULL) {
av_push (wd, &PL_sv_undef);
} else if (word[count][0] == 0) {
av_push (wd, newSVpvn ("",0));
} else {
temp = newSVpv (word[count], 0);
SvUTF8_on (temp);
av_push (wd, temp);
}
}
/*xchat_printf (ph, "Recieved %d words in print callback", av_len (wd)+1); */
PUSHMARK (SP);
XPUSHs (newRV_noinc ((SV *) wd));
XPUSHs (data->userdata);
PUTBACK;
data->depth++;
count = call_sv (data->callback, G_EVAL);
data->depth--;
SPAGAIN;
if (SvTRUE (ERRSV)) {
xchat_printf (ph, "Error in print callback %s", SvPV_nolen (ERRSV));
if (!SvOK (POPs)) {} /* remove undef from the top of the stack */
retVal = XCHAT_EAT_NONE;
} else {
if (count != 1) {
xchat_print (ph, "Print handler should only return 1 value.");
retVal = XCHAT_EAT_NONE;
} else {
retVal = POPi;
}
}
PUTBACK;
FREETMPS;
LEAVE;
return retVal;
}
static void
report_event(PSTATE* p_state,
event_id_t event,
char *beg, char *end, U32 utf8,
token_pos_t *tokens, int num_tokens,
SV* self
)
{
struct p_handler *h;
dTHX;
dSP;
AV *array;
STRLEN my_na;
char *argspec;
char *s;
#ifdef UNICODE_HTML_PARSER
#define CHR_DIST(a,b) (utf8 ? utf8_distance((U8*)(a),(U8*)(b)) : (a) - (b))
#else
#define CHR_DIST(a,b) ((a) - (b))
#endif
/* capture offsets */
STRLEN offset = p_state->offset;
STRLEN line = p_state->line;
STRLEN column = p_state->column;
#if 0
{ /* used for debugging at some point */
char *s = beg;
int i;
/* print debug output */
switch(event) {
case E_DECLARATION: printf("DECLARATION"); break;
case E_COMMENT: printf("COMMENT"); break;
case E_START: printf("START"); break;
case E_END: printf("END"); break;
case E_TEXT: printf("TEXT"); break;
case E_PROCESS: printf("PROCESS"); break;
case E_NONE: printf("NONE"); break;
default: printf("EVENT #%d", event); break;
}
printf(" [");
while (s < end) {
if (*s == '\n') {
putchar('\\'); putchar('n');
}
else
putchar(*s);
s++;
}
printf("] %d\n", end - beg);
for (i = 0; i < num_tokens; i++) {
printf(" token %d: %d %d\n",
i,
tokens[i].beg - beg,
tokens[i].end - tokens[i].beg);
}
}
#endif
if (p_state->pending_end_tag && event != E_TEXT && event != E_COMMENT) {
token_pos_t t;
char dummy;
t.beg = p_state->pending_end_tag;
t.end = p_state->pending_end_tag + strlen(p_state->pending_end_tag);
p_state->pending_end_tag = 0;
report_event(p_state, E_END, &dummy, &dummy, 0, &t, 1, self);
SPAGAIN;
}
/* update offsets */
p_state->offset += CHR_DIST(end, beg);
if (line) {
char *s = beg;
char *nl = NULL;
while (s < end) {
if (*s == '\n') {
p_state->line++;
nl = s;
}
s++;
}
if (nl)
p_state->column = CHR_DIST(end, nl) - 1;
else
p_state->column += CHR_DIST(end, beg);
}
if (event == E_NONE)
goto IGNORE_EVENT;
#ifdef MARKED_SECTION
if (p_state->ms == MS_IGNORE)
goto IGNORE_EVENT;
#endif
/* tag filters */
if (p_state->ignore_tags || p_state->report_tags || p_state->ignore_elements) {
if (event == E_START || event == E_END) {
SV* tagname = p_state->tmp;
assert(num_tokens >= 1);
sv_setpvn(tagname, tokens[0].beg, tokens[0].end - tokens[0].beg);
if (utf8)
SvUTF8_on(tagname);
else
SvUTF8_off(tagname);
if (!CASE_SENSITIVE(p_state))
sv_lower(aTHX_ tagname);
if (p_state->ignoring_element) {
if (sv_eq(p_state->ignoring_element, tagname)) {
if (event == E_START)
p_state->ignore_depth++;
else if (--p_state->ignore_depth == 0) {
SvREFCNT_dec(p_state->ignoring_element);
p_state->ignoring_element = 0;
}
}
goto IGNORE_EVENT;
}
if (p_state->ignore_elements &&
hv_fetch_ent(p_state->ignore_elements, tagname, 0, 0))
{
p_state->ignoring_element = newSVsv(tagname);
p_state->ignore_depth = 1;
goto IGNORE_EVENT;
}
if (p_state->ignore_tags &&
hv_fetch_ent(p_state->ignore_tags, tagname, 0, 0))
{
goto IGNORE_EVENT;
}
if (p_state->report_tags &&
!hv_fetch_ent(p_state->report_tags, tagname, 0, 0))
{
goto IGNORE_EVENT;
}
}
else if (p_state->ignoring_element) {
goto IGNORE_EVENT;
}
}
h = &p_state->handlers[event];
if (!h->cb) {
/* event = E_DEFAULT; */
h = &p_state->handlers[E_DEFAULT];
if (!h->cb)
goto IGNORE_EVENT;
}
if (SvTYPE(h->cb) != SVt_PVAV && !SvTRUE(h->cb)) {
/* FALSE scalar ('' or 0) means IGNORE this event */
return;
}
if (p_state->unbroken_text && event == E_TEXT) {
/* should buffer text */
if (!p_state->pend_text)
p_state->pend_text = newSV(256);
if (SvOK(p_state->pend_text)) {
if (p_state->is_cdata != p_state->pend_text_is_cdata) {
flush_pending_text(p_state, self);
SPAGAIN;
goto INIT_PEND_TEXT;
}
}
else {
INIT_PEND_TEXT:
p_state->pend_text_offset = offset;
p_state->pend_text_line = line;
p_state->pend_text_column = column;
p_state->pend_text_is_cdata = p_state->is_cdata;
sv_setpvn(p_state->pend_text, "", 0);
if (!utf8)
SvUTF8_off(p_state->pend_text);
}
#ifdef UNICODE_HTML_PARSER
if (utf8 && !SvUTF8(p_state->pend_text))
sv_utf8_upgrade(p_state->pend_text);
if (utf8 || !SvUTF8(p_state->pend_text)) {
sv_catpvn(p_state->pend_text, beg, end - beg);
}
else {
SV *tmp = newSVpvn(beg, end - beg);
sv_utf8_upgrade(tmp);
sv_catsv(p_state->pend_text, tmp);
SvREFCNT_dec(tmp);
}
#else
sv_catpvn(p_state->pend_text, beg, end - beg);
#endif
return;
}
else if (p_state->pend_text && SvOK(p_state->pend_text)) {
flush_pending_text(p_state, self);
SPAGAIN;
}
/* At this point we have decided to generate an event callback */
argspec = h->argspec ? SvPV(h->argspec, my_na) : "";
if (SvTYPE(h->cb) == SVt_PVAV) {
if (*argspec == ARG_FLAG_FLAT_ARRAY) {
argspec++;
array = (AV*)h->cb;
}
else {
/* start sub-array for accumulator array */
array = newAV();
}
}
else {
array = 0;
if (*argspec == ARG_FLAG_FLAT_ARRAY)
argspec++;
/* start argument stack for callback */
ENTER;
SAVETMPS;
PUSHMARK(SP);
}
for (s = argspec; *s; s++) {
SV* arg = 0;
int push_arg = 1;
enum argcode argcode = (enum argcode)*s;
switch( argcode ) {
case ARG_SELF:
arg = sv_mortalcopy(self);
break;
case ARG_TOKENS:
if (num_tokens >= 1) {
AV* av = newAV();
SV* prev_token = &PL_sv_undef;
int i;
av_extend(av, num_tokens);
for (i = 0; i < num_tokens; i++) {
if (tokens[i].beg) {
prev_token = newSVpvn(tokens[i].beg, tokens[i].end-tokens[i].beg);
if (utf8)
SvUTF8_on(prev_token);
av_push(av, prev_token);
}
else { /* boolean */
av_push(av, p_state->bool_attr_val
? newSVsv(p_state->bool_attr_val)
: newSVsv(prev_token));
}
}
arg = sv_2mortal(newRV_noinc((SV*)av));
}
break;
case ARG_TOKENPOS:
if (num_tokens >= 1 && tokens[0].beg >= beg) {
AV* av = newAV();
int i;
av_extend(av, num_tokens*2);
for (i = 0; i < num_tokens; i++) {
if (tokens[i].beg) {
av_push(av, newSViv(CHR_DIST(tokens[i].beg, beg)));
av_push(av, newSViv(CHR_DIST(tokens[i].end, tokens[i].beg)));
}
else { /* boolean tag value */
av_push(av, newSViv(0));
av_push(av, newSViv(0));
}
}
arg = sv_2mortal(newRV_noinc((SV*)av));
}
break;
case ARG_TOKEN0:
case ARG_TAGNAME:
/* fall through */
case ARG_TAG:
if (num_tokens >= 1) {
arg = sv_2mortal(newSVpvn(tokens[0].beg,
tokens[0].end - tokens[0].beg));
if (utf8)
SvUTF8_on(arg);
if (!CASE_SENSITIVE(p_state) && argcode != ARG_TOKEN0)
sv_lower(aTHX_ arg);
if (argcode == ARG_TAG && event != E_START) {
char *e_type = "!##/#?#";
sv_insert(arg, 0, 0, &e_type[event], 1);
}
}
break;
case ARG_ATTR:
case ARG_ATTRARR:
if (event == E_START) {
HV* hv;
int i;
if (argcode == ARG_ATTR) {
hv = newHV();
arg = sv_2mortal(newRV_noinc((SV*)hv));
}
else {
#ifdef __GNUC__
/* gcc -Wall reports this variable as possibly used uninitialized */
hv = 0;
#endif
push_arg = 0; /* deal with argument pushing here */
}
for (i = 1; i < num_tokens; i += 2) {
SV* attrname = newSVpvn(tokens[i].beg,
tokens[i].end-tokens[i].beg);
SV* attrval;
if (utf8)
SvUTF8_on(attrname);
if (tokens[i+1].beg) {
char *beg = tokens[i+1].beg;
STRLEN len = tokens[i+1].end - beg;
if (*beg == '"' || *beg == '\'') {
assert(len >= 2 && *beg == beg[len-1]);
beg++; len -= 2;
}
attrval = newSVpvn(beg, len);
if (utf8)
SvUTF8_on(attrval);
if (!p_state->attr_encoded) {
#ifdef UNICODE_HTML_PARSER
if (p_state->utf8_mode)
sv_utf8_decode(attrval);
#endif
decode_entities(aTHX_ attrval, p_state->entity2char, 0);
if (p_state->utf8_mode)
SvUTF8_off(attrval);
}
}
else { /* boolean */
if (p_state->bool_attr_val)
attrval = newSVsv(p_state->bool_attr_val);
else
attrval = newSVsv(attrname);
}
if (!CASE_SENSITIVE(p_state))
sv_lower(aTHX_ attrname);
if (argcode == ARG_ATTR) {
if (hv_exists_ent(hv, attrname, 0) ||
!hv_store_ent(hv, attrname, attrval, 0)) {
SvREFCNT_dec(attrval);
}
SvREFCNT_dec(attrname);
}
else { /* ARG_ATTRARR */
if (array) {
av_push(array, attrname);
av_push(array, attrval);
}
else {
XPUSHs(sv_2mortal(attrname));
XPUSHs(sv_2mortal(attrval));
}
}
}
}
else if (argcode == ARG_ATTRARR) {
push_arg = 0;
}
break;
case ARG_ATTRSEQ: /* (v2 compatibility stuff) */
if (event == E_START) {
AV* av = newAV();
int i;
for (i = 1; i < num_tokens; i += 2) {
SV* attrname = newSVpvn(tokens[i].beg,
tokens[i].end-tokens[i].beg);
if (utf8)
SvUTF8_on(attrname);
if (!CASE_SENSITIVE(p_state))
sv_lower(aTHX_ attrname);
av_push(av, attrname);
}
arg = sv_2mortal(newRV_noinc((SV*)av));
}
break;
case ARG_TEXT:
arg = sv_2mortal(newSVpvn(beg, end - beg));
if (utf8)
SvUTF8_on(arg);
break;
case ARG_DTEXT:
if (event == E_TEXT) {
arg = sv_2mortal(newSVpvn(beg, end - beg));
if (utf8)
SvUTF8_on(arg);
if (!p_state->is_cdata) {
#ifdef UNICODE_HTML_PARSER
if (p_state->utf8_mode)
sv_utf8_decode(arg);
#endif
decode_entities(aTHX_ arg, p_state->entity2char, 1);
if (p_state->utf8_mode)
SvUTF8_off(arg);
}
}
break;
case ARG_IS_CDATA:
if (event == E_TEXT) {
arg = boolSV(p_state->is_cdata);
}
break;
case ARG_SKIPPED_TEXT:
arg = sv_2mortal(p_state->skipped_text);
p_state->skipped_text = newSVpvn("", 0);
break;
case ARG_OFFSET:
arg = sv_2mortal(newSViv(offset));
break;
case ARG_OFFSET_END:
arg = sv_2mortal(newSViv(offset + CHR_DIST(end, beg)));
break;
case ARG_LENGTH:
arg = sv_2mortal(newSViv(CHR_DIST(end, beg)));
break;
case ARG_LINE:
arg = sv_2mortal(newSViv(line));
break;
case ARG_COLUMN:
arg = sv_2mortal(newSViv(column));
break;
case ARG_EVENT:
assert(event >= 0 && event < EVENT_COUNT);
arg = sv_2mortal(newSVpv(event_id_str[event], 0));
break;
case ARG_LITERAL:
{
int len = (unsigned char)s[1];
arg = sv_2mortal(newSVpvn(s+2, len));
if (SvUTF8(h->argspec))
SvUTF8_on(arg);
s += len + 1;
}
break;
case ARG_UNDEF:
arg = sv_mortalcopy(&PL_sv_undef);
break;
default:
arg = sv_2mortal(newSVpvf("Bad argspec %d", *s));
break;
}
if (push_arg) {
if (!arg)
arg = sv_mortalcopy(&PL_sv_undef);
if (array) {
/* have to fix mortality here or add mortality to
* XPUSHs after removing it from the switch cases.
*/
av_push(array, SvREFCNT_inc(arg));
}
else {
XPUSHs(arg);
}
}
}
if (array) {
if (array != (AV*)h->cb)
av_push((AV*)h->cb, newRV_noinc((SV*)array));
}
else {
PUTBACK;
if ((enum argcode)*argspec == ARG_SELF && !SvROK(h->cb)) {
char *method = SvPV(h->cb, my_na);
perl_call_method(method, G_DISCARD | G_EVAL | G_VOID);
}
else {
perl_call_sv(h->cb, G_DISCARD | G_EVAL | G_VOID);
}
if (SvTRUE(ERRSV)) {
RETHROW;
}
FREETMPS;
LEAVE;
}
if (p_state->skipped_text)
SvCUR_set(p_state->skipped_text, 0);
return;
IGNORE_EVENT:
if (p_state->skipped_text) {
if (event != E_TEXT && p_state->pend_text && SvOK(p_state->pend_text))
flush_pending_text(p_state, self);
#ifdef UNICODE_HTML_PARSER
if (utf8 && !SvUTF8(p_state->skipped_text))
sv_utf8_upgrade(p_state->skipped_text);
if (utf8 || !SvUTF8(p_state->skipped_text)) {
#endif
sv_catpvn(p_state->skipped_text, beg, end - beg);
#ifdef UNICODE_HTML_PARSER
}
else {
SV *tmp = newSVpvn(beg, end - beg);
sv_utf8_upgrade(tmp);
sv_catsv(p_state->pend_text, tmp);
SvREFCNT_dec(tmp);
}
#endif
}
#undef CHR_DIST
return;
}
