Пример #1
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);
}
Пример #2
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;
}
Пример #3
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);
            }
        }
    }
}
Пример #4
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));
}
Пример #5
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;
}
Пример #6
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;
}
Пример #7
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);
        }
    }
}
Пример #8
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);
}
Пример #9
0
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);
	}
}
Пример #10
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;
}
Пример #11
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);
	}
    }
}
Пример #12
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);
                }
            }
        }
    }
}
Пример #13
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;
}
Пример #14
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;
}
Пример #15
0
STATIC void
S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
                        HV *stash, HV *oldstash, SV *namesv)
{
    XPVHV* xhv;
    HE *entry;
    I32 riter = -1;
    I32 items = 0;
    const bool stash_had_name = stash && HvENAME(stash);
    bool fetched_isarev = FALSE;
    HV *seen = NULL;
    HV *isarev = NULL;
    SV **svp = NULL;

    PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;

    /* We use the seen_stashes hash to keep track of which packages have
       been encountered so far. This must be separate from the main list of
       stashes, as we need to distinguish between stashes being assigned
       and stashes being replaced/deleted. (A nested stash can be on both
       sides of an assignment. We cannot simply skip iterating through a
       stash on the right if we have seen it on the left, as it will not
       get its ename assigned to it.)

       To avoid allocating extra SVs, instead of a bitfield we can make
       bizarre use of immortals:

        &PL_sv_undef:  seen on the left  (oldstash)
        &PL_sv_no   :  seen on the right (stash)
        &PL_sv_yes  :  seen on both sides

     */

    if(oldstash) {
        /* Add to the big list. */
        struct mro_meta * meta;
        HE * const entry
            = (HE *)
              hv_common(
                  seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
                  HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
              );
        if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
            oldstash = NULL;
            goto check_stash;
        }
        HeVAL(entry)
            = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
        meta = HvMROMETA(oldstash);
        (void)
        hv_store(
            stashes, (const char *)&oldstash, sizeof(HV *),
            meta->isa
            ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
            : &PL_sv_yes,
            0
        );
        CLEAR_LINEAR(meta);

        /* Update the effective name. */
        if(HvENAME_get(oldstash)) {
            const HEK * const enamehek = HvENAME_HEK(oldstash);
            if(SvTYPE(namesv) == SVt_PVAV) {
                items = AvFILLp((AV *)namesv) + 1;
                svp = AvARRAY((AV *)namesv);
            }
            else {
                items = 1;
                svp = &namesv;
            }
            while (items--) {
                const U32 name_utf8 = SvUTF8(*svp);
                STRLEN len;
                const char *name = SvPVx_const(*svp, len);
                if(PL_stashcache) {
                    DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n",
                                     SVfARG(*svp)));
                    (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
                }
                ++svp;
                hv_ename_delete(oldstash, name, len, name_utf8);

                if (!fetched_isarev) {
                    /* If the name deletion caused a name change, then we
                     * are not going to call mro_isa_changed_in with this
                     * name (and not at all if it has become anonymous) so
                     * we need to delete old isarev entries here, both
                     * those in the superclasses and this class's own list
                     * of subclasses. We simply delete the latter from
                     * PL_isarev, since we still need it. hv_delete morti-
                     * fies it for us, so sv_2mortal is not necessary. */
                    if(HvENAME_HEK(oldstash) != enamehek) {
                        if(meta->isa && HvARRAY(meta->isa))
                            mro_clean_isarev(meta->isa, name, len, 0, 0,
                                             name_utf8 ? HVhek_UTF8 : 0);
                        isarev = (HV *)hv_delete(PL_isarev, name,
                                                 name_utf8 ? -(I32)len : (I32)len, 0);
                        fetched_isarev=TRUE;
                    }
                }
            }
        }
    }
