Exemple #1
0
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;
}
Exemple #2
0
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));
}
Exemple #3
0
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;
            }
        }
    }
}
Exemple #4
0
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);
}
Exemple #5
0
/* 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);
            }
        }
    }
}
Exemple #6
0
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;
}
Exemple #7
0
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;
}
Exemple #8
0
/*
=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;
}
Exemple #9
0
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);
	}
}
Exemple #10
0
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;
}
Exemple #11
0
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);
}
Exemple #12
0
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;
}
Exemple #13
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;
}
Exemple #14
0
/*
=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);
        }
    }
}
Exemple #15
0
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);
}
Exemple #16
0
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);
	}
}
Exemple #18
0
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;
}
Exemple #19
0
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;
}
Exemple #20
0
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);
}
Exemple #21
0
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);
	}
    }
}
Exemple #22
0
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);
                }
            }
        }
    }
}
Exemple #23
0
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;
}
Exemple #24
0
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;
}
Exemple #25
0
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));
	}
}
Exemple #26
0
/*
=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);
            }
        }
    }
}
Exemple #27
0
void *swiftperl_hv_iternext(void *vp) {
    return (void *)hv_iternext((HV *)vp);
}
Exemple #28
0
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);
  }
}
Exemple #29
0
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);
  }
}
Exemple #30
0
HE *p5_hv_iternext(PerlInterpreter *my_perl, HV *hv) {
    PERL_SET_CONTEXT(my_perl);
    return hv_iternext(hv);
}