[p5sagit/p5-mst-13.2.git] / universal.c

/*    universal.c
 *
 *    Copyright (c) 1997-2002, Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 * "The roots of those mountains must be roots indeed; there must be
 * great secrets buried there which have not been discovered since the
 * beginning." --Gandalf, relating Gollum's story
 */

#include "EXTERN.h"
#define PERL_IN_UNIVERSAL_C
#include "perl.h"

/*
 * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
 * The main guts of traverse_isa was actually copied from gv_fetchmeth
 */

STATIC SV *
S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
             int len, int level)
{
    AV* av;
    GV* gv;
    GV** gvp;
    HV* hv = Nullhv;
    SV* subgen = Nullsv;

    /* A stash/class can go by many names (ie. User == main::User), so 
       we compare the stash itself just in case */
    if (name_stash && (stash == name_stash))
        return &PL_sv_yes;

    if (strEQ(HvNAME(stash), name))
	return &PL_sv_yes;

    if (level > 100)
	Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
		   HvNAME(stash));

    gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);

    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
	&& (hv = GvHV(gv)))
    {
	if (SvIV(subgen) == (IV)PL_sub_generation) {
	    SV* sv;
	    SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
	    if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
	        DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
				  name, HvNAME(stash)) );
		return sv;
	    }
	}
	else {
	    DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
			      HvNAME(stash)) );
	    hv_clear(hv);
	    sv_setiv(subgen, PL_sub_generation);
	}
    }

    gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);

    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
	if (!hv || !subgen) {
	    gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);

	    gv = *gvp;

	    if (SvTYPE(gv) != SVt_PVGV)
		gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);

	    if (!hv)
		hv = GvHVn(gv);
	    if (!subgen) {
		subgen = newSViv(PL_sub_generation);
		GvSV(gv) = subgen;
	    }
	}
	if (hv) {
	    SV** svp = AvARRAY(av);
	    /* NOTE: No support for tied ISA */
	    I32 items = AvFILLp(av) + 1;
	    while (items--) {
		SV* sv = *svp++;
		HV* basestash = gv_stashsv(sv, FALSE);
		if (!basestash) {
		    if (ckWARN(WARN_MISC))
			Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
		             "Can't locate package %s for @%s::ISA",
			    SvPVX(sv), HvNAME(stash));
		    continue;
		}
		if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, 
                                             len, level + 1)) {
		    (void)hv_store(hv,name,len,&PL_sv_yes,0);
		    return &PL_sv_yes;
		}
	    }
	    (void)hv_store(hv,name,len,&PL_sv_no,0);
	}
    }

    return boolSV(strEQ(name, "UNIVERSAL"));
}

/*
=head1 SV Manipulation Functions

=for apidoc sv_derived_from

Returns a boolean indicating whether the SV is derived from the specified
class.  This is the function that implements C<UNIVERSAL::isa>.  It works
for class names as well as for objects.

=cut
*/

bool
Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
{
    char *type;
    HV *stash;
    HV *name_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);
    }

    name_stash = gv_stashpv(name, FALSE);

    return (type && strEQ(type,name)) ||
            (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) 
             == &PL_sv_yes)
        ? TRUE
        : FALSE ;
}

#include "XSUB.h"

void XS_UNIVERSAL_isa(pTHX_ CV *cv);
void XS_UNIVERSAL_can(pTHX_ CV *cv);
void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
XS(XS_version_new);
XS(XS_version_stringify);
XS(XS_version_numify);
XS(XS_version_vcmp);
XS(XS_version_boolean);
XS(XS_version_noop);
XS(XS_utf8_valid);
XS(XS_utf8_encode);
XS(XS_utf8_decode);
XS(XS_utf8_upgrade);
XS(XS_utf8_downgrade);
XS(XS_utf8_unicode_to_native);
XS(XS_utf8_native_to_unicode);
XS(XS_Internals_SvREADONLY);
XS(XS_Internals_SvREFCNT);
XS(XS_Internals_hv_clear_placehold);

void
Perl_boot_core_UNIVERSAL(pTHX)
{
    char *file = __FILE__;

    newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
    newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
    newXS("UNIVERSAL::VERSION", 	XS_UNIVERSAL_VERSION, 	  file);
    {
	/* create the package stash for version objects */
	HV *hv = get_hv("version::OVERLOAD",TRUE);
	SV *sv = *hv_fetch(hv,"register",8,1);
	sv_inc(sv);
	SvSETMAGIC(sv);
	/* Make it findable via fetchmethod */
	newXS("version::new", XS_version_new, file);
	newXS("version::(\"\"", XS_version_stringify, file);
	newXS("version::stringify", XS_version_stringify, file);
	newXS("version::(0+", XS_version_numify, file);
	newXS("version::numify", XS_version_numify, file);
	newXS("version::(cmp", XS_version_vcmp, file);
	newXS("version::(<=>", XS_version_vcmp, file);
	newXS("version::vcmp", XS_version_vcmp, file);
	newXS("version::(bool", XS_version_boolean, file);
	newXS("version::boolean", XS_version_boolean, file);
	newXS("version::(nomethod", XS_version_noop, file);
	newXS("version::noop", XS_version_noop, file);
    }
    newXS("utf8::valid", XS_utf8_valid, file);
    newXS("utf8::encode", XS_utf8_encode, file);
    newXS("utf8::decode", XS_utf8_decode, file);
    newXS("utf8::upgrade", XS_utf8_upgrade, file);
    newXS("utf8::downgrade", XS_utf8_downgrade, file);
    newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
    newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
    newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
    newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
    newXSproto("Internals::hv_clear_placeholders",
               XS_Internals_hv_clear_placehold, file, "\\%");
}


