예제 #1
0
static SV *modperl_hv_request_find(pTHX_ SV *in, char *classname, CV *cv)
{
    static char *r_keys[] = { "r", "_r", NULL };
    HV *hv = (HV *)SvRV(in);
    SV *sv = (SV *)NULL;
    int i;

    for (i=0; r_keys[i]; i++) {
        int klen = i + 1; /* assumes r_keys[] will never change */
        SV **svp;

        if ((svp = hv_fetch(hv, r_keys[i], klen, FALSE)) && (sv = *svp)) {
            if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV)) {
                /* dig deeper */
                return modperl_hv_request_find(aTHX_ sv, classname, cv);
            }
            break;
        }
    }

    if (!sv) {
        Perl_croak(aTHX_
                   "method `%s' invoked by a `%s' object with no `r' key!",
                   cv ? GvNAME(CvGV(cv)) : "unknown",
                   (SvRV(in) && SvSTASH(SvRV(in)))
                       ? HvNAME(SvSTASH(SvRV(in)))
                       : "unknown");
    }

    return SvROK(sv) ? SvRV(sv) : sv;
}
예제 #2
0
/* Converts perl values to equivalent JavaScript values */
JSBool PJS_ConvertPerlToJSType(JSContext *cx, JSObject *seen, JSObject *obj, SV *ref, jsval *rval) {
    int destroy_seen = 0; /* TODO - do we _need_ to clean up after us? */
    
    if (sv_isobject(ref) && strcmp(HvNAME(SvSTASH(SvRV(ref))), PJS_BOXED_PACKAGE) == 0) {
        /* XXX: test this more */
        ref = *av_fetch((AV *) SvRV(SvRV(ref)), 0, 0);
    }

    if (sv_isobject(ref)) { /* blessed */
        PJS_Context *pcx;
        PJS_Class *pjsc;
        JSObject *newobj;
        HV *stash = SvSTASH(SvRV(ref));
        char *name = HvNAME(stash);

        if (strcmp(name, PJS_FUNCTION_PACKAGE) == 0) {
            JSFunction *func = INT2PTR(JSFunction *, SvIV((SV *) SvRV(PJS_call_perl_method("content", ref, NULL))));
            JSObject *obj = JS_GetFunctionObject(func);
            *rval = OBJECT_TO_JSVAL(obj);
            return JS_TRUE;
        }
        
	if (strcmp(name, PJS_GENERATOR_PACKAGE) == 0) {
	  JSObject *obj = INT2PTR(JSObject *, SvIV((SV *) SvRV(PJS_call_perl_method("content", ref, NULL))));
	  *rval = OBJECT_TO_JSVAL(obj);
	  return JS_TRUE;
	}
예제 #3
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;
}
예제 #4
0
bool
Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
{
    char *type;
    HV *stash;

    stash = Nullhv;
    type = Nullch;

    if (SvGMAGICAL(sv))
        mg_get(sv) ;

    if (SvROK(sv)) {
        sv = SvRV(sv);
        type = sv_reftype(sv,0);
        if (SvOBJECT(sv))
            stash = SvSTASH(sv);
    }
    else {
        stash = gv_stashsv(sv, FALSE);
    }

    return (type && strEQ(type,name)) ||
            (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes)
        ? TRUE
        : FALSE ;
}
예제 #5
0
파일: xsutils.c 프로젝트: bulk88/cperl
/* helper to return the stash for a svref, (Sv|Cv|Gv|GvE)STASH */
static HV*
S_guess_stash(pTHX_ SV* sv)
{
    if (SvOBJECT(sv)) {
	return SvSTASH(sv);
    }
    else {
	HV *stash = NULL;
	switch (SvTYPE(sv)) {
	case SVt_PVCV:
	    if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
		return GvSTASH(CvGV(sv));
	    else if (/* !CvANON(sv) && */ CvSTASH(sv))
		return CvSTASH(sv);
	    break;
	case SVt_PVGV:
	    if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
		return GvESTASH(MUTABLE_GV(sv));
	    break;
	default:
	    break;
	}
        return stash;
    }
}
예제 #6
0
GV *p5_look_up_method(PerlInterpreter *my_perl, SV *obj, char *name) {
    PERL_SET_CONTEXT(my_perl);
    {
        HV * const pkg = SvSTASH((SV*)SvRV(obj));
        GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
        if (gv && isGV(gv))
            return gv;
        return NULL;
    }
}
예제 #7
0
파일: Point.cpp 프로젝트: dually8/Slic3r
void
Point::from_SV_check(SV* point_sv)
{
    if (sv_isobject(point_sv) && (SvTYPE(SvRV(point_sv)) == SVt_PVMG)) {
        if (!sv_isa(point_sv, perl_class_name(this)) && !sv_isa(point_sv, perl_class_name_ref(this)))
            CONFESS("Not a valid %s object (got %s)", perl_class_name(this), HvNAME(SvSTASH(SvRV(point_sv))));
        *this = *(Point*)SvIV((SV*)SvRV( point_sv ));
    } else {
        this->from_SV(point_sv);
    }
}
예제 #8
0
SV *p5_call_parent_method(PerlInterpreter *my_perl, char *package, SV *obj, I32 context, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        int i;
        SV * retval = NULL;
        int flags = (context ? G_SCALAR : G_ARRAY) | G_EVAL;

        ENTER;
        SAVETMPS;

        HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(obj));
        GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
        if (gv && isGV(gv)) {
            PUSHMARK(SP);

            if (len > 1) {
                XPUSHs(package != NULL ? sv_2mortal(args[0]) : args[0]);
                for (i = 1; i < len; i++) {
                    if (args[i] != NULL) /* skip Nil which gets turned into NULL */
                        XPUSHs(sv_2mortal(args[i]));
                }
            }
            else if (len > 0)
                if (args != NULL) /* skip Nil which gets turned into NULL */
                    XPUSHs(package != NULL ? sv_2mortal((SV*)args) : (SV*)args);

            PUTBACK;

            SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));

            *count = call_sv(rv, flags);
            SPAGAIN;

            handle_p5_error(err);
            retval = pop_return_values(my_perl, sp, *count, type);
            SPAGAIN;
        }
        else {
            ERRSV = newSVpvf("Could not find method \"%s\" of \"%s\" object", name, HvNAME(pkg));
        }

        PUTBACK;
        FREETMPS;
        LEAVE;

        return retval;
    }
}
예제 #9
0
AV *p5_call_method(PerlInterpreter *my_perl, char *package, SV *obj, char *name, int len, SV *args[]) {
    dSP;
    int i;
    AV * const retval = newAV();
    int flags = G_ARRAY | G_EVAL;

    PERL_SET_CONTEXT(my_perl);

    ENTER;
    SAVETMPS;

    HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(obj));
    GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
    if (gv && isGV(gv)) {
        I32 count;
        PUSHMARK(SP);

        for (i = 0; i < len; i++) {
            XPUSHs(sv_2mortal(args[i]));
        }

        PUTBACK;

        SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));

        count = call_sv(rv, flags);
        SPAGAIN;

        if (count > 0)
            av_extend(retval, count - 1);
        for (i = count - 1; i >= 0; i--) {
            SV * const next = POPs;
            SvREFCNT_inc(next);

            if (av_store(retval, i, next) == NULL)
                SvREFCNT_dec(next); /* see perlguts Working with AVs */
        }
    }
    else {
        ERRSV = newSVpvf("Could not find method \"%s\" of \"%s\" object", name, HvNAME(pkg));
    }

    PUTBACK;
    FREETMPS;
    LEAVE;

    return retval;
}
예제 #10
0
MP_INLINE int modperl_io_handle_tied(pTHX_ GV *handle, char *classname)
{
    MAGIC *mg;
    SV *sv = TIEHANDLE_SV(handle);

    if (SvMAGICAL(sv) && (mg = mg_find(sv, PERL_MAGIC_tiedscalar))) {
        char *package = HvNAME(SvSTASH((SV*)SvRV(mg->mg_obj)));

        if (!strEQ(package, classname)) {
            MP_TRACE_r(MP_FUNC, "%s tied to %s", GvNAME(handle), package);
            return TRUE;
        }
    }

    return FALSE;
}
예제 #11
0
/*
 * Return the integer catalog value from the passed Catalog or IV.
 * Calls croak() if the SV is not of the correct type.
 */
ea_catalog_t
catalog_value(SV *catalog)
{
	SV	*sv;

	/* If a reference, dereference and check it is a Catalog. */
	if (SvROK(catalog)) {
		sv = SvRV(catalog);
		if (SvIOK(sv) &&
		    SvSTASH(sv) == Sun_Solaris_Exacct_Catalog_stash) {
			return (SvIV(sv));
		} else {
			croak("Parameter is not a Catalog or integer");
		}

	/* For a plain IV, just return the value. */
	} else if (SvIOK(catalog)) {
		return (SvIV(catalog));

	/* Anything else is an error */
	} else {
		croak("Parameter is not a Catalog or integer");
	}
}
예제 #12
0
파일: PJS_Reflection.c 프로젝트: gitpan/JSP
/* Wrap a JS value to export into perl
 * Returns a new SV, REFCNT_dec is caller's responsability
 */
