[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);
    {
	/* 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))))
	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 ( !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 %s required--this is only version %s",
		HvNAME(pkg), SvPV(req,PL_na), SvPV(sv,PL_na));
    }

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