static void
Encode_XSEncoding(pTHX_ encode_t *enc)
{
dSP;
HV *stash = gv_stashpv("Encode::XS", TRUE);
SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
int i = 0;
PUSHMARK(sp);
XPUSHs(sv);
while (enc->name[i])
{
const char *name = enc->name[i++];
XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
}
PUTBACK;
call_pv("Encode::define_encoding",G_DISCARD);
SvREFCNT_dec(sv);
}
SV *radio_get_status() {
have_status = _dsp_chain_rstat_queue.try_pop_all(lrstat);
HV *hash;
hash = newHV();
hv_stores(hash,"have_status",newSViv(have_status));
if (have_status) {
___PERL_INSERT_HASH_COPYING_lrstat
std::string a_bit = "";
while (_dsp_chain_id_text_queue.try_pop(a_bit)) {
id_instr += a_bit;
}
hv_stores(hash,"id_instr",newSVpv(id_instr.c_str(),id_instr.size()));
id_instr.clear();
}
return newRV_noinc((SV *)hash);
};
/*
* 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;
}
/*
* convert job_step_info_t to perl HV
*/
int
job_step_info_to_hv(job_step_info_t *step_info, HV *hv)
{
int j;
AV *av;
STORE_FIELD(hv, step_info, array_job_id, uint32_t);
STORE_FIELD(hv, step_info, array_task_id, uint32_t);
if(step_info->ckpt_dir)
STORE_FIELD(hv, step_info, ckpt_dir, charp);
STORE_FIELD(hv, step_info, ckpt_interval, uint16_t);
if(step_info->gres)
STORE_FIELD(hv, step_info, gres, charp);
STORE_FIELD(hv, step_info, job_id, uint32_t);
if(step_info->name)
STORE_FIELD(hv, step_info, name, charp);
if(step_info->network)
STORE_FIELD(hv, step_info, network, charp);
if(step_info->nodes)
STORE_FIELD(hv, step_info, nodes, charp);
av = newAV();
for(j = 0; ; j += 2) {
if(step_info->node_inx[j] == -1)
break;
av_store_int(av, j, step_info->node_inx[j]);
av_store_int(av, j+1, step_info->node_inx[j+1]);
}
hv_store_sv(hv, "node_inx", newRV_noinc((SV*)av));
STORE_FIELD(hv, step_info, num_cpus, uint32_t);
STORE_FIELD(hv, step_info, num_tasks, uint32_t);
if(step_info->partition)
STORE_FIELD(hv, step_info, partition, charp);
STORE_FIELD(hv, step_info, profile, uint32_t);
if(step_info->resv_ports)
STORE_FIELD(hv, step_info, resv_ports, charp);
STORE_FIELD(hv, step_info, run_time, time_t);
STORE_FIELD(hv, step_info, start_time, time_t);
STORE_FIELD(hv, step_info, step_id, uint32_t);
STORE_FIELD(hv, step_info, time_limit, uint32_t);
STORE_FIELD(hv, step_info, user_id, uint32_t);
STORE_FIELD(hv, step_info, state, uint16_t);
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;
}
bool THX_MopMcV_has_attribute(pTHX_ SV* metaclass, SV* name) {
SV* attributes = MopOV_get_at_slot(metaclass, CLASS_ATTRIBUTE_SLOT);
if (attributes == NULL) {
attributes = newRV_noinc((SV*) newHV());
MopOV_set_at_slot(metaclass, CLASS_ATTRIBUTE_SLOT, attributes);
// NOTE:
// I know I am not going to
// have the value since I
// only just now created the
// HV to store it.
return FALSE;
}
if (SvTYPE(attributes) != SVt_RV && SvTYPE(SvRV(attributes)) != SVt_PVHV) {
croak("attributes is not a HASH ref, this is wrong");
}
return hv_exists_ent((HV*) SvRV(attributes), name, 0);
}
static SV *psv_to_slotsv(SV *sv) {
dTHX;
ECAslot *slot = sv2slot(sv);
HV *hv = newHV();
// may be NULL
hv_stores_or_croak(hv, "value",
newSVsv(slot->value ? slot->value : &PL_sv_undef));
hv_stores_or_croak(hv, "check",
newSVsv(slot->check ? slot->check : &PL_sv_undef));
hv_stores_or_croak(hv, "inject",
newSVsv(slot->inject ? slot->inject : &PL_sv_undef));
hv_stores_or_croak(hv, "name", newSVsv(slot->key)); // always defined
hv_stores_or_croak(hv, "ro", newSViv(slot->is_ro));
hv_stores_or_croak(hv, "type", newSViv(slot->type));
return newRV_noinc((SV *)hv);
}
SV *get_tags(pTHX_ const TagTypeInfo *ptti, CtTagList taglist)
{
HV *hv = newHV();
CtTag *tag;
for (tag = taglist; tag; tag = tag->next)
{
if (tag->type < NUM_TAGIDS)
{
SV *sv = gs_TagTbl[tag->type].get(aTHX_ ptti, tag);
const char *id = gs_TagIdStr[tag->type];
if (hv_store(hv, id, strlen(id), sv, 0) == NULL)
fatal("hv_store() failed in get_tags()");
}
else
fatal("Unknown tag type (%d) in get_tags()", (int) tag->type);
}
return sv_2mortal(newRV_noinc((SV *) hv));
}
void store_self(pTHX, mthread* thread) {
SV *thread_sv, *self;
AV* message_cache;
thread_sv = newSV_type(SVt_PV);
SvPVX(thread_sv) = (char*) thread;
SvCUR(thread_sv) = sizeof(mthread);
SvLEN(thread_sv) = 0;
SvPOK_only(thread_sv);
SvREADONLY_on(thread_sv);
hv_store(PL_modglobal, "threads::lite::thread", 21, thread_sv, 0);
self = newRV_noinc(newSVuv(thread->id));
sv_bless(self, gv_stashpv("threads::lite::tid", TRUE));
hv_store(PL_modglobal, "threads::lite::self", 19, self, 0);
message_cache = newAV();
hv_store(PL_modglobal, "threads::lite::message_cache", 28, (SV*)message_cache, 0);
thread->cache = message_cache;
}
static SV *
list_item_to_sv ( xchat_list *list, const char *const *fields )
{
HV *hash = newHV();
SV *field_value;
const char *field;
int field_index = 0;
const char *field_name;
int name_len;
while (fields[field_index] != NULL) {
field_name = fields[field_index] + 1;
name_len = strlen (field_name);
switch (fields[field_index][0]) {
case 's':
field = xchat_list_str (ph, list, field_name);
if (field != NULL) {
field_value = newSVpvn (field, strlen (field));
} else {
field_value = &PL_sv_undef;
}
break;
case 'p':
field_value = newSViv (PTR2IV (xchat_list_str (ph, list,
field_name)));
break;
case 'i':
field_value = newSVuv (xchat_list_int (ph, list, field_name));
break;
case 't':
field_value = newSVnv (xchat_list_time (ph, list, field_name));
break;
default:
field_value = &PL_sv_undef;
}
hv_store (hash, field_name, name_len, field_value, 0);
field_index++;
}
return sv_2mortal (newRV_noinc ((SV *) hash));
}
SV *
getFieldTypeFromHV ( BrokerTypeDef type_def, char * key )
{
HV * hv;
BrokerTypeDef newTypeDef;
hv = newHV();
gErr = awGetTypeDefFieldDef ( type_def, key, &newTypeDef );
if ( gErr != AW_NO_ERROR )
return ( Nullsv );
gErr = awxsSetHashFromTypeDef ( newTypeDef, hv );
if ( gErr != AW_NO_ERROR )
return ( Nullsv );
return ( newRV_noinc((SV*) hv) );
}
static SV *
custom_convert(AV *docav, SV *meth, SV *input, uint32_t *flags, int direction)
{
dSP;
SV *ret;
SV *flags_rv;
SV *input_rv;
int callflags;
ENTER; SAVETMPS;
PUSHMARK(SP);
input_rv = sv_2mortal(newRV_inc(input));
flags_rv = sv_2mortal(newRV_noinc(newSVuv(*flags)));
XPUSHs(sv_2mortal(newRV_inc( (SV *)docav)));
XPUSHs(input_rv);
XPUSHs(flags_rv);
PUTBACK;
callflags = G_VOID|G_DISCARD;
if (direction == CONVERT_OUT) {
callflags |= G_EVAL;
}
call_sv(meth, callflags);
SPAGAIN;
if (SvTRUE(ERRSV)) {
ret = input;
} else {
warn("Conversion function failed");
ret = SvRV(input_rv);
*flags = SvUV(SvRV(flags_rv));
}
SvREFCNT_inc(ret);
return ret;
}
SV *get_single_hook(pTHX_ const SingleHook *hook)
{
SV *sv;
assert(hook != NULL);
sv = hook->sub;
if (sv == NULL)
return NULL;
sv = newRV_inc(sv);
if (hook->arg)
{
AV *av = newAV();
int j, len = 1 + av_len(hook->arg);
av_extend(av, len);
if (av_store(av, 0, sv) == NULL)
fatal("av_store() failed in get_hooks()");
for (j = 0; j < len; j++)
{
SV **pSV = av_fetch(hook->arg, j, 0);
if (pSV == NULL)
fatal("NULL returned by av_fetch() in get_hooks()");
SvREFCNT_inc(*pSV);
if (av_store(av, j+1, *pSV) == NULL)
fatal("av_store() failed in get_hooks()");
}
sv = newRV_noinc((SV *) av);
}
return sv;
}
SV *PerlIONginxError_newhandle(pTHX_ ngx_http_request_t *r)
{
GV *gv = (GV*)SvREFCNT_inc(newGVgen("Nginx::PSGI::Error"));
if (!gv)
return &PL_sv_undef;
(void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
PerlIO *f = PerlIO_allocate(aTHX);
if (!(f = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_nginx_error), ">", NULL)) ) {
return &PL_sv_undef;
}
if (!do_open(gv, "+>&", 3, FALSE, O_WRONLY, 0, f)) {
return &PL_sv_undef;
}
PerlIONginxError *st = PerlIOSelf(f, PerlIONginxError);
st->log = r->connection->log;
return newRV_noinc((SV*)gv);
}
void decode_map(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
struct cc_type *key_type, *value_type;
int i;
STRLEN pos;
HV *the_map;
SV *the_rv;
key_type = &type->inner_type[0];
value_type = &type->inner_type[1];
assert(key_type && value_type);
if (UNLIKELY(len < 4))
croak("decode_map: len < 4");
int32_t num_elements = (int32_t)ntohl(*(uint32_t*)(input));
if (UNLIKELY(num_elements < 0))
croak("decode_map: num_elements < 0");
the_map = newHV();
the_rv = newRV_noinc((SV*)the_map);
sv_setsv(output, the_rv);
SvREFCNT_dec(the_rv);
pos = 4;
for (i = 0; i < num_elements; i++) {
SV *key, *value;
key = newSV(0);
sv_2mortal(key);
decode_cell(aTHX_ input, len, &pos, key_type, key);
value = newSV(0);
hv_store_ent(the_map, key, value, 0);
decode_cell(aTHX_ input, len, &pos, value_type, value);
}
}
/*
* 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;
char buffer[1024];
int attr, len;
hv_undef(rad_hv);
nvp = paircopy(vp);
while (nvp != NULL) {
attr = nvp->attribute;
vpa = paircopy2(nvp,attr);
if (vpa->next) {
av = newAV();
vpn = vpa;
while (vpn) {
len = vp_prints_value(buffer, sizeof(buffer),
vpn, FALSE);
av_push(av, newSVpv(buffer, len));
vpn = vpn->next;
}
hv_store(rad_hv, nvp->name, strlen(nvp->name),
newRV_noinc((SV *) av), 0);
} else {
len = vp_prints_value(buffer, sizeof(buffer),
vpa, FALSE);
hv_store(rad_hv, vpa->name, strlen(vpa->name),
newSVpv(buffer, len), 0);
}
pairfree(&vpa);
vpa = nvp; while ((vpa != NULL) && (vpa->attribute == attr))
vpa = vpa->next;
pairdelete(&nvp, attr);
nvp = vpa;
}
}
/*
* convert reserve_info_t to perl HV
*/
int
reserve_info_to_hv(reserve_info_t *reserve_info, HV *hv)
{
if (reserve_info->accounts)
STORE_FIELD(hv, reserve_info, accounts, charp);
STORE_FIELD(hv, reserve_info, end_time, time_t);
if (reserve_info->features)
STORE_FIELD(hv, reserve_info, features, charp);
STORE_FIELD(hv, reserve_info, flags, uint16_t);
if (reserve_info->licenses)
STORE_FIELD(hv, reserve_info, licenses, charp);
if (reserve_info->name)
STORE_FIELD(hv, reserve_info, name, charp);
STORE_FIELD(hv, reserve_info, node_cnt, uint32_t);
if (reserve_info->node_list)
STORE_FIELD(hv, reserve_info, node_list, charp);
/* no store for int pointers yet */
if (reserve_info->node_inx) {
int j;
AV *av = newAV();
for(j = 0; ; j += 2) {
if(reserve_info->node_inx[j] == -1)
break;
av_store(av, j, newSVuv(reserve_info->node_inx[j]));
av_store(av, j+1,
newSVuv(reserve_info->node_inx[j+1]));
}
hv_store_sv(hv, "node_inx", newRV_noinc((SV*)av));
}
if (reserve_info->partition)
STORE_FIELD(hv, reserve_info, partition, charp);
STORE_FIELD(hv, reserve_info, start_time, time_t);
if (reserve_info->users)
STORE_FIELD(hv, reserve_info, users, charp);
return 0;
}
static SV *
fold_results(I32 count)
{
dSP;
SV *retval = &PL_sv_undef;
if (count > 1) {
/* convert multiple return items into a list reference */
AV *av = newAV();
SV *last_sv = &PL_sv_undef;
SV *sv = &PL_sv_undef;
I32 i;
av_extend(av, count - 1);
for(i = 1; i <= count; i++) {
last_sv = sv;
sv = POPs;
if (SvOK(sv) && !av_store(av, count - i, SvREFCNT_inc(sv)))
SvREFCNT_dec(sv);
}
PUTBACK;
retval = sv_2mortal((SV *) newRV_noinc((SV *) av));
if (!SvOK(sv) || sv == &PL_sv_undef) {
/* if first element was undef, die */
croak(ERRMSG "Call error");
}
return retval;
}
else {
if (count)
retval = POPs;
PUTBACK;
return retval;
}
}
// create a new coro
SV * coroae_coro_new(CV *block) {
SV *newobj = NULL;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
mXPUSHs(newSVpvs("Coro"));
mXPUSHs(newRV_noinc((SV *)block));
PUTBACK;
call_method("new", G_SCALAR|G_EVAL);
SPAGAIN;
if(SvTRUE(ERRSV)) {
uwsgi_log("[uwsgi-perl error] %s", SvPV_nolen(ERRSV));
(void)POPs; // we must pop undef from the stack in G_SCALAR context
}
else {
newobj = SvREFCNT_inc(POPs);
}
PUTBACK;
FREETMPS;
LEAVE;
return newobj;
}
static SV *coroae_add_watcher(int fd, CV *cb) {
SV *newobj;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
mXPUSHs(newSVpvs("AnyEvent"));
mXPUSHs(newSVpvs("fh"));
mXPUSHs(newSViv(fd));
mXPUSHs(newSVpvs("poll"));
mXPUSHs(newSVpvs("r"));
mXPUSHs(newSVpvs("cb"));
mXPUSHs(newRV_noinc((SV *)cb));
PUTBACK;
call_method( "io", G_SCALAR|G_EVAL);
SPAGAIN;
if(SvTRUE(ERRSV)) {
// no need to continue...
uwsgi_log("[uwsgi-perl error] %s", SvPV_nolen(ERRSV));
exit(1);
}
else {
newobj = SvREFCNT_inc(POPs);
}
PUTBACK;
FREETMPS;
LEAVE;
return newobj;
}
void scan_result_response(const char** src, const char* max, HV *out) {
I32 r;
SV *sv;
scan_enum(src, max, &r);
hv_stores(out, "result", newSVsv(ldap_error2sv_noinc(r)));
sv = newSV(0);
hv_stores(out, "matched_dn", sv);
scan_string_utf8(src, max, sv);
sv = newSV(0);
hv_stores(out, "message", sv);
scan_string_utf8(src, max, sv);
if (*src < max) {
U8 type;
U32 tag;
STRLEN len;
AV *referrals;
scan_tag(src, max, &type, &tag);
if (type != (ASN1_CONTEXT_SPECIFIC | ASN1_CONSTRUCTED) || tag != 3)
croak("bad packed data");
scan_length(src, max, &len);
if (len != max - *src)
croak("scan_result_response: packet too short");
referrals = newAV();
hv_stores(out, "referrals", newRV_noinc((SV*)referrals));
while (*src < max) {
SV *v = newSV(0);
av_push(referrals, v);
scan_string_utf8(src, max, v);
}
}
}
SV* isaHMM (char *input){
P7_HMMFILE *hfp = NULL; /* open input HMM file */
P7_HMM *hmm = NULL; /* HMM object */
ESL_ALPHABET *abc = NULL; /* alphabet (set from the HMM file)*/
int isaHMM = 1;
int status;
int cnt = 0;
HV* hash = newHV();
hv_store(hash, "type", strlen("type"), newSVpv("UNK", 3), 0);
/* read the hmm */
if ((status = p7_hmmfile_OpenBuffer(input, strlen(input), &hfp)) != 0 ) {
hv_store(hash, "error", strlen("error"), newSViv(status), 0);
}else{
hv_store(hash, "type", strlen("type"), newSVpv("HMM", 3), 0);
}
if(status == 0){
/* double check that we can read the whole HMM */
status = p7_hmmfile_Read(hfp, &abc, &hmm);
cnt++;
if (status != eslOK ){
hv_store(hash, "error", strlen("error"), newSVpv("Error in HMM format",19 ), 0);
}else{
hv_store(hash, "alpha", strlen("alpha"), newSViv(abc->type), 0);
hv_store(hash, "hmmpgmd", strlen("hmmpgmd"), newSVpv(input, strlen(input)), 0);
hv_store(hash, "count", strlen("count"), newSViv(cnt), 0);
}
}
if (abc != NULL) esl_alphabet_Destroy(abc);
if(hfp != NULL) p7_hmmfile_Close(hfp);
if(hmm != NULL) p7_hmm_Destroy(hmm);
return newRV_noinc((SV*) hash);
}
static void *
create_event_common(lcb_io_opt_t cbcio, int type)
{
plcb_EVENT *cevent;
plcb_IOPROCS *async;
SV *initproc = NULL, *tmprv = NULL;
async = (plcb_IOPROCS*) cbcio->v.v0.cookie;
Newxz(cevent, 1, plcb_EVENT);
cevent->pl_event = newAV();
cevent->rv_event = newRV_noinc((SV*)cevent->pl_event);
cevent->evtype = type;
cevent->fd = -1;
sv_bless(cevent->rv_event, gv_stashpv(PLCB_EVENT_CLASS, GV_ADD));
av_store(cevent->pl_event, PLCB_EVIDX_OPAQUE, newSViv(PTR2IV(cevent)));
av_store(cevent->pl_event, PLCB_EVIDX_FD, newSViv(-1));
av_store(cevent->pl_event, PLCB_EVIDX_TYPE, newSViv(type));
av_store(cevent->pl_event, PLCB_EVIDX_WATCHFLAGS, newSViv(0));
tmprv = newRV_inc(*av_fetch(cevent->pl_event, PLCB_EVIDX_OPAQUE, 0));
sv_bless(tmprv, gv_stashpv("Couchbase::IO::_CEvent", GV_ADD));
SvREFCNT_dec(tmprv);
if (type == PLCB_EVTYPE_IO) {
initproc = async->cv_evinit;
} else {
initproc = async->cv_tminit;
}
if (initproc) {
cb_args_noret(initproc, 0, 2, async->userdata, cevent->rv_event);
}
return cevent;
}
void THX_MopMcV_add_attribute(pTHX_ SV* metaclass, SV* attribute) {
SV* attr_name;
SV* attributes = MopOV_get_at_slot(metaclass, CLASS_ATTRIBUTE_SLOT);
if (attributes == NULL) {
attributes = newRV_noinc((SV*) newHV());
MopOV_set_at_slot(metaclass, CLASS_ATTRIBUTE_SLOT, attributes);
}
if (SvTYPE(attributes) != SVt_RV && SvTYPE(SvRV(attributes)) != SVt_PVHV) {
croak("attributes is not a HASH ref, this is wrong");
}
attr_name = MopMaV_get_name(attribute);
if (attr_name == NULL) {
croak("The attribute has no name, this is wrong!");
}
if (NULL == hv_store_ent((HV*) SvRV(attributes), attr_name, attribute, 0)) {
croak("The attribute failed to store, this is wrong!");
}
MopMaV_set_associated_class(attribute, metaclass);
}
/*
* 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);
fr_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];
/*
* 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->vp_type) {
case FR_TYPE_STRING:
RDEBUG2("$%s{'%s'} = &%s:%s -> '%pV'", hash_name, vp->da->name, list_name,
vp->da->name, &vp->data);
(void)hv_store(rad_hv, name, strlen(name), newSVpvn(vp->vp_strvalue, vp->vp_length), 0);
break;
case FR_TYPE_OCTETS:
RDEBUG2("$%s{'%s'} = &%s:%s -> %pV", hash_name, vp->da->name, list_name,
vp->da->name, &vp->data);
(void)hv_store(rad_hv, name, strlen(name),
newSVpvn((char const *)vp->vp_octets, vp->vp_length), 0);
break;
default:
{
char buffer[1024];
size_t len;
len = fr_pair_value_snprint(buffer, sizeof(buffer), vp, '\0');
RDEBUG2("$%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();
}
static SV *
plperl_trigger_build_args(FunctionCallInfo fcinfo)
{
TriggerData *tdata;
TupleDesc tupdesc;
int i;
char *level;
char *event;
char *relid;
char *when;
HV *hv;
hv = newHV();
tdata = (TriggerData *) fcinfo->context;
tupdesc = tdata->tg_relation->rd_att;
relid = DatumGetCString(
DirectFunctionCall1(oidout,
ObjectIdGetDatum(tdata->tg_relation->rd_id)
)
);
hv_store(hv, "name", 4, newSVpv(tdata->tg_trigger->tgname, 0), 0);
hv_store(hv, "relid", 5, newSVpv(relid, 0), 0);
if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
{
event = "INSERT";
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
hv_store(hv, "new", 3,
plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
0);
}
else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
{
event = "DELETE";
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
hv_store(hv, "old", 3,
plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
0);
}
else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
{
event = "UPDATE";
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
{
hv_store(hv, "old", 3,
plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
0);
hv_store(hv, "new", 3,
plperl_hash_from_tuple(tdata->tg_newtuple, tupdesc),
0);
}
}
else
event = "UNKNOWN";
hv_store(hv, "event", 5, newSVpv(event, 0), 0);
hv_store(hv, "argc", 4, newSViv(tdata->tg_trigger->tgnargs), 0);
if (tdata->tg_trigger->tgnargs > 0)
{
AV *av = newAV();
for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
av_push(av, newSVpv(tdata->tg_trigger->tgargs[i], 0));
hv_store(hv, "args", 4, newRV_noinc((SV *) av), 0);
}
hv_store(hv, "relname", 7,
newSVpv(SPI_getrelname(tdata->tg_relation), 0), 0);
if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
when = "BEFORE";
else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
when = "AFTER";
else
when = "UNKNOWN";
hv_store(hv, "when", 4, newSVpv(when, 0), 0);
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
level = "ROW";
else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
level = "STATEMENT";
else
level = "UNKNOWN";
hv_store(hv, "level", 5, newSVpv(level, 0), 0);
return newRV_noinc((SV *) hv);
}
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 (CvXSUB(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 */
}
static void perl_call_signal(PERL_SCRIPT_REC *script, SV *func,
int signal_id, gconstpointer *args)
{
dSP;
PERL_SIGNAL_ARGS_REC *rec;
SV *sv, *perlarg, *saved_args[SIGNAL_MAX_ARGUMENTS];
AV *av;
void *arg;
int n;
ENTER;
SAVETMPS;
PUSHMARK(sp);
/* push signal argument to perl stack */
rec = perl_signal_args_find(signal_id);
memset(saved_args, 0, sizeof(saved_args));
for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&
rec != NULL && rec->args[n] != NULL; n++) {
arg = (void *) args[n];
if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
/* pointer to linked list - push as AV */
GList *tmp, **ptr;
int is_iobject, is_str;
is_iobject = strcmp(rec->args[n]+9, "iobject") == 0;
is_str = strcmp(rec->args[n]+9, "char*") == 0;
av = newAV();
ptr = arg;
for (tmp = *ptr; tmp != NULL; tmp = tmp->next) {
sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :
is_str ? new_pv(tmp->data) :
irssi_bless_plain(rec->args[n]+9, tmp->data);
av_push(av, sv);
}
saved_args[n] = perlarg = newRV_noinc((SV *) av);
} else if (strcmp(rec->args[n], "int") == 0)
perlarg = newSViv((IV)arg);
else if (arg == NULL)
perlarg = &PL_sv_undef;
else if (strcmp(rec->args[n], "string") == 0)
perlarg = new_pv(arg);
else if (strcmp(rec->args[n], "ulongptr") == 0)
perlarg = newSViv(*(unsigned long *) arg);
else if (strcmp(rec->args[n], "intptr") == 0)
saved_args[n] = perlarg = newRV_noinc(newSViv(*(int *) arg));
else if (strncmp(rec->args[n], "gslist_", 7) == 0) {
/* linked list - push as AV */
GSList *tmp;
int is_iobject;
is_iobject = strcmp(rec->args[n]+7, "iobject") == 0;
av = newAV();
for (tmp = arg; tmp != NULL; tmp = tmp->next) {
sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :
irssi_bless_plain(rec->args[n]+7, tmp->data);
av_push(av, sv);
}
perlarg = newRV_noinc((SV *) av);
} else if (strcmp(rec->args[n], "iobject") == 0) {
/* "irssi object" - any struct that has
"int type; int chat_type" as it's first
variables (server, channel, ..) */
perlarg = iobject_bless((SERVER_REC *) arg);
} else if (strcmp(rec->args[n], "siobject") == 0) {
/* "simple irssi object" - any struct that has
int type; as it's first variable (dcc) */
perlarg = simple_iobject_bless((SERVER_REC *) arg);
} else {
/* blessed object */
perlarg = plain_bless(arg, rec->args[n]);
}
XPUSHs(sv_2mortal(perlarg));
}
PUTBACK;
perl_call_sv(func, G_EVAL|G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV)) {
char *error = g_strdup(SvPV_nolen(ERRSV));
signal_emit("script error", 2, script, error);
g_free(error);
rec = NULL;
}
/* restore arguments the perl script modified */
for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&
rec != NULL && rec->args[n] != NULL; n++) {
arg = (void *) args[n];
if (saved_args[n] == NULL)
continue;
if (strcmp(rec->args[n], "intptr") == 0) {
int *val = arg;
*val = SvIV(SvRV(saved_args[n]));
} else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
GList **ret = arg;
GList *out = NULL;
void *val;
int count;
av = (AV *) SvRV(saved_args[n]);
count = av_len(av);
while (count-- >= 0) {
sv = av_shift(av);
if (SvPOKp(sv))
val = g_strdup(SvPV_nolen(sv));
else
val = GINT_TO_POINTER(SvIV(sv));
out = g_list_append(out, val);
}
if (strcmp(rec->args[n]+9, "char*") == 0)
g_list_foreach(*ret, (GFunc) g_free, NULL);
g_list_free(*ret);
*ret = out;
}
}
FREETMPS;
LEAVE;
}
/*
* 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(TALLOC_CTX *ctx, VALUE_PAIR *vps, HV *rad_hv)
{
VALUE_PAIR *head, *sublist;
AV *av;
char const *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. This is a horrible hack to
* get around various other stupidity.
*/
head = paircopy(ctx, vps);
while (head) {
vp_cursor_t cursor;
/*
* Tagged attributes are added to the hash with name
* <attribute>:<tag>, others just use the normal attribute
* name as the key.
*/
if (head->da->flags.has_tag && (head->tag != 0)) {
snprintf(namebuf, sizeof(namebuf), "%s:%d",
head->da->name, head->tag);
name = namebuf;
} else {
name = head->da->name;
}
/*
* Create a new list with all the attributes like this one
* which are in the same tag group.
*/
sublist = NULL;
pairfilter(ctx, &sublist, &head, head->da->attr, head->da->vendor, head->tag);
fr_cursor_init(&cursor, &sublist);
/*
* Attribute has multiple values
*/
if (fr_cursor_next(&cursor)) {
VALUE_PAIR *vp;
av = newAV();
for (vp = fr_cursor_first(&cursor);
vp;
vp = fr_cursor_next(&cursor)) {
len = vp_prints_value(buffer, sizeof(buffer), vp, 0);
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), sublist, 0);
(void)hv_store(rad_hv, name, strlen(name), newSVpv(buffer, len), 0);
}
pairfree(&sublist);
}
rad_assert(!head);
}
void
scan_search_reference_response(const char **src, const char *max, HV *hv) {
AV *av = newAV();
hv_stores(hv, "uris", newRV_noinc((SV*)av));
scan_array_of_string_utf8(src, max, av);
}