XS(XS_UNIVERSAL_isa)
{
    dXSARGS;
    SV *sv;
    char *name;
    STRLEN n_a;

    if (items != 2)
	Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");

    sv = ST(0);

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

    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
	XSRETURN_UNDEF;

    name = (char *)SvPV(ST(1),n_a);

    ST(0) = boolSV(sv_derived_from(sv, name));
    XSRETURN(1);
}

XS(XS_UNIVERSAL_can)
{
    dXSARGS;
    SV   *sv;
    char *name;
    SV   *rv;
    HV   *pkg = NULL;
    STRLEN n_a;

    if (items != 2)
	Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");

    sv = ST(0);

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

    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
	XSRETURN_UNDEF;

    name = (char *)SvPV(ST(1),n_a);
    rv = &PL_sv_undef;

    if (SvROK(sv)) {
        sv = (SV*)SvRV(sv);
        if (SvOBJECT(sv))
            pkg = SvSTASH(sv);
    }
    else {
        pkg = gv_stashsv(sv, FALSE);
    }

    if (pkg) {
        GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
        if (gv && isGV(gv))
	    rv = sv_2mortal(newRV((SV*)GvCV(gv)));
    }

    ST(0) = rv;
    XSRETURN(1);
}

XS(XS_UNIVERSAL_VERSION)
{
    dXSARGS;
    HV *pkg;
    GV **gvp;
    GV *gv;
    SV *sv;
    char *undef;

    if (SvROK(ST(0))) {
        sv = (SV*)SvRV(ST(0));
        if (!SvOBJECT(sv))
            Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
        pkg = SvSTASH(sv);
    }
    else {
        pkg = gv_stashsv(ST(0), FALSE);
    }

    gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);

    if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
        SV *nsv = sv_newmortal();
        sv_setsv(nsv, sv);
        sv = nsv;
        undef = Nullch;
    }
    else {
        sv = (SV*)&PL_sv_undef;
        undef = "(undef)";
    }

    if (items > 1) {
	STRLEN len;
	SV *req = ST(1);

	if (undef) {
	     if (pkg)
		  Perl_croak(aTHX_
			     "%s does not define $%s::VERSION--version check failed",
			     HvNAME(pkg), HvNAME(pkg));
	     else {
		  char *str = SvPVx(ST(0), len);

		  Perl_croak(aTHX_
			     "%s defines neither package nor VERSION--version check failed", str);
	     }
	}
	if (!SvNIOK(sv) && SvPOK(sv)) {
	    char *str = SvPVx(sv,len);
	    while (len) {
		--len;
		/* XXX could DWIM "1.2.3" here */
		if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
		    break;
	    }
	    if (len) {
		if (SvNOK(req) && SvPOK(req)) {
		    /* they said C<use Foo v1.2.3> and $Foo::VERSION
		     * doesn't look like a float: do string compare */
		    if (sv_cmp(req,sv) == 1) {
			Perl_croak(aTHX_ "%s v%"VDf" required--"
				   "this is only v%"VDf,
				   HvNAME(pkg), req, sv);
		    }
		    goto finish;
		}
		/* they said C<use Foo 1.002_003> and $Foo::VERSION
		 * doesn't look like a float: force numeric compare */
		(void)SvUPGRADE(sv, SVt_PVNV);
		SvNVX(sv) = str_to_version(sv);
		SvPOK_off(sv);
		SvNOK_on(sv);
	    }
	}
	/* if we get here, we're looking for a numeric comparison,
	 * so force the required version into a float, even if they
	 * said C<use Foo v1.2.3> */
	if (SvNOK(req) && SvPOK(req)) {
	    NV n = SvNV(req);
	    req = sv_newmortal();
	    sv_setnv(req, n);
	}

	if (SvNV(req) > SvNV(sv))
	    Perl_croak(aTHX_ "%s version %s required--this is only version %s",
		       HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
    }

finish:
    ST(0) = sv;

    XSRETURN(1);
}

XS(XS_version_new)
{
    dXSARGS;
    if (items != 2)
	Perl_croak(aTHX_ "Usage: version::new(class, version)");
    SP -= items;
    {
/*	char *	class = (char *)SvPV_nolen(ST(0)); */
	SV *	version = ST(1);

{
    PUSHs(new_version(version));
}

	PUTBACK;
	return;
    }
}

XS(XS_version_stringify)
{
    dXSARGS;
    if (items < 1)
	Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
    SP -= items;
    {
	SV *	lobj;

        if (sv_derived_from(ST(0), "version")) {
                SV *tmp = SvRV(ST(0));
        	lobj = tmp;
        }
        else
                Perl_croak(aTHX_ "lobj is not of type version");

{
    SV  *vs = NEWSV(92,5);
    if ( lobj == SvRV(PL_patchlevel) )
	sv_catsv(vs,lobj);
    else
	vstringify(vs,lobj);
    PUSHs(vs);
}

	PUTBACK;
	return;
    }
}

