static HeapTuple plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta) { TupleDesc td = attinmeta->tupdesc; char **values; SV *val; char *key; I32 klen; HeapTuple tup; values = (char **) palloc0(td->natts * sizeof(char *)); hv_iterinit(perlhash); while ((val = hv_iternextsv(perlhash, &key, &klen))) { int attn = SPI_fnumber(td, key); if (attn <= 0 || td->attrs[attn - 1]->attisdropped) ereport(ERROR, (errcode(ERRCODE_UNDEFINED_COLUMN), errmsg("Perl hash contains nonexistent column \"%s\"", key))); if (SvOK(val) && SvTYPE(val) != SVt_NULL) values[attn - 1] = SvPV(val, PL_na); } hv_iterinit(perlhash); tup = BuildTupleFromCStrings(attinmeta, values); pfree(values); return tup; }
/* convert a hash to a string, with the format "key=val,key=val" */ char * hash2str( HV* hash ) { SV* val; /* temp for iterating over hash */ char* key; /* temp for iterating over hash */ I32 keylen; /* temp for iterating over hash */ int len = 0; /* length of final string, including EOS */ int n; /* number of elements in hash */ char* str; /* final string */ char* ptr; /* temp ptr */ /* iterate over hash, determining the length of the final string */ hv_iterinit(hash); while( val = hv_iternextsv(hash, &key, &keylen) ) { /* complain if the value is undefined or if it's a reference */ if ( !SvOK(val) || SvROK(val) ) croak( "hash entry for `%s' not a scalar", key ); n++; len += keylen + SvCUR(val); } len += n /* '=' */ + n-1 /* ',' */ + 1; /* EOS */ /* now, fill in string */ New( 0, str, len, char ); ptr = str; hv_iterinit(hash); while( val = hv_iternextsv(hash, &key, &keylen) ) { STRLEN cur; char *pv; strcpy(ptr, key); ptr += keylen; *ptr++ = '='; pv = SvPV(val, cur); strncpy(ptr, pv, cur); ptr += cur; *ptr++ = ','; } /* the EOS position now contains a ',', and ptr is one past that. fix that */ *--ptr = '\0'; return str; }
/* This assumes that `val' is actually a Perl Hash table and that elementType identifies a _primitive_ Perl type and that all the elements in the table are of that type. This then creates an S vector of the corresponding type and populates it with the elements of the table and puts the names of the elements as the names of the S vector. */ USER_OBJECT_ fromHomogeneousTable(SV *val, svtype elementType) { USER_OBJECT_ ans, names; SV *av, *el; I32 len; char *key; int n, i; dTHX; if(SvROK(val)) av = SvRV(val) ; else av = val; n = hv_iterinit((HV *) av); PROTECT(ans = PerlAllocHomogeneousVector(n, elementType)); PROTECT(names = NEW_CHARACTER(n)); for(i = 0; i < n; i++) { el = hv_iternextsv((HV *) av, &key, &len); if(el) { PerlAddHomogeneousElement(el, i, ans, elementType); } if(key && key[0]) { SET_STRING_ELT(names, i, COPY_TO_USER_STRING(key)); } } SET_NAMES(ans, names); UNPROTECT(2); return(ans); }
USER_OBJECT_ RS_GetPerlReferenceObjects(USER_OBJECT_ which) { USER_OBJECT_ ans, tmp; int n, i = 0; ForeignReferenceTable *table= &exportReferenceTable; SV *el; char *key; I32 len; dTHX; if(table->entries == NULL) { return(NULL_USER_OBJECT); } n = GET_LENGTH(which); if(n == 0) { n = hv_iterinit(table->entries); PROTECT(ans = NEW_LIST(n)); while(i < n) { el = hv_iternextsv(table->entries, &key, &len); if(el == NULL) break; tmp = makeRSReferenceObject(key, computeRSPerlClassVector(el, NULL, TRUE), table); SET_VECTOR_ELT(ans, i, tmp); i++; } } else { } return(ans); }
/* Deletes name from all the isarev entries listed in isa */ STATIC void S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, const STRLEN len, HV * const exceptions, U32 hash, U32 flags) { HE* iter; PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV; /* Delete our name from our former parents' isarevs. */ if(HvARRAY(isa) && hv_iterinit(isa)) { SV **svp; while((iter = hv_iternext(isa))) { I32 klen; const char * const key = hv_iterkey(iter, &klen); if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen)) continue; svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0); if(svp) { HV * const isarev = (HV *)*svp; (void)hv_common(isarev, NULL, name, len, flags, G_DISCARD|HV_DELETE, NULL, hash); if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev)) (void)hv_delete(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, G_DISCARD); } } } }
/* * Gets the content from hashes */ static int get_hv_content(TALLOC_CTX *ctx, REQUEST *request, HV *my_hv, VALUE_PAIR **vps, const char *hash_name, const char *list_name) { SV *res_sv, **av_sv; AV *av; char *key; I32 key_len, len, i, j; int ret = 0; *vps = NULL; for (i = hv_iterinit(my_hv); i > 0; i--) { res_sv = hv_iternextsv(my_hv,&key,&key_len); if (SvROK(res_sv) && (SvTYPE(SvRV(res_sv)) == SVt_PVAV)) { av = (AV*)SvRV(res_sv); len = av_len(av); for (j = 0; j <= len; j++) { av_sv = av_fetch(av, j, 0); ret = pairadd_sv(ctx, request, vps, key, *av_sv, T_OP_ADD, hash_name, list_name) + ret; } } else ret = pairadd_sv(ctx, request, vps, key, res_sv, T_OP_EQ, hash_name, list_name) + ret; } if (*vps) LIST_VERIFY(*vps); return ret; }
/* Loop over all the key-value pairs and convert them to string and USER_OBJECT_ and put the latter into an R/S LIST and use the vector of keys as the names. */ USER_OBJECT_ fromPerlHV(HV *table, unsigned int depth) { I32 len; char *key; SV *el; I32 n, i; Rboolean sameType; svtype elType; dTHX; USER_OBJECT_ names, ans; sameType = isHomogeneous((SV*)table, &elType); if(sameType && isPerlPrimitiveType(elType, (SV *)table)) { return(fromHomogeneousTable((SV *) table, elType)); } n = hv_iterinit(table); i = 0; PROTECT(names = NEW_CHARACTER(n)); PROTECT(ans = NEW_LIST(n)); while(i < n) { el = hv_iternextsv(table, &key, &len); if(key == NULL) break; SET_VECTOR_ELT(ans, i, fromPerl(el, TRUE)); SET_STRING_ELT(names, i, COPY_TO_USER_STRING(key)); i++; } SET_NAMES(ans, names); UNPROTECT(2); return(ans); }
void dump_hash(pTHX_ HV* hash, Buffer* buf) { int count = 0; if (!hash) { return; } buffer_append(buf, "{", 1); hv_iterinit(hash); while (1) { I32 len = 0; char* key = 0; SV* val = 0; HE* entry = hv_iternext(hash); if (!entry) { break; } if (count++) { buffer_append(buf, ",", 1); } key = hv_iterkey(entry, &len); val = hv_iterval(hash, entry); buffer_append(buf, "\"", 1); buffer_append(buf, key, len); buffer_append(buf, "\":", 2); dump_value(aTHX_ val, buf); } buffer_append(buf, "}", 1); }
void HRA_fetch_a(SV *self, SV *attr, char *t) { dXSARGS; SP -= 3; if(GIMME_V == G_VOID) { XSRETURN(0); } SV *aobj = attr_get(self, attr, t, 0); if(!aobj) { HR_DEBUG("Can't find attribute!"); XSRETURN_EMPTY; } else { HR_DEBUG("Found aobj=%p", aobj); } hrattr_simple *aptr = attr_from_sv(SvRV(aobj)); HR_DEBUG("Attrhash=%p", aptr->attrhash); int nkeys = hv_iterinit(aptr->attrhash); HR_DEBUG("We have %d keys", nkeys); if(GIMME_V == G_SCALAR) { HR_DEBUG("Scalar return value requested"); XSRETURN_IV(nkeys); } HR_DEBUG("Will do some stack voodoo"); EXTEND(sp, nkeys); HE *cur = hv_iternext(aptr->attrhash); for(; cur != NULL; cur = hv_iternext(aptr->attrhash)) { XPUSHs(sv_mortalcopy(hv_iterval(aptr->attrhash, cur))); } PUTBACK; }
void CroakOptsHash(char * name, char * value, HV * o) { dTHR; SV * result = sv_newmortal(); HE * he; int i=0; sv_catpv(result, "invalid "); sv_catpv(result, name); sv_catpv(result, " "); sv_catpv(result, value); sv_catpv(result, ", expecting"); hv_iterinit(o); he = hv_iternext(o); while(he) { I32 len; char * key = hv_iterkey(he, &len); he = hv_iternext(o); if (i==0) sv_catpv(result," '"); else if (he) sv_catpv(result,"', '"); else sv_catpv(result,"', or '"); i=1; sv_catpvn(result, key, len); } sv_catpv(result,"'"); croak(SvPV(result, PL_na)); }
long SvDefFlagsHash (GtkType type, SV *name) { long val = 0; GtkFlagValue * vals; int i; vals = gtk_type_flags_get_values(type); if (!vals) { warn("Invalid type for flags: %s", gtk_type_name(type)); return SvIV(name); } if (SvROK(name) && (SvTYPE(SvRV(name)) == SVt_PVAV)) { AV * r = (AV*)SvRV(name); for(i=0;i<=av_len(r);i++) val |= SvEFValueLookup(vals, SvPV(*av_fetch(r, i, 0), PL_na), type); } else if (SvROK(name) && (SvTYPE(SvRV(name)) == SVt_PVHV)) { HV * r = (HV*)SvRV(name); HE * he; I32 len; hv_iterinit(r); while ((he=hv_iternext(r))) { val |= SvEFValueLookup(vals, hv_iterkey(he, &len), type); } } else val |= SvEFValueLookup(vals, SvPV(name, PL_na), type); return val; }
SV * newSVFlagsHash(long value, char * optname, HV * o) { SV * target, *result; int i; HE * he; SV * s; I32 len; char * key; if (!pgtk_use_array) target = (SV*)newHV(); else target = (SV*)newAV(); hv_iterinit(o); while((s = hv_iternextsv(o, &key, &len))) { int val = SvIV(s); if ((value & val) == val) { if (!pgtk_use_array) hv_store((HV*)target, key, len, newSViv(1), 0); else av_push((AV*)target, newSVpv(key, len)); value &= ~val; } } result = newRV(target); SvREFCNT_dec(target); return result; }
long SvFlagsHash(SV * name, char * optname, HV * o) { int i; int val=0; if (!name || !SvOK(name)) return 0; if (SvRV(name) && (SvTYPE(SvRV(name)) == SVt_PVAV)) { AV * r = (AV*)SvRV(name); for(i=0;i<=av_len(r);i++) val |= SvOptsHash(*av_fetch(r, i, 0), optname, o); } else if (SvRV(name) && (SvTYPE(SvRV(name)) == SVt_PVHV)) { HV * r = (HV*)SvRV(name); HE * h; hv_iterinit(r); while((h = hv_iternext(r))) { I32 len; char * key = hv_iterkey(h, &len); SV ** f; if (*key == '-') { key++; len--; } f = hv_fetch(o, key, len, 0); if (f) val |= SvIV(hv_iterval(o, h)); else CroakOptsHash(optname, key, o); } } else val |= SvOptsHash(name, optname, o); return val; }
int plcb_extract_args(SV *sv, plcb_OPTION *values) { char *cur_key; I32 klen; if (SvROK(sv)) { sv = SvRV(sv); } if (SvTYPE(sv) == SVt_PVHV) { HV *hv = (HV*)sv; SV *cur_val; hv_iterinit(hv); while ( (cur_val = hv_iternextsv(hv, &cur_key, &klen)) ) { plcb_OPTION *curdst = find_valspec(values, cur_key, klen); if (!curdst) { warn("Unrecognized key '%.*s'", (int)klen, cur_key); continue; } if (convert_valspec(curdst, cur_val) == -1) { die("Bad value for %.*s'", (int)klen, cur_key); } curdst->sv = cur_val; } } else { die("Unrecognized options type. Must be hash"); } return 0; }
KHARON_DECL void * encode_map_iter(void *data) { SV *in = data; HV *hv; D(fprintf(stderr, "map_iter = %p\n", in)); hv = (HV *)SvRV(in); hv_iterinit(hv); return hv; }
/* =for apidoc mro_method_changed_in Invalidates method caching on any child classes of the given stash, so that they might notice the changes in this one. Ideally, all instances of C<PL_sub_generation++> in perl source outside of F<mro.c> should be replaced by calls to this. Perl automatically handles most of the common ways a method might be redefined. However, there are a few ways you could change a method in a stash without the cache code noticing, in which case you need to call this method afterwards: 1) Directly manipulating the stash HV entries from XS code. 2) Assigning a reference to a readonly scalar constant into a stash entry in order to create a constant subroutine (like F<constant.pm> does). This same method is available from pure perl via, C<mro::method_changed_in(classname)>. =cut */ void Perl_mro_method_changed_in(pTHX_ HV *stash) { const char * const stashname = HvENAME_get(stash); const STRLEN stashname_len = HvENAMELEN_get(stash); SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK(stash), 0); HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL; PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN; if(!stashname) Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table"); /* Inc the package generation, since a local method changed */ HvMROMETA(stash)->pkg_gen++; /* DESTROY can be cached in SvSTASH. */ if (!SvOBJECT(stash)) SvSTASH(stash) = NULL; /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, invalidate all method caches globally */ if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { PL_sub_generation++; return; } /* else, invalidate the method caches of all child classes, but not itself */ if(isarev) { HE* iter; hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0); struct mro_meta* mrometa; if(!revstash) continue; mrometa = HvMROMETA(revstash); mrometa->cache_gen++; if(mrometa->mro_nextmethod) hv_clear(mrometa->mro_nextmethod); if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; } } /* The method change may be due to *{$package . "::()"} = \&nil; in overload.pm. */ HvAMAGIC_on(stash); /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */ HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; }
void mop_get_package_symbols (HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud) { HE *he; (void)hv_iterinit(stash); if (filter == TYPE_FILTER_NONE) { while ( (he = hv_iternext(stash)) ) { STRLEN keylen; const char *key = HePV(he, keylen); if (!cb(key, keylen, HeVAL(he), ud)) { return; } } return; } while ( (he = hv_iternext(stash)) ) { GV * const gv = (GV*)HeVAL(he); STRLEN keylen; const char * const key = HePV(he, keylen); SV *sv = NULL; if(isGV(gv)){ switch (filter) { case TYPE_FILTER_CODE: sv = (SV *)GvCVu(gv); break; case TYPE_FILTER_ARRAY: sv = (SV *)GvAV(gv); break; case TYPE_FILTER_IO: sv = (SV *)GvIO(gv); break; case TYPE_FILTER_HASH: sv = (SV *)GvHV(gv); break; case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv); break; default: croak("Unknown type"); } } /* expand the gv into a real typeglob if it * contains stub functions or constants and we * were asked to return CODE references */ else if (filter == TYPE_FILTER_CODE) { gv_init(gv, stash, key, keylen, GV_ADDMULTI); sv = (SV *)GvCV(gv); } if (sv) { if (!cb(key, keylen, sv, ud)) { return; } } } }
USER_OBJECT_ RS_PerlLength(USER_OBJECT_ obj) { SV *sv; int n; USER_OBJECT_ ans; dTHX; sv = RS_PerlGetSV(obj); if(!sv) { PROBLEM "Can't get Perl object from S object" ERROR; } /* Check for a) objects, b) references here. */ #if 0 if(sv_isobject(sv)) { /*XXX What are we warning here. Is it debugging? */ PROBLEM "Calling length on a Perl object" WARN; } #endif if(SvROK(sv)) { sv = SvRV(sv); } switch(SvTYPE(sv)) { case SVt_PVHV: n = hv_iterinit((HV*) sv); break; case SVt_PVAV: n = av_len((AV*) sv) + 1; break; default: n = 0; break; } ans = NEW_INTEGER(1); INTEGER_DATA(ans)[0] = n; return(ans); }
USER_OBJECT_ RS_PerlNames(USER_OBJECT_ obj) { HV* hv; SV *el; int n, i; USER_OBJECT_ names; char *key; I32 len; dTHX; if(IS_CHARACTER(obj)) { hv = get_hv(CHAR_DEREF(STRING_ELT(obj,0)), FALSE); } else hv = (HV *) RS_PerlGetSV(obj); if(hv == NULL) { PROBLEM "identifier does not refer to a Perl hashtable object" ERROR; } if(SvTYPE(hv) != SVt_PVHV) { if(SvROK(hv) && SvTYPE(SvRV(hv)) == SVt_PVHV) { hv = (HV *) SvRV(hv); } else { PROBLEM "identifier is not a Perl hashtable object, but some other type %s", getPerlType((SV*)hv) ERROR; } } n = hv_iterinit(hv); if(n == 0) return(NULL_USER_OBJECT); PROTECT(names = NEW_CHARACTER(n)); i = 0; while(i < n) { el = hv_iternextsv(hv, &key, &len); if(key == NULL) break; SET_STRING_ELT(names, i, COPY_TO_USER_STRING(key)); i++; } UNPROTECT(1); return(names); }
static void tn_encode_hash(SV *data, struct tn_buffer *buf) { HV *hash = (HV *)data; HE *entry; SV *key; hv_iterinit(hash); while(entry = hv_iternext(hash)) { key = hv_iterkeysv(entry); SvPOK_on(key); tn_encode(hv_iterval(hash, entry), buf); tn_encode(key, buf); } }
USER_OBJECT_ RS_PerlReferenceCount() { USER_OBJECT_ ans; ForeignReferenceTable *table= &exportReferenceTable; dTHX; PROTECT(ans = NEW_INTEGER(2)); if(table->entries != NULL) { INTEGER_DATA(ans)[0] = hv_iterinit(table->entries); INTEGER_DATA(ans)[1] = table->numReferences; } UNPROTECT(1); return(ans); }
static amf0_data_t* _amf0_data_rv(SV* sv) { svtype svt = SvTYPE(sv); int i, len, count; amf0_data_t* d; SV** svp; SV* k; AV* ary; HV* hval; HE* he; STRLEN strlen; char* key; if (SVt_PVAV == svt) { d = (amf0_data_t*)amf0_strictarray_init(); ary = (AV*)sv; len = av_len(ary) + 1; for (i = 0; i < len; ++i) { svp = av_fetch(ary, i, 0); if (svp) { amf0_strictarray_add((amf0_strictarray_t*)d, _amf0_data(*svp)); } else { amf0_strictarray_add((amf0_strictarray_t*)d, _amf0_data(NULL)); } } } else if (SVt_PVHV == svt) { d = (amf0_data_t*)amf0_object_init(); hval = (HV*)sv; count = hv_iterinit(hval); while ( (he = hv_iternext(hval)) ) { k = hv_iterkeysv(he); key = SvPV(k, strlen); amf0_object_add((amf0_object_t*)d, key, _amf0_data(HeVAL(he))); } } else { Perl_croak(aTHX_ "Data::AMF::XS doesn't support references except ARRAY and HASH"); } return d; }
Datum plperl_to_hstore(PG_FUNCTION_ARGS) { HV *hv; HE *he; int32 buflen; int32 i; int32 pcount; HStore *out; Pairs *pairs; hv = (HV *) SvRV((SV *) PG_GETARG_POINTER(0)); pcount = hv_iterinit(hv); pairs = palloc(pcount * sizeof(Pairs)); i = 0; while ((he = hv_iternext(hv))) { char *key = sv2cstr(HeSVKEY_force(he)); SV *value = HeVAL(he); pairs[i].key = pstrdup(key); pairs[i].keylen = hstoreCheckKeyLen(strlen(pairs[i].key)); pairs[i].needfree = true; if (!SvOK(value)) { pairs[i].val = NULL; pairs[i].vallen = 0; pairs[i].isnull = true; } else { pairs[i].val = pstrdup(sv2cstr(value)); pairs[i].vallen = hstoreCheckValLen(strlen(pairs[i].val)); pairs[i].isnull = false; } i++; } pcount = hstoreUniquePairs(pairs, pcount, &buflen); out = hstorePairs(pairs, pcount, buflen); PG_RETURN_POINTER(out); }
void HRXSATTR_ithread_predup(SV *self, SV *table, HV *ptr_map) { hrattr_simple *attr = attr_from_sv(SvRV(self)); /*Make sure our attribute hash is visible to perl space*/ SV *attrhash_ref; RV_Newtmp(attrhash_ref, (SV*)attr->attrhash); hr_dup_store_rv(ptr_map, attrhash_ref); RV_Freetmp(attrhash_ref); char *ktmp; I32 tmplen; SV *vtmp; SV *rlookup; get_hashes(REF2TABLE(table), HR_HKEY_LOOKUP_REVERSE, &rlookup, HR_HKEY_LOOKUP_NULL); hv_iterinit(attr->attrhash); while( (vtmp = hv_iternextsv(attr->attrhash, &ktmp, &tmplen))) { HR_Dup_Vinfo *vi = hr_dup_get_vinfo(ptr_map, SvRV(vtmp), 1); if(!vi->vhash) { SV *vaddr = newSVuv((UV)SvRV(vtmp)); SV *vhash = get_vhash_from_rlookup(rlookup, vaddr, 0); vi->vhash = vhash; SvREFCNT_dec(vaddr); } } if(attr->encap) { hrattr_encap *aencap = attr_encap_cast(attr); hr_dup_store_rv(ptr_map, aencap->obj_rv); char *ai = (char*)hr_dup_store_kinfo( ptr_map, HR_DUPKEY_AENCAP, aencap->obj_paddr, 1); if(SvWEAKREF(aencap->obj_rv)) { *ai = HRK_DUP_WEAK_ENCAP; } else { *ai = 0; } } }
/* XXX TODO: Messages should round-trip properly between message2hashref and hashref2message. Currently we lose zephyr-specific properties stored in the ZNotice_t */ CALLER_OWN owl_message *owl_perlconfig_hashref2message(SV *msg) { owl_message * m; HE * ent; I32 len; const char *key,*val; HV * hash; struct tm tm; hash = (HV*)SvRV(msg); m = g_new(owl_message, 1); owl_message_init(m); hv_iterinit(hash); while((ent = hv_iternext(hash))) { key = hv_iterkey(ent, &len); val = SvPV_nolen(hv_iterval(hash, ent)); if(!strcmp(key, "type")) { owl_message_set_type(m, val); } else if(!strcmp(key, "direction")) { owl_message_set_direction(m, owl_message_parse_direction(val)); } else if(!strcmp(key, "private")) { SV * v = hv_iterval(hash, ent); if(SvTRUE(v)) { owl_message_set_isprivate(m); } } else if (!strcmp(key, "hostname")) { owl_message_set_hostname(m, val); } else if (!strcmp(key, "zwriteline")) { owl_message_set_zwriteline(m, val); } else if (!strcmp(key, "time")) { g_free(m->timestr); m->timestr = g_strdup(val); strptime(val, "%a %b %d %T %Y", &tm); m->time = mktime(&tm); } else { owl_message_set_attribute(m, key, val); } } if(owl_message_is_type_admin(m)) { if(!owl_message_get_attribute_value(m, "adminheader")) owl_message_set_attribute(m, "adminheader", ""); } return m; }
/* =for apidoc mro_method_changed_in Invalidates method caching on any child classes of the given stash, so that they might notice the changes in this one. Ideally, all instances of C<PL_sub_generation++> in perl source outside of C<mro.c> should be replaced by calls to this. Perl automatically handles most of the common ways a method might be redefined. However, there are a few ways you could change a method in a stash without the cache code noticing, in which case you need to call this method afterwards: 1) Directly manipulating the stash HV entries from XS code. 2) Assigning a reference to a readonly scalar constant into a stash entry in order to create a constant subroutine (like constant.pm does). This same method is available from pure perl via, C<mro::method_changed_in(classname)>. =cut */ void Perl_mro_method_changed_in(pTHX_ HV *stash) { const char * const stashname = HvNAME_get(stash); const STRLEN stashname_len = HvNAMELEN_get(stash); SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL; PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN; if(!stashname) Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table"); /* Inc the package generation, since a local method changed */ HvMROMETA(stash)->pkg_gen++; /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, invalidate all method caches globally */ if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { PL_sub_generation++; return; } /* else, invalidate the method caches of all child classes, but not itself */ if(isarev) { HE* iter; hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { I32 len; const char* const revkey = hv_iterkey(iter, &len); HV* const revstash = gv_stashpvn(revkey, len, 0); struct mro_meta* mrometa; if(!revstash) continue; mrometa = HvMROMETA(revstash); mrometa->cache_gen++; if(mrometa->mro_nextmethod) hv_clear(mrometa->mro_nextmethod); } } }
SV * newSVOptsHash(long value, char * optname, HV * o) { int i; HE * h; SV * result = 0; hv_iterinit(o); while((h = hv_iternext(o))) { SV * s = hv_iterval(o, h); if (SvIV(s) == value) { I32 len; char * p = hv_iterkey(h, &len); result = newSVpv(p, len); } } if (result) return result; croak("invalid %s value %d", optname, value); }
void perl_ht_to_ht(HV *perl_ht, struct hashtable *ht) { HE *he; STRLEN len; I32 len2; hv_iterinit(perl_ht); while ((he = hv_iternext(perl_ht))) { SV *val = hv_iterval(perl_ht, he); char *val_str = strdup(SvPV(val, len)); char *key_str = strdup(hv_iterkey(he, &len2)); if (hashtable_search(ht, key_str)) { warnx("key '%s' already exists in ht, ignoring", key_str); continue; } hashtable_insert(ht, key_str, val_str); } }
cfish_Vector* LUCY_Doc_Field_Names_IMP(lucy_Doc *self) { dTHX; lucy_DocIVARS *const ivars = lucy_Doc_IVARS(self); HV *fields = (HV*)ivars->fields; I32 num_fields = hv_iterinit(fields); cfish_Vector *retval = cfish_Vec_new(num_fields); while (num_fields--) { HE *entry = hv_iternext(fields); STRLEN key_size; const char *key = XSBind_hash_key_to_utf8(aTHX_ entry, &key_size); cfish_String *key_str = cfish_Str_new_from_trusted_utf8(key, key_size); CFISH_Vec_Push(retval, (cfish_Obj*)key_str); } return retval; }
int find_hooks(pTHX_ const char *type, HV *hooks, TypeHooks *pTH) { HE *h; int i, num; assert(type != NULL); assert(hooks != NULL); assert(pTH != NULL); (void) hv_iterinit(hooks); while ((h = hv_iternext(hooks)) != NULL) { const char *key; I32 keylen; SV *sub; enum HookId id; key = hv_iterkey(h, &keylen); sub = hv_iterval(hooks, h); id = get_hook_id(key); if (id >= HOOKID_COUNT) { if (id == HOOKID_INVALID) Perl_croak(aTHX_ "Invalid hook type '%s'", key); else fatal("Invalid hook id %d for hook '%s'", id, key); } single_hook_fill(aTHX_ key, type, &pTH->hooks[id], sub, SHF_ALLOW_ARG_SELF | SHF_ALLOW_ARG_TYPE | SHF_ALLOW_ARG_DATA | SHF_ALLOW_ARG_HOOK); } for (i = num = 0; i < HOOKID_COUNT; i++) if (pTH->hooks[i].sub) num++; return num; }