[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::()", XS_version_noop, file);
	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 */
be2ebcad	195	newXS("version::()", XS_version_noop, file);
439cb1c4	196	newXS("version::new", XS_version_new, file);
	197	newXS("version::(\"\"", XS_version_stringify, file);
	198	newXS("version::stringify", XS_version_stringify, file);
	199	newXS("version::(0+", XS_version_numify, file);
	200	newXS("version::numify", XS_version_numify, file);
	201	newXS("version::(cmp", XS_version_vcmp, file);
	202	newXS("version::(<=>", XS_version_vcmp, file);
	203	newXS("version::vcmp", XS_version_vcmp, file);
	204	newXS("version::(bool", XS_version_boolean, file);
	205	newXS("version::boolean", XS_version_boolean, file);
	206	newXS("version::(nomethod", XS_version_noop, file);
	207	newXS("version::noop", XS_version_noop, file);
	208	}
1b026014	209	newXS("utf8::valid", XS_utf8_valid, file);
	210	newXS("utf8::encode", XS_utf8_encode, file);
	211	newXS("utf8::decode", XS_utf8_decode, file);
	212	newXS("utf8::upgrade", XS_utf8_upgrade, file);
	213	newXS("utf8::downgrade", XS_utf8_downgrade, file);
	214	newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
	215	newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577	216	newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
29569577	217	newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f	218	newXSproto("Internals::hv_clear_placeholders",
f044d0d1	219	XS_Internals_hv_clear_placehold, file, "\\%");
0cb96387	220	}
0cb96387	221
55497cff	222
6d4a7be2	223	XS(XS_UNIVERSAL_isa)
	224	{
	225	dXSARGS;
55497cff	226	SV *sv;
55497cff	227	char *name;
2d8e6c8d	228	STRLEN n_a;
6d4a7be2	229
6d4a7be2	230	if (items != 2)
cea2e8a9	231	Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2	232
6d4a7be2	233	sv = ST(0);
f8f70380	234
d3f7f2b2	235	if (SvGMAGICAL(sv))
	236	mg_get(sv);
	237
aca069ec	238	if (!SvOK(sv) \|\| !(SvROK(sv) \|\| (SvPOK(sv) && SvCUR(sv))))
f8f70380	239	XSRETURN_UNDEF;
f8f70380	240
2d8e6c8d	241	name = (char *)SvPV(ST(1),n_a);
6d4a7be2	242
54310121	243	ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2	244	XSRETURN(1);
	245	}
	246
6d4a7be2	247	XS(XS_UNIVERSAL_can)
	248	{
	249	dXSARGS;
	250	SV *sv;
	251	char *name;
	252	SV *rv;
6f08146e	253	HV *pkg = NULL;
2d8e6c8d	254	STRLEN n_a;
6d4a7be2	255
6d4a7be2	256	if (items != 2)
cea2e8a9	257	Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2	258
6d4a7be2	259	sv = ST(0);
f8f70380	260
d3f7f2b2	261	if (SvGMAGICAL(sv))
	262	mg_get(sv);
	263
aca069ec	264	if (!SvOK(sv) \|\| !(SvROK(sv) \|\| (SvPOK(sv) && SvCUR(sv))))
f8f70380	265	XSRETURN_UNDEF;
f8f70380	266
2d8e6c8d	267	name = (char *)SvPV(ST(1),n_a);
3280af22	268	rv = &PL_sv_undef;
6d4a7be2	269
46e4b22b	270	if (SvROK(sv)) {
6f08146e	271	sv = (SV*)SvRV(sv);
46e4b22b	272	if (SvOBJECT(sv))
6f08146e	273	pkg = SvSTASH(sv);
	274	}
	275	else {
	276	pkg = gv_stashsv(sv, FALSE);
	277	}
	278
	279	if (pkg) {
dc848c6f	280	GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
	281	if (gv && isGV(gv))
	282	rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2	283	}
	284
	285	ST(0) = rv;
	286	XSRETURN(1);
	287	}
	288
6d4a7be2	289	XS(XS_UNIVERSAL_VERSION)
	290	{
	291	dXSARGS;
	292	HV *pkg;
	293	GV **gvp;
	294	GV *gv;
	295	SV *sv;
	296	char *undef;
	297
1571675a	298	if (SvROK(ST(0))) {
6d4a7be2	299	sv = (SV*)SvRV(ST(0));
1571675a	300	if (!SvOBJECT(sv))
cea2e8a9	301	Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2	302	pkg = SvSTASH(sv);
	303	}
	304	else {
	305	pkg = gv_stashsv(ST(0), FALSE);
	306	}
	307
	308	gvp = pkg ? (GV)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV);
	309