XS(XS_version_numify)
{
    dXSARGS;
    if (items < 1)
	Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
    SP -= items;
    {
	SV *	lobj;

        if (sv_derived_from(ST(0), "version")) {
                SV *tmp = SvRV(ST(0));
        	lobj = tmp;
        }
        else
                Perl_croak(aTHX_ "lobj is not of type version");

{
    SV  *vs = NEWSV(92,5);
    vnumify(vs,lobj);
    PUSHs(vs);
}

	PUTBACK;
	return;
    }
}

XS(XS_version_vcmp)
{
    dXSARGS;
    if (items < 1)
	Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
    SP -= items;
    {
	SV *	lobj;

        if (sv_derived_from(ST(0), "version")) {
                SV *tmp = SvRV(ST(0));
        	lobj = tmp;
        }
        else
                Perl_croak(aTHX_ "lobj is not of type version");

{
    SV	*rs;
    SV	*rvs;
    SV * robj = ST(1);
    IV	 swap = (IV)SvIV(ST(2));

    if ( ! sv_derived_from(robj, "version") )
    {
	robj = new_version(robj);
    }
    rvs = SvRV(robj);

    if ( swap )
    {
        rs = newSViv(sv_cmp(rvs,lobj));
    }
    else
    {
        rs = newSViv(sv_cmp(lobj,rvs));
    }

    PUSHs(rs);
}

	PUTBACK;
	return;
    }
}

XS(XS_version_boolean)
{
    dXSARGS;
    if (items < 1)
	Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
    SP -= items;
    {
	SV *	lobj;

        if (sv_derived_from(ST(0), "version")) {
                SV *tmp = SvRV(ST(0));
        	lobj = tmp;
        }
        else
                Perl_croak(aTHX_ "lobj is not of type version");

{
    SV	*rs;
    rs = newSViv(sv_cmp(lobj,Nullsv));
    PUSHs(rs);
}

	PUTBACK;
	return;
    }
}

XS(XS_version_noop)
{
    dXSARGS;
    if (items < 1)
	Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
    {
	SV *	lobj;

        if (sv_derived_from(ST(0), "version")) {
                SV *tmp = SvRV(ST(0));
        	lobj = tmp;
        }
        else
                Perl_croak(aTHX_ "lobj is not of type version");

{
    Perl_croak(aTHX_ "operation not supported with version object");
}

    }
    XSRETURN_EMPTY;
}

XS(XS_utf8_valid)
{
    dXSARGS;
    if (items != 1)
	Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
    {
	SV *	sv = ST(0);
 {
  STRLEN len;
  char *s = SvPV(sv,len);
  if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
   XSRETURN_YES;
  else
   XSRETURN_NO;
 }
    }
    XSRETURN_EMPTY;
}

XS(XS_utf8_encode)
{
    dXSARGS;
    if (items != 1)
	Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
    {
	SV *	sv = ST(0);

	sv_utf8_encode(sv);
    }
    XSRETURN_EMPTY;
}

XS(XS_utf8_decode)
{
    dXSARGS;
    if (items != 1)
	Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
    {
	SV *	sv = ST(0);
	bool	RETVAL;

	RETVAL = sv_utf8_decode(sv);
	ST(0) = boolSV(RETVAL);
	sv_2mortal(ST(0));
    }
    XSRETURN(1);
}

XS(XS_utf8_upgrade)
{
    dXSARGS;
    if (items != 1)
	Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
    {
	SV *	sv = ST(0);
	STRLEN	RETVAL;
	dXSTARG;

	RETVAL = sv_utf8_upgrade(sv);
	XSprePUSH; PUSHi((IV)RETVAL);
    }
    XSRETURN(1);
}

XS(XS_utf8_downgrade)
{
    dXSARGS;
    if (items < 1 || items > 2)
	Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
    {
	SV *	sv = ST(0);
	bool	failok;
	bool	RETVAL;

	if (items < 2)
	    failok = 0;
	else {
	    failok = (int)SvIV(ST(1));
	}

	RETVAL = sv_utf8_downgrade(sv, failok);
	ST(0) = boolSV(RETVAL);
	sv_2mortal(ST(0));
    }
    XSRETURN(1);
}

XS(XS_utf8_native_to_unicode)
{
 dXSARGS;
 UV uv = SvUV(ST(0));

 if (items > 1)
     Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");

 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 XSRETURN(1);
}

XS(XS_utf8_unicode_to_native)
{
 dXSARGS;
 UV uv = SvUV(ST(0));

 if (items > 1)
     Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");

 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 XSRETURN(1);
}

XS(XS_Internals_SvREADONLY)	/* This is dangerous stuff. */
{
    dXSARGS;
    SV *sv = SvRV(ST(0));
    if (items == 1) {
	 if (SvREADONLY(sv))
	     XSRETURN_YES;
	 else
	     XSRETURN_NO;
    }
    else if (items == 2) {
	if (SvTRUE(ST(1))) {
	    SvREADONLY_on(sv);
	    XSRETURN_YES;
	}
	else {
	    /* I hope you really know what you are doing. */
	    SvREADONLY_off(sv);
	    XSRETURN_NO;
	}
    }
    XSRETURN_UNDEF; /* Can't happen. */
}

XS(XS_Internals_SvREFCNT)	/* This is dangerous stuff. */
{
    dXSARGS;
    SV *sv = SvRV(ST(0));
    if (items == 1)
	 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
    else if (items == 2) {
         /* I hope you really know what you are doing. */
	 SvREFCNT(sv) = SvIV(ST(1));
	 XSRETURN_IV(SvREFCNT(sv));
    }
    XSRETURN_UNDEF; /* Can't happen. */
}