JSBool
PJS_ReflectJS2Perl(
    pTHX_
    JSContext *cx,
    jsval value,
    SV** sv,
    int full
) {
    if(JSVAL_IS_PRIMITIVE(value)) {
	*sv = PrimJSVALToSV(aTHX_ cx, value);
	if(*sv) return JS_TRUE;
    }
    else if(JSVAL_IS_OBJECT(value)) {
	PJS_Context *pcx = PJS_GET_CONTEXT(cx);
	JSObject *object = JSVAL_TO_OBJECT(value);
	JSClass *clasp = PJS_GET_CLASS(cx, object);
	const char *classname = clasp->name;
	JSObject *passport;
	SV *wrapper;
	SV *box;
	char hkey[32];
	jsval temp = JSVAL_VOID;

	snprintf(hkey, 32, "%p", (void *)object);
	PJS_DEBUG2("Wrapping a %s(%s)\n", classname, hkey);

	if(PJS_getFlag(pcx, "ConvertRegExp") && strEQ(classname, "RegExp")) {
	    jsval src;
	    char *str;

	    if(JS_CallFunctionName(cx, object, "toSource", 0, NULL, &src) &&
	       (str = JS_GetStringBytes(JS_ValueToString(cx, src))) )
	    {
		dSP;
		SV *tmp = newSVpvf("qr%s", str);
		eval_sv(tmp, G_SCALAR);
		sv_free(tmp); // Don't leak
		SPAGAIN;
		tmp = POPs;
		PUTBACK;
		if(!SvTRUE(ERRSV)) {
		    *sv = SvREFCNT_inc_simple_NN(tmp);
		    return JS_TRUE;
		}
	    }
	    return JS_FALSE;
	}

	if(IS_PERL_CLASS(clasp)) {
	    /* IS_PERL_CLASS means actual perl object is there */
	    SV *priv = (SV *)JS_GetPrivate(cx, object);
	    if(priv && SvOK(priv) && SvROK(priv)) {
		*sv = SvREFCNT_inc_simple_NN(priv);
		return JS_TRUE;
	    }
	    croak("A private %s?!\n", classname);
	    return JS_FALSE;
	}

	/* Common JSObject case */

	/* Check registered perl visitors */
	JS_LookupProperty(cx, pcx->pvisitors, hkey, &temp);

	if(temp != JSVAL_VOID) {
	    /* Already registered, so exits a reference in perl space
	     * _must_ hold a PASSPORT */
	    assert(JSVAL_TO_OBJECT(temp) == object);
	    box = PJS_GetPassport(aTHX_ cx, object);
	    SvREFCNT_inc_void_NN(box); /* In perl should be one more */
	    PJS_DEBUG1("Cached!: %s\n", hkey);
	} else {
	    /* Check if with a PASSPORT */
	    JS_LookupPropertyWithFlags(cx, object, PJS_PASSPORT_PROP, 0, &temp);
	    if(JSVAL_IS_OBJECT(temp) && (passport = JSVAL_TO_OBJECT(temp)) &&
	       PJS_GET_CLASS(cx, passport) == &passport_class &&
	       JS_GetReservedSlot(cx, passport, 0, &temp) &&
	       object == (JSObject *)JSVAL_TO_PRIVATE(temp)
	    ) { /* Yes, reentering perl */
		box = (SV *)JS_GetPrivate(cx, passport);
		/* Here we don't increment refcount, the ownership in passport is 
		 * transferred to perl land.
		 */
		PJS_DEBUG1("Reenter: %s\n", hkey);
	    }
	    else { /* No, first time, must wrap the object */
		SV *boxref;
		const char *package;
		SV *robj = newSV(0);
		SV *rjsv = newSV(0);

		if (JS_ObjectIsFunction(cx, object))
		    package = PJS_FUNCTION_PACKAGE;
		else if(JS_IsArrayObject(cx, object))
		    package = PJS_ARRAY_PACKAGE;
		else if(strEQ(classname, PJS_PACKAGE_CLASS_NAME))
		    package = PJS_STASH_PACKAGE;
#if JS_HAS_XML_SUPPORT
		else if(strEQ(classname, "XML"))
		    package = PJS_XMLOBJ_PACKAGE;
#endif
		else if(strEQ(classname, "Error"))
		    package = PJS_ERROR_PACKAGE;
		else {
		    SV **sv = hv_fetch(get_hv(NAMESPACE"ClassMap", 1), classname, 
			               strlen(classname), 0);
		    if(sv) package = SvPV_nolen(*sv);
		    else package = PJS_OBJECT_PACKAGE;
		}

		sv_setref_pv(robj, PJS_RAW_OBJECT, (void*)object);
		sv_setref_iv(rjsv, PJS_RAW_JSVAL, (IV)value);
		boxref = PJS_CallPerlMethod(aTHX_ cx,
		    "__new",
		    sv_2mortal(newSVpv(package, 0)),	 // package
		    sv_2mortal(robj),			 // content
		    sv_2mortal(rjsv),			 // jsval
		    NULL
		);

		if(!boxref) return JS_FALSE;
		if(!SvOK(boxref) || !sv_derived_from(boxref, PJS_BOXED_PACKAGE))
		    croak("PJS_Assert: Contructor must return a "NAMESPACE"Boxed");

		/* Create a new PASSPORT */
		passport = JS_NewObject(cx, &passport_class, NULL, object);

		if(!passport ||
		   !JS_DefineProperty(cx, object, PJS_PASSPORT_PROP,
		                      OBJECT_TO_JSVAL(passport),
		                      NULL, NULL, JSPROP_READONLY | JSPROP_PERMANENT))
		    return JS_FALSE;
		box = SvRV(boxref);
		/* boxref is mortal, so we need to increment its rc, at end of
		 * scope, PASSPORT owns created box */
		JS_SetPrivate(cx, passport, (void *)SvREFCNT_inc_simple_NN(box));
		JS_SetReservedSlot(cx, passport, 0, PRIVATE_TO_JSVAL(object));
		PJS_DEBUG2("New boxed: %s brc: %d\n", hkey, SvREFCNT(box));
	    }

	    /* Root object adding it to pvisitors list, will be unrooted by
	     * jsc_free_root at Boxed DESTROY time
	     */
	    JS_DefineProperty(cx, pcx->pvisitors, hkey, value, NULL, NULL, 0);
	}
	/* Here the RC of box in PASSPORT reflects wrapper's ownership */

	if(full && PJS_getFlag(pcx, "AutoTie") &&
	   (strEQ(classname, "Object") || strEQ(classname, "Array"))
	) {
	    /* Return tied */
	    AV *avbox = (AV *)SvRV(box);
	    SV **last;
	    SV *tied;
	    SV *tier;
	    if(strEQ(classname, "Array")) {
		last = av_fetch(avbox, 6, 1);
		if(last && SvOK(*last) && SvROK(*last)) { // Cached
		    *sv = newSVsv(*last);
		    sv_free(box); /* Hard copy 'sv' owns the reference */
		    return JS_TRUE;
		}
		tied = (SV *)newAV();
	    } else { // Object
		last = av_fetch(avbox, 5, 1);
		if(last && SvOK(*last) && SvROK(*last)) { // Cached
		    *sv = newSVsv(*last);
		    sv_free(box); /* Hard copy 'sv' owns the reference */
		    return JS_TRUE;
		}
		tied = (SV *)newHV();
	    }
	    /* hv_magic below own a reference to box, we use an explicit path, 
	     * to make clear that to perl land only one reference is given
	     */
	    tier = newRV_inc(box);
	    hv_magic((HV *)tied, (GV *)tier, PERL_MAGIC_tied);
	    sv_free(tier);
	    wrapper = newRV_noinc(tied); /* Don't leak the hidden tied variable */
	    /* Save in cache a weaken copy, the cache itself dosn't hold a reference */
	    sv_setsv(*last, wrapper);
	    sv_rvweaken(*last);
	    PJS_DEBUG1("Return tied for %s\n", SvPV_nolen(tier));
	}
	else {    
	    wrapper = newRV_noinc(box); /* Transfer ownership to wrapper */
#if PERL_VERSION < 9
	    sv_bless(wrapper, SvSTASH(box)); 
#endif
	}
	*sv = wrapper;
	return JS_TRUE;
    }
    return JS_FALSE;
}
예제 #13
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));
	}
}
예제 #14
0
/****************************
 * SV* Py2Pl(PyObject *obj)
 *
 * Converts arbitrary Python data structures to Perl data structures
 * Note on references: does not Py_DECREF(obj).
 *
 * Modifications by Eric Wilhelm 2004-07-11 marked as elw
 *
 ****************************/
SV *Py2Pl(PyObject * const obj) {
    /* elw: see what python says things are */
#if PY_MAJOR_VERSION >= 3
    int const is_string = PyBytes_Check(obj) || PyUnicode_Check(obj);
#else
    int const is_string = PyString_Check(obj) || PyUnicode_Check(obj);
#endif
#ifdef I_PY_DEBUG
    PyObject *this_type = PyObject_Type(obj); /* new reference */
    PyObject *t_string = PyObject_Str(this_type); /* new reference */
#if PY_MAJOR_VERSION >= 3
    PyObject *type_str_bytes = PyUnicode_AsUTF8String(t_string); /* new reference */
    char *type_str = PyBytes_AsString(type_str_bytes);
#else
    char *type_str = PyString_AsString(t_string);
#endif
    Printf(("type is %s\n", type_str));
    printf("Py2Pl object:\n\t");
    PyObject_Print(obj, stdout, Py_PRINT_RAW);
    printf("\ntype:\n\t");
    PyObject_Print(this_type, stdout, Py_PRINT_RAW);
    printf("\n");
    Printf(("String check:   %i\n", is_string));
    Printf(("Number check:   %i\n", PyNumber_Check(obj)));
    Printf(("Int check:      %i\n", PyInt_Check(obj)));
    Printf(("Long check:     %i\n", PyLong_Check(obj)));
    Printf(("Float check:    %i\n", PyFloat_Check(obj)));
    Printf(("Type check:     %i\n", PyType_Check(obj)));
#if PY_MAJOR_VERSION < 3
    Printf(("Class check:    %i\n", PyClass_Check(obj)));
    Printf(("Instance check: %i\n", PyInstance_Check(obj)));
#endif
    Printf(("Dict check:     %i\n", PyDict_Check(obj)));
    Printf(("Mapping check:  %i\n", PyMapping_Check(obj)));
    Printf(("Sequence check: %i\n", PySequence_Check(obj)));
    Printf(("Iter check:     %i\n", PyIter_Check(obj)));
    Printf(("Function check: %i\n", PyFunction_Check(obj)));
    Printf(("Module check:   %i\n", PyModule_Check(obj)));
    Printf(("Method check:   %i\n", PyMethod_Check(obj)));
#if PY_MAJOR_VERSION < 3
    if ((obj->ob_type->tp_flags & Py_TPFLAGS_HEAPTYPE))
        printf("heaptype true\n");
    if ((obj->ob_type->tp_flags & Py_TPFLAGS_HAVE_CLASS))
        printf("has class\n");
#else
    Py_DECREF(type_str_bytes);
#endif
    Py_DECREF(t_string);
    Py_DECREF(this_type);
#endif
    /* elw: this needs to be early */
    /* None (like undef) */
    if (!obj || obj == Py_None) {
        Printf(("Py2Pl: Py_None\n"));
        return &PL_sv_undef;
    }
    else

#ifdef EXPOSE_PERL
    /* unwrap Perl objects */
    if (PerlObjObject_Check(obj)) {
        Printf(("Py2Pl: Obj_object\n"));
        return ((PerlObj_object *) obj)->obj;
    }

    /* unwrap Perl code refs */
    else if (PerlSubObject_Check(obj)) {
        Printf(("Py2Pl: Sub_object\n"));
        SV * ref = ((PerlSub_object *) obj)->ref;
        if (! ref) { /* probably an inherited method */
            if (! ((PerlSub_object *) obj)->obj)
                croak("Error: could not find a code reference or object method for PerlSub");
            SV * const sub_obj = (SV*)SvRV(((PerlSub_object *) obj)->obj);
            HV * const pkg = SvSTASH(sub_obj);
#if PY_MAJOR_VERSION >= 3
            char * const sub = PyBytes_AsString(((PerlSub_object *) obj)->sub);
#else
            PyObject *obj_sub_str = PyObject_Str(((PerlSub_object *) obj)->sub); /* new ref. */
            char * const sub = PyString_AsString(obj_sub_str);
#endif
            GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, sub, TRUE);
            if (gv && isGV(gv)) {
                ref = (SV *)GvCV(gv);
            }
#if PY_MAJOR_VERSION < 3
            Py_DECREF(obj_sub_str);
#endif
        }
        return newRV_inc((SV *) ref);
    }

    else
