[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_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);
    newXS("utf8::valid", XS_utf8_valid, file);
    newXS("utf8::encode", XS_utf8_encode, file);
    newXS("utf8::decode", XS_utf8_decode, file);
    newXS("utf8::upgrade", XS_utf8_upgrade, file);
    newXS("utf8::downgrade", XS_utf8_downgrade, file);
    newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
    newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
    newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
    newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
    newXSproto("Internals::hv_clear_placeholders",
               XS_Internals_hv_clear_placehold, file, "\\%");
}


XS(XS_UNIVERSAL_isa)
{
    dXSARGS;
    SV *sv;
    char *name;
    STRLEN n_a;

    if (items != 2)
	Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");

    sv = ST(0);

    if (SvGMAGICAL(sv))
	mg_get(sv);

    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
	XSRETURN_UNDEF;

    name = (char *)SvPV(ST(1),n_a);

    ST(0) = boolSV(sv_derived_from(sv, name));
    XSRETURN(1);
}

XS(XS_UNIVERSAL_can)
{
    dXSARGS;
    SV   *sv;
    char *name;
    SV   *rv;
    HV   *pkg = NULL;
    STRLEN n_a;

    if (items != 2)
	Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");

    sv = ST(0);

    if (SvGMAGICAL(sv))
	mg_get(sv);

    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
	XSRETURN_UNDEF;

    name = (char *)SvPV(ST(1),n_a);
    rv = &PL_sv_undef;

    if (SvROK(sv)) {
        sv = (SV*)SvRV(sv);
        if (SvOBJECT(sv))
            pkg = SvSTASH(sv);
    }
    else {
        pkg = gv_stashsv(sv, FALSE);
    }

    if (pkg) {
        GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
        if (gv && isGV(gv))
	    rv = sv_2mortal(newRV((SV*)GvCV(gv)));
    }

    ST(0) = rv;
    XSRETURN(1);
}

XS(XS_UNIVERSAL_VERSION)
{
    dXSARGS;
    HV *pkg;
    GV **gvp;
    GV *gv;
    SV *sv;
    char *undef;

    if (SvROK(ST(0))) {
        sv = (SV*)SvRV(ST(0));
        if (!SvOBJECT(sv))
            Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
        pkg = SvSTASH(sv);
    }
    else {
        pkg = gv_stashsv(ST(0), FALSE);
    }

    gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);

    if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
        SV *nsv = sv_newmortal();
        sv_setsv(nsv, sv);
        sv = nsv;
        undef = Nullch;
    }
    else {
        sv = (SV*)&PL_sv_undef;
        undef = "(undef)";
    }

    if (items > 1) {
	STRLEN len;
	SV *req = ST(1);

	if (undef) {
	     if (pkg)
		  Perl_croak(aTHX_
			     "%s does not define $%s::VERSION--version check failed",
			     HvNAME(pkg), HvNAME(pkg));
	     else {
		  char *str = SvPVx(ST(0), len);

		  Perl_croak(aTHX_
			     "%s defines neither package nor VERSION--version check failed", str);
	     }
	}
	if (!SvNIOK(sv) && SvPOK(sv)) {
	    char *str = SvPVx(sv,len);
	    while (len) {
		--len;
		/* XXX could DWIM "1.2.3" here */
		if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
		    break;
	    }
	    if (len) {
		if (SvNOK(req) && SvPOK(req)) {
		    /* they said C<use Foo v1.2.3> and $Foo::VERSION
		     * doesn't look like a float: do string compare */
		    if (sv_cmp(req,sv) == 1) {
			Perl_croak(aTHX_ "%s v%"VDf" required--"
				   "this is only v%"VDf,
				   HvNAME(pkg), req, sv);
		    }
		    goto finish;
		}
		/* they said C<use Foo 1.002_003> and $Foo::VERSION
		 * doesn't look like a float: force numeric compare */
		(void)SvUPGRADE(sv, SVt_PVNV);
		SvNVX(sv) = str_to_version(sv);
		SvPOK_off(sv);
		SvNOK_on(sv);
	    }
	}
	/* if we get here, we're looking for a numeric comparison,
	 * so force the required version into a float, even if they
	 * said C<use Foo v1.2.3> */
	if (SvNOK(req) && SvPOK(req)) {
	    NV n = SvNV(req);
	    req = sv_newmortal();
	    sv_setnv(req, n);
	}

	if (SvNV(req) > SvNV(sv))
	    Perl_croak(aTHX_ "%s version %s required--this is only version %s",
		       HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
    }

finish:
    ST(0) = sv;

    XSRETURN(1);
}