/* Maybe this should return the number of placeholders found in scalar context,
   and a list of them in list context.  */
XS(XS_Internals_hv_clear_placehold)
{
    dXSARGS;
    HV *hv = (HV *) SvRV(ST(0));

    /* I don't care how many parameters were passed in, but I want to avoid
       the unused variable warning. */

    items = (I32)HvPLACEHOLDERS(hv);

    if (items) {
        HE *entry;
        I32 riter = HvRITER(hv);
        HE *eiter = HvEITER(hv);
        hv_iterinit(hv);
        /* This may look suboptimal with the items *after* the iternext, but
           it's quite deliberate. We only get here with items==0 if we've
           just deleted the last placeholder in the hash. If we've just done
           that then it means that the hash is in lazy delete mode, and the
           HE is now only referenced in our iterator. If we just quit the loop
           and discarded our iterator then the HE leaks. So we do the && the
           other way to ensure iternext is called just one more time, which
           has the side effect of triggering the lazy delete.  */
        while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
            && items) {
            SV *val = hv_iterval(hv, entry);

            if (val == &PL_sv_undef) {

                /* It seems that I have to go back in the front of the hash
                   API to delete a hash, even though I have a HE structure
                   pointing to the very entry I want to delete, and could hold
                   onto the previous HE that points to it. And it's easier to
                   go in with SVs as I can then specify the precomputed hash,
                   and don't have fun and games with utf8 keys.  */
                SV *key = hv_iterkeysv(entry);

                hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
                items--;
            }
        }
        HvRITER(hv) = riter;
        HvEITER(hv) = eiter;
    }

    XSRETURN(0);
}
Commit	Line	Data
d6376244	1	/* universal.c
	2	*
	3	* Copyright (c) 1997-2002, Larry Wall
	4	*
	5	* You may distribute under the terms of either the GNU General Public
	6	* License or the Artistic License, as specified in the README file.
	7	*
	8	*/
	9
d31a8517	10	/*
	11	* "The roots of those mountains must be roots indeed; there must be
	12	* great secrets buried there which have not been discovered since the
	13	* beginning." --Gandalf, relating Gollum's story
	14	*/
	15
6d4a7be2	16	#include "EXTERN.h"
864dbfa3	17	#define PERL_IN_UNIVERSAL_C
6d4a7be2	18	#include "perl.h"
6d4a7be2	19
	20	/*
	21	* Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
	22	* The main guts of traverse_isa was actually copied from gv_fetchmeth
	23	*/
	24
76e3520e	25	STATIC SV *
301daebc	26	S_isa_lookup(pTHX_ HV stash, const char name, HV* name_stash,
301daebc	27	int len, int level)
6d4a7be2	28	{
	29	AV* av;
	30	GV* gv;
	31	GV** gvp;
	32	HV* hv = Nullhv;
46e4b22b	33	SV* subgen = Nullsv;
6d4a7be2	34
301daebc	35	/* A stash/class can go by many names (ie. User == main::User), so
	36	we compare the stash itself just in case */
	37	if (name_stash && (stash == name_stash))
	38	return &PL_sv_yes;
6d4a7be2	39
46e4b22b	40	if (strEQ(HvNAME(stash), name))
3280af22	41	return &PL_sv_yes;
6d4a7be2	42
6d4a7be2	43	if (level > 100)
46e4b22b	44	Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
46e4b22b	45	HvNAME(stash));
6d4a7be2	46
	47	gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
	48
46e4b22b	49	if (gvp && (gv = gvp) != (GV)&PL_sv_undef && (subgen = GvSV(gv))
	50	&& (hv = GvHV(gv)))
	51	{
eb160463	52	if (SvIV(subgen) == (IV)PL_sub_generation) {
46e4b22b	53	SV* sv;
	54	SV svp = (SV)hv_fetch(hv, name, len, FALSE);
	55	if (svp && (sv = svp) != (SV)&PL_sv_undef) {
	56	DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
	57	name, HvNAME(stash)) );
	58	return sv;
	59	}
	60	}
	61	else {
	62	DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
	63	HvNAME(stash)) );
	64	hv_clear(hv);
	65	sv_setiv(subgen, PL_sub_generation);
	66	}
6d4a7be2	67	}
	68
	69	gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
46e4b22b	70
3280af22	71	if (gvp && (gv = gvp) != (GV)&PL_sv_undef && (av = GvAV(gv))) {
46e4b22b	72	if (!hv \|\| !subgen) {
6d4a7be2	73	gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
	74
	75	gv = *gvp;
	76
	77	if (SvTYPE(gv) != SVt_PVGV)
	78	gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
	79
46e4b22b	80	if (!hv)
	81	hv = GvHVn(gv);
	82	if (!subgen) {
	83	subgen = newSViv(PL_sub_generation);
	84	GvSV(gv) = subgen;
	85	}
6d4a7be2	86	}
46e4b22b	87	if (hv) {
6d4a7be2	88	SV** svp = AvARRAY(av);
93965878	89	/* NOTE: No support for tied ISA */
93965878	90	I32 items = AvFILLp(av) + 1;
6d4a7be2	91	while (items--) {
	92	SV* sv = *svp++;
	93	HV* basestash = gv_stashsv(sv, FALSE);
	94	if (!basestash) {
599cee73	95	if (ckWARN(WARN_MISC))
9014280d	96	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
599cee73	97	"Can't locate package %s for @%s::ISA",
6d4a7be2	98	SvPVX(sv), HvNAME(stash));
	99	continue;
	100	}
301daebc	101	if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
301daebc	102	len, level + 1)) {
3280af22	103	(void)hv_store(hv,name,len,&PL_sv_yes,0);
3280af22	104	return &PL_sv_yes;
6d4a7be2	105	}
6d4a7be2	106	}
3280af22	107	(void)hv_store(hv,name,len,&PL_sv_no,0);
6d4a7be2	108	}
	109	}
	110