d4bea2fb	310	if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2	311	SV *nsv = sv_newmortal();
	312	sv_setsv(nsv, sv);
	313	sv = nsv;
	314	undef = Nullch;
	315	}
	316	else {
3280af22	317	sv = (SV*)&PL_sv_undef;
6d4a7be2	318	undef = "(undef)";
	319	}
	320
1571675a	321	if (items > 1) {
	322	STRLEN len;
	323	SV *req = ST(1);
	324
62658f4d	325	if (undef) {
	326	if (pkg)
	327	Perl_croak(aTHX_
	328	"%s does not define $%s::VERSION--version check failed",
	329	HvNAME(pkg), HvNAME(pkg));
	330	else {
	331	char *str = SvPVx(ST(0), len);
	332
	333	Perl_croak(aTHX_
	334	"%s defines neither package nor VERSION--version check failed", str);
	335	}
	336	}
1571675a	337	if (!SvNIOK(sv) && SvPOK(sv)) {
	338	char *str = SvPVx(sv,len);
	339	while (len) {
	340	--len;
	341	/* XXX could DWIM "1.2.3" here */
	342	if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
	343	break;
	344	}
	345	if (len) {
4305d8ab	346	if (SvNOK(req) && SvPOK(req)) {
1571675a	347	/* they said C<use Foo v1.2.3> and $Foo::VERSION
	348	* doesn't look like a float: do string compare */
	349	if (sv_cmp(req,sv) == 1) {
d2560b70	350	Perl_croak(aTHX_ "%s v%"VDf" required--"
d2560b70	351	"this is only v%"VDf,
1571675a	352	HvNAME(pkg), req, sv);
	353	}
	354	goto finish;
	355	}
	356	/* they said C<use Foo 1.002_003> and $Foo::VERSION
	357	* doesn't look like a float: force numeric compare */
155aba94	358	(void)SvUPGRADE(sv, SVt_PVNV);
1571675a	359	SvNVX(sv) = str_to_version(sv);
	360	SvPOK_off(sv);
	361	SvNOK_on(sv);
	362	}
	363	}
	364	/* if we get here, we're looking for a numeric comparison,
	365	* so force the required version into a float, even if they
	366	* said C<use Foo v1.2.3> */
4305d8ab	367	if (SvNOK(req) && SvPOK(req)) {
1571675a	368	NV n = SvNV(req);
	369	req = sv_newmortal();
	370	sv_setnv(req, n);
	371	}
	372
f6eb1a96	373	if (SvNV(req) > SvNV(sv))
1571675a	374	Perl_croak(aTHX_ "%s version %s required--this is only version %s",
f6eb1a96	375	HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
2d8e6c8d	376	}
6d4a7be2	377
1571675a	378	finish:
6d4a7be2	379	ST(0) = sv;
	380
	381	XSRETURN(1);
	382	}
	383