XS(XS_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);
1b026014	163	XS(XS_utf8_valid);
	164	XS(XS_utf8_encode);
	165	XS(XS_utf8_decode);
	166	XS(XS_utf8_upgrade);
	167	XS(XS_utf8_downgrade);
	168	XS(XS_utf8_unicode_to_native);
	169	XS(XS_utf8_native_to_unicode);
29569577	170	XS(XS_Internals_SvREADONLY);
29569577	171	XS(XS_Internals_SvREFCNT);
f044d0d1	172	XS(XS_Internals_hv_clear_placehold);
0cb96387	173
	174	void
	175	Perl_boot_core_UNIVERSAL(pTHX)
	176	{
	177	char *file = __FILE__;
	178
	179	newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
	180	newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
	181	newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
1b026014	182	newXS("utf8::valid", XS_utf8_valid, file);
	183	newXS("utf8::encode", XS_utf8_encode, file);
	184	newXS("utf8::decode", XS_utf8_decode, file);
	185	newXS("utf8::upgrade", XS_utf8_upgrade, file);
	186	newXS("utf8::downgrade", XS_utf8_downgrade, file);
	187	newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
	188	newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577	189	newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
29569577	190	newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f	191	newXSproto("Internals::hv_clear_placeholders",
f044d0d1	192	XS_Internals_hv_clear_placehold, file, "\\%");
0cb96387	193	}
0cb96387	194
55497cff	195
6d4a7be2	196	XS(XS_UNIVERSAL_isa)
	197	{
	198	dXSARGS;
55497cff	199	SV *sv;
55497cff	200	char *name;
2d8e6c8d	201	STRLEN n_a;
6d4a7be2	202
6d4a7be2	203	if (items != 2)
cea2e8a9	204	Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2	205
6d4a7be2	206	sv = ST(0);
f8f70380	207
d3f7f2b2	208	if (SvGMAGICAL(sv))
	209	mg_get(sv);
	210
aca069ec	211	if (!SvOK(sv) \|\| !(SvROK(sv) \|\| (SvPOK(sv) && SvCUR(sv))))
f8f70380	212	XSRETURN_UNDEF;
f8f70380	213
2d8e6c8d	214	name = (char *)SvPV(ST(1),n_a);
6d4a7be2	215
54310121	216	ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2	217	XSRETURN(1);
	218	}
	219
6d4a7be2	220	XS(XS_UNIVERSAL_can)
	221	{
	222	dXSARGS;
	223	SV *sv;
	224	char *name;
	225	SV *rv;
6f08146e	226	HV *pkg = NULL;
2d8e6c8d	227	STRLEN n_a;
6d4a7be2	228
6d4a7be2	229	if (items != 2)
cea2e8a9	230	Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2	231
6d4a7be2	232	sv = ST(0);
f8f70380	233
d3f7f2b2	234	if (SvGMAGICAL(sv))
	235	mg_get(sv);
	236
aca069ec	237	if (!SvOK(sv) \|\| !(SvROK(sv) \|\| (SvPOK(sv) && SvCUR(sv))))
f8f70380	238	XSRETURN_UNDEF;
f8f70380	239
2d8e6c8d	240	name = (char *)SvPV(ST(1),n_a);
3280af22	241	rv = &PL_sv_undef;
6d4a7be2	242
46e4b22b	243	if (SvROK(sv)) {
6f08146e	244	sv = (SV*)SvRV(sv);
46e4b22b	245	if (SvOBJECT(sv))
6f08146e	246	pkg = SvSTASH(sv);
	247	}
	248	else {
	249	pkg = gv_stashsv(sv, FALSE);
	250	}
	251
	252	if (pkg) {
dc848c6f	253	GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
	254	if (gv && isGV(gv))
	255	rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2	256	}
	257
	258	ST(0) = rv;
	259	XSRETURN(1);
	260	}
	261
6d4a7be2	262	XS(XS_UNIVERSAL_VERSION)
	263	{
	264	dXSARGS;
	265	HV *pkg;
	266	GV **gvp;
	267	GV *gv;
	268	SV *sv;
	269	char *undef;
	270
1571675a	271	if (SvROK(ST(0))) {
6d4a7be2	272	sv = (SV*)SvRV(ST(0));
1571675a	273	if (!SvOBJECT(sv))
cea2e8a9	274	Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2	275	pkg = SvSTASH(sv);
	276	}
	277	else {
	278	pkg = gv_stashsv(ST(0), FALSE);
	279	}
	280
	281	gvp = pkg ? (GV)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV);
	282