e09f3e01	111	return boolSV(strEQ(name, "UNIVERSAL"));
6d4a7be2	112	}
6d4a7be2	113
954c1994	114	/*
ccfc67b7	115	=head1 SV Manipulation Functions
ccfc67b7	116
954c1994	117	=for apidoc sv_derived_from
	118
	119	Returns a boolean indicating whether the SV is derived from the specified
	120	class. This is the function that implements C<UNIVERSAL::isa>. It works
	121	for class names as well as for objects.
	122
	123	=cut
	124	*/
	125
55497cff	126	bool
864dbfa3	127	Perl_sv_derived_from(pTHX_ SV sv, const char name)
55497cff	128	{
55497cff	129	char *type;
55497cff	130	HV *stash;
301daebc	131	HV *name_stash;
46e4b22b	132
55497cff	133	stash = Nullhv;
55497cff	134	type = Nullch;
46e4b22b	135
55497cff	136	if (SvGMAGICAL(sv))
	137	mg_get(sv) ;
	138
	139	if (SvROK(sv)) {
	140	sv = SvRV(sv);
	141	type = sv_reftype(sv,0);
46e4b22b	142	if (SvOBJECT(sv))
55497cff	143	stash = SvSTASH(sv);
	144	}
	145	else {
	146	stash = gv_stashsv(sv, FALSE);
	147	}
46e4b22b	148
301daebc	149	name_stash = gv_stashpv(name, FALSE);
301daebc	150
55497cff	151	return (type && strEQ(type,name)) \|\|
301daebc	152	(stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
301daebc	153	== &PL_sv_yes)
55497cff	154	? TRUE
55497cff	155	: FALSE ;
55497cff	156	}
55497cff	157
1b026014	158	#include "XSUB.h"
1b026014	159
acfe0abc	160	void XS_UNIVERSAL_isa(pTHX_ CV *cv);
	161	void XS_UNIVERSAL_can(pTHX_ CV *cv);
	162	void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
439cb1c4	163	XS(XS_version_new);
	164	XS(XS_version_stringify);
	165	XS(XS_version_numify);
	166	XS(XS_version_vcmp);
	167	XS(XS_version_boolean);
	168	XS(XS_version_noop);
1b026014	169	XS(XS_utf8_valid);
	170	XS(XS_utf8_encode);
	171	XS(XS_utf8_decode);
	172	XS(XS_utf8_upgrade);
	173	XS(XS_utf8_downgrade);
	174	XS(XS_utf8_unicode_to_native);
	175	XS(XS_utf8_native_to_unicode);
29569577	176	XS(XS_Internals_SvREADONLY);
29569577	177	XS(XS_Internals_SvREFCNT);
f044d0d1	178	XS(XS_Internals_hv_clear_placehold);
0cb96387	179
	180	void
	181	Perl_boot_core_UNIVERSAL(pTHX)
	182	{
	183	char *file = __FILE__;
	184
	185	newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
	186	newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
	187	newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
439cb1c4	188	{
	189	/* create the package stash for version objects */
	190	HV *hv = get_hv("version::OVERLOAD",TRUE);
	191	SV sv = hv_fetch(hv,"register",8,1);
	192	sv_inc(sv);
	193	SvSETMAGIC(sv);
	194	/* Make it findable via fetchmethod */
439cb1c4	195	newXS("version::new", XS_version_new, file);
	196	newXS("version::(\"\"", XS_version_stringify, file);
	197	newXS("version::stringify", XS_version_stringify, file);
	198	newXS("version::(0+", XS_version_numify, file);
	199	newXS("version::numify", XS_version_numify, file);
	200	newXS("version::(cmp", XS_version_vcmp, file);
	201	newXS("version::(<=>", XS_version_vcmp, file);
	202	newXS("version::vcmp", XS_version_vcmp, file);
	203	newXS("version::(bool", XS_version_boolean, file);
	204	newXS("version::boolean", XS_version_boolean, file);
	205	newXS("version::(nomethod", XS_version_noop, file);
	206	newXS("version::noop", XS_version_noop, file);
	207	}
1b026014	208	newXS("utf8::valid", XS_utf8_valid, file);
	209	newXS("utf8::encode", XS_utf8_encode, file);
	210	newXS("utf8::decode", XS_utf8_decode, file);
	211	newXS("utf8::upgrade", XS_utf8_upgrade, file);
	212	newXS("utf8::downgrade", XS_utf8_downgrade, file);
	213	newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
	214	newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577	215	newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
29569577	216	newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f	217	newXSproto("Internals::hv_clear_placeholders",
f044d0d1	218	XS_Internals_hv_clear_placehold, file, "\\%");
0cb96387	219	}
0cb96387	220
55497cff	221
6d4a7be2	222	XS(XS_UNIVERSAL_isa)
	223	{
	224	dXSARGS;
55497cff	225	SV *sv;
55497cff	226	char *name;
2d8e6c8d	227	STRLEN n_a;
6d4a7be2	228
6d4a7be2	229	if (items != 2)
cea2e8a9	230	Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2	231
6d4a7be2	232	sv = ST(0);
f8f70380	233
d3f7f2b2	234	if (SvGMAGICAL(sv))
	235	mg_get(sv);
	236
aca069ec	237	if (!SvOK(sv) \|\| !(SvROK(sv) \|\| (SvPOK(sv) && SvCUR(sv))))
f8f70380	238	XSRETURN_UNDEF;
f8f70380	239
2d8e6c8d	240	name = (char *)SvPV(ST(1),n_a);
6d4a7be2	241
54310121	242	ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2	243	XSRETURN(1);
	244	}
	245
