[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 > 3)
	Perl_croak(aTHX_ "Usage: version::new(class, version)");
    SP -= items;
    {
/*	char *	class = (char *)SvPV_nolen(ST(0)); */
        SV *version = ST(1);
	if (items == 3 )
	{
	    char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
	    version = Perl_newSVpvf(aTHX_ "v%s",vs);
	}

	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;
129318bd	355	if (items > 3)
439cb1c4	356	Perl_croak(aTHX_ "Usage: version::new(class, version)");
	357	SP -= items;
	358	{
	359	/* char * class = (char )SvPV_nolen(ST(0)); /
129318bd	360	SV *version = ST(1);
	361	if (items == 3 )
	362	{
	363	char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
9be22fdc	364	version = Perl_newSVpvf(aTHX_ "v%s",vs);
129318bd	365	}
439cb1c4	366
129318bd	367	PUSHs(new_version(version));
439cb1c4	368	PUTBACK;
	369	return;
	370	}
	371	}
	372
	373	XS(XS_version_stringify)
	374	{
	375	dXSARGS;
	376	if (items < 1)
	377	Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
	378	SP -= items;
	379	{
	380	SV * lobj;
	381
	382	if (sv_derived_from(ST(0), "version")) {
	383	SV *tmp = SvRV(ST(0));
	384	lobj = tmp;
	385	}
	386	else
ba329e04	387	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	388
439cb1c4	389	{
ad63d80f	390	PUSHs(vstringify(lobj));
439cb1c4	391	}
	392
	393	PUTBACK;
	394	return;
	395	}
	396	}
	397
	398	XS(XS_version_numify)
	399	{
	400	dXSARGS;
	401	if (items < 1)
	402	Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
	403	SP -= items;
	404	{
	405	SV * lobj;
	406
	407	if (sv_derived_from(ST(0), "version")) {
	408	SV *tmp = SvRV(ST(0));
	409	lobj = tmp;
	410	}
	411	else
ba329e04	412	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	413
439cb1c4	414	{
ad63d80f	415	PUSHs(vnumify(lobj));
439cb1c4	416	}
	417
	418	PUTBACK;
	419	return;
	420	}
	421	}
	422
	423	XS(XS_version_vcmp)
	424	{
	425	dXSARGS;
	426	if (items < 1)
	427	Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
	428	SP -= items;
	429	{
	430	SV * lobj;
	431
	432	if (sv_derived_from(ST(0), "version")) {
	433	SV *tmp = SvRV(ST(0));
	434	lobj = tmp;
	435	}
	436	else
ba329e04	437	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	438
	439	{
	440	SV *rs;
	441	SV *rvs;
	442	SV * robj = ST(1);
	443	IV swap = (IV)SvIV(ST(2));
	444
	445	if ( ! sv_derived_from(robj, "version") )
	446	{
	447	robj = new_version(robj);
	448	}
	449	rvs = SvRV(robj);
	450
	451	if ( swap )
	452	{
ad63d80f	453	rs = newSViv(vcmp(rvs,lobj));
439cb1c4	454	}
	455	else
	456	{
ad63d80f	457	rs = newSViv(vcmp(lobj,rvs));
439cb1c4	458	}
	459
	460	PUSHs(rs);
	461	}
	462
	463	PUTBACK;
	464	return;
	465	}
	466	}
	467
	468	XS(XS_version_boolean)
	469	{
	470	dXSARGS;
	471	if (items < 1)
	472	Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
	473	SP -= items;
	474	{
	475	SV * lobj;
	476
	477	if (sv_derived_from(ST(0), "version")) {
	478	SV *tmp = SvRV(ST(0));
	479	lobj = tmp;
	480	}
	481	else
ba329e04	482	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	483
	484	{
	485	SV *rs;
ad63d80f	486	rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
439cb1c4	487	PUSHs(rs);
	488	}
	489
	490	PUTBACK;
	491	return;
	492	}
	493	}
	494
	495	XS(XS_version_noop)
	496	{
	497	dXSARGS;
	498	if (items < 1)
	499	Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
	500	{
	501	SV * lobj;
	502
	503	if (sv_derived_from(ST(0), "version")) {
	504	SV *tmp = SvRV(ST(0));
	505	lobj = tmp;
	506	}
	507	else
ba329e04	508	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	509
439cb1c4	510	{
ba329e04	511	Perl_croak(aTHX_ "operation not supported with version object");
439cb1c4	512	}
	513
	514	}
	515	XSRETURN_EMPTY;
	516	}
	517
1b026014	518	XS(XS_utf8_valid)
	519	{
	520	dXSARGS;
	521	if (items != 1)
	522	Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
	523	{
	524	SV * sv = ST(0);
	525	{
	526	STRLEN len;
	527	char *s = SvPV(sv,len);
	528	if (!SvUTF8(sv) \|\| is_utf8_string((U8*)s,len))
	529	XSRETURN_YES;
	530	else
	531	XSRETURN_NO;
	532	}
	533	}
	534	XSRETURN_EMPTY;
	535	}
	536
	537	XS(XS_utf8_encode)
	538	{
	539	dXSARGS;
	540	if (items != 1)
	541	Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
	542	{
	543	SV * sv = ST(0);
	544
	545	sv_utf8_encode(sv);
	546	}
	547	XSRETURN_EMPTY;
	548	}
	549
	550	XS(XS_utf8_decode)
	551	{
	552	dXSARGS;
	553	if (items != 1)
	554	Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
	555	{
	556	SV * sv = ST(0);
	557	bool RETVAL;
	558
	559	RETVAL = sv_utf8_decode(sv);
	560	ST(0) = boolSV(RETVAL);
	561	sv_2mortal(ST(0));
	562	}
	563	XSRETURN(1);
	564	}
	565
	566	XS(XS_utf8_upgrade)
	567	{
	568	dXSARGS;
	569	if (items != 1)
	570	Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
	571	{
	572	SV * sv = ST(0);
	573	STRLEN RETVAL;
	574	dXSTARG;
	575
	576	RETVAL = sv_utf8_upgrade(sv);
	577	XSprePUSH; PUSHi((IV)RETVAL);
	578	}
	579	XSRETURN(1);
	580	}
	581
582	XS(XS_utf8_downgrade)
583	{
584	dXSARGS;
585	if (items < 1 \|\| items > 2)
586	Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
587	{
588	SV * sv = ST(0);
589	bool failok;
590	bool RETVAL;
591
592	if (items < 2)
593	failok = 0;
594	else {
595	failok = (int)SvIV(ST(1));
596	}
597
598	RETVAL = sv_utf8_downgrade(sv, failok);
599	ST(0) = boolSV(RETVAL);
600	sv_2mortal(ST(0));
601	}
602	XSRETURN(1);
603	}
604
605	XS(XS_utf8_native_to_unicode)
606	{
607	dXSARGS;
608	UV uv = SvUV(ST(0));
b7953727	609
	610	if (items > 1)
	611	Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
	612
1b026014	613	ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
	614	XSRETURN(1);
	615	}
	616
	617	XS(XS_utf8_unicode_to_native)
	618	{
	619	dXSARGS;
	620	UV uv = SvUV(ST(0));
b7953727	621
	622	if (items > 1)
	623	Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
	624
1b026014	625	ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
	626	XSRETURN(1);
	627	}
	628
14a976d6	629	XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577	630	{
	631	dXSARGS;
	632	SV *sv = SvRV(ST(0));
	633	if (items == 1) {
	634	if (SvREADONLY(sv))
	635	XSRETURN_YES;
	636	else
	637	XSRETURN_NO;
	638	}
	639	else if (items == 2) {
	640	if (SvTRUE(ST(1))) {
	641	SvREADONLY_on(sv);
	642	XSRETURN_YES;
	643	}
	644	else {
14a976d6	645	/* I hope you really know what you are doing. */
29569577	646	SvREADONLY_off(sv);
	647	XSRETURN_NO;
	648	}
	649	}