check_stash:
    if(stash) {
        if(SvTYPE(namesv) == SVt_PVAV) {
            items = AvFILLp((AV *)namesv) + 1;
            svp = AvARRAY((AV *)namesv);
        }
        else {
            items = 1;
            svp = &namesv;
        }
        while (items--) {
            const U32 name_utf8 = SvUTF8(*svp);
            STRLEN len;
            const char *name = SvPVx_const(*svp++, len);
            hv_ename_add(stash, name, len, name_utf8);
        }

        /* Add it to the big list if it needs
        * mro_isa_changed_in called on it. That happens if it was
        * detached from the symbol table (so it had no HvENAME) before
        * being assigned to the spot named by the 'name' variable, because
        * its cached isa linearisation is now stale (the effective name
        * having changed), and subclasses will then use that cache when
        * mro_package_moved calls mro_isa_changed_in. (See
        * [perl #77358].)
        *
        * If it did have a name, then its previous name is still
        * used in isa caches, and there is no need for
        * mro_package_moved to call mro_isa_changed_in.
        */

        entry
            = (HE *)
              hv_common(
                  seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
                  HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
              );
        if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
            stash = NULL;
        else {
            HeVAL(entry)
                = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
            if(!stash_had_name)
            {
                struct mro_meta * const meta = HvMROMETA(stash);
                (void)
                hv_store(
                    stashes, (const char *)&stash, sizeof(HV *),
                    meta->isa
                    ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
                    : &PL_sv_yes,
                    0
                );
                CLEAR_LINEAR(meta);
            }
        }
    }

    if(!stash && !oldstash)
        /* Both stashes have been encountered already. */
        return;

    /* Add all the subclasses to the big list. */
    if(!fetched_isarev) {
        /* If oldstash is not null, then we can use its HvENAME to look up
           the isarev hash, since all its subclasses will be listed there.
           It will always have an HvENAME. It the HvENAME was removed
           above, then fetch_isarev will be true, and this code will not be
           reached.

           If oldstash is null, then this is an empty spot with no stash in
           it, so subclasses could be listed in isarev hashes belonging to
           any of the names, so we have to check all of them.
         */
        assert(!oldstash || HvENAME(oldstash));
        if (oldstash) {
            /* Extra variable to avoid a compiler warning */
            const HEK * const hvename = HvENAME_HEK(oldstash);
            fetched_isarev = TRUE;
            svp = hv_fetchhek(PL_isarev, hvename, 0);
            if (svp) isarev = MUTABLE_HV(*svp);
        }
        else if(SvTYPE(namesv) == SVt_PVAV) {
            items = AvFILLp((AV *)namesv) + 1;
            svp = AvARRAY((AV *)namesv);
        }
        else {
            items = 1;
            svp = &namesv;
        }
    }
    if(
        isarev || !fetched_isarev
    ) {
        while (fetched_isarev || items--) {
            HE *iter;

            if (!fetched_isarev) {
                HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
                if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
            }

            hv_iterinit(isarev);
            while((iter = hv_iternext(isarev))) {
                HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
                struct mro_meta * meta;

                if(!revstash) continue;
                meta = HvMROMETA(revstash);
                (void)
                hv_store(
                    stashes, (const char *)&revstash, sizeof(HV *),
                    meta->isa
                    ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
                    : &PL_sv_yes,
                    0
                );
                CLEAR_LINEAR(meta);
            }

            if (fetched_isarev) break;
        }
    }

    /* This is partly based on code in hv_iternext_flags. We are not call-
       ing that here, as we want to avoid resetting the hash iterator. */

    /* Skip the entire loop if the hash is empty.   */
    if(oldstash && HvUSEDKEYS(oldstash)) {
        xhv = (XPVHV*)SvANY(oldstash);
        seen = (HV *) sv_2mortal((SV *)newHV());

        /* Iterate through entries in the oldstash, adding them to the
           list, meanwhile doing the equivalent of $seen{$key} = 1.
         */

        while (++riter <= (I32)xhv->xhv_max) {
            entry = (HvARRAY(oldstash))[riter];

            /* Iterate through the entries in this list */
            for(; entry; entry = HeNEXT(entry)) {
                const char* key;
                I32 len;

                /* If this entry is not a glob, ignore it.
                   Try the next.  */
                if (!isGV(HeVAL(entry))) continue;

                key = hv_iterkey(entry, &len);
                if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
                        || (len == 1 && key[0] == ':')) {
                    HV * const oldsubstash = GvHV(HeVAL(entry));
                    SV ** const stashentry
                        = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
                    HV *substash = NULL;

                    /* Avoid main::main::main::... */
                    if(oldsubstash == oldstash) continue;

                    if(
                        (
                            stashentry && *stashentry && isGV(*stashentry)
                            && (substash = GvHV(*stashentry))
                        )
                        || (oldsubstash && HvENAME_get(oldsubstash))
                    )
                    {
                        /* Add :: and the key (minus the trailing ::)
                           to each name. */
                        SV *subname;
                        if(SvTYPE(namesv) == SVt_PVAV) {
                            SV *aname;
                            items = AvFILLp((AV *)namesv) + 1;
                            svp = AvARRAY((AV *)namesv);
                            subname = sv_2mortal((SV *)newAV());
                            while (items--) {
                                aname = newSVsv(*svp++);
                                if (len == 1)
                                    sv_catpvs(aname, ":");
                                else {
                                    sv_catpvs(aname, "::");
                                    sv_catpvn_flags(
                                        aname, key, len-2,
                                        HeUTF8(entry)
                                        ? SV_CATUTF8 : SV_CATBYTES
                                    );
                                }
                                av_push((AV *)subname, aname);
                            }
                        }
                        else {
                            subname = sv_2mortal(newSVsv(namesv));
                            if (len == 1) sv_catpvs(subname, ":");
                            else {
                                sv_catpvs(subname, "::");
                                sv_catpvn_flags(
                                    subname, key, len-2,
                                    HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
                                );
                            }
                        }
                        mro_gather_and_rename(
                            stashes, seen_stashes,
                            substash, oldsubstash, subname
                        );
                    }

                    (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
                }
            }
        }
    }

    /* Skip the entire loop if the hash is empty.   */
    if (stash && HvUSEDKEYS(stash)) {
        xhv = (XPVHV*)SvANY(stash);
        riter = -1;

        /* Iterate through the new stash, skipping $seen{$key} items,
           calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
        while (++riter <= (I32)xhv->xhv_max) {
            entry = (HvARRAY(stash))[riter];

            /* Iterate through the entries in this list */
            for(; entry; entry = HeNEXT(entry)) {
                const char* key;
                I32 len;

                /* If this entry is not a glob, ignore it.
                   Try the next.  */
                if (!isGV(HeVAL(entry))) continue;

                key = hv_iterkey(entry, &len);
                if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
                        || (len == 1 && key[0] == ':')) {
                    HV *substash;

                    /* If this entry was seen when we iterated through the
                       oldstash, skip it. */
                    if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;

                    /* We get here only if this stash has no corresponding
                       entry in the stash being replaced. */

                    substash = GvHV(HeVAL(entry));
                    if(substash) {
                        SV *subname;

                        /* Avoid checking main::main::main::... */
                        if(substash == stash) continue;

                        /* Add :: and the key (minus the trailing ::)
                           to each name. */
                        if(SvTYPE(namesv) == SVt_PVAV) {
                            SV *aname;
                            items = AvFILLp((AV *)namesv) + 1;
                            svp = AvARRAY((AV *)namesv);
                            subname = sv_2mortal((SV *)newAV());
                            while (items--) {
                                aname = newSVsv(*svp++);
                                if (len == 1)
                                    sv_catpvs(aname, ":");
                                else {
                                    sv_catpvs(aname, "::");
                                    sv_catpvn_flags(
                                        aname, key, len-2,
                                        HeUTF8(entry)
                                        ? SV_CATUTF8 : SV_CATBYTES
                                    );
                                }
                                av_push((AV *)subname, aname);
                            }
                        }
                        else {
                            subname = sv_2mortal(newSVsv(namesv));
                            if (len == 1) sv_catpvs(subname, ":");
                            else {
                                sv_catpvs(subname, "::");
                                sv_catpvn_flags(
                                    subname, key, len-2,
                                    HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
                                );
                            }
                        }
                        mro_gather_and_rename(
                            stashes, seen_stashes,
                            substash, NULL, subname
                        );
                    }
                }
            }
        }
    }
}
Пример #16
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);
            }
        }
    }
}
Пример #17
0
/* XXX TODO: Messages should round-trip properly between
   message2hashref and hashref2message. Currently we lose
   zephyr-specific properties stored in the ZNotice_t

   This has been somewhat addressed, but is still not lossless.
 */
