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));
}
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;
}
}
}
}
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);
}
/* 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);
}
}
}
}
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;
}
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;
}
/*
=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;
}
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);
}
}
KHARON_DECL int
encode_map_next(void *data, void **key, void **val)
{
HV *in = data;
HE *elem;
elem = hv_iternext(in);
if (!elem)
return 0;
*key = hv_iterkeysv(elem);
*val = hv_iterval(in, elem);
D(fprintf(stderr, "map_next = (key = %p, val = %p)\n", *key, *val));
return 1;
}
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);
}
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;
}
/* 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);
}
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;
}
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;
}
bool
LUCY_Doc_Equals_IMP(lucy_Doc *self, cfish_Obj *other) {
if ((lucy_Doc*)other == self) { return true; }
if (!cfish_Obj_is_a(other, LUCY_DOC)) { return false; }
lucy_DocIVARS *const ivars = lucy_Doc_IVARS(self);
lucy_DocIVARS *const ovars = lucy_Doc_IVARS((lucy_Doc*)other);
if (!ivars->doc_id == ovars->doc_id) { return false; }
if (!!ivars->fields ^ !!ovars->fields) { return false; }
// Verify fields. Don't allow any deep data structures.
dTHX;
HV *my_fields = (HV*)ivars->fields;
HV *other_fields = (HV*)ovars->fields;
if (HvKEYS(my_fields) != HvKEYS(other_fields)) { return false; }
I32 num_fields = hv_iterinit(my_fields);
while (num_fields--) {
HE *my_entry = hv_iternext(my_fields);
SV *my_val_sv = HeVAL(my_entry);
STRLEN key_len;
char *key;
if (HeKLEN(my_entry) == HEf_SVKEY) {
SV *key_sv = HeKEY_sv(my_entry);
key = SvPV(key_sv, key_len);
if (SvUTF8(key_sv)) { key_len = -key_len; }
}
else {
key_len = HeKLEN(my_entry);
key = key_len ? HeKEY(my_entry) : Nullch;
if (HeKUTF8(my_entry)) { key_len = -key_len; }
}
SV **const other_val = hv_fetch(other_fields, key, key_len, 0);
if (!other_val) { return false; }
if (!sv_eq(my_val_sv, *other_val)) { return false; }
}
return true;
}
SV*
Application_font_encodings( Handle self, char * encoding)
{
AV * glo = newAV();
HE *he;
PHash h = apc_font_encodings( self);
if ( !h) return newRV_noinc(( SV *) glo);
hv_iterinit(( HV*) h);
for (;;)
{
void *value, *key;
STRLEN keyLen;
if (( he = hv_iternext( h)) == nil)
break;
value = HeVAL( he);
key = HeKEY( he);
keyLen = HeKLEN( he);
av_push( glo, newSVpvn(( char*) key, keyLen));
}
return newRV_noinc(( SV *) glo);
}
void VAstEnt::import(VAstEnt* pkgEntp, const string& id_or_star) {
if (id_or_star != "*") { // Import single entry
if (VAstEnt* idEntp = pkgEntp->findSym(id_or_star)) {
// We can just add a second reference to the same AstEnt object
if (debug()) cout<<"VAstEnt::import under="<<this<<" "<<idEntp->ascii()<<"\n";
replaceInsert(idEntp, id_or_star);
}
} else {
// Walk old sym table
HV* hvp = pkgEntp->subhash(); assert(hvp);
hv_iterinit(hvp);
while (HE* hep = hv_iternext(hvp)) {
I32 retlen;
const char* namep = hv_iterkey(hep, &retlen);
string name = string(namep,retlen);
SV* svp = hv_iterval(hvp, hep);
VAstEnt* idEntp = avToSymEnt((AV*)(SvRV(svp)));
if (debug()) cout<<"VAstEnt::import under="<<this<<" "<<idEntp->ascii(name)<<"\n";
replaceInsert(idEntp, name);
}
}
}
static void modperl_package_clear_stash(pTHX_ const char *package)
{
HV *stash;
if ((stash = gv_stashpv(package, FALSE))) {
HE *he;
I32 len;
char *key;
hv_iterinit(stash);
while ((he = hv_iternext(stash))) {
key = hv_iterkey(he, &len);
if (MP_SAFE_STASH(key, len)) {
SV *val = hv_iterval(stash, he);
/* The safe thing to do is to skip over stash entries
* that don't come from the package we are trying to
* unload
*/
if (GvSTASH(val) == stash) {
(void)hv_delete(stash, key, len, G_DISCARD);
}
}
}
}
}
JSFunctionSpec *PJS_add_class_functions(PJS_Class *pcls, HV *fs, U8 flags) {
JSFunctionSpec *fs_list, *current_fs;
PJS_Function *pfunc;
HE *entry;
char *name;
I32 len;
SV *callback;
I32 number_of_keys = hv_iterinit(fs);
Newz(1, fs_list, number_of_keys + 1, JSFunctionSpec);
current_fs = fs_list;
while((entry = hv_iternext(fs)) != NULL) {
name = hv_iterkey(entry, &len);
callback = hv_iterval(fs, entry);
len = strlen(name);
Newz(1, pfunc, 1, PJS_Function);
if (pfunc == NULL) {
/* We might need to free more memory stuff here */
croak("Failed to allocate memory for PJS_Function");
}
/* Name of function */
Newz(1, pfunc->name, len + 1, char);
if (pfunc->name == NULL) {
Safefree(pfunc);
croak("Failed to allocate memory for PJS_Function name");
}
Copy(name, pfunc->name, len, char);
/* Setup JSFunctionSpec */
Newz(1, current_fs->name, len + 1, char);
if (current_fs->name == NULL) {
Safefree(pfunc->name);
Safefree(pfunc);
croak("Failed to allocate memory for JSFunctionSpec name");
}
Copy(name, current_fs->name, len, char);
current_fs->call = PJS_invoke_perl_object_method;
current_fs->nargs = 0;
current_fs->flags = 0;
current_fs->extra = 0;
pfunc->callback = SvREFCNT_inc(callback);
/* Add entry to linked list */
pfunc->_next = pcls->methods;
pcls->methods = pfunc;
/* Get next function */
current_fs++;
}
current_fs->name = 0;
current_fs->call = 0;
current_fs->nargs = 0;
current_fs->flags = 0;
current_fs->extra = 0;
return fs_list;
}
JSPropertySpec *PJS_add_class_properties(PJS_Class *pcls, HV *ps, U8 flags) {
JSPropertySpec *ps_list, *current_ps;
PJS_Property *pprop;
HE *entry;
char *name;
I32 len;
AV *callbacks;
SV **getter, **setter;
I32 number_of_keys = hv_iterinit(ps);
Newz(1, ps_list, number_of_keys + 1, JSPropertySpec);
current_ps = ps_list;
while((entry = hv_iternext(ps)) != NULL) {
name = hv_iterkey(entry, &len);
callbacks = (AV *) SvRV(hv_iterval(ps, entry));
len = strlen(name);
Newz(1, pprop, 1, PJS_Property);
if (pprop == NULL) {
/* We might need to free more memory stuff here */
croak("Failed to allocate memory for PJS_Property");
}
/* Setup JSFunctionSpec */
Newz(1, current_ps->name, len + 1, char);
if (current_ps->name == NULL) {
Safefree(pprop);
croak("Failed to allocate memory for JSPropertySpec name");
}
Copy(name, current_ps->name, len, char);
getter = av_fetch(callbacks, 0, 0);
setter = av_fetch(callbacks, 1, 0);
pprop->getter = getter != NULL && SvTRUE(*getter) ? SvREFCNT_inc(*getter) : NULL;
pprop->setter = setter != NULL && SvTRUE(*setter) ? SvREFCNT_inc(*setter) : NULL;
current_ps->getter = PJS_invoke_perl_property_getter;
current_ps->setter = PJS_invoke_perl_property_setter;
current_ps->tinyid = pcls->next_property_id++;
current_ps->flags = JSPROP_ENUMERATE;
if (setter == NULL) {
current_ps->flags |= JSPROP_READONLY;
}
pprop->tinyid = current_ps->tinyid;
pprop->_next = pcls->properties;
pcls->properties = pprop;
current_ps++;
}
current_ps->name = 0;
current_ps->tinyid = 0;
current_ps->flags = 0;
current_ps->getter = 0;
current_ps->setter = 0;
return ps_list;
}
void _mpack_item(SV *res, SV *o)
{
size_t len, res_len, new_len;
char *s, *res_s;
res_s = SvPVbyte(res, res_len);
unsigned i;
if (!SvOK(o)) {
new_len = res_len + mp_sizeof_nil();
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_nil(res_s + res_len);
return;
}
if (SvROK(o)) {
o = SvRV(o);
if (SvOBJECT(o)) {
SvGETMAGIC(o);
HV *stash = SvSTASH(o);
GV *mtd = gv_fetchmethod_autoload(stash, "msgpack", 0);
if (!mtd)
croak("Object has no method 'msgpack'");
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs (sv_bless (sv_2mortal (newRV_inc(o)), stash));
PUTBACK;
call_sv((SV *)GvCV(mtd), G_SCALAR);
SPAGAIN;
SV *pkt = POPs;
if (!SvOK(pkt))
croak("O->msgpack returned undef");
s = SvPV(pkt, len);
new_len = res_len + len;
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
memcpy(res_s + res_len, s, len);
PUTBACK;
FREETMPS;
LEAVE;
return;
}
switch(SvTYPE(o)) {
case SVt_PVAV: {
AV *a = (AV *)o;
len = av_len(a) + 1;
new_len = res_len + mp_sizeof_array(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_array(res_s + res_len, len);
for (i = 0; i < len; i++) {
SV **item = av_fetch(a, i, 0);
if (!item)
_mpack_item(res, 0);
else
_mpack_item(res, *item);
}
break;
}
case SVt_PVHV: {
HV *h = (HV *)o;
len = hv_iterinit(h);
new_len = res_len + mp_sizeof_map(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_map(res_s + res_len, len);
for (;;) {
HE * iter = hv_iternext(h);
if (!iter)
break;
SV *k = hv_iterkeysv(iter);
SV *v = HeVAL(iter);
_mpack_item(res, k);
_mpack_item(res, v);
}
break;
}
default:
croak("Can't serialize reference");
}
return;
}
switch(SvTYPE(o)) {
case SVt_PV:
case SVt_PVIV:
case SVt_PVNV:
case SVt_PVMG:
case SVt_REGEXP:
if (!looks_like_number(o)) {
s = SvPV(o, len);
new_len = res_len + mp_sizeof_str(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_str(res_s + res_len, s, len);
break;
}
case SVt_NV: {
NV v = SvNV(o);
IV iv = (IV)v;
if (v != iv) {
new_len = res_len + mp_sizeof_double(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_double(res_s + res_len, v);
break;
}
}
case SVt_IV: {
IV v = SvIV(o);
if (v >= 0) {
new_len = res_len + mp_sizeof_uint(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_uint(res_s + res_len, v);
} else {
new_len = res_len + mp_sizeof_int(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_int(res_s + res_len, v);
}
break;
}
default:
croak("Internal msgpack error %d", SvTYPE(o));
}
}
/*
=for apidoc mro_isa_changed_in
Takes the necessary steps (cache invalidations, mostly)
when the @ISA of the given package has changed. Invoked
by the C<setisa> magic, should not need to invoke directly.
=cut
*/
void
Perl_mro_isa_changed_in(pTHX_ HV* stash)
{
dVAR;
HV* isarev;
AV* linear_mro;
HE* iter;
SV** svp;
I32 items;
bool is_universal;
struct mro_meta * meta;
const char * const stashname = HvNAME_get(stash);
const STRLEN stashname_len = HvNAMELEN_get(stash);
PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
/* wipe out the cached linearizations for this stash */
meta = HvMROMETA(stash);
if (meta->mro_linear_dfs) {
SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs));
meta->mro_linear_dfs = NULL;
/* This is just acting as a shortcut pointer. */
meta->mro_linear_c3 = NULL;
} else if (meta->mro_linear_c3) {
/* Only the current MRO is stored, so this owns the data. */
SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3));
meta->mro_linear_c3 = NULL;
}
if (meta->isa) {
SvREFCNT_dec(meta->isa);
meta->isa = NULL;
}
/* Inc the package generation, since our @ISA changed */
meta->pkg_gen++;
/* Wipe the global method cache if this package
is UNIVERSAL or one of its parents */
svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
isarev = svp ? MUTABLE_HV(*svp) : NULL;
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
PL_sub_generation++;
is_universal = TRUE;
}
else { /* Wipe the local method cache otherwise */
meta->cache_gen++;
is_universal = FALSE;
}
/* wipe next::method cache too */
if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
/* Iterate the isarev (classes that are our children),
wiping out their linearization, method and isa caches */
if(isarev) {
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
I32 len;
const char* const revkey = hv_iterkey(iter, &len);
HV* revstash = gv_stashpvn(revkey, len, 0);
struct mro_meta* revmeta;
if(!revstash) continue;
revmeta = HvMROMETA(revstash);
if (revmeta->mro_linear_dfs) {
SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs));
revmeta->mro_linear_dfs = NULL;
/* This is just acting as a shortcut pointer. */
revmeta->mro_linear_c3 = NULL;
} else if (revmeta->mro_linear_c3) {
/* Only the current MRO is stored, so this owns the data. */
SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_c3));
revmeta->mro_linear_c3 = NULL;
}
if(!is_universal)
revmeta->cache_gen++;
if(revmeta->mro_nextmethod)
hv_clear(revmeta->mro_nextmethod);
if (revmeta->isa) {
SvREFCNT_dec(revmeta->isa);
revmeta->isa = NULL;
}
}
}
/* Now iterate our MRO (parents), and do a few things:
1) instantiate with the "fake" flag if they don't exist
2) flag them as universal if we are universal
3) Add everything from our isarev to their isarev
*/
/* We're starting at the 2nd element, skipping ourselves here */
linear_mro = mro_get_linear_isa(stash);
svp = AvARRAY(linear_mro) + 1;
items = AvFILLp(linear_mro);
while (items--) {
SV* const sv = *svp++;
HV* mroisarev;
HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
/* That fetch should not fail. But if it had to create a new SV for
us, then we can detect it, because it will not be the correct type.
Probably faster and cleaner for us to free that scalar [very little
code actually executed to free it] and create a new HV than to
copy&paste [SIN!] the code from newHV() to allow us to upgrade the
new SV from SVt_NULL. */
mroisarev = MUTABLE_HV(HeVAL(he));
if(SvTYPE(mroisarev) != SVt_PVHV) {
SvREFCNT_dec(mroisarev);
mroisarev = newHV();
HeVAL(he) = MUTABLE_SV(mroisarev);
}
/* This hash only ever contains PL_sv_yes. Storing it over itself is
almost as cheap as calling hv_exists, so on aggregate we expect to
save time by not making two calls to the common HV code for the
case where it doesn't exist. */
(void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
if(isarev) {
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
I32 revkeylen;
char* const revkey = hv_iterkey(iter, &revkeylen);
(void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
}
}
}
}
void *swiftperl_hv_iternext(void *vp) {
return (void *)hv_iternext((HV *)vp);
}
static void bitfields_option(pTHX_ BitfieldLayouter *layouter, SV *sv_val, SV **rval)
{
BitfieldLayouter bl_new = NULL;
BitfieldLayouter bl = *layouter;
if(sv_val)
{
if (SvROK(sv_val))
{
sv_val = SvRV(sv_val);
if (SvTYPE(sv_val) == SVt_PVHV)
{
HV *hv = (HV *) sv_val;
HE *entry;
SV **engine = hv_fetch(hv, "Engine", 6, 0);
int noptions;
const BLOption *options;
if (engine && *engine)
{
const char *name = SvPV_nolen(*engine);
bl = bl_new = bl_create(name);
if (bl_new == NULL)
Perl_croak(aTHX_ "Unknown bitfield layout engine '%s'", name);
}
(void) hv_iterinit(hv);
options = bl->m->options(bl, &noptions);
while ((entry = hv_iternext(hv)) != NULL)
{
SV *value;
I32 keylen;
int i;
const char *prop_string = hv_iterkey(entry, &keylen);
BLProperty prop;
BLPropValue prop_value;
const BLOption *opt = NULL;
enum BLError error;
if (strEQ(prop_string, "Engine"))
continue;
prop = bl_property(prop_string);
for (i = 0; i < noptions; i++)
if (options[i].prop == prop)
{
opt = &options[i];
break;
}
if (opt == NULL)
FAIL_CLEAN((aTHX_ "Invalid option '%s' for bitfield layout engine '%s'",
prop_string, bl->m->class_name(bl)));
value = hv_iterval(hv, entry);
prop_value.type = opt->type;
switch (opt->type)
{
case BLPVT_INT:
prop_value.v.v_int = SvIV(value);
if (opt->nval)
{
const BLPropValInt *pval = opt->pval;
for (i = 0; i < opt->nval; i++)
if (pval[i] == prop_value.v.v_int)
break;
}
break;
case BLPVT_STR:
prop_value.v.v_str = bl_propval(SvPV_nolen(value));
if (opt->nval)
{
const BLPropValStr *pval = opt->pval;
for (i = 0; i < opt->nval; i++)
if (pval[i] == prop_value.v.v_str)
break;
}
break;
default:
fatal("unknown opt->type (%d) in bitfields_option()", opt->type);
break;
}
if (opt->nval && i == opt->nval)
FAIL_CLEAN((aTHX_ "Invalid value '%s' for option '%s'",
SvPV_nolen(value), prop_string));
error = bl->m->set(bl, prop, &prop_value);
switch (error)
{
case BLE_NO_ERROR:
break;
case BLE_INVALID_PROPERTY:
FAIL_CLEAN((aTHX_ "Invalid value '%s' for option '%s'",
SvPV_nolen(value), prop_string));
break;
default:
fatal("unknown error code (%d) returned by set method", error);
break;
}
}
if (bl_new)
{
(*layouter)->m->destroy(*layouter);
*layouter = bl_new;
}
}
else
Perl_croak(aTHX_ "Bitfields wants a hash reference");
}
else
Perl_croak(aTHX_ "Bitfields wants a hash reference");
}
if (rval)
{
int noptions;
const BLOption *opt;
int i;
HV *hv = newHV();
SV *sv = newSVpv(bl->m->class_name(bl), 0);
if (hv_store(hv, "Engine", 6, sv, 0) == NULL)
SvREFCNT_dec(sv);
opt = bl->m->options(bl, &noptions);
for (i = 0; i < noptions; i++, opt++)
{
BLPropValue value;
enum BLError error;
const char *prop_string;
error = bl->m->get(bl, opt->prop, &value);
if (error != BLE_NO_ERROR)
fatal("unexpected error (%d) returned by get method", error);
assert(value.type == opt->type);
switch (opt->type)
{
case BLPVT_INT:
sv = newSViv(value.v.v_int);
break;
case BLPVT_STR:
{
const char *valstr = bl_propval_string(value.v.v_str);
assert(valstr != NULL);
sv = newSVpv(valstr, 0);
}
break;
default:
fatal("unknown opt->type (%d) in bitfields_option()", opt->type);
break;
}
prop_string = bl_property_string(opt->prop);
assert(prop_string != NULL);
if (hv_store(hv, prop_string, strlen(prop_string), sv, 0) == NULL)
SvREFCNT_dec(sv);
}
*rval = newRV_noinc((SV *) hv);
}
}
static void keyword_map(pTHX_ HashTable *current, SV *sv, SV **rval)
{
HashTable keyword_map = NULL;
if(sv)
{
if (SvROK(sv))
{
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVHV)
{
HV *hv = (HV *) sv;
HE *entry;
keyword_map = HT_new_ex(4, HT_AUTOGROW);
(void) hv_iterinit(hv);
while ((entry = hv_iternext(hv)) != NULL)
{
SV *value;
I32 keylen;
const char *key, *c;
const CKeywordToken *pTok;
c = key = hv_iterkey(entry, &keylen);
if (*c == '\0')
FAIL_CLEAN((aTHX_ "Cannot use empty string as a keyword"));
while (*c == '_' || isALPHA(*c))
c++;
if (*c != '\0')
FAIL_CLEAN((aTHX_ "Cannot use '%s' as a keyword", key));
value = hv_iterval(hv, entry);
if (!SvOK(value))
pTok = get_skip_token();
else
{
const char *map;
if (SvROK(value))
FAIL_CLEAN((aTHX_ "Cannot use a reference as a keyword"));
map = SvPV_nolen(value);
if ((pTok = get_c_keyword_token(map)) == NULL)
FAIL_CLEAN((aTHX_ "Cannot use '%s' as a keyword", map));
}
(void) HT_store(keyword_map, key, (int) keylen, 0,
(CKeywordToken *) pTok);
}
if (current != NULL)
{
HT_destroy(*current, NULL);
*current = keyword_map;
}
}
else
Perl_croak(aTHX_ "KeywordMap wants a hash reference");
}
else
Perl_croak(aTHX_ "KeywordMap wants a hash reference");
}
if (rval)
{
HashIterator hi;
HV *hv = newHV();
CKeywordToken *tok;
const char *key;
int keylen;
HI_init(&hi, *current);
while (HI_next(&hi, &key, &keylen, (void **) &tok))
{
SV *val;
val = tok->name == NULL ? newSV(0) : newSVpv(CONST_CHAR(tok->name), 0);
if (hv_store(hv, key, keylen, val, 0) == NULL)
SvREFCNT_dec(val);
}
*rval = newRV_noinc((SV *) hv);
}
}
HE *p5_hv_iternext(PerlInterpreter *my_perl, HV *hv) {
PERL_SET_CONTEXT(my_perl);
return hv_iternext(hv);
}