14a976d6	650	XSRETURN_UNDEF; /* Can't happen. */
29569577	651	}
29569577	652
14a976d6	653	XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577	654	{
	655	dXSARGS;
	656	SV *sv = SvRV(ST(0));
	657	if (items == 1)
14a976d6	658	XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577	659	else if (items == 2) {
14a976d6	660	/* I hope you really know what you are doing. */
29569577	661	SvREFCNT(sv) = SvIV(ST(1));
	662	XSRETURN_IV(SvREFCNT(sv));
	663	}
14a976d6	664	XSRETURN_UNDEF; /* Can't happen. */
29569577	665	}
29569577	666
dfd4ef2f	667	/* Maybe this should return the number of placeholders found in scalar context,
dfd4ef2f	668	and a list of them in list context. */
f044d0d1	669	XS(XS_Internals_hv_clear_placehold)
dfd4ef2f	670	{
	671	dXSARGS;
	672	HV hv = (HV ) SvRV(ST(0));
	673
	674	/* I don't care how many parameters were passed in, but I want to avoid
	675	the unused variable warning. */
	676
eb160463	677	items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f	678
	679	if (items) {
	680	HE *entry;
	681	I32 riter = HvRITER(hv);
	682	HE *eiter = HvEITER(hv);
	683	hv_iterinit(hv);
fe7bca90	684	/* This may look suboptimal with the items after the iternext, but
	685	it's quite deliberate. We only get here with items==0 if we've
	686	just deleted the last placeholder in the hash. If we've just done
	687	that then it means that the hash is in lazy delete mode, and the
	688	HE is now only referenced in our iterator. If we just quit the loop
	689	and discarded our iterator then the HE leaks. So we do the && the
	690	other way to ensure iternext is called just one more time, which
	691	has the side effect of triggering the lazy delete. */
	692	while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
	693	&& items) {
dfd4ef2f	694	SV *val = hv_iterval(hv, entry);
	695
	696	if (val == &PL_sv_undef) {
	697
	698	/* It seems that I have to go back in the front of the hash
	699	API to delete a hash, even though I have a HE structure
	700	pointing to the very entry I want to delete, and could hold
	701	onto the previous HE that points to it. And it's easier to
	702	go in with SVs as I can then specify the precomputed hash,
	703	and don't have fun and games with utf8 keys. */
	704	SV *key = hv_iterkeysv(entry);
	705
	706	hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
	707	items--;
	708	}
	709	}
	710	HvRITER(hv) = riter;
	711	HvEITER(hv) = eiter;
	712	}
	713
	714	XSRETURN(0);
	715	}