owl_message * owl_perlconfig_hashref2message(SV *msg)
{
  owl_message * m;
  HE * ent;
  I32 count, len;
  const char *key,*val;
  HV * hash;
  struct tm tm;

  hash = (HV*)SvRV(msg);

  m = owl_malloc(sizeof(owl_message));
  owl_message_init(m);

  count = 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")) {
      m->timestr = owl_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", "");
  }
#ifdef HAVE_LIBZEPHYR
  if (owl_message_is_type_zephyr(m)) {
    ZNotice_t *n = &(m->notice);
    n->z_kind = ACKED;
    n->z_port = 0;
    n->z_auth = ZAUTH_NO;
    n->z_checked_auth = 0;
    n->z_class = zstr(owl_message_get_class(m));
    n->z_class_inst = zstr(owl_message_get_instance(m));
    n->z_opcode = zstr(owl_message_get_opcode(m));
    n->z_sender = zstr(owl_message_get_sender(m));
    n->z_recipient = zstr(owl_message_get_recipient(m));
    n->z_default_format = zstr("[zephyr created from perl]");
    n->z_multinotice = zstr("[zephyr created from perl]");
    n->z_num_other_fields = 0;
    n->z_message = owl_sprintf("%s%c%s", owl_message_get_zsig(m), '\0', owl_message_get_body(m));
    n->z_message_len = strlen(owl_message_get_zsig(m)) + strlen(owl_message_get_body(m)) + 1;
  }
#endif
  return m;
}
Пример #18
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);
  }
}
Пример #19
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);
  }
}