d4bea2fb	283	if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2	284	SV *nsv = sv_newmortal();
	285	sv_setsv(nsv, sv);
	286	sv = nsv;
	287	undef = Nullch;
	288	}
	289	else {
3280af22	290	sv = (SV*)&PL_sv_undef;
6d4a7be2	291	undef = "(undef)";
	292	}
	293
1571675a	294	if (items > 1) {
	295	STRLEN len;
	296	SV *req = ST(1);
	297
62658f4d	298	if (undef) {
	299	if (pkg)
	300	Perl_croak(aTHX_
	301	"%s does not define $%s::VERSION--version check failed",
	302	HvNAME(pkg), HvNAME(pkg));
	303	else {
	304	char *str = SvPVx(ST(0), len);
	305
	306	Perl_croak(aTHX_
	307	"%s defines neither package nor VERSION--version check failed", str);
	308	}
	309	}
1571675a	310	if (!SvNIOK(sv) && SvPOK(sv)) {
	311	char *str = SvPVx(sv,len);
	312	while (len) {
	313	--len;
	314	/* XXX could DWIM "1.2.3" here */
	315	if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
	316	break;
	317	}
	318	if (len) {
4305d8ab	319	if (SvNOK(req) && SvPOK(req)) {
1571675a	320	/* they said C<use Foo v1.2.3> and $Foo::VERSION
	321	* doesn't look like a float: do string compare */
	322	if (sv_cmp(req,sv) == 1) {
d2560b70	323	Perl_croak(aTHX_ "%s v%"VDf" required--"
d2560b70	324	"this is only v%"VDf,
1571675a	325	HvNAME(pkg), req, sv);
	326	}
	327	goto finish;
	328	}
	329	/* they said C<use Foo 1.002_003> and $Foo::VERSION
	330	* doesn't look like a float: force numeric compare */
155aba94	331	(void)SvUPGRADE(sv, SVt_PVNV);
1571675a	332	SvNVX(sv) = str_to_version(sv);
	333	SvPOK_off(sv);
	334	SvNOK_on(sv);
	335	}
	336	}
	337	/* if we get here, we're looking for a numeric comparison,
	338	* so force the required version into a float, even if they
	339	* said C<use Foo v1.2.3> */
4305d8ab	340	if (SvNOK(req) && SvPOK(req)) {
1571675a	341	NV n = SvNV(req);
	342	req = sv_newmortal();
	343	sv_setnv(req, n);
	344	}
	345
f6eb1a96	346	if (SvNV(req) > SvNV(sv))
1571675a	347	Perl_croak(aTHX_ "%s version %s required--this is only version %s",
f6eb1a96	348	HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
2d8e6c8d	349	}
6d4a7be2	350
1571675a	351	finish:
6d4a7be2	352	ST(0) = sv;
	353
	354	XSRETURN(1);
	355	}
	356
1b026014	357	XS(XS_utf8_valid)
	358	{
	359	dXSARGS;
	360	if (items != 1)
	361	Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
	362	{
	363	SV * sv = ST(0);
	364	{
	365	STRLEN len;
	366	char *s = SvPV(sv,len);
	367	if (!SvUTF8(sv) \|\| is_utf8_string((U8*)s,len))
	368	XSRETURN_YES;
	369	else
	370	XSRETURN_NO;
	371	}
	372	}
	373	XSRETURN_EMPTY;
	374	}
	375
	376	XS(XS_utf8_encode)
	377	{
	378	dXSARGS;
	379	if (items != 1)
	380	Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
	381	{
	382	SV * sv = ST(0);
	383
	384	sv_utf8_encode(sv);
	385	}
	386	XSRETURN_EMPTY;
	387	}
	388
	389	XS(XS_utf8_decode)
	390	{
	391	dXSARGS;
	392	if (items != 1)
	393	Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
	394	{
	395	SV * sv = ST(0);
	396	bool RETVAL;
	397
	398	RETVAL = sv_utf8_decode(sv);
	399	ST(0) = boolSV(RETVAL);
	400	sv_2mortal(ST(0));
	401	}
	402	XSRETURN(1);
	403	}
	404
	405	XS(XS_utf8_upgrade)
	406	{
	407	dXSARGS;
	408	if (items != 1)
	409	Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
	410	{
	411	SV * sv = ST(0);
	412	STRLEN RETVAL;
	413	dXSTARG;
	414
	415	RETVAL = sv_utf8_upgrade(sv);
	416	XSprePUSH; PUSHi((IV)RETVAL);
	417	}
	418	XSRETURN(1);
	419	}
	420
