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

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