6d4a7be2	246	XS(XS_UNIVERSAL_can)
	247	{
	248	dXSARGS;
	249	SV *sv;
	250	char *name;
	251	SV *rv;
6f08146e	252	HV *pkg = NULL;
2d8e6c8d	253	STRLEN n_a;
6d4a7be2	254
6d4a7be2	255	if (items != 2)
cea2e8a9	256	Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2	257
6d4a7be2	258	sv = ST(0);
f8f70380	259
d3f7f2b2	260	if (SvGMAGICAL(sv))
	261	mg_get(sv);
	262
aca069ec	263	if (!SvOK(sv) \|\| !(SvROK(sv) \|\| (SvPOK(sv) && SvCUR(sv))))
f8f70380	264	XSRETURN_UNDEF;
f8f70380	265
2d8e6c8d	266	name = (char *)SvPV(ST(1),n_a);
3280af22	267	rv = &PL_sv_undef;
6d4a7be2	268
46e4b22b	269	if (SvROK(sv)) {
6f08146e	270	sv = (SV*)SvRV(sv);
46e4b22b	271	if (SvOBJECT(sv))
6f08146e	272	pkg = SvSTASH(sv);
	273	}
	274	else {
	275	pkg = gv_stashsv(sv, FALSE);
	276	}
	277
	278	if (pkg) {
dc848c6f	279	GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
	280	if (gv && isGV(gv))
	281	rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2	282	}
	283
	284	ST(0) = rv;
	285	XSRETURN(1);
	286	}
	287
6d4a7be2	288	XS(XS_UNIVERSAL_VERSION)
	289	{
	290	dXSARGS;
	291	HV *pkg;
	292	GV **gvp;
	293	GV *gv;
	294	SV *sv;
	295	char *undef;
	296
1571675a	297	if (SvROK(ST(0))) {
6d4a7be2	298	sv = (SV*)SvRV(ST(0));
1571675a	299	if (!SvOBJECT(sv))
cea2e8a9	300	Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2	301	pkg = SvSTASH(sv);
	302	}
	303	else {
	304	pkg = gv_stashsv(ST(0), FALSE);
	305	}
	306
	307	gvp = pkg ? (GV)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV);
	308
d4bea2fb	309	if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2	310	SV *nsv = sv_newmortal();
	311	sv_setsv(nsv, sv);
	312	sv = nsv;
	313	undef = Nullch;
	314	}
	315	else {
3280af22	316	sv = (SV*)&PL_sv_undef;
6d4a7be2	317	undef = "(undef)";
	318	}
	319
1571675a	320	if (items > 1) {
	321	STRLEN len;
	322	SV *req = ST(1);
	323
62658f4d	324	if (undef) {
	325	if (pkg)
	326	Perl_croak(aTHX_
	327	"%s does not define $%s::VERSION--version check failed",
	328	HvNAME(pkg), HvNAME(pkg));
	329	else {
	330	char *str = SvPVx(ST(0), len);
	331
	332	Perl_croak(aTHX_
	333	"%s defines neither package nor VERSION--version check failed", str);
	334	}
	335	}
1571675a	336	if (!SvNIOK(sv) && SvPOK(sv)) {
	337	char *str = SvPVx(sv,len);
	338	while (len) {
	339	--len;
	340	/* XXX could DWIM "1.2.3" here */
	341	if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
	342	break;
	343	}
	344	if (len) {
4305d8ab	345	if (SvNOK(req) && SvPOK(req)) {
1571675a	346	/* they said C<use Foo v1.2.3> and $Foo::VERSION
	347	* doesn't look like a float: do string compare */
	348	if (sv_cmp(req,sv) == 1) {
d2560b70	349	Perl_croak(aTHX_ "%s v%"VDf" required--"
d2560b70	350	"this is only v%"VDf,
1571675a	351	HvNAME(pkg), req, sv);
	352	}
	353	goto finish;
	354	}
	355	/* they said C<use Foo 1.002_003> and $Foo::VERSION
	356	* doesn't look like a float: force numeric compare */
155aba94	357	(void)SvUPGRADE(sv, SVt_PVNV);
1571675a	358	SvNVX(sv) = str_to_version(sv);
	359	SvPOK_off(sv);
	360	SvNOK_on(sv);
	361	}
	362	}
	363	/* if we get here, we're looking for a numeric comparison,
	364	* so force the required version into a float, even if they
	365	* said C<use Foo v1.2.3> */
4305d8ab	366	if (SvNOK(req) && SvPOK(req)) {
1571675a	367	NV n = SvNV(req);
	368	req = sv_newmortal();
	369	sv_setnv(req, n);
	370	}
	371
f6eb1a96	372	if (SvNV(req) > SvNV(sv))
1571675a	373	Perl_croak(aTHX_ "%s version %s required--this is only version %s",
f6eb1a96	374	HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
2d8e6c8d	375	}
6d4a7be2	376
1571675a	377	finish:
6d4a7be2	378	ST(0) = sv;
	379
	380	XSRETURN(1);
	381	}
	382
