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); }