#endif

    /* wrap an instance of a Python class */
    /* elw: here we need to make these look like instances: */
    if ((obj->ob_type->tp_flags & Py_TPFLAGS_HEAPTYPE)
#if PY_MAJOR_VERSION < 3
        || PyInstance_Check(obj)
#endif
    ) {

        /* This is a Python class instance -- bless it into an
         * Inline::Python::Object. If we're being called from an
         * Inline::Python class, it will be re-blessed into whatever
         * class that is.
         */
        SV * const inst_ptr = newSViv(0);
        SV * const inst = newSVrv(inst_ptr, "Inline::Python::Object");;
        _inline_magic priv;

        /* set up magic */
        priv.key = INLINE_MAGIC_KEY;
        sv_magic(inst, inst, PERL_MAGIC_ext, (char *) &priv, sizeof(priv));
        MAGIC * const mg = mg_find(inst, PERL_MAGIC_ext);
        mg->mg_virtual = &inline_mg_vtbl;

        sv_setiv(inst, (IV) obj);
        /*SvREADONLY_on(inst); */ /* to uncomment this means I can't
            re-bless it */
        Py_INCREF(obj);
        Printf(("Py2Pl: Instance. Obj: %p, inst_ptr: %p\n", obj, inst_ptr));

        sv_2mortal(inst_ptr);
        return inst_ptr;
    }

    /* a tuple or a list */
    else if (PySequence_Check(obj) && !is_string) {
        AV * const retval = newAV();
        int i;
        int const sz = PySequence_Length(obj);

        Printf(("sequence (%i)\n", sz));

        for (i = 0; i < sz; i++) {
            PyObject * const tmp = PySequence_GetItem(obj, i);    /* new reference */
            SV * const next = Py2Pl(tmp);
            av_push(retval, next);
            if (sv_isobject(next)) // needed because objects get mortalized in Py2Pl
                SvREFCNT_inc(next);
            Py_DECREF(tmp);
        }

        if (PyTuple_Check(obj)) {
            _inline_magic priv;
            priv.key = TUPLE_MAGIC_KEY;

            sv_magic((SV * const)retval, (SV * const)NULL, PERL_MAGIC_ext, (char *) &priv, sizeof(priv));
        }

        return newRV_noinc((SV *) retval);
    }

    /* a dictionary or fake Mapping object */
    /* elw: PyMapping_Check() now returns true for strings */
    else if (! is_string && PyMapping_Check(obj)) {
        HV * const retval = newHV();
        int i;
        int const sz = PyMapping_Length(obj);
        PyObject * const keys = PyMapping_Keys(obj);   /* new reference */
        PyObject * const vals = PyMapping_Values(obj); /* new reference */

        Printf(("Py2Pl: dict/map\n"));
        Printf(("mapping (%i)\n", sz));

        for (i = 0; i < sz; i++) {
            PyObject * const key = PySequence_GetItem(keys, i), /* new reference */
                                 * const val = PySequence_GetItem(vals, i); /* new reference */
            SV       * const sv_val = Py2Pl(val);
            char     *       key_val;

            if (PyUnicode_Check(key)) {
                PyObject * const utf8_string = PyUnicode_AsUTF8String(key); /* new reference */
#if PY_MAJOR_VERSION >= 3
                key_val = PyBytes_AsString(utf8_string);
                SV * const utf8_key = newSVpv(key_val, PyBytes_Size(utf8_string));
#else
                key_val = PyString_AsString(utf8_string);
                SV * const utf8_key = newSVpv(key_val, PyString_Size(utf8_string));
#endif
                SvUTF8_on(utf8_key);

                hv_store_ent(retval, utf8_key, sv_val, 0);
                Py_DECREF(utf8_string);
            }
            else {
                PyObject * s = NULL;
#if PY_MAJOR_VERSION >= 3
                PyObject * s_bytes = NULL;
                if (PyBytes_Check(key)) {
                    key_val = PyBytes_AsString(key);
#else
                if (PyString_Check(key)) {
                    key_val = PyString_AsString(key);
#endif
                }
                else {
                    /* Warning -- encountered a non-string key value while converting a
                     * Python dictionary into a Perl hash. Perl can only use strings as
                     * key values. Using Python's string representation of the key as
                     * Perl's key value.
                     */
                    s = PyObject_Str(key); /* new reference */
#if PY_MAJOR_VERSION >= 3
                    s_bytes = PyUnicode_AsUTF8String(s); /* new reference */
                    key_val = PyBytes_AsString(s_bytes);
#else
                    key_val = PyString_AsString(s);
#endif
                    Py_DECREF(s);
                    if (PL_dowarn)
                        warn("Stringifying non-string hash key value: '%s'",
                             key_val);
                }

                if (!key_val) {
                    croak("Invalid key on key %i of mapping\n", i);
                }

                hv_store(retval, key_val, strlen(key_val), sv_val, 0);
#if PY_MAJOR_VERSION >= 3
                Py_XDECREF(s_bytes);
#endif
                Py_XDECREF(s);
            }
            if (sv_isobject(sv_val)) // needed because objects get mortalized in Py2Pl
                SvREFCNT_inc(sv_val);
            Py_DECREF(key);
            Py_DECREF(val);
        }
        Py_DECREF(keys);
        Py_DECREF(vals);
        return newRV_noinc((SV *) retval);
    }

    /* a boolean */
    else if (PyBool_Check(obj)) {
예제 #15
0
char *p5_stash_name(PerlInterpreter *my_perl, SV *obj) {
    HV * const pkg = SvSTASH((SV*)SvRV(obj));
    return HvNAME(pkg);
}
예제 #16
0
파일: call.C 프로젝트: Gustra/libperl--
Stash::Stash(const reference::Reference_base& value) : interp(value.interp), stash(SvSTASH(SvRV(value.get_SV(false)))) {
}
예제 #17
0
static int perl_init_aaaa()
{
	dTARG;
	dSP;
	listop_list[0].op_ppaddr = PL_ppaddr[OP_LEAVE];
	op_list[0].op_ppaddr = PL_ppaddr[OP_ENTER];
	cop_list[0].op_ppaddr = PL_ppaddr[OP_NEXTSTATE];
	cop_list[0].cop_warnings = pWARN_STD;
	CopFILE_set(&cop_list[0], "hello.p");
	CopSTASHPV_set(&cop_list[0], "main");
	listop_list[1].op_ppaddr = PL_ppaddr[OP_PRINT];
	op_list[1].op_ppaddr = PL_ppaddr[OP_PUSHMARK];
	svop_list[0].op_ppaddr = PL_ppaddr[OP_CONST];
	gv_list[0] = gv_fetchpv("main::/", TRUE, SVt_PV);
	SvFLAGS(gv_list[0]) = 0x600d;
	GvFLAGS(gv_list[0]) = 0xa;
	GvLINE(gv_list[0]) = 0;
	SvPVX(gv_list[0]) = emptystring;

	SvREFCNT(gv_list[0]) += 4;
	GvREFCNT(gv_list[0]) += 1;
	gv_list[1] = gv_fetchpv("main::stderr", TRUE, SVt_PV);
	SvFLAGS(gv_list[1]) = 0x600d;
	GvFLAGS(gv_list[1]) = 0x2;
	GvLINE(gv_list[1]) = 0;
	SvPVX(gv_list[1]) = emptystring;

	SvREFCNT(gv_list[1]) += 2;
	GvREFCNT(gv_list[1]) += 1;
	GvSV(gv_list[1]) = &sv_list[0];
	GvFILE(gv_list[1]) = "hello.p";
	IoIFP((IO*)&sv_list[1])=PerlIO_stderr();
	IoOFP((IO*)&sv_list[1])=PerlIO_stderr();
	hv0 = gv_stashpv("FileHandle", TRUE);
	SvSTASH((IO*)&sv_list[1]) = hv0;
	GvIOp(gv_list[1]) = (IO*)&sv_list[1];
	gv_list[2] = gv_fetchpv("main::SIG", TRUE, SVt_PV);
	SvFLAGS(gv_list[2]) = 0x600d;
	GvFLAGS(gv_list[2]) = 0xa;
	GvLINE(gv_list[2]) = 62;
	SvPVX(gv_list[2]) = emptystring;

	SvREFCNT(gv_list[2]) += 12;
	GvREFCNT(gv_list[2]) += 1;
	gv_list[3] = gv_fetchpv("main::,", TRUE, SVt_PV);
	SvFLAGS(gv_list[3]) = 0x600d;
	GvFLAGS(gv_list[3]) = 0xa;
	GvLINE(gv_list[3]) = 474;
	SvPVX(gv_list[3]) = emptystring;

	SvREFCNT(gv_list[3]) += 6;
	GvREFCNT(gv_list[3]) += 1;
	gv_list[4] = gv_fetchpv("utf8::unicode_to_native", TRUE, SVt_PV);
	SvFLAGS(gv_list[4]) = 0x600d;
	GvFLAGS(gv_list[4]) = 0xa;
	GvLINE(gv_list[4]) = 0;
	SvPVX(gv_list[4]) = emptystring;

	SvREFCNT(gv_list[4]) += 3;
	GvREFCNT(gv_list[4]) += 1;
	GvSV(gv_list[4]) = &sv_list[2];
	GvCV(gv_list[4]) = (CV*)((perl_get_cv("utf8::unicode_to_native",TRUE)));
	GvFILE(gv_list[4]) = "hello.p";
	gv_list[5] = gv_fetchpv("utf8::encode", TRUE, SVt_PV);
	SvFLAGS(gv_list[5]) = 0x600d;
	GvFLAGS(gv_list[5]) = 0x2;
	GvLINE(gv_list[5]) = 0;
	SvPVX(gv_list[5]) = emptystring;

	SvREFCNT(gv_list[5]) += 2;
	GvREFCNT(gv_list[5]) += 1;
	GvSV(gv_list[5]) = &sv_list[3];
	GvCV(gv_list[5]) = (CV*)((perl_get_cv("utf8::encode",TRUE)));
	GvFILE(gv_list[5]) = "hello.p";
	gv_list[6] = gv_fetchpv("utf8::valid", TRUE, SVt_PV);
	SvFLAGS(gv_list[6]) = 0x600d;
	GvFLAGS(gv_list[6]) = 0x2;
	GvLINE(gv_list[6]) = 0;
	SvPVX(gv_list[6]) = emptystring;

	SvREFCNT(gv_list[6]) += 2;
	GvREFCNT(gv_list[6]) += 1;
	GvSV(gv_list[6]) = &sv_list[4];
	GvCV(gv_list[6]) = (CV*)((perl_get_cv("utf8::valid",TRUE)));
	GvFILE(gv_list[6]) = "hello.p";
	gv_list[7] = gv_fetchpv("utf8::native_to_unicode", TRUE, SVt_PV);
	SvFLAGS(gv_list[7]) = 0x600d;
	GvFLAGS(gv_list[7]) = 0x2;
	GvLINE(gv_list[7]) = 0;
	SvPVX(gv_list[7]) = emptystring;

	SvREFCNT(gv_list[7]) += 2;
	GvREFCNT(gv_list[7]) += 1;
	GvSV(gv_list[7]) = &sv_list[5];
	GvCV(gv_list[7]) = (CV*)((perl_get_cv("utf8::native_to_unicode",TRUE)));
	GvFILE(gv_list[7]) = "hello.p";
	gv_list[8] = gv_fetchpv("utf8::decode", TRUE, SVt_PV);
	SvFLAGS(gv_list[8]) = 0x600d;
	GvFLAGS(gv_list[8]) = 0x2;
	GvLINE(gv_list[8]) = 0;
	SvPVX(gv_list[8]) = emptystring;

	SvREFCNT(gv_list[8]) += 2;
	GvREFCNT(gv_list[8]) += 1;
	GvSV(gv_list[8]) = &sv_list[6];
	GvCV(gv_list[8]) = (CV*)((perl_get_cv("utf8::decode",TRUE)));
	GvFILE(gv_list[8]) = "hello.p";
	gv_list[9] = gv_fetchpv("utf8::downgrade", TRUE, SVt_PV);
	SvFLAGS(gv_list[9]) = 0x600d;
	GvFLAGS(gv_list[9]) = 0x2;
	GvLINE(gv_list[9]) = 0;
	SvPVX(gv_list[9]) = emptystring;

	SvREFCNT(gv_list[9]) += 2;
	GvREFCNT(gv_list[9]) += 1;
	GvSV(gv_list[9]) = &sv_list[7];
	GvCV(gv_list[9]) = (CV*)((perl_get_cv("utf8::downgrade",TRUE)));
	GvFILE(gv_list[9]) = "hello.p";
	gv_list[10] = gv_fetchpv("utf8::upgrade", TRUE, SVt_PV);
	SvFLAGS(gv_list[10]) = 0x600d;
	GvFLAGS(gv_list[10]) = 0x2;
	GvLINE(gv_list[10]) = 0;
	SvPVX(gv_list[10]) = emptystring;

	SvREFCNT(gv_list[10]) += 2;
	GvREFCNT(gv_list[10]) += 1;
	GvSV(gv_list[10]) = &sv_list[8];
	GvCV(gv_list[10]) = (CV*)((perl_get_cv("utf8::upgrade",TRUE)));
	GvFILE(gv_list[10]) = "hello.p";
	gv_list[11] = gv_fetchpv("utf8::is_utf8", TRUE, SVt_PV);
	SvFLAGS(gv_list[11]) = 0x600d;
	GvFLAGS(gv_list[11]) = 0x2;
	GvLINE(gv_list[11]) = 0;
	SvPVX(gv_list[11]) = emptystring;

	SvREFCNT(gv_list[11]) += 2;
	GvREFCNT(gv_list[11]) += 1;
	GvSV(gv_list[11]) = &sv_list[9];
	GvCV(gv_list[11]) = (CV*)((perl_get_cv("utf8::is_utf8",TRUE)));
	GvFILE(gv_list[11]) = "hello.p";
	gv_list[12] = gv_fetchpv("main::\"", TRUE, SVt_PV);
	SvFLAGS(gv_list[12]) = 0x600d;
	GvFLAGS(gv_list[12]) = 0xa;
	GvLINE(gv_list[12]) = 0;
	SvPVX(gv_list[12]) = emptystring;

	SvREFCNT(gv_list[12]) += 10;
	GvREFCNT(gv_list[12]) += 1;
	gv_list[13] = gv_fetchpv("main::stdout", TRUE, SVt_PV);
	SvFLAGS(gv_list[13]) = 0x600d;
	GvFLAGS(gv_list[13]) = 0x2;
	GvLINE(gv_list[13]) = 0;
	SvPVX(gv_list[13]) = emptystring;

	SvREFCNT(gv_list[13]) += 2;
	GvREFCNT(gv_list[13]) += 1;
	GvSV(gv_list[13]) = &sv_list[10];
	GvFILE(gv_list[13]) = "hello.p";
	IoIFP((IO*)&sv_list[11])=PerlIO_stdout();
	IoOFP((IO*)&sv_list[11])=PerlIO_stdout();
	SvSTASH((IO*)&sv_list[11]) = hv0;
	GvIOp(gv_list[13]) = (IO*)&sv_list[11];
	gv_list[14] = gv_fetchpv("main::\022", TRUE, SVt_PV);
	SvFLAGS(gv_list[14]) = 0x600d;
	GvFLAGS(gv_list[14]) = 0x2;
	GvLINE(gv_list[14]) = 0;
	SvPVX(gv_list[14]) = emptystring;

	SvREFCNT(gv_list[14]) += 2;
	GvREFCNT(gv_list[14]) += 1;
	gv_list[15] = gv_fetchpv("main::|", TRUE, SVt_PV);
	SvFLAGS(gv_list[15]) = 0x600d;
	GvFLAGS(gv_list[15]) = 0xa;
	GvLINE(gv_list[15]) = 466;
	SvPVX(gv_list[15]) = emptystring;

	SvREFCNT(gv_list[15]) += 5;
	GvREFCNT(gv_list[15]) += 1;
	gv_list[16] = gv_fetchpv("Regexp::DESTROY", TRUE, SVt_PV);
	SvFLAGS(gv_list[16]) = 0x600d;
	GvFLAGS(gv_list[16]) = 0x2;
	GvLINE(gv_list[16]) = 0;
	SvPVX(gv_list[16]) = emptystring;

	SvREFCNT(gv_list[16]) += 2;
	GvREFCNT(gv_list[16]) += 1;
	GvSV(gv_list[16]) = &sv_list[12];
	GvCV(gv_list[16]) = (CV*)((perl_get_cv("Regexp::DESTROY",TRUE)));
	GvFILE(gv_list[16]) = "hello.p";
	gv_list[17] = gv_fetchpv("main::\f", TRUE, SVt_PV);
	SvFLAGS(gv_list[17]) = 0x600d;
	GvFLAGS(gv_list[17]) = 0xa;
	GvLINE(gv_list[17]) = 554;
	SvPVX(gv_list[17]) = emptystring;

	SvREFCNT(gv_list[17]) += 4;
	GvREFCNT(gv_list[17]) += 1;
	gv_list[18] = gv_fetchpv("main::^", TRUE, SVt_PV);
	SvFLAGS(gv_list[18]) = 0x600d;
	GvFLAGS(gv_list[18]) = 0xa;
	GvLINE(gv_list[18]) = 538;
	SvPVX(gv_list[18]) = emptystring;

	SvREFCNT(gv_list[18]) += 4;
	GvREFCNT(gv_list[18]) += 1;
	gv_list[19] = gv_fetchpv("main::\001", TRUE, SVt_PV);
	SvFLAGS(gv_list[19]) = 0x600d;
	GvFLAGS(gv_list[19]) = 0xa;
	GvLINE(gv_list[19]) = 562;
	SvPVX(gv_list[19]) = emptystring;

	SvREFCNT(gv_list[19]) += 5;
	GvREFCNT(gv_list[19]) += 1;
	gv_list[20] = gv_fetchpv("main::$", TRUE, SVt_PV);
	SvFLAGS(gv_list[20]) = 0x600d;
	GvFLAGS(gv_list[20]) = 0x2;
	GvLINE(gv_list[20]) = 0;
	SvPVX(gv_list[20]) = emptystring;

	SvREFCNT(gv_list[20]) += 2;
	GvREFCNT(gv_list[20]) += 1;
	gv_list[21] = gv_fetchpv("main::\\", TRUE, SVt_PV);
	SvFLAGS(gv_list[21]) = 0x600d;
	GvFLAGS(gv_list[21]) = 0xa;
	GvLINE(gv_list[21]) = 441;
	SvPVX(gv_list[21]) = emptystring;

	SvREFCNT(gv_list[21]) += 9;
	GvREFCNT(gv_list[21]) += 1;
	gv_list[22] = gv_fetchpv("main::_</usr/lib/perl5/5.8.5/i386-linux-thread-multi/XSLoader.pm", TRUE, SVt_PV);
	SvFLAGS(gv_list[22]) = 0x600d;
	GvFLAGS(gv_list[22]) = 0x2;
	GvLINE(gv_list[22]) = 4294967295;
	SvPVX(gv_list[22]) = emptystring;

	SvREFCNT(gv_list[22]) += 2;
	GvREFCNT(gv_list[22]) += 1;
	xpv_list[0].xpv_pv = savepvn("/usr/lib/perl5/5.8.5/i386-linux-thread-multi/XSLoader.pm", 56);
	GvSV(gv_list[22]) = &sv_list[13];
	GvFILE(gv_list[22]) = "/usr/lib/perl5/5.8.5/i386-linux-thread-multi/XSLoader.pm";
	gv_list[23] = gv_fetchpv("main::~", TRUE, SVt_PV);
	SvFLAGS(gv_list[23]) = 0x600d;
	GvFLAGS(gv_list[23]) = 0xa;
	GvLINE(gv_list[23]) = 530;
	SvPVX(gv_list[23]) = emptystring;

	SvREFCNT(gv_list[23]) += 4;
	GvREFCNT(gv_list[23]) += 1;
	gv_list[24] = gv_fetchpv("main::-", TRUE, SVt_PV);
	SvFLAGS(gv_list[24]) = 0x600d;
	GvFLAGS(gv_list[24]) = 0xa;
	GvLINE(gv_list[24]) = 0;
	SvPVX(gv_list[24]) = emptystring;

	SvREFCNT(gv_list[24]) += 4;
	GvREFCNT(gv_list[24]) += 1;
	gv_list[25] = gv_fetchpv("main::_<perlmain.c", TRUE, SVt_PV);
	SvFLAGS(gv_list[25]) = 0x600d;
	GvFLAGS(gv_list[25]) = 0x2;
	GvLINE(gv_list[25]) = 0;
	SvPVX(gv_list[25]) = emptystring;

	SvREFCNT(gv_list[25]) += 2;
	GvREFCNT(gv_list[25]) += 1;
	xpv_list[1].xpv_pv = savepvn("perlmain.c", 10);
	GvSV(gv_list[25]) = &sv_list[14];
	GvFILE(gv_list[25]) = "hello.p";
	gv_list[26] = gv_fetchpv("main::_</usr/lib/perl5/5.8.5/File/Spec/Unix.pm", TRUE, SVt_PV);
	SvFLAGS(gv_list[26]) = 0x600d;
	GvFLAGS(gv_list[26]) = 0x2;
	GvLINE(gv_list[26]) = 98;
	SvPVX(gv_list[26]) = emptystring;

	SvREFCNT(gv_list[26]) += 2;
	GvREFCNT(gv_list[26]) += 1;
	xpv_list[2].xpv_pv = savepvn("/usr/lib/perl5/5.8.5/File/Spec/Unix.pm", 38);
	GvSV(gv_list[26]) = &sv_list[15];
	GvFILE(gv_list[26]) = "x/\031\b q\024\b\332T\305";
	gv_list[27] = gv_fetchpv("main::_</usr/lib/perl5/5.8.5/i386-linux-thread-multi/auto/B/C/C.so", TRUE, SVt_PV);
	SvFLAGS(gv_list[27]) = 0x600d;
	GvFLAGS(gv_list[27]) = 0x2;
	GvLINE(gv_list[27]) = 87;
	SvPVX(gv_list[27]) = emptystring;

	SvREFCNT(gv_list[27]) += 2;
	GvREFCNT(gv_list[27]) += 1;
	xpv_list[3].xpv_pv = savepvn("/usr/lib/perl5/5.8.5/i386-linux-thread-multi/auto/B/C/C.so", 58);
	GvSV(gv_list[27]) = &sv_list[16];
	GvFILE(gv_list[27]) = "/usr/lib/perl5/5.8.5/i386-linux-thread-multi/XSLoader.pm";
	gv_list[28] = gv_fetchpv("main::_<universal.c", TRUE, SVt_PV);
	SvFLAGS(gv_list[28]) = 0x600d;
	GvFLAGS(gv_list[28]) = 0x2;
	GvLINE(gv_list[28]) = 0;
	SvPVX(gv_list[28]) = emptystring;

	SvREFCNT(gv_list[28]) += 2;
	GvREFCNT(gv_list[28]) += 1;
	xpv_list[4].xpv_pv = savepvn("universal.c", 11);
	GvSV(gv_list[28]) = &sv_list[17];
	GvFILE(gv_list[28]) = "hello.p";
	gv_list[29] = gv_fetchpv("main::BEGIN", TRUE, SVt_PV);
	SvFLAGS(gv_list[29]) = 0x600d;
	GvFLAGS(gv_list[29]) = 0x2;
	GvLINE(gv_list[29]) = 0;
	SvPVX(gv_list[29]) = emptystring;

	SvREFCNT(gv_list[29]) += 2;
	GvREFCNT(gv_list[29]) += 1;
	GvSV(gv_list[29]) = &sv_list[18];
	GvFILE(gv_list[29]) = "hello.p";
	gv_list[30] = gv_fetchpv("main::_<xsutils.c", TRUE, SVt_PV);
	SvFLAGS(gv_list[30]) = 0x600d;
	GvFLAGS(gv_list[30]) = 0x2;
	GvLINE(gv_list[30]) = 0;
	SvPVX(gv_list[30]) = emptystring;

	SvREFCNT(gv_list[30]) += 2;
	GvREFCNT(gv_list[30]) += 1;
	xpv_list[5].xpv_pv = savepvn("xsutils.c", 9);
	GvSV(gv_list[30]) = &sv_list[19];
	GvFILE(gv_list[30]) = "hello.p";
	gv_list[31] = gv_fetchpv("main::!", TRUE, SVt_PV);
	SvFLAGS(gv_list[31]) = 0x600d;
	GvFLAGS(gv_list[31]) = 0xa;
	GvLINE(gv_list[31]) = 2054;
	SvPVX(gv_list[31]) = emptystring;

	SvREFCNT(gv_list[31]) += 3;
	GvREFCNT(gv_list[31]) += 1;
	GvFILE(gv_list[31]) = "";
	gv_list[32] = gv_fetchpv("main::\024AINT", TRUE, SVt_PV);
	SvFLAGS(gv_list[32]) = 0x600d;
	GvFLAGS(gv_list[32]) = 0xa;
	GvLINE(gv_list[32]) = 1589;
	SvPVX(gv_list[32]) = emptystring;

	SvREFCNT(gv_list[32]) += 3;
	GvREFCNT(gv_list[32]) += 1;
	sv_magic((SV*)&sv_list[20], (SV*)gv_list[32], '\000', "\024AINT", 5);
	GvSV(gv_list[32]) = &sv_list[20];
	GvFILE(gv_list[32]) = "";
	gv_list[33] = gv_fetchpv("main::\017", TRUE, SVt_PV);
	SvFLAGS(gv_list[33]) = 0x600d;
	GvFLAGS(gv_list[33]) = 0xa;
	GvLINE(gv_list[33]) = 55;
	SvPVX(gv_list[33]) = emptystring;

	SvREFCNT(gv_list[33]) += 4;
	GvREFCNT(gv_list[33]) += 1;
	gv_list[34] = gv_fetchpv("main::%", TRUE, SVt_PV);
	SvFLAGS(gv_list[34]) = 0x600d;
	GvFLAGS(gv_list[34]) = 0xa;
	GvLINE(gv_list[34]) = 506;
	SvPVX(gv_list[34]) = emptystring;

	SvREFCNT(gv_list[34]) += 4;
	GvREFCNT(gv_list[34]) += 1;
	gv_list[35] = gv_fetchpv("main::\030", TRUE, SVt_PV);
	SvFLAGS(gv_list[35]) = 0x600d;
	GvFLAGS(gv_list[35]) = 0x2;
	GvLINE(gv_list[35]) = 0;
	SvPVX(gv_list[35]) = emptystring;

	SvREFCNT(gv_list[35]) += 2;
	GvREFCNT(gv_list[35]) += 1;
	gv_list[36] = gv_fetchpv("main::_", TRUE, SVt_PV);
	SvFLAGS(gv_list[36]) = 0x630d;
	GvFLAGS(gv_list[36]) = 0xa;
	GvLINE(gv_list[36]) = 0;
	SvPVX(gv_list[36]) = emptystring;

	SvREFCNT(gv_list[36]) += 470;
	GvREFCNT(gv_list[36]) += 1;
	gv_list[37] = gv_fetchpv("main::+", TRUE, SVt_PV);
	SvFLAGS(gv_list[37]) = 0x600d;
	GvFLAGS(gv_list[37]) = 0x2;
	GvLINE(gv_list[37]) = 0;
	SvPVX(gv_list[37]) = emptystring;

	SvREFCNT(gv_list[37]) += 2;
	GvREFCNT(gv_list[37]) += 1;
	gv_list[38] = gv_fetchpv("Internals::SvREFCNT", TRUE, SVt_PV);
	SvFLAGS(gv_list[38]) = 0x600d;
	GvFLAGS(gv_list[38]) = 0x2;
	GvLINE(gv_list[38]) = 0;
	SvPVX(gv_list[38]) = emptystring;

	SvREFCNT(gv_list[38]) += 2;
	GvREFCNT(gv_list[38]) += 1;
	GvSV(gv_list[38]) = &sv_list[21];
	GvCV(gv_list[38]) = (CV*)((perl_get_cv("Internals::SvREFCNT",TRUE)));
	GvFILE(gv_list[38]) = "hello.p";
	gv_list[39] = gv_fetchpv("Internals::hv_clear_placeholders", TRUE, SVt_PV);
	SvFLAGS(gv_list[39]) = 0x600d;
	GvFLAGS(gv_list[39]) = 0x2;
	GvLINE(gv_list[39]) = 0;
	SvPVX(gv_list[39]) = emptystring;

	SvREFCNT(gv_list[39]) += 2;
	GvREFCNT(gv_list[39]) += 1;
	GvSV(gv_list[39]) = &sv_list[22];
	GvCV(gv_list[39]) = (CV*)((perl_get_cv("Internals::hv_clear_placeholders",TRUE)));
	GvFILE(gv_list[39]) = "hello.p";
	gv_list[40] = gv_fetchpv("Internals::hash_seed", TRUE, SVt_PV);
	SvFLAGS(gv_list[40]) = 0x600d;
	GvFLAGS(gv_list[40]) = 0x2;
	GvLINE(gv_list[40]) = 0;
	SvPVX(gv_list[40]) = emptystring;

	SvREFCNT(gv_list[40]) += 2;
	GvREFCNT(gv_list[40]) += 1;
	GvSV(gv_list[40]) = &sv_list[23];
	GvCV(gv_list[40]) = (CV*)((perl_get_cv("Internals::hash_seed",TRUE)));
	GvFILE(gv_list[40]) = "hello.p";
	gv_list[41] = gv_fetchpv("Internals::SvREADONLY", TRUE, SVt_PV);
	SvFLAGS(gv_list[41]) = 0x600d;
	GvFLAGS(gv_list[41]) = 0x2;
	GvLINE(gv_list[41]) = 0;
	SvPVX(gv_list[41]) = emptystring;

	SvREFCNT(gv_list[41]) += 2;
	GvREFCNT(gv_list[41]) += 1;
	GvSV(gv_list[41]) = &sv_list[24];
	GvCV(gv_list[41]) = (CV*)((perl_get_cv("Internals::SvREADONLY",TRUE)));
	GvFILE(gv_list[41]) = "hello.p";
	gv_list[42] = gv_fetchpv("Internals::HvREHASH", TRUE, SVt_PV);
	SvFLAGS(gv_list[42]) = 0x600d;
	GvFLAGS(gv_list[42]) = 0x2;
	GvLINE(gv_list[42]) = 0;
	SvPVX(gv_list[42]) = emptystring;

	SvREFCNT(gv_list[42]) += 2;
	GvREFCNT(gv_list[42]) += 1;
	GvSV(gv_list[42]) = &sv_list[25];
	GvCV(gv_list[42]) = (CV*)((perl_get_cv("Internals::HvREHASH",TRUE)));
	GvFILE(gv_list[42]) = "hello.p";
	gv_list[43] = gv_fetchpv("Internals::rehash_seed", TRUE, SVt_PV);
	SvFLAGS(gv_list[43]) = 0x600d;
	GvFLAGS(gv_list[43]) = 0x2;
	GvLINE(gv_list[43]) = 0;
	SvPVX(gv_list[43]) = emptystring;

	SvREFCNT(gv_list[43]) += 2;
	GvREFCNT(gv_list[43]) += 1;
	GvSV(gv_list[43]) = &sv_list[26];
	GvCV(gv_list[43]) = (CV*)((perl_get_cv("Internals::rehash_seed",TRUE)));
	GvFILE(gv_list[43]) = "hello.p";
	gv_list[44] = gv_fetchpv("main::STDIN", TRUE, SVt_PV);
	SvFLAGS(gv_list[44]) = 0x600d;
	GvFLAGS(gv_list[44]) = 0xa;
	GvLINE(gv_list[44]) = 0;
	SvPVX(gv_list[44]) = emptystring;

	SvREFCNT(gv_list[44]) += 2;
	GvREFCNT(gv_list[44]) += 1;
	gv_list[45] = gv_fetchpv("DB::args", TRUE, SVt_PV);
	SvFLAGS(gv_list[45]) = 0x600d;
	GvFLAGS(gv_list[45]) = 0xa;
	GvLINE(gv_list[45]) = 431;
	SvPVX(gv_list[45]) = emptystring;

	SvREFCNT(gv_list[45]) += 4;
	GvREFCNT(gv_list[45]) += 1;
	GvSV(gv_list[45]) = &sv_list[27];
	GvAV(gv_list[45]) = (AV*)&sv_list[28];
	GvFILE(gv_list[45]) = "\260\r\016\b";
	gv_list[46] = gv_fetchpv("main::\026", TRUE, SVt_PV);
	SvFLAGS(gv_list[46]) = 0x600d;
	GvFLAGS(gv_list[46]) = 0xa;
	GvLINE(gv_list[46]) = 30;
	SvPVX(gv_list[46]) = emptystring;

	SvREFCNT(gv_list[46]) += 2;
	GvREFCNT(gv_list[46]) += 1;
	gv_list[47] = gv_fetchpv("main::=", TRUE, SVt_PV);
	SvFLAGS(gv_list[47]) = 0x600d;
	GvFLAGS(gv_list[47]) = 0xa;
	GvLINE(gv_list[47]) = 514;
	SvPVX(gv_list[47]) = emptystring;

	SvREFCNT(gv_list[47]) += 4;
	GvREFCNT(gv_list[47]) += 1;
	gv_list[48] = gv_fetchpv("main::2", TRUE, SVt_PV);
	SvFLAGS(gv_list[48]) = 0x600d;
	GvFLAGS(gv_list[48]) = 0xa;
	GvLINE(gv_list[48]) = 257;
	SvPVX(gv_list[48]) = emptystring;

	SvREFCNT(gv_list[48]) += 6;
	GvREFCNT(gv_list[48]) += 1;
	gv_list[49] = gv_fetchpv("main::_<Fcntl.c", TRUE, SVt_PV);
	SvFLAGS(gv_list[49]) = 0x600d;
	GvFLAGS(gv_list[49]) = 0x2;
	GvLINE(gv_list[49]) = 92;
	SvPVX(gv_list[49]) = emptystring;

	SvREFCNT(gv_list[49]) += 2;
	GvREFCNT(gv_list[49]) += 1;
	xpv_list[6].xpv_pv = savepvn("Fcntl.c", 7);
	GvSV(gv_list[49]) = &sv_list[29];
	GvFILE(gv_list[49]) = "/usr/lib/perl5/5.8.5/i386-linux-thread-multi/XSLoader.pm";
	gv_list[50] = gv_fetchpv("main::1", TRUE, SVt_PV);
	SvFLAGS(gv_list[50]) = 0x600d;
	GvFLAGS(gv_list[50]) = 0xa;
	GvLINE(gv_list[50]) = 74;
	SvPVX(gv_list[50]) = emptystring;

	SvREFCNT(gv_list[50]) += 28;
	GvREFCNT(gv_list[50]) += 1;
	gv_list[51] = gv_fetchpv("main::_<IO.c", TRUE, SVt_PV);
	SvFLAGS(gv_list[51]) = 0x600d;
	GvFLAGS(gv_list[51]) = 0x2;
	GvLINE(gv_list[51]) = 92;
	SvPVX(gv_list[51]) = emptystring;

	SvREFCNT(gv_list[51]) += 2;
	GvREFCNT(gv_list[51]) += 1;
	xpv_list[7].xpv_pv = savepvn("IO.c", 4);
	GvSV(gv_list[51]) = &sv_list[30];
	GvFILE(gv_list[51]) = "/usr/lib/perl5/5.8.5/i386-linux-thread-multi/XSLoader.pm";
	gv_list[52] = gv_fetchpv("main::\027ARNING_BITS", TRUE, SVt_PV);
	SvFLAGS(gv_list[52]) = 0x600d;
	GvFLAGS(gv_list[52]) = 0xa;
	GvLINE(gv_list[52]) = 341;
	SvPVX(gv_list[52]) = emptystring;

	SvREFCNT(gv_list[52]) += 6;
	GvREFCNT(gv_list[52]) += 1;
	sv_magic((SV*)&sv_list[31], (SV*)gv_list[52], '\000', "\027ARNING_BITS", 12);
	GvSV(gv_list[52]) = &sv_list[31];
	GvFILE(gv_list[52]) = "\260\r\016\b";
	gv_list[53] = gv_fetchpv("main::_<B.c", TRUE, SVt_PV);
	SvFLAGS(gv_list[53]) = 0x600d;
	GvFLAGS(gv_list[53]) = 0x2;
	GvLINE(gv_list[53]) = 92;
	SvPVX(gv_list[53]) = emptystring;

	SvREFCNT(gv_list[53]) += 2;
	GvREFCNT(gv_list[53]) += 1;
	xpv_list[8].xpv_pv = savepvn("B.c", 3);
	GvSV(gv_list[53]) = &sv_list[32];
	GvFILE(gv_list[53]) = "/usr/lib/perl5/5.8.5/i386-linux-thread-multi/XSLoader.pm";
	gv_list[54] = gv_fetchpv("main::_<DynaLoader.c", TRUE, SVt_PV);
	SvFLAGS(gv_list[54]) = 0x600d;
	GvFLAGS(gv_list[54]) = 0x2;
	GvLINE(gv_list[54]) = 16;
	SvPVX(gv_list[54]) = emptystring;

	SvREFCNT(gv_list[54]) += 2;
	GvREFCNT(gv_list[54]) += 1;
	xpv_list[9].xpv_pv = savepvn("DynaLoader.c", 12);
	GvSV(gv_list[54]) = &sv_list[33];
	GvFILE(gv_list[54]) = "\335\367\302";
	gv_list[55] = gv_fetchpv("main::_</usr/lib/perl5/5.8.5/i386-linux-thread-multi/auto/IO/IO.so", TRUE, SVt_PV);
	SvFLAGS(gv_list[55]) = 0x600d;
	GvFLAGS(gv_list[55]) = 0x2;
	GvLINE(gv_list[55]) = 87;
	SvPVX(gv_list[55]) = emptystring;

	SvREFCNT(gv_list[55]) += 2;
	GvREFCNT(gv_list[55]) += 1;
	xpv_list[10].xpv_pv = savepvn("/usr/lib/perl5/5.8.5/i386-linux-thread-multi/auto/IO/IO.so", 58);
	GvSV(gv_list[55]) = &sv_list[34];
	GvFILE(gv_list[55]) = "/usr/lib/perl5/5.8.5/i386-linux-thread-multi/XSLoader.pm";
	gv_list[56] = gv_fetchpv("attributes::bootstrap", TRUE, SVt_PV);
	SvFLAGS(gv_list[56]) = 0x600d;
	GvFLAGS(gv_list[56]) = 0x2;
	GvLINE(gv_list[56]) = 0;
	SvPVX(gv_list[56]) = emptystring;

	SvREFCNT(gv_list[56]) += 2;
	GvREFCNT(gv_list[56]) += 1;
	GvSV(gv_list[56]) = &sv_list[35];
	GvFILE(gv_list[56]) = "hello.p";
	gv_list[57] = gv_fetchpv("main::stdin", TRUE, SVt_PV);
	SvFLAGS(gv_list[57]) = 0x600d;
	GvFLAGS(gv_list[57]) = 0x2;
	GvLINE(gv_list[57]) = 0;
	SvPVX(gv_list[57]) = emptystring;

	SvREFCNT(gv_list[57]) += 2;
	GvREFCNT(gv_list[57]) += 1;
	GvSV(gv_list[57]) = &sv_list[36];
	GvFILE(gv_list[57]) = "hello.p";
	IoIFP((IO*)&sv_list[37])=PerlIO_stdin();
	IoOFP((IO*)&sv_list[37])=PerlIO_stdin();
	SvSTASH((IO*)&sv_list[37]) = hv0;
	GvIOp(gv_list[57]) = (IO*)&sv_list[37];
	gv_list[58] = gv_fetchpv("main::ARGV", TRUE, SVt_PV);
	SvFLAGS(gv_list[58]) = 0x600d;
	GvFLAGS(gv_list[58]) = 0x2;
	GvLINE(gv_list[58]) = 0;
	SvPVX(gv_list[58]) = emptystring;

	SvREFCNT(gv_list[58]) += 2;
	GvREFCNT(gv_list[58]) += 1;
	gv_list[59] = gv_fetchpv("main::INC", TRUE, SVt_PV);
	SvFLAGS(gv_list[59]) = 0x600d;
	GvFLAGS(gv_list[59]) = 0xa;
	GvLINE(gv_list[59]) = 0;
	SvPVX(gv_list[59]) = emptystring;

	SvREFCNT(gv_list[59]) += 7;
	GvREFCNT(gv_list[59]) += 1;
	GvSV(gv_list[59]) = &sv_list[38];
	xpv_list[11].xpv_pv = savepvn("/usr/lib/perl5/5.8.5/i386-linux-thread-multi", 44);
	xpv_list[12].xpv_pv = savepvn("/usr/lib/perl5/5.8.5", 20);
	xpv_list[13].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.5/i386-linux-thread-multi", 54);
	xpv_list[14].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.4/i386-linux-thread-multi", 54);
	xpv_list[15].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.3/i386-linux-thread-multi", 54);
	xpv_list[16].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.2/i386-linux-thread-multi", 54);
	xpv_list[17].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.1/i386-linux-thread-multi", 54);
	xpv_list[18].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.0/i386-linux-thread-multi", 54);
	xpv_list[19].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.5", 30);
	xpv_list[20].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.4", 30);
	xpv_list[21].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.3", 30);
	xpv_list[22].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.2", 30);
	xpv_list[23].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.1", 30);
	xpv_list[24].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.0", 30);
	xpv_list[25].xpv_pv = savepvn("/usr/lib/perl5/site_perl", 24);
	xpv_list[26].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.5/i386-linux-thread-multi", 56);
	xpv_list[27].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.4/i386-linux-thread-multi", 56);
	xpv_list[28].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.3/i386-linux-thread-multi", 56);
	xpv_list[29].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.2/i386-linux-thread-multi", 56);
	xpv_list[30].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.1/i386-linux-thread-multi", 56);
	xpv_list[31].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.0/i386-linux-thread-multi", 56);
	xpv_list[32].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.5", 32);
	xpv_list[33].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.4", 32);
	xpv_list[34].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.3", 32);
	xpv_list[35].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.2", 32);
	xpv_list[36].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.1", 32);
	xpv_list[37].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.0", 32);
	xpv_list[38].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl", 26);
	xpv_list[39].xpv_pv = savepvn(".", 1);
	xpv_list[40].xpv_pv = savepvn("/usr/lib/perl5/5.8.5/i386-linux-thread-multi", 44);
	xpv_list[41].xpv_pv = savepvn("/usr/lib/perl5/5.8.5", 20);
	xpv_list[42].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.5/i386-linux-thread-multi", 54);
	xpv_list[43].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.4/i386-linux-thread-multi", 54);
	xpv_list[44].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.3/i386-linux-thread-multi", 54);
	xpv_list[45].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.2/i386-linux-thread-multi", 54);
	xpv_list[46].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.1/i386-linux-thread-multi", 54);
	xpv_list[47].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.0/i386-linux-thread-multi", 54);
	xpv_list[48].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.5", 30);
	xpv_list[49].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.4", 30);
	xpv_list[50].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.3", 30);
	xpv_list[51].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.2", 30);
	xpv_list[52].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.1", 30);
	xpv_list[53].xpv_pv = savepvn("/usr/lib/perl5/site_perl/5.8.0", 30);
	xpv_list[54].xpv_pv = savepvn("/usr/lib/perl5/site_perl", 24);
	xpv_list[55].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.5/i386-linux-thread-multi", 56);
	xpv_list[56].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.4/i386-linux-thread-multi", 56);
	xpv_list[57].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.3/i386-linux-thread-multi", 56);
	xpv_list[58].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.2/i386-linux-thread-multi", 56);
	xpv_list[59].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.1/i386-linux-thread-multi", 56);
	xpv_list[60].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.0/i386-linux-thread-multi", 56);
	xpv_list[61].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.5", 32);
	xpv_list[62].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.4", 32);
	xpv_list[63].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.3", 32);
	xpv_list[64].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.2", 32);
	xpv_list[65].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.1", 32);
	xpv_list[66].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl/5.8.0", 32);
	xpv_list[67].xpv_pv = savepvn("/usr/lib/perl5/vendor_perl", 26);
	xpv_list[68].xpv_pv = savepvn(".", 1);
	{
		SV **svp;
		AV *av = (AV*)&sv_list[39];
		av_extend(av, 57);
		svp = AvARRAY(av);
		*svp++ = (SV*)&sv_list[40];
		*svp++ = (SV*)&sv_list[41];
		*svp++ = (SV*)&sv_list[42];
		*svp++ = (SV*)&sv_list[43];
		*svp++ = (SV*)&sv_list[44];
		*svp++ = (SV*)&sv_list[45];
		*svp++ = (SV*)&sv_list[46];
		*svp++ = (SV*)&sv_list[47];
		*svp++ = (SV*)&sv_list[48];
		*svp++ = (SV*)&sv_list[49];
		*svp++ = (SV*)&sv_list[50];
		*svp++ = (SV*)&sv_list[51];
		*svp++ = (SV*)&sv_list[52];
		*svp++ = (SV*)&sv_list[53];
		*svp++ = (SV*)&sv_list[54];
		*svp++ = (SV*)&sv_list[55];
		*svp++ = (SV*)&sv_list[56];
		*svp++ = (SV*)&sv_list[57];
		*svp++ = (SV*)&sv_list[58];
		*svp++ = (SV*)&sv_list[59];
		*svp++ = (SV*)&sv_list[60];
		*svp++ = (SV*)&sv_list[61];
		*svp++ = (SV*)&sv_list[62];
		*svp++ = (SV*)&sv_list[63];
		*svp++ = (SV*)&sv_list[64];
		*svp++ = (SV*)&sv_list[65];
		*svp++ = (SV*)&sv_list[66];
		*svp++ = (SV*)&sv_list[67];
		*svp++ = (SV*)&sv_list[68];
		*svp++ = (SV*)&sv_list[69];
		*svp++ = (SV*)&sv_list[70];
		*svp++ = (SV*)&sv_list[71];
		*svp++ = (SV*)&sv_list[72];
		*svp++ = (SV*)&sv_list[73];
		*svp++ = (SV*)&sv_list[74];
		*svp++ = (SV*)&sv_list[75];
		*svp++ = (SV*)&sv_list[76];
		*svp++ = (SV*)&sv_list[77];
		*svp++ = (SV*)&sv_list[78];
		*svp++ = (SV*)&sv_list[79];
		*svp++ = (SV*)&sv_list[80];
		*svp++ = (SV*)&sv_list[81];
		*svp++ = (SV*)&sv_list[82];
		*svp++ = (SV*)&sv_list[83];
		*svp++ = (SV*)&sv_list[84];
		*svp++ = (SV*)&sv_list[85];
		*svp++ = (SV*)&sv_list[86];
		*svp++ = (SV*)&sv_list[87];
		*svp++ = (SV*)&sv_list[88];
		*svp++ = (SV*)&sv_list[89];
		*svp++ = (SV*)&sv_list[90];
		*svp++ = (SV*)&sv_list[91];
		*svp++ = (SV*)&sv_list[92];
		*svp++ = (SV*)&sv_list[93];
		*svp++ = (SV*)&sv_list[94];
		*svp++ = (SV*)&sv_list[95];
		*svp++ = (SV*)&sv_list[96];
		*svp++ = (SV*)&sv_list[97];
	

		AvFILLp(av) = 57;
	}
	GvAV(gv_list[59]) = (AV*)&sv_list[39];
	GvHV(gv_list[59]) = (HV*)&sv_list[98];
	GvFILE(gv_list[59]) = "";
	gv_list[60] = gv_fetchpv("main::ENV", TRUE, SVt_PV);
	SvFLAGS(gv_list[60]) = 0x600d;
	GvFLAGS(gv_list[60]) = 0xa;
	GvLINE(gv_list[60]) = 0;
	SvPVX(gv_list[60]) = emptystring;

	SvREFCNT(gv_list[60]) += 5;
	GvREFCNT(gv_list[60]) += 1;
	gv_list[61] = gv_fetchpv("main::_<perlio.c", TRUE, SVt_PV);
	SvFLAGS(gv_list[61]) = 0x600d;
	GvFLAGS(gv_list[61]) = 0x2;
	GvLINE(gv_list[61]) = 0;
	SvPVX(gv_list[61]) = emptystring;

	SvREFCNT(gv_list[61]) += 2;
	GvREFCNT(gv_list[61]) += 1;
	xpv_list[69].xpv_pv = savepvn("perlio.c", 8);
	GvSV(gv_list[61]) = &sv_list[99];
	GvFILE(gv_list[61]) = "hello.p";
	gv_list[62] = gv_fetchpv("main:::", TRUE, SVt_PV);
	SvFLAGS(gv_list[62]) = 0x600d;
	GvFLAGS(gv_list[62]) = 0xa;
	GvLINE(gv_list[62]) = 546;
	SvPVX(gv_list[62]) = emptystring;

	SvREFCNT(gv_list[62]) += 4;
	GvREFCNT(gv_list[62]) += 1;
	gv_list[63] = gv_fetchpv("PerlIO::get_layers", TRUE, SVt_PV);
	SvFLAGS(gv_list[63]) = 0x600d;
	GvFLAGS(gv_list[63]) = 0x2;
	GvLINE(gv_list[63]) = 0;
	SvPVX(gv_list[63]) = emptystring;

	SvREFCNT(gv_list[63]) += 2;
	GvREFCNT(gv_list[63]) += 1;
	GvSV(gv_list[63]) = &sv_list[100];
	GvCV(gv_list[63]) = (CV*)((perl_get_cv("PerlIO::get_layers",TRUE)));
	GvFILE(gv_list[63]) = "hello.p";
	gv_list[64] = gv_fetchpv("PerlIO::Layer::NoWarnings", TRUE, SVt_PV);
	SvFLAGS(gv_list[64]) = 0x600d;
	GvFLAGS(gv_list[64]) = 0x2;
	GvLINE(gv_list[64]) = 0;
	SvPVX(gv_list[64]) = emptystring;

	SvREFCNT(gv_list[64]) += 2;
	GvREFCNT(gv_list[64]) += 1;
	GvSV(gv_list[64]) = &sv_list[101];
	GvCV(gv_list[64]) = (CV*)((perl_get_cv("PerlIO::Layer::NoWarnings",TRUE)));
	GvFILE(gv_list[64]) = "hello.p";
	gv_list[65] = gv_fetchpv("PerlIO::Layer::find", TRUE, SVt_PV);
	SvFLAGS(gv_list[65]) = 0x600d;
	GvFLAGS(gv_list[65]) = 0x2;
	GvLINE(gv_list[65]) = 0;
	SvPVX(gv_list[65]) = emptystring;

	SvREFCNT(gv_list[65]) += 2;
	GvREFCNT(gv_list[65]) += 1;
	GvSV(gv_list[65]) = &sv_list[102];
	GvCV(gv_list[65]) = (CV*)((perl_get_cv("PerlIO::Layer::find",TRUE)));
	GvFILE(gv_list[65]) = "hello.p";
	gv_list[66] = gv_fetchpv("main::0", TRUE, SVt_PV);
	SvFLAGS(gv_list[66]) = 0x600d;
	GvFLAGS(gv_list[66]) = 0xa;
	GvLINE(gv_list[66]) = 0;
	SvPVX(gv_list[66]) = emptystring;

	SvREFCNT(gv_list[66]) += 5;
	GvREFCNT(gv_list[66]) += 1;
	gv_list[67] = gv_fetchpv("main::.", TRUE, SVt_PV);
	SvFLAGS(gv_list[67]) = 0x600d;
	GvFLAGS(gv_list[67]) = 0xa;
	GvLINE(gv_list[67]) = 496;
	SvPVX(gv_list[67]) = emptystring;

	SvREFCNT(gv_list[67]) += 5;
	GvREFCNT(gv_list[67]) += 1;
	gv_list[68] = gv_fetchpv("main::\b", TRUE, SVt_PV);
	SvFLAGS(gv_list[68]) = 0x600d;
	GvFLAGS(gv_list[68]) = 0xa;
	GvLINE(gv_list[68]) = 0;
	SvPVX(gv_list[68]) = emptystring;

	SvREFCNT(gv_list[68]) += 5;
	GvREFCNT(gv_list[68]) += 1;
	gv_list[69] = gv_fetchpv("main::@", TRUE, SVt_PV);
	SvFLAGS(gv_list[69]) = 0x600d;
	GvFLAGS(gv_list[69]) = 0xa;
	GvLINE(gv_list[69]) = 0;
	SvPVX(gv_list[69]) = emptystring;

	SvREFCNT(gv_list[69]) += 13;
	GvREFCNT(gv_list[69]) += 1;
	gv_list[70] = gv_fetchpv("main::_</usr/lib/perl5/5.8.5/base.pm", TRUE, SVt_PV);
	SvFLAGS(gv_list[70]) = 0x600d;
	GvFLAGS(gv_list[70]) = 0x2;
	GvLINE(gv_list[70]) = 8;
	SvPVX(gv_list[70]) = emptystring;

	SvREFCNT(gv_list[70]) += 2;
	GvREFCNT(gv_list[70]) += 1;
	xpv_list[70].xpv_pv = savepvn("/usr/lib/perl5/5.8.5/base.pm", 28);
	GvSV(gv_list[70]) = &sv_list[103];
	GvFILE(gv_list[70]) = "\270/\r\b";
	gv_list[71] = gv_fetchpv("main::STDOUT", TRUE, SVt_PV);
	SvFLAGS(gv_list[71]) = 0x630d;
	GvFLAGS(gv_list[71]) = 0xa;
	GvLINE(gv_list[71]) = 0;
	SvPVX(gv_list[71]) = emptystring;

	SvREFCNT(gv_list[71]) += 13;
	GvREFCNT(gv_list[71]) += 1;
	gv_list[72] = gv_fetchpv("main::_</usr/lib/perl5/5.8.5/i386-linux-thread-multi/B/C.pm", TRUE, SVt_PV);
	SvFLAGS(gv_list[72]) = 0x600d;
	GvFLAGS(gv_list[72]) = 0x2;
	GvLINE(gv_list[72]) = 1096;
	SvPVX(gv_list[72]) = emptystring;

	SvREFCNT(gv_list[72]) += 2;
	GvREFCNT(gv_list[72]) += 1;
	xpv_list[71].xpv_pv = savepvn("/usr/lib/perl5/5.8.5/i386-linux-thread-multi/B/C.pm", 51);
	GvSV(gv_list[72]) = &sv_list[104];
	GvFILE(gv_list[72]) = "";
	gv_list[73] = gv_fetchpv("main::_</usr/lib/perl5/5.8.5/i386-linux-thread-multi/B.pm", TRUE, SVt_PV);
	SvFLAGS(gv_list[73]) = 0x600d;
	GvFLAGS(gv_list[73]) = 0x2;
	GvLINE(gv_list[73]) = 87;
	SvPVX(gv_list[73]) = emptystring;

	SvREFCNT(gv_list[73]) += 2;
	GvREFCNT(gv_list[73]) += 1;
	xpv_list[72].xpv_pv = savepvn("/usr/lib/perl5/5.8.5/i386-linux-thread-multi/B.pm", 49);
	GvSV(gv_list[73]) = &sv_list[105];
	GvFILE(gv_list[73]) = "\210\327\a\b\b";
	gv_list[74] = gv_fetchpv("main::]", TRUE, SVt_PV);
	SvFLAGS(gv_list[74]) = 0x600d;
	GvFLAGS(gv_list[74]) = 0xa;
	GvLINE(gv_list[74]) = 41;
	SvPVX(gv_list[74]) = emptystring;

	SvREFCNT(gv_list[74]) += 2;
	GvREFCNT(gv_list[74]) += 1;
	gv_list[75] = gv_fetchpv("main::\027", TRUE, SVt_PV);
	SvFLAGS(gv_list[75]) = 0x600d;
	GvFLAGS(gv_list[75]) = 0xa;
	GvLINE(gv_list[75]) = 227;
	SvPVX(gv_list[75]) = emptystring;

	SvREFCNT(gv_list[75]) += 4;
	GvREFCNT(gv_list[75]) += 1;
	gv_list[76] = gv_fetchpv("main::STDERR", TRUE, SVt_PV);
	SvFLAGS(gv_list[76]) = 0x630d;
	GvFLAGS(gv_list[76]) = 0xa;
	GvLINE(gv_list[76]) = 0;
	SvPVX(gv_list[76]) = emptystring;

	SvREFCNT(gv_list[76]) += 4;
	GvREFCNT(gv_list[76]) += 1;
	gv_list[77] = gv_fetchpv("main::_</usr/lib/perl5/5.8.5/i386-linux-thread-multi/auto/B/B.so", TRUE, SVt_PV);
	SvFLAGS(gv_list[77]) = 0x600d;
	GvFLAGS(gv_list[77]) = 0x2;
	GvLINE(gv_list[77]) = 87;
	SvPVX(gv_list[77]) = emptystring;

	SvREFCNT(gv_list[77]) += 2;
	GvREFCNT(gv_list[77]) += 1;
	xpv_list[73].xpv_pv = savepvn("/usr/lib/perl5/5.8.5/i386-linux-thread-multi/auto/B/B.so", 56);
	GvSV(gv_list[77]) = &sv_list[106];
	GvFILE(gv_list[77]) = "/usr/lib/perl5/5.8.5/i386-linux-thread-multi/XSLoader.pm";
	gv_list[78] = gv_fetchpv("main::_</usr/lib/perl5/5.8.5/i386-linux-thread-multi/auto/Fcntl/Fcntl.so", TRUE, SVt_PV);
	SvFLAGS(gv_list[78]) = 0x600d;
	GvFLAGS(gv_list[78]) = 0x2;
	GvLINE(gv_list[78]) = 87;
	SvPVX(gv_list[78]) = emptystring;

	SvREFCNT(gv_list[78]) += 2;
	GvREFCNT(gv_list[78]) += 1;
	xpv_list[74].xpv_pv = savepvn("/usr/lib/perl5/5.8.5/i386-linux-thread-multi/auto/Fcntl/Fcntl.so", 64);
	GvSV(gv_list[78]) = &sv_list[107];
	GvFILE(gv_list[78]) = "/usr/lib/perl5/5.8.5/i386-linux-thread-multi/XSLoader.pm";
	    PL_dowarn = ( 0 ) ? G_WARN_ON : G_WARN_OFF;
	PL_main_root = (OP*)&listop_list[0];
	PL_main_start = &op_list[0];
	PL_initav = (AV *) Nullsv;
	PL_endav = (AV*) Nullsv;
	xpv_list[75].xpv_pv = savepvn("Hello World\n", 12);
	{
		SV **svp;
		AV *av = (AV*)&sv_list[109];
		av_extend(av, 2);
		svp = AvARRAY(av);
		*svp++ = (SV*)&PL_sv_undef;
		*svp++ = (SV*)&sv_list[110];
		*svp++ = (SV*)&sv_list[111];
	

		AvFILLp(av) = 2;
	}
	PL_curpad = AvARRAY((AV*)&sv_list[109]);
	GvHV(PL_incgv) = (HV*)&sv_list[98];
	GvAV(PL_incgv) = (AV*)&sv_list[39];
	av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc((AV*)&sv_list[108]));
	av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc((AV*)&sv_list[109]));
	PL_amagic_generation= 0;
	return 0;
}
예제 #18
0
파일: call.C 프로젝트: Gustra/libperl--
static inline HV* get_stash(const Scalar::Value& value) {
    SV* const handler = value.get_SV(true);
    interpreter* const interp = value.interp;
    return (SvROK(handler) && sv_isobject(handler)) ? SvSTASH(SvRV(handler)) : gv_stashsv(handler, false);
}
예제 #19
0
void
Perl_mro_isa_changed_in(pTHX_ HV* stash)
{
    HV* isarev;
    AV* linear_mro;
    HE* iter;
    SV** svp;
    I32 items;
    bool is_universal;
    struct mro_meta * meta;
    HV *isa = NULL;

    const HEK * const stashhek = HvENAME_HEK(stash);
    const char * const stashname = HvENAME_get(stash);
    const STRLEN stashname_len = HvENAMELEN_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);
    CLEAR_LINEAR(meta);
    if (meta->isa) {
        /* Steal it for our own purposes. */
        isa = (HV *)sv_2mortal((SV *)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_fetchhek(PL_isarev, stashhek, 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);

    /* Changes to @ISA might turn overloading on */
    HvAMAGIC_on(stash);
    /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
    HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;

    /* DESTROY can be cached in SvSTASH. */
    if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;

    /* Iterate the isarev (classes that are our children),
       wiping out their linearization, method and isa caches
       and upating PL_isarev. */
    if(isarev) {
        HV *isa_hashes = NULL;

        /* We have to iterate through isarev twice to avoid a chicken and
         * egg problem: if A inherits from B and both are in isarev, A might
         * be processed before B and use B's previous linearisation.
         */

        /* First iteration: Wipe everything, but stash away the isa hashes
         * since we still need them for updating PL_isarev.
         */

        if(hv_iterinit(isarev)) {
            /* Only create the hash if we need it; i.e., if isarev has
               any elements. */
            isa_hashes = (HV *)sv_2mortal((SV *)newHV());
        }
        while((iter = hv_iternext(isarev))) {
            HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
            struct mro_meta* revmeta;

            if(!revstash) continue;
            revmeta = HvMROMETA(revstash);
            CLEAR_LINEAR(revmeta);
            if(!is_universal)
                revmeta->cache_gen++;
            if(revmeta->mro_nextmethod)
                hv_clear(revmeta->mro_nextmethod);
            if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;

            (void)
            hv_store(
                isa_hashes, (const char*)&revstash, sizeof(HV *),
                revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
            );
            revmeta->isa = NULL;
        }

        /* Second pass: Update PL_isarev. We can just use isa_hashes to
         * avoid another round of stash lookups. */

        /* isarev might be deleted from PL_isarev during this loop, so hang
         * on to it. */
        SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));

        if(isa_hashes) {
            hv_iterinit(isa_hashes);
            while((iter = hv_iternext(isa_hashes))) {
                HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
                HV * const isa = (HV *)HeVAL(iter);
                const HEK *namehek;

                /* We're starting at the 2nd element, skipping revstash */
                linear_mro = mro_get_linear_isa(revstash);
                svp = AvARRAY(linear_mro) + 1;
                items = AvFILLp(linear_mro);

                namehek = HvENAME_HEK(revstash);
                if (!namehek) namehek = HvNAME_HEK(revstash);

                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 will need to upgrade it to an
                       HV (which sv_upgrade() can now do for us). */

                    mroisarev = MUTABLE_HV(HeVAL(he));

                    SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);

                    /* 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_storehek(mroisarev, namehek, &PL_sv_yes);
                }

                if ((SV *)isa != &PL_sv_undef) {
                    assert(namehek);
                    mro_clean_isarev(
                        isa, HEK_KEY(namehek), HEK_LEN(namehek),
                        HvMROMETA(revstash)->isa, HEK_HASH(namehek),
                        HEK_UTF8(namehek)
                    );
                }
            }
        }
    }

    /* Now iterate our MRO (parents), adding ourselves and 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 will need to upgrade it to an HV (which sv_upgrade() can
           now do for us. */

        mroisarev = MUTABLE_HV(HeVAL(he));

        SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);

        /* 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_storehek(mroisarev, stashhek, &PL_sv_yes);
    }

    /* Delete our name from our former parents' isarevs. */
    if(isa && HvARRAY(isa))
        mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
                         HEK_HASH(stashhek), HEK_UTF8(stashhek));
}
예제 #20
0
xh_int_t
xh_h2x_native_attr(xh_h2x_ctx_t *ctx, xh_char_t *key, I32 key_len, SV *value, xh_int_t flag)
{
    xh_uint_t       type;
    size_t          len, i, nattrs, done;
    xh_sort_hash_t *sorted_hash;
    SV             *item_value;
    xh_char_t      *item;
    I32             item_len;
    GV             *method;

    nattrs = 0;

    if (ctx->opts.content[0] != '\0' && xh_strcmp(key, ctx->opts.content) == 0)
        flag = flag | XH_H2X_F_CONTENT;

    value = xh_h2x_resolve_value(ctx, value, &type);

    if (type & XH_H2X_T_BLESSED && (method = gv_fetchmethod_autoload(SvSTASH(value), "iternext", 0)) != NULL) {
        if (!(flag & XH_H2X_F_COMPLEX)) goto FINISH;

        while (1) {
            item_value = xh_h2x_call_method(value, method);
            if (!SvOK(item_value)) break;
            (void) xh_h2x_native_attr(ctx, key, key_len, item_value, XH_H2X_F_SIMPLE | XH_H2X_F_COMPLEX);
            SvREFCNT_dec(item_value);
        }
        nattrs++;

        goto FINISH;
    }

    if (type & XH_H2X_T_SCALAR) {
        if (flag & XH_H2X_F_COMPLEX && (flag & XH_H2X_F_SIMPLE || type & XH_H2X_T_RAW)) {
            xh_xml_write_node(&ctx->writer, key, key_len, value, type & XH_H2X_T_RAW);
        }
        else if (flag & XH_H2X_F_COMPLEX && flag & XH_H2X_F_CONTENT) {
            xh_xml_write_content(&ctx->writer, value);
        }
        else if (flag & XH_H2X_F_SIMPLE && !(flag & XH_H2X_F_CONTENT) && !(type & XH_H2X_T_RAW)) {
            xh_xml_write_attribute(&ctx->writer, key, key_len, value);
            nattrs++;
        }
    }
    else if (type & XH_H2X_T_HASH) {
        if (!(flag & XH_H2X_F_COMPLEX)) goto FINISH;

        len = HvUSEDKEYS((SV *) value);
        if (len == 0) {
            xh_xml_write_empty_node(&ctx->writer, key, key_len);
            goto FINISH;
        }

        xh_xml_write_start_tag(&ctx->writer, key, key_len);

        done = 0;

        if (len > 1 && ctx->opts.canonical) {
            sorted_hash = xh_sort_hash((HV *) value, len);

            for (i = 0; i < len; i++) {
                done += xh_h2x_native_attr(ctx, sorted_hash[i].key, sorted_hash[i].key_len, sorted_hash[i].value, XH_H2X_F_SIMPLE);
            }

            if (done == len) {
                xh_xml_write_closed_end_tag(&ctx->writer);
            }
            else {
                xh_xml_write_end_tag(&ctx->writer);

                for (i = 0; i < len; i++) {
                    (void) xh_h2x_native_attr(ctx, sorted_hash[i].key, sorted_hash[i].key_len, sorted_hash[i].value, XH_H2X_F_COMPLEX);
                }

                xh_xml_write_end_node(&ctx->writer, key, key_len);
            }

            free(sorted_hash);
        }
        else {
            hv_iterinit((HV *) value);
            while ((item_value = hv_iternextsv((HV *) value, (char **) &item, &item_len))) {
                done += xh_h2x_native_attr(ctx, item, item_len,item_value, XH_H2X_F_SIMPLE);
            }

            if (done == len) {
                xh_xml_write_closed_end_tag(&ctx->writer);
            }
            else {
                xh_xml_write_end_tag(&ctx->writer);

                hv_iterinit((HV *) value);
                while ((item_value = hv_iternextsv((HV *) value, (char **) &item, &item_len))) {
                    (void) xh_h2x_native_attr(ctx, item, item_len,item_value, XH_H2X_F_COMPLEX);
                }

                xh_xml_write_end_node(&ctx->writer, key, key_len);
            }
        }

        nattrs++;
    }
    else if (type & XH_H2X_T_ARRAY) {
        if (!(flag & XH_H2X_F_COMPLEX)) goto FINISH;

        len = av_len((AV *) value) + 1;
        for (i = 0; i < len; i++) {
            (void) xh_h2x_native_attr(ctx, key, key_len, *av_fetch((AV *) value, i, 0), XH_H2X_F_SIMPLE | XH_H2X_F_COMPLEX);
        }

        nattrs++;
    }
    else {
        if (flag & XH_H2X_F_SIMPLE && flag & XH_H2X_F_COMPLEX) {
            xh_xml_write_empty_node(&ctx->writer, key, key_len);
        }
        else if (flag & XH_H2X_F_SIMPLE && !(flag & XH_H2X_F_CONTENT)) {
            xh_xml_write_attribute(&ctx->writer, key, key_len, NULL);
            nattrs++;
        }
    }

FINISH:
    ctx->depth--;

    return nattrs;
}