439cb1c4	383	XS(XS_version_new)
	384	{
	385	dXSARGS;
	386	if (items != 2)
	387	Perl_croak(aTHX_ "Usage: version::new(class, version)");
	388	SP -= items;
	389	{
	390	/* char * class = (char )SvPV_nolen(ST(0)); /
	391	SV * version = ST(1);
	392
	393	{
	394	PUSHs(new_version(version));
	395	}
	396
	397	PUTBACK;
	398	return;
	399	}
	400	}
	401
	402	XS(XS_version_stringify)
	403	{
	404	dXSARGS;
	405	if (items < 1)
	406	Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
	407	SP -= items;
	408	{
	409	SV * lobj;
	410
	411	if (sv_derived_from(ST(0), "version")) {
	412	SV *tmp = SvRV(ST(0));
	413	lobj = tmp;
	414	}
	415	else
ba329e04	416	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	417
	418	{
	419	SV *vs = NEWSV(92,5);
	420	if ( lobj == SvRV(PL_patchlevel) )
	421	sv_catsv(vs,lobj);
	422	else
	423	vstringify(vs,lobj);
	424	PUSHs(vs);
	425	}
	426
	427	PUTBACK;
	428	return;
	429	}
	430	}
	431
	432	XS(XS_version_numify)
	433	{
	434	dXSARGS;
	435	if (items < 1)
	436	Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
	437	SP -= items;
	438	{
	439	SV * lobj;
	440
	441	if (sv_derived_from(ST(0), "version")) {
	442	SV *tmp = SvRV(ST(0));
	443	lobj = tmp;
	444	}
	445	else
ba329e04	446	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	447
	448	{
	449	SV *vs = NEWSV(92,5);
	450	vnumify(vs,lobj);
	451	PUSHs(vs);
	452	}
	453
	454	PUTBACK;
	455	return;
	456	}
	457	}
	458
	459	XS(XS_version_vcmp)
	460	{
	461	dXSARGS;
	462	if (items < 1)
	463	Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
	464	SP -= items;
	465	{
	466	SV * lobj;
	467
	468	if (sv_derived_from(ST(0), "version")) {
	469	SV *tmp = SvRV(ST(0));
	470	lobj = tmp;
	471	}
	472	else
ba329e04	473	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	474
	475	{
	476	SV *rs;
	477	SV *rvs;
	478	SV * robj = ST(1);
	479	IV swap = (IV)SvIV(ST(2));
	480
	481	if ( ! sv_derived_from(robj, "version") )
	482	{
	483	robj = new_version(robj);
	484	}
	485	rvs = SvRV(robj);
	486
	487	if ( swap )
	488	{
	489	rs = newSViv(sv_cmp(rvs,lobj));
	490	}
	491	else
	492	{
	493	rs = newSViv(sv_cmp(lobj,rvs));
	494	}
	495
	496	PUSHs(rs);
	497	}
	498
	499	PUTBACK;
	500	return;
	501	}
	502	}
	503
	504	XS(XS_version_boolean)
	505	{
	506	dXSARGS;
	507	if (items < 1)
	508	Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
	509	SP -= items;
	510	{
	511	SV * lobj;
	512
	513	if (sv_derived_from(ST(0), "version")) {
	514	SV *tmp = SvRV(ST(0));
	515	lobj = tmp;
	516	}
	517	else
ba329e04	518	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	519
	520	{
	521	SV *rs;
	522	rs = newSViv(sv_cmp(lobj,Nullsv));
	523	PUSHs(rs);
	524	}
	525
	526	PUTBACK;
	527	return;
	528	}
	529	}
	530
	531	XS(XS_version_noop)
	532	{
	533	dXSARGS;
	534	if (items < 1)
	535	Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
	536	{
	537	SV * lobj;
	538
	539	if (sv_derived_from(ST(0), "version")) {
	540	SV *tmp = SvRV(ST(0));
	541	lobj = tmp;
	542	}
	543	else
ba329e04	544	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	545
439cb1c4	546	{
ba329e04	547	Perl_croak(aTHX_ "operation not supported with version object");
439cb1c4	548	}
	549
	550	}
	551	XSRETURN_EMPTY;
	552	}
	553
1b026014	554	XS(XS_utf8_valid)
	555	{
	556	dXSARGS;
	557	if (items != 1)
	558	Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
	559	{
	560	SV * sv = ST(0);
	561	{
	562	STRLEN len;
	563	char *s = SvPV(sv,len);
	564	if (!SvUTF8(sv) \|\| is_utf8_string((U8*)s,len))
	565	XSRETURN_YES;
	566	else
	567	XSRETURN_NO;
	568	}
	569	}
	570	XSRETURN_EMPTY;
	571	}
	572
	573	XS(XS_utf8_encode)
	574	{
	575	dXSARGS;
	576	if (items != 1)
	577	Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
	578	{
	579	SV * sv = ST(0);
	580
	581	sv_utf8_encode(sv);
	582	}
	583	XSRETURN_EMPTY;
	584	}
	585
	586	XS(XS_utf8_decode)
	587	{
	588	dXSARGS;
	589	if (items != 1)
	590	Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
	591	{
	592	SV * sv = ST(0);
	593	bool RETVAL;
	594
	595	RETVAL = sv_utf8_decode(sv);
	596	ST(0) = boolSV(RETVAL);
	597	sv_2mortal(ST(0));
	598	}
	599	XSRETURN(1);
	600	}
	601
	602	XS(XS_utf8_upgrade)
	603	{
	604	dXSARGS;
	605	if (items != 1)
	606	Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
	607	{
	608	SV * sv = ST(0);
	609	STRLEN RETVAL;
	610	dXSTARG;
	611
	612	RETVAL = sv_utf8_upgrade(sv);
	613	XSprePUSH; PUSHi((IV)RETVAL);
	614	}
	615	XSRETURN(1);
	616	}
	617
618	XS(XS_utf8_downgrade)
619	{
620	dXSARGS;
621	if (items < 1 \|\| items > 2)
622	Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
623	{
624	SV * sv = ST(0);
625	bool failok;
626	bool RETVAL;
627
628	if (items < 2)
629	failok = 0;
630	else {
631	failok = (int)SvIV(ST(1));
632	}
633
634	RETVAL = sv_utf8_downgrade(sv, failok);
635	ST(0) = boolSV(RETVAL);
636	sv_2mortal(ST(0));
637	}
638	XSRETURN(1);
639	}
640
641	XS(XS_utf8_native_to_unicode)
642	{
643	dXSARGS;
644	UV uv = SvUV(ST(0));
b7953727	645
	646	if (items > 1)
	647	Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
	648
1b026014	649	ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
	650	XSRETURN(1);
	651	}
	652
	653	XS(XS_utf8_unicode_to_native)
	654	{
	655	dXSARGS;
	656	UV uv = SvUV(ST(0));
b7953727	657
	658	if (items > 1)
	659	Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
	660
1b026014	661	ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
	662	XSRETURN(1);
	663	}
	664
14a976d6	665	XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577	666	{
	667	dXSARGS;
	668	SV *sv = SvRV(ST(0));
	669	if (items == 1) {
	670	if (SvREADONLY(sv))
	671	XSRETURN_YES;
	672	else
	673	XSRETURN_NO;
	674	}
	675	else if (items == 2) {
	676	if (SvTRUE(ST(1))) {
	677	SvREADONLY_on(sv);
	678	XSRETURN_YES;
	679	}
	680	else {
14a976d6	681	/* I hope you really know what you are doing. */
29569577	682	SvREADONLY_off(sv);
	683	XSRETURN_NO;
	684	}
	685	}