421	XS(XS_utf8_downgrade)
422	{
423	dXSARGS;
424	if (items < 1 \|\| items > 2)
425	Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
426	{
427	SV * sv = ST(0);
428	bool failok;
429	bool RETVAL;
430
431	if (items < 2)
432	failok = 0;
433	else {
434	failok = (int)SvIV(ST(1));
435	}
436
437	RETVAL = sv_utf8_downgrade(sv, failok);
438	ST(0) = boolSV(RETVAL);
439	sv_2mortal(ST(0));
440	}
441	XSRETURN(1);
442	}
443
444	XS(XS_utf8_native_to_unicode)
445	{
446	dXSARGS;
447	UV uv = SvUV(ST(0));
b7953727	448
	449	if (items > 1)
	450	Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
	451
1b026014	452	ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
	453	XSRETURN(1);
	454	}
	455
	456	XS(XS_utf8_unicode_to_native)
	457	{
	458	dXSARGS;
	459	UV uv = SvUV(ST(0));
b7953727	460
	461	if (items > 1)
	462	Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
	463
1b026014	464	ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
	465	XSRETURN(1);
	466	}
	467
14a976d6	468	XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577	469	{
	470	dXSARGS;
	471	SV *sv = SvRV(ST(0));
	472	if (items == 1) {
	473	if (SvREADONLY(sv))
	474	XSRETURN_YES;
	475	else
	476	XSRETURN_NO;
	477	}
	478	else if (items == 2) {
	479	if (SvTRUE(ST(1))) {
	480	SvREADONLY_on(sv);
	481	XSRETURN_YES;
	482	}
	483	else {
14a976d6	484	/* I hope you really know what you are doing. */
29569577	485	SvREADONLY_off(sv);
	486	XSRETURN_NO;
	487	}
	488	}
14a976d6	489	XSRETURN_UNDEF; /* Can't happen. */
29569577	490	}
29569577	491
14a976d6	492	XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577	493	{
	494	dXSARGS;
	495	SV *sv = SvRV(ST(0));
	496	if (items == 1)
14a976d6	497	XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577	498	else if (items == 2) {
14a976d6	499	/* I hope you really know what you are doing. */
29569577	500	SvREFCNT(sv) = SvIV(ST(1));
	501	XSRETURN_IV(SvREFCNT(sv));
	502	}
14a976d6	503	XSRETURN_UNDEF; /* Can't happen. */
29569577	504	}
29569577	505
dfd4ef2f	506	/* Maybe this should return the number of placeholders found in scalar context,
dfd4ef2f	507	and a list of them in list context. */
f044d0d1	508	XS(XS_Internals_hv_clear_placehold)
dfd4ef2f	509	{
	510	dXSARGS;
	511	HV hv = (HV ) SvRV(ST(0));
	512
	513	/* I don't care how many parameters were passed in, but I want to avoid
	514	the unused variable warning. */
	515
eb160463	516	items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f	517
	518	if (items) {
	519	HE *entry;
	520	I32 riter = HvRITER(hv);
	521	HE *eiter = HvEITER(hv);
	522	hv_iterinit(hv);
fe7bca90	523	/* This may look suboptimal with the items after the iternext, but
	524	it's quite deliberate. We only get here with items==0 if we've
	525	just deleted the last placeholder in the hash. If we've just done
	526	that then it means that the hash is in lazy delete mode, and the
	527	HE is now only referenced in our iterator. If we just quit the loop
	528	and discarded our iterator then the HE leaks. So we do the && the
	529	other way to ensure iternext is called just one more time, which
	530	has the side effect of triggering the lazy delete. */
	531	while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
	532	&& items) {
dfd4ef2f	533	SV *val = hv_iterval(hv, entry);
	534
	535	if (val == &PL_sv_undef) {
	536
	537	/* It seems that I have to go back in the front of the hash
	538	API to delete a hash, even though I have a HE structure
	539	pointing to the very entry I want to delete, and could hold
	540	onto the previous HE that points to it. And it's easier to
	541	go in with SVs as I can then specify the precomputed hash,
	542	and don't have fun and games with utf8 keys. */
	543	SV *key = hv_iterkeysv(entry);
	544
	545	hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
	546	items--;
	547	}
	548	}
	549	HvRITER(hv) = riter;
	550	HvEITER(hv) = eiter;
	551	}
	552
	553	XSRETURN(0);
	554	}