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