14a976d6	686	XSRETURN_UNDEF; /* Can't happen. */
29569577	687	}
29569577	688
14a976d6	689	XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577	690	{
	691	dXSARGS;
	692	SV *sv = SvRV(ST(0));
	693	if (items == 1)
14a976d6	694	XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577	695	else if (items == 2) {
14a976d6	696	/* I hope you really know what you are doing. */
29569577	697	SvREFCNT(sv) = SvIV(ST(1));
	698	XSRETURN_IV(SvREFCNT(sv));
	699	}
14a976d6	700	XSRETURN_UNDEF; /* Can't happen. */
29569577	701	}
29569577	702
dfd4ef2f	703	/* Maybe this should return the number of placeholders found in scalar context,
dfd4ef2f	704	and a list of them in list context. */
f044d0d1	705	XS(XS_Internals_hv_clear_placehold)
dfd4ef2f	706	{
	707	dXSARGS;
	708	HV hv = (HV ) SvRV(ST(0));
	709
	710	/* I don't care how many parameters were passed in, but I want to avoid
	711	the unused variable warning. */
	712
eb160463	713	items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f	714
	715	if (items) {
	716	HE *entry;
	717	I32 riter = HvRITER(hv);
	718	HE *eiter = HvEITER(hv);
	719	hv_iterinit(hv);
fe7bca90	720	/* This may look suboptimal with the items after the iternext, but
	721	it's quite deliberate. We only get here with items==0 if we've
	722	just deleted the last placeholder in the hash. If we've just done
	723	that then it means that the hash is in lazy delete mode, and the
	724	HE is now only referenced in our iterator. If we just quit the loop
	725	and discarded our iterator then the HE leaks. So we do the && the
	726	other way to ensure iternext is called just one more time, which
	727	has the side effect of triggering the lazy delete. */
	728	while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
	729	&& items) {
dfd4ef2f	730	SV *val = hv_iterval(hv, entry);
	731
	732	if (val == &PL_sv_undef) {
	733
	734	/* It seems that I have to go back in the front of the hash
	735	API to delete a hash, even though I have a HE structure
	736	pointing to the very entry I want to delete, and could hold
	737	onto the previous HE that points to it. And it's easier to
	738	go in with SVs as I can then specify the precomputed hash,
	739	and don't have fun and games with utf8 keys. */
	740	SV *key = hv_iterkeysv(entry);
	741
	742	hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
	743	items--;
	744	}
	745	}
	746	HvRITER(hv) = riter;
	747	HvEITER(hv) = eiter;
	748	}
	749
	750	XSRETURN(0);
	751	}