[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 %"SVf" for @%s::ISA",
			    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);
    {
	/* register the overloading (type 'A') magic */
	PL_amagic_generation++;
	/* 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))
		|| (SvGMAGICAL(sv) && SvPOKp(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))
		|| (SvGMAGICAL(sv) && SvPOKp(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 ( !sv_derived_from(sv, "version"))
	    sv = new_version(sv);

	if ( !sv_derived_from(req, "version"))
	    req = new_version(req);

	if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
	    Perl_croak(aTHX_ "%s version %_ required--this is only version %_",
		HvNAME(pkg), req, sv);
    }

    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");

{
    PUSHs(vstringify(lobj));
}

	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");

{
    PUSHs(vnumify(lobj));
}

	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(vcmp(rvs,lobj));
    }
    else
    {
        rs = newSViv(vcmp(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( vcmp(lobj,new_version(newSVpvn("0",1))) );
    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),
35c1215d	97	"Can't locate package %"SVf" for @%s::ISA",
35c1215d	98	sv, HvNAME(stash));
6d4a7be2	99	continue;
6d4a7be2	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	{
ad63d80f	189	/* register the overloading (type 'A') magic */
ad63d80f	190	PL_amagic_generation++;
439cb1c4	191	/* Make it findable via fetchmethod */
be2ebcad	192	newXS("version::()", XS_version_noop, file);
439cb1c4	193	newXS("version::new", XS_version_new, file);
	194	newXS("version::(\"\"", XS_version_stringify, file);
	195	newXS("version::stringify", XS_version_stringify, file);
	196	newXS("version::(0+", XS_version_numify, file);
	197	newXS("version::numify", XS_version_numify, file);
	198	newXS("version::(cmp", XS_version_vcmp, file);
	199	newXS("version::(<=>", XS_version_vcmp, file);
	200	newXS("version::vcmp", XS_version_vcmp, file);
	201	newXS("version::(bool", XS_version_boolean, file);
	202	newXS("version::boolean", XS_version_boolean, file);
	203	newXS("version::(nomethod", XS_version_noop, file);
	204	newXS("version::noop", XS_version_noop, file);
	205	}
1b026014	206	newXS("utf8::valid", XS_utf8_valid, file);
	207	newXS("utf8::encode", XS_utf8_encode, file);
	208	newXS("utf8::decode", XS_utf8_decode, file);
	209	newXS("utf8::upgrade", XS_utf8_upgrade, file);
	210	newXS("utf8::downgrade", XS_utf8_downgrade, file);
	211	newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
	212	newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577	213	newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