439cb1c4	384	XS(XS_version_new)
	385	{
	386	dXSARGS;
	387	if (items != 2)
	388	Perl_croak(aTHX_ "Usage: version::new(class, version)");
	389	SP -= items;
	390	{
	391	/* char * class = (char )SvPV_nolen(ST(0)); /
	392	SV * version = ST(1);
	393
	394	{
	395	PUSHs(new_version(version));
	396	}
	397
	398	PUTBACK;
	399	return;
	400	}
	401	}
	402
	403	XS(XS_version_stringify)
	404	{
	405	dXSARGS;
	406	if (items < 1)
	407	Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
	408	SP -= items;
	409	{
	410	SV * lobj;
	411
	412	if (sv_derived_from(ST(0), "version")) {
	413	SV *tmp = SvRV(ST(0));
	414	lobj = tmp;
	415	}
	416	else
ba329e04	417	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	418
	419	{
	420	SV *vs = NEWSV(92,5);
	421	if ( lobj == SvRV(PL_patchlevel) )
	422	sv_catsv(vs,lobj);
	423	else
	424	vstringify(vs,lobj);
	425	PUSHs(vs);
	426	}
	427
	428	PUTBACK;
	429	return;
	430	}
	431	}
	432
	433	XS(XS_version_numify)
	434	{
	435	dXSARGS;
	436	if (items < 1)
	437	Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
	438	SP -= items;
	439	{
	440	SV * lobj;
	441
	442	if (sv_derived_from(ST(0), "version")) {
	443	SV *tmp = SvRV(ST(0));
	444	lobj = tmp;
	445	}
	446	else
ba329e04	447	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	448
	449	{
	450	SV *vs = NEWSV(92,5);
	451	vnumify(vs,lobj);
	452	PUSHs(vs);
	453	}
	454
	455	PUTBACK;
	456	return;
	457	}
	458	}
	459
	460	XS(XS_version_vcmp)
	461	{
	462	dXSARGS;
	463	if (items < 1)
	464	Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
	465	SP -= items;
	466	{
	467	SV * lobj;
	468
	469	if (sv_derived_from(ST(0), "version")) {
	470	SV *tmp = SvRV(ST(0));
	471	lobj = tmp;
	472	}
	473	else
ba329e04	474	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	475
	476	{
	477	SV *rs;
	478	SV *rvs;
	479	SV * robj = ST(1);
	480	IV swap = (IV)SvIV(ST(2));
	481
	482	if ( ! sv_derived_from(robj, "version") )
	483	{
	484	robj = new_version(robj);
	485	}
	486	rvs = SvRV(robj);
	487
	488	if ( swap )
	489	{
	490	rs = newSViv(sv_cmp(rvs,lobj));
	491	}
	492	else
	493	{
	494	rs = newSViv(sv_cmp(lobj,rvs));
	495	}
	496
	497	PUSHs(rs);
	498	}
	499
	500	PUTBACK;
	501	return;
	502	}
	503	}
	504
	505	XS(XS_version_boolean)
	506	{
	507	dXSARGS;
	508	if (items < 1)
	509	Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
	510	SP -= items;
	511	{
	512	SV * lobj;
	513
	514	if (sv_derived_from(ST(0), "version")) {
	515	SV *tmp = SvRV(ST(0));
	516	lobj = tmp;
	517	}
	518	else
ba329e04	519	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	520
	521	{
	522	SV *rs;
	523	rs = newSViv(sv_cmp(lobj,Nullsv));
	524	PUSHs(rs);
	525	}
	526
	527	PUTBACK;
	528	return;
	529	}
	530	}
	531
	532	XS(XS_version_noop)
	533	{
	534	dXSARGS;
	535	if (items < 1)
	536	Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
	537	{
	538	SV * lobj;
	539
	540	if (sv_derived_from(ST(0), "version")) {
	541	SV *tmp = SvRV(ST(0));
	542	lobj = tmp;
	543	}
	544	else
ba329e04	545	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	546
439cb1c4	547	{
ba329e04	548	Perl_croak(aTHX_ "operation not supported with version object");
439cb1c4	549	}
	550
	551	}
	552	XSRETURN_EMPTY;
	553	}
	554
1b026014	555	XS(XS_utf8_valid)
	556	{
	557	dXSARGS;
	558	if (items != 1)
	559	Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
	560	{
	561	SV * sv = ST(0);
	562	{
	563	STRLEN len;
	564	char *s = SvPV(sv,len);
	565	if (!SvUTF8(sv) \|\| is_utf8_string((U8*)s,len))
	566	XSRETURN_YES;
	567	else
	568	XSRETURN_NO;
	569	}
	570	}
	571	XSRETURN_EMPTY;
	572	}
	573
	574	XS(XS_utf8_encode)
	575	{
	576	dXSARGS;
	577	if (items != 1)
	578	Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
	579	{
	580	SV * sv = ST(0);
	581
	582	sv_utf8_encode(sv);
	583	}
	584	XSRETURN_EMPTY;
	585	}
	586
	587	XS(XS_utf8_decode)
	588	{
	589	dXSARGS;
	590	if (items != 1)
	591	Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
	592	{
	593	SV * sv = ST(0);
	594	bool RETVAL;
	595
	596	RETVAL = sv_utf8_decode(sv);
	597	ST(0) = boolSV(RETVAL);
	598	sv_2mortal(ST(0));
	599	}
	600	XSRETURN(1);
	601	}
	602
	603	XS(XS_utf8_upgrade)
	604	{
	605	dXSARGS;
	606	if (items != 1)
	607	Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
	608	{
	609	SV * sv = ST(0);
	610	STRLEN RETVAL;
	611	dXSTARG;
	612
	613	RETVAL = sv_utf8_upgrade(sv);
	614	XSprePUSH; PUSHi((IV)RETVAL);
	615	}
	616	XSRETURN(1);
	617	}
	618
619	XS(XS_utf8_downgrade)
620	{
621	dXSARGS;
622	if (items < 1 \|\| items > 2)
623	Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
624	{
625	SV * sv = ST(0);
626	bool failok;
627	bool RETVAL;
628
629	if (items < 2)
630	failok = 0;
631	else {
632	failok = (int)SvIV(ST(1));
633	}
634
635	RETVAL = sv_utf8_downgrade(sv, failok);
636	ST(0) = boolSV(RETVAL);
637	sv_2mortal(ST(0));
638	}
639	XSRETURN(1);
640	}
641
642	XS(XS_utf8_native_to_unicode)
643	{
644	dXSARGS;
645	UV uv = SvUV(ST(0));
b7953727	646
	647	if (items > 1)
	648	Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
	649
1b026014	650	ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
	651	XSRETURN(1);
	652	}
	653
	654	XS(XS_utf8_unicode_to_native)
	655	{
	656	dXSARGS;
	657	UV uv = SvUV(ST(0));
b7953727	658
	659	if (items > 1)
	660	Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
	661
1b026014	662	ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
	663	XSRETURN(1);
	664	}
	665
14a976d6	666	XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577	667	{
	668	dXSARGS;
	669	SV *sv = SvRV(ST(0));
	670	if (items == 1) {
	671	if (SvREADONLY(sv))
	672	XSRETURN_YES;
	673	else
	674	XSRETURN_NO;
	675	}
	676	else if (items == 2) {
	677	if (SvTRUE(ST(1))) {
	678	SvREADONLY_on(sv);
	679	XSRETURN_YES;
	680	}
	681	else {
14a976d6	682	/* I hope you really know what you are doing. */
29569577	683	SvREADONLY_off(sv);
	684	XSRETURN_NO;
	685	}
	686	}