29569577	214	newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f	215	newXSproto("Internals::hv_clear_placeholders",
f044d0d1	216	XS_Internals_hv_clear_placehold, file, "\\%");
0cb96387	217	}
0cb96387	218
55497cff	219
6d4a7be2	220	XS(XS_UNIVERSAL_isa)
	221	{
	222	dXSARGS;
55497cff	223	SV *sv;
55497cff	224	char *name;
2d8e6c8d	225	STRLEN n_a;
6d4a7be2	226
6d4a7be2	227	if (items != 2)
cea2e8a9	228	Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2	229
6d4a7be2	230	sv = ST(0);
f8f70380	231
d3f7f2b2	232	if (SvGMAGICAL(sv))
	233	mg_get(sv);
	234
253ecd6d	235	if (!SvOK(sv) \|\| !(SvROK(sv) \|\| (SvPOK(sv) && SvCUR(sv))
253ecd6d	236	\|\| (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380	237	XSRETURN_UNDEF;
f8f70380	238
2d8e6c8d	239	name = (char *)SvPV(ST(1),n_a);
6d4a7be2	240
54310121	241	ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2	242	XSRETURN(1);
	243	}
	244
6d4a7be2	245	XS(XS_UNIVERSAL_can)
	246	{
	247	dXSARGS;
	248	SV *sv;
	249	char *name;
	250	SV *rv;
6f08146e	251	HV *pkg = NULL;
2d8e6c8d	252	STRLEN n_a;
6d4a7be2	253
6d4a7be2	254	if (items != 2)
cea2e8a9	255	Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2	256
6d4a7be2	257	sv = ST(0);
f8f70380	258
d3f7f2b2	259	if (SvGMAGICAL(sv))
	260	mg_get(sv);
	261
253ecd6d	262	if (!SvOK(sv) \|\| !(SvROK(sv) \|\| (SvPOK(sv) && SvCUR(sv))
253ecd6d	263	\|\| (SvGMAGICAL(sv) && SvPOKp(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	}
ad63d80f	336	if ( !sv_derived_from(sv, "version"))
	337	sv = new_version(sv);
	338
	339	if ( !sv_derived_from(req, "version"))
	340	req = new_version(req);
1571675a	341
ad63d80f	342	if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
0773b1f0	343	Perl_croak(aTHX_ "%s version %_ required--this is only version %_",
0773b1f0	344	HvNAME(pkg), req, sv);
2d8e6c8d	345	}
6d4a7be2	346
	347	ST(0) = sv;
	348
	349	XSRETURN(1);
	350	}
	351
439cb1c4	352	XS(XS_version_new)
	353	{
	354	dXSARGS;
	355	if (items != 2)
	356	Perl_croak(aTHX_ "Usage: version::new(class, version)");
	357	SP -= items;
	358	{
	359	/* char * class = (char )SvPV_nolen(ST(0)); /
	360	SV * version = ST(1);
	361
	362	{
	363	PUSHs(new_version(version));
	364	}
	365
	366	PUTBACK;
	367	return;
	368	}
	369	}
	370
	371	XS(XS_version_stringify)
	372	{
	373	dXSARGS;
	374	if (items < 1)
	375	Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
	376	SP -= items;
	377	{
	378	SV * lobj;
	379
	380	if (sv_derived_from(ST(0), "version")) {
	381	SV *tmp = SvRV(ST(0));
	382	lobj = tmp;
	383	}
	384	else
ba329e04	385	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	386
439cb1c4	387	{
ad63d80f	388	PUSHs(vstringify(lobj));
439cb1c4	389	}
	390
	391	PUTBACK;
	392	return;
	393	}
	394	}
	395
	396	XS(XS_version_numify)
	397	{
	398	dXSARGS;
	399	if (items < 1)
	400	Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
	401	SP -= items;
	402	{
	403	SV * lobj;
	404
	405	if (sv_derived_from(ST(0), "version")) {
	406	SV *tmp = SvRV(ST(0));
	407	lobj = tmp;
	408	}
	409	else
ba329e04	410	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	411
439cb1c4	412	{
ad63d80f	413	PUSHs(vnumify(lobj));
439cb1c4	414	}
	415
	416	PUTBACK;
	417	return;
	418	}
	419	}
	420
	421	XS(XS_version_vcmp)
	422	{
	423	dXSARGS;
	424	if (items < 1)
	425	Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
	426	SP -= items;
	427	{
	428	SV * lobj;
	429
	430	if (sv_derived_from(ST(0), "version")) {
	431	SV *tmp = SvRV(ST(0));
	432	lobj = tmp;
	433	}
	434	else
ba329e04	435	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	436
	437	{
	438	SV *rs;
	439	SV *rvs;
	440	SV * robj = ST(1);
	441	IV swap = (IV)SvIV(ST(2));
	442
	443	if ( ! sv_derived_from(robj, "version") )
	444	{
	445	robj = new_version(robj);
	446	}
	447	rvs = SvRV(robj);
	448
	449	if ( swap )
	450	{
ad63d80f	451	rs = newSViv(vcmp(rvs,lobj));
439cb1c4	452	}
	453	else
	454	{
ad63d80f	455	rs = newSViv(vcmp(lobj,rvs));
439cb1c4	456	}
	457
	458	PUSHs(rs);
	459	}
	460
	461	PUTBACK;
	462	return;
	463	}
	464	}
	465
	466	XS(XS_version_boolean)
	467	{
	468	dXSARGS;
	469	if (items < 1)
	470	Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
	471	SP -= items;
	472	{
	473	SV * lobj;
	474
	475	if (sv_derived_from(ST(0), "version")) {
	476	SV *tmp = SvRV(ST(0));
	477	lobj = tmp;
	478	}
	479	else
ba329e04	480	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	481
	482	{
	483	SV *rs;
ad63d80f	484	rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
439cb1c4	485	PUSHs(rs);
	486	}
	487
	488	PUTBACK;
	489	return;
	490	}
	491	}
	492
	493	XS(XS_version_noop)
	494	{
	495	dXSARGS;
	496	if (items < 1)
	497	Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
	498	{
	499	SV * lobj;
	500
	501	if (sv_derived_from(ST(0), "version")) {
	502	SV *tmp = SvRV(ST(0));
	503	lobj = tmp;
	504	}
	505	else
ba329e04	506	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	507
439cb1c4	508	{
ba329e04	509	Perl_croak(aTHX_ "operation not supported with version object");
439cb1c4	510	}
	511
	512	}
	513	XSRETURN_EMPTY;
	514	}
	515
1b026014	516	XS(XS_utf8_valid)
	517	{
	518	dXSARGS;
	519	if (items != 1)
	520	Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
	521	{
	522	SV * sv = ST(0);
	523	{
	524	STRLEN len;
	525	char *s = SvPV(sv,len);
	526	if (!SvUTF8(sv) \|\| is_utf8_string((U8*)s,len))
	527	XSRETURN_YES;
	528	else
	529	XSRETURN_NO;
	530	}
	531	}
	532	XSRETURN_EMPTY;
	533	}
	534
	535	XS(XS_utf8_encode)
	536	{
	537	dXSARGS;
	538	if (items != 1)
	539	Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
	540	{
	541	SV * sv = ST(0);
	542
	543	sv_utf8_encode(sv);
	544	}
	545	XSRETURN_EMPTY;
	546	}
	547
	548	XS(XS_utf8_decode)
	549	{
	550	dXSARGS;
	551	if (items != 1)
	552	Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
	553	{
	554	SV * sv = ST(0);
	555	bool RETVAL;
	556
	557	RETVAL = sv_utf8_decode(sv);
	558	ST(0) = boolSV(RETVAL);
	559	sv_2mortal(ST(0));
	560	}
	561	XSRETURN(1);
	562	}
	563
	564	XS(XS_utf8_upgrade)
	565	{
	566	dXSARGS;
	567	if (items != 1)
	568	Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
	569	{
	570	SV * sv = ST(0);
	571	STRLEN RETVAL;
	572	dXSTARG;
	573
	574	RETVAL = sv_utf8_upgrade(sv);
	575	XSprePUSH; PUSHi((IV)RETVAL);
	576	}
	577	XSRETURN(1);
	578	}
	579
580	XS(XS_utf8_downgrade)
581	{
582	dXSARGS;
583	if (items < 1 \|\| items > 2)
584	Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
585	{
586	SV * sv = ST(0);
587	bool failok;
588	bool RETVAL;
589
590	if (items < 2)
591	failok = 0;
592	else {
593	failok = (int)SvIV(ST(1));
594	}
595
596	RETVAL = sv_utf8_downgrade(sv, failok);
597	ST(0) = boolSV(RETVAL);
598	sv_2mortal(ST(0));
599	}
600	XSRETURN(1);
601	}
602
603	XS(XS_utf8_native_to_unicode)
604	{
605	dXSARGS;
606	UV uv = SvUV(ST(0));
b7953727	607
	608	if (items > 1)
	609	Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
	610
1b026014	611	ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
	612	XSRETURN(1);
	613	}
	614
	615	XS(XS_utf8_unicode_to_native)
	616	{
	617	dXSARGS;
	618	UV uv = SvUV(ST(0));
b7953727	619
	620	if (items > 1)
	621	Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
	622
1b026014	623	ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
	624	XSRETURN(1);
	625	}
	626
14a976d6	627	XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577	628	{
	629	dXSARGS;
	630	SV *sv = SvRV(ST(0));
	631	if (items == 1) {
	632	if (SvREADONLY(sv))
	633	XSRETURN_YES;
	634	else
	635	XSRETURN_NO;
	636	}
	637	else if (items == 2) {
	638	if (SvTRUE(ST(1))) {
	639	SvREADONLY_on(sv);
	640	XSRETURN_YES;
	641	}
	642	else {
14a976d6	643	/* I hope you really know what you are doing. */
29569577	644	SvREADONLY_off(sv);
	645	XSRETURN_NO;
	646	}
	647	}
14a976d6	648	XSRETURN_UNDEF; /* Can't happen. */
29569577	649	}
29569577	650
14a976d6	651	XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577	652	{
	653	dXSARGS;
	654	SV *sv = SvRV(ST(0));
	655	if (items == 1)
14a976d6	656	XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577	657	else if (items == 2) {
14a976d6	658	/* I hope you really know what you are doing. */
29569577	659	SvREFCNT(sv) = SvIV(ST(1));
	660	XSRETURN_IV(SvREFCNT(sv));
	661	}
14a976d6	662	XSRETURN_UNDEF; /* Can't happen. */
29569577	663	}
29569577	664
dfd4ef2f	665	/* Maybe this should return the number of placeholders found in scalar context,
dfd4ef2f	666	and a list of them in list context. */
f044d0d1	667	XS(XS_Internals_hv_clear_placehold)
dfd4ef2f	668	{
	669	dXSARGS;
	670	HV hv = (HV ) SvRV(ST(0));
	671
	672	/* I don't care how many parameters were passed in, but I want to avoid
	673	the unused variable warning. */
	674
eb160463	675	items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f	676
	677	if (items) {
	678	HE *entry;
	679	I32 riter = HvRITER(hv);
	680	HE *eiter = HvEITER(hv);
	681	hv_iterinit(hv);
fe7bca90	682	/* This may look suboptimal with the items after the iternext, but
	683	it's quite deliberate. We only get here with items==0 if we've
	684	just deleted the last placeholder in the hash. If we've just done
	685	that then it means that the hash is in lazy delete mode, and the
	686	HE is now only referenced in our iterator. If we just quit the loop
	687	and discarded our iterator then the HE leaks. So we do the && the
	688	other way to ensure iternext is called just one more time, which
	689	has the side effect of triggering the lazy delete. */
	690	while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
	691	&& items) {
dfd4ef2f	692	SV *val = hv_iterval(hv, entry);
	693
	694	if (val == &PL_sv_undef) {
	695
	696	/* It seems that I have to go back in the front of the hash
	697	API to delete a hash, even though I have a HE structure
	698	pointing to the very entry I want to delete, and could hold
	699	onto the previous HE that points to it. And it's easier to
	700	go in with SVs as I can then specify the precomputed hash,
	701	and don't have fun and games with utf8 keys. */
	702	SV *key = hv_iterkeysv(entry);
	703
	704	hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
	705	items--;
	706	}
	707	}
	708	HvRITER(hv) = riter;
	709	HvEITER(hv) = eiter;
	710	}
	711
	712	XSRETURN(0);
	713	}