14a976d6	687	XSRETURN_UNDEF; /* Can't happen. */
29569577	688	}
29569577	689
14a976d6	690	XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577	691	{
	692	dXSARGS;
	693	SV *sv = SvRV(ST(0));
	694	if (items == 1)
14a976d6	695	XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577	696	else if (items == 2) {
14a976d6	697	/* I hope you really know what you are doing. */
29569577	698	SvREFCNT(sv) = SvIV(ST(1));
	699	XSRETURN_IV(SvREFCNT(sv));
	700	}
14a976d6	701	XSRETURN_UNDEF; /* Can't happen. */
29569577	702	}
29569577	703
dfd4ef2f	704	/* Maybe this should return the number of placeholders found in scalar context,
dfd4ef2f	705	and a list of them in list context. */
f044d0d1	706	XS(XS_Internals_hv_clear_placehold)
dfd4ef2f	707	{
	708	dXSARGS;
	709	HV hv = (HV ) SvRV(ST(0));
	710
	711	/* I don't care how many parameters were passed in, but I want to avoid
	712	the unused variable warning. */
	713
eb160463	714	items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f	715
	716	if (items) {
	717	HE *entry;
	718	I32 riter = HvRITER(hv);
	719	HE *eiter = HvEITER(hv);
	720	hv_iterinit(hv);
fe7bca90	721	/* This may look suboptimal with the items after the iternext, but
	722	it's quite deliberate. We only get here with items==0 if we've
	723	just deleted the last placeholder in the hash. If we've just done
	724	that then it means that the hash is in lazy delete mode, and the
	725	HE is now only referenced in our iterator. If we just quit the loop
	726	and discarded our iterator then the HE leaks. So we do the && the
	727	other way to ensure iternext is called just one more time, which
	728	has the side effect of triggering the lazy delete. */
	729	while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
	730	&& items) {
dfd4ef2f	731	SV *val = hv_iterval(hv, entry);
	732
	733	if (val == &PL_sv_undef) {
	734
	735	/* It seems that I have to go back in the front of the hash
	736	API to delete a hash, even though I have a HE structure
	737	pointing to the very entry I want to delete, and could hold
	738	onto the previous HE that points to it. And it's easier to
	739	go in with SVs as I can then specify the precomputed hash,
	740	and don't have fun and games with utf8 keys. */
	741	SV *key = hv_iterkeysv(entry);
	742
	743	hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
	744	items--;
	745	}
	746	}
	747	HvRITER(hv) = riter;
	748	HvEITER(hv) = eiter;
	749	}
	750
	751	XSRETURN(0);
	752	}