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

/*    universal.c
 *
 *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
 *    by Larry Wall and others
 *
 *    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"

#ifdef USE_PERLIO
#include "perliol.h" /* For the PERLIO_F_XXX */
#endif

/*
 * 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_is_utf8);
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);
XS(XS_PerlIO_get_layers);
XS(XS_Regexp_DESTROY);

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::is_utf8", XS_utf8_is_utf8, 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, "\\%");
    newXSproto("PerlIO::get_layers",
               XS_PerlIO_get_layers, file, "*;@");
    newXS("Regexp::DESTROY", XS_Regexp_DESTROY, 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_is_utf8)
{
    dXSARGS;
    if (items != 1)
	Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
    {
	SV *	sv = ST(0);
 {
  STRLEN len;
  if (SvUTF8(sv))
   XSRETURN_YES;
  else
   XSRETURN_NO;
 }
    }
    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);
}

XS(XS_Regexp_DESTROY)
{

}

XS(XS_PerlIO_get_layers)
{
    dXSARGS;
    if (items < 1 || items % 2 == 0)
	Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
#ifdef USE_PERLIO
    {
	SV *	sv;
	GV *	gv;
	IO *	io;
	bool	input = TRUE;
	bool	details = FALSE;

	if (items > 1) {
	     SV **svp;
	     
	     for (svp = MARK + 2; svp <= SP; svp += 2) {
		  SV **varp = svp;
		  SV **valp = svp + 1;
		  STRLEN klen;
		  char *key = SvPV(*varp, klen);

		  switch (*key) {
		  case 'i':
		       if (klen == 5 && memEQ(key, "input", 5)) {
			    input = SvTRUE(*valp);
			    break;
		       }
		       goto fail;
		  case 'o': 
		       if (klen == 6 && memEQ(key, "output", 6)) {
			    input = !SvTRUE(*valp);
			    break;
		       }
		       goto fail;
		  case 'd':
		       if (klen == 7 && memEQ(key, "details", 7)) {
			    details = SvTRUE(*valp);
			    break;
		       }
		       goto fail;
		  default:
		  fail:
		       Perl_croak(aTHX_
				  "get_layers: unknown argument '%s'",
				  key);
		  }
	     }

	     SP -= (items - 1);
	}

	sv = POPs;
	gv = (GV*)sv;

	if (!isGV(sv)) {
	     if (SvROK(sv) && isGV(SvRV(sv)))
		  gv = (GV*)SvRV(sv);
	     else
		  gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
	}

	if (gv && (io = GvIO(gv))) {
	     dTARGET;
	     AV* av = PerlIO_get_layers(aTHX_ input ?
					IoIFP(io) : IoOFP(io));
	     I32 i;
	     I32 last = av_len(av);
	     I32 nitem = 0;
	     
	     for (i = last; i >= 0; i -= 3) {
		  SV **namsvp;
		  SV **argsvp;
		  SV **flgsvp;
		  bool namok, argok, flgok;

		  namsvp = av_fetch(av, i - 2, FALSE);
		  argsvp = av_fetch(av, i - 1, FALSE);
		  flgsvp = av_fetch(av, i,     FALSE);

		  namok = namsvp && *namsvp && SvPOK(*namsvp);
		  argok = argsvp && *argsvp && SvPOK(*argsvp);
		  flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);

		  if (details) {
		       XPUSHs(namok ?
			     newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
		       XPUSHs(argok ?
			     newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
		       if (flgok)
			    XPUSHi(SvIVX(*flgsvp));
		       else
			    XPUSHs(&PL_sv_undef);
		       nitem += 3;
		  }
		  else {
		       if (namok && argok)
			    XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
					       *namsvp, *argsvp));
		       else if (namok)
			    XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
		       else
			    XPUSHs(&PL_sv_undef);
		       nitem++;
		       if (flgok) {
			    IV flags = SvIVX(*flgsvp);

			    if (flags & PERLIO_F_UTF8) {
				 XPUSHs(newSVpvn("utf8", 4));
				 nitem++;
			    }
		       }
		  }
	     }

	     SvREFCNT_dec(av);

	     XSRETURN(nitem);
	}
    }
#endif

    XSRETURN(0);
}
Commit	Line	Data
d6376244	1	/* universal.c
d6376244	2	*
4bb101f2	3	* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4bb101f2	4	* by Larry Wall and others
d6376244	5	*
	6	* You may distribute under the terms of either the GNU General Public
	7	* License or the Artistic License, as specified in the README file.
	8	*
	9	*/
	10
d31a8517	11	/*
	12	* "The roots of those mountains must be roots indeed; there must be
	13	* great secrets buried there which have not been discovered since the
	14	* beginning." --Gandalf, relating Gollum's story
	15	*/
	16
6d4a7be2	17	#include "EXTERN.h"
864dbfa3	18	#define PERL_IN_UNIVERSAL_C
6d4a7be2	19	#include "perl.h"
6d4a7be2	20
39f7a870	21	#ifdef USE_PERLIO
	22	#include "perliol.h" /* For the PERLIO_F_XXX */
	23	#endif
	24
6d4a7be2	25	/*
	26	* Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
	27	* The main guts of traverse_isa was actually copied from gv_fetchmeth
	28	*/
	29
76e3520e	30	STATIC SV *
301daebc	31	S_isa_lookup(pTHX_ HV stash, const char name, HV* name_stash,
301daebc	32	int len, int level)
6d4a7be2	33	{
	34	AV* av;
	35	GV* gv;
	36	GV** gvp;
	37	HV* hv = Nullhv;
46e4b22b	38	SV* subgen = Nullsv;
6d4a7be2	39
301daebc	40	/* A stash/class can go by many names (ie. User == main::User), so
	41	we compare the stash itself just in case */
	42	if (name_stash && (stash == name_stash))
	43	return &PL_sv_yes;
6d4a7be2	44
46e4b22b	45	if (strEQ(HvNAME(stash), name))
3280af22	46	return &PL_sv_yes;
6d4a7be2	47
6d4a7be2	48	if (level > 100)
46e4b22b	49	Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
46e4b22b	50	HvNAME(stash));
6d4a7be2	51
	52	gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
	53
46e4b22b	54	if (gvp && (gv = gvp) != (GV)&PL_sv_undef && (subgen = GvSV(gv))
	55	&& (hv = GvHV(gv)))
	56	{
eb160463	57	if (SvIV(subgen) == (IV)PL_sub_generation) {
46e4b22b	58	SV* sv;
	59	SV svp = (SV)hv_fetch(hv, name, len, FALSE);
	60	if (svp && (sv = svp) != (SV)&PL_sv_undef) {
	61	DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
	62	name, HvNAME(stash)) );
	63	return sv;
	64	}
	65	}
	66	else {
	67	DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
	68	HvNAME(stash)) );
	69	hv_clear(hv);
	70	sv_setiv(subgen, PL_sub_generation);
	71	}
6d4a7be2	72	}
	73
	74	gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
46e4b22b	75
3280af22	76	if (gvp && (gv = gvp) != (GV)&PL_sv_undef && (av = GvAV(gv))) {
46e4b22b	77	if (!hv \|\| !subgen) {
6d4a7be2	78	gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
	79
	80	gv = *gvp;
	81
	82	if (SvTYPE(gv) != SVt_PVGV)
	83	gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
	84
46e4b22b	85	if (!hv)
	86	hv = GvHVn(gv);
	87	if (!subgen) {
	88	subgen = newSViv(PL_sub_generation);
	89	GvSV(gv) = subgen;
	90	}
6d4a7be2	91	}
46e4b22b	92	if (hv) {
6d4a7be2	93	SV** svp = AvARRAY(av);
93965878	94	/* NOTE: No support for tied ISA */
93965878	95	I32 items = AvFILLp(av) + 1;
6d4a7be2	96	while (items--) {
	97	SV* sv = *svp++;
	98	HV* basestash = gv_stashsv(sv, FALSE);
	99	if (!basestash) {
599cee73	100	if (ckWARN(WARN_MISC))
9014280d	101	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
35c1215d	102	"Can't locate package %"SVf" for @%s::ISA",
35c1215d	103	sv, HvNAME(stash));
6d4a7be2	104	continue;
6d4a7be2	105	}
301daebc	106	if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
301daebc	107	len, level + 1)) {
3280af22	108	(void)hv_store(hv,name,len,&PL_sv_yes,0);
3280af22	109	return &PL_sv_yes;
6d4a7be2	110	}
6d4a7be2	111	}
3280af22	112	(void)hv_store(hv,name,len,&PL_sv_no,0);
6d4a7be2	113	}
	114	}
	115
e09f3e01	116	return boolSV(strEQ(name, "UNIVERSAL"));
6d4a7be2	117	}
6d4a7be2	118
954c1994	119	/*
ccfc67b7	120	=head1 SV Manipulation Functions
ccfc67b7	121
954c1994	122	=for apidoc sv_derived_from
	123
	124	Returns a boolean indicating whether the SV is derived from the specified
	125	class. This is the function that implements C<UNIVERSAL::isa>. It works
	126	for class names as well as for objects.
	127
	128	=cut
	129	*/
	130
55497cff	131	bool
864dbfa3	132	Perl_sv_derived_from(pTHX_ SV sv, const char name)
55497cff	133	{
55497cff	134	char *type;
55497cff	135	HV *stash;
301daebc	136	HV *name_stash;
46e4b22b	137
55497cff	138	stash = Nullhv;
55497cff	139	type = Nullch;
46e4b22b	140
55497cff	141	if (SvGMAGICAL(sv))
	142	mg_get(sv) ;
	143
	144	if (SvROK(sv)) {
	145	sv = SvRV(sv);
	146	type = sv_reftype(sv,0);
46e4b22b	147	if (SvOBJECT(sv))
55497cff	148	stash = SvSTASH(sv);
	149	}
	150	else {
	151	stash = gv_stashsv(sv, FALSE);
	152	}
46e4b22b	153
301daebc	154	name_stash = gv_stashpv(name, FALSE);
301daebc	155
55497cff	156	return (type && strEQ(type,name)) \|\|
301daebc	157	(stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
301daebc	158	== &PL_sv_yes)
55497cff	159	? TRUE
55497cff	160	: FALSE ;
55497cff	161	}
55497cff	162
1b026014	163	#include "XSUB.h"
1b026014	164
acfe0abc	165	void XS_UNIVERSAL_isa(pTHX_ CV *cv);
	166	void XS_UNIVERSAL_can(pTHX_ CV *cv);
	167	void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
439cb1c4	168	XS(XS_version_new);
	169	XS(XS_version_stringify);
	170	XS(XS_version_numify);
	171	XS(XS_version_vcmp);
	172	XS(XS_version_boolean);
	173	XS(XS_version_noop);
8800c35a	174	XS(XS_utf8_is_utf8);
1b026014	175	XS(XS_utf8_valid);
	176	XS(XS_utf8_encode);
	177	XS(XS_utf8_decode);
	178	XS(XS_utf8_upgrade);
	179	XS(XS_utf8_downgrade);
	180	XS(XS_utf8_unicode_to_native);
	181	XS(XS_utf8_native_to_unicode);
29569577	182	XS(XS_Internals_SvREADONLY);
29569577	183	XS(XS_Internals_SvREFCNT);
f044d0d1	184	XS(XS_Internals_hv_clear_placehold);
39f7a870	185	XS(XS_PerlIO_get_layers);
39cff0d9	186	XS(XS_Regexp_DESTROY);
0cb96387	187
	188	void
	189	Perl_boot_core_UNIVERSAL(pTHX)
	190	{
	191	char *file = __FILE__;
	192
	193	newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
	194	newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
	195	newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
439cb1c4	196	{
ad63d80f	197	/* register the overloading (type 'A') magic */
ad63d80f	198	PL_amagic_generation++;
439cb1c4	199	/* Make it findable via fetchmethod */
be2ebcad	200	newXS("version::()", XS_version_noop, file);
439cb1c4	201	newXS("version::new", XS_version_new, file);
	202	newXS("version::(\"\"", XS_version_stringify, file);
	203	newXS("version::stringify", XS_version_stringify, file);
	204	newXS("version::(0+", XS_version_numify, file);
	205	newXS("version::numify", XS_version_numify, file);
	206	newXS("version::(cmp", XS_version_vcmp, file);
	207	newXS("version::(<=>", XS_version_vcmp, file);
	208	newXS("version::vcmp", XS_version_vcmp, file);
	209	newXS("version::(bool", XS_version_boolean, file);
	210	newXS("version::boolean", XS_version_boolean, file);
	211	newXS("version::(nomethod", XS_version_noop, file);
	212	newXS("version::noop", XS_version_noop, file);
	213	}
8800c35a	214	newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
1b026014	215	newXS("utf8::valid", XS_utf8_valid, file);
	216	newXS("utf8::encode", XS_utf8_encode, file);
	217	newXS("utf8::decode", XS_utf8_decode, file);
	218	newXS("utf8::upgrade", XS_utf8_upgrade, file);
	219	newXS("utf8::downgrade", XS_utf8_downgrade, file);
	220	newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
	221	newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577	222	newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
29569577	223	newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f	224	newXSproto("Internals::hv_clear_placeholders",
f044d0d1	225	XS_Internals_hv_clear_placehold, file, "\\%");
9d569fce	226	newXSproto("PerlIO::get_layers",
9d569fce	227	XS_PerlIO_get_layers, file, "*;@");
39cff0d9	228	newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
0cb96387	229	}
0cb96387	230
55497cff	231
6d4a7be2	232	XS(XS_UNIVERSAL_isa)
	233	{
	234	dXSARGS;
55497cff	235	SV *sv;
55497cff	236	char *name;
2d8e6c8d	237	STRLEN n_a;
6d4a7be2	238
6d4a7be2	239	if (items != 2)
cea2e8a9	240	Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2	241
6d4a7be2	242	sv = ST(0);
f8f70380	243
d3f7f2b2	244	if (SvGMAGICAL(sv))
	245	mg_get(sv);
	246
253ecd6d	247	if (!SvOK(sv) \|\| !(SvROK(sv) \|\| (SvPOK(sv) && SvCUR(sv))
253ecd6d	248	\|\| (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380	249	XSRETURN_UNDEF;
f8f70380	250
2d8e6c8d	251	name = (char *)SvPV(ST(1),n_a);
6d4a7be2	252
54310121	253	ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2	254	XSRETURN(1);
	255	}
	256
6d4a7be2	257	XS(XS_UNIVERSAL_can)
	258	{
	259	dXSARGS;
	260	SV *sv;
	261	char *name;
	262	SV *rv;
6f08146e	263	HV *pkg = NULL;
2d8e6c8d	264	STRLEN n_a;
6d4a7be2	265
6d4a7be2	266	if (items != 2)
cea2e8a9	267	Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2	268
6d4a7be2	269	sv = ST(0);
f8f70380	270
d3f7f2b2	271	if (SvGMAGICAL(sv))
	272	mg_get(sv);
	273
253ecd6d	274	if (!SvOK(sv) \|\| !(SvROK(sv) \|\| (SvPOK(sv) && SvCUR(sv))
253ecd6d	275	\|\| (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380	276	XSRETURN_UNDEF;
f8f70380	277
2d8e6c8d	278	name = (char *)SvPV(ST(1),n_a);
3280af22	279	rv = &PL_sv_undef;
6d4a7be2	280
46e4b22b	281	if (SvROK(sv)) {
6f08146e	282	sv = (SV*)SvRV(sv);
46e4b22b	283	if (SvOBJECT(sv))
6f08146e	284	pkg = SvSTASH(sv);
	285	}
	286	else {
	287	pkg = gv_stashsv(sv, FALSE);
	288	}
	289
	290	if (pkg) {
dc848c6f	291	GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
	292	if (gv && isGV(gv))
	293	rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2	294	}
	295
	296	ST(0) = rv;
	297	XSRETURN(1);
	298	}
	299
6d4a7be2	300	XS(XS_UNIVERSAL_VERSION)
	301	{
	302	dXSARGS;
	303	HV *pkg;
	304	GV **gvp;
	305	GV *gv;
	306	SV *sv;
	307	char *undef;
	308
1571675a	309	if (SvROK(ST(0))) {
6d4a7be2	310	sv = (SV*)SvRV(ST(0));
1571675a	311	if (!SvOBJECT(sv))
cea2e8a9	312	Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2	313	pkg = SvSTASH(sv);
	314	}
	315	else {
	316	pkg = gv_stashsv(ST(0), FALSE);
	317	}
	318
	319	gvp = pkg ? (GV)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV);
	320
d4bea2fb	321	if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2	322	SV *nsv = sv_newmortal();
	323	sv_setsv(nsv, sv);
	324	sv = nsv;
	325	undef = Nullch;
	326	}
	327	else {
3280af22	328	sv = (SV*)&PL_sv_undef;
6d4a7be2	329	undef = "(undef)";
	330	}
	331
1571675a	332	if (items > 1) {
	333	STRLEN len;
	334	SV *req = ST(1);
	335
62658f4d	336	if (undef) {
	337	if (pkg)
	338	Perl_croak(aTHX_
	339	"%s does not define $%s::VERSION--version check failed",
	340	HvNAME(pkg), HvNAME(pkg));
	341	else {
	342	char *str = SvPVx(ST(0), len);
	343
	344	Perl_croak(aTHX_
	345	"%s defines neither package nor VERSION--version check failed", str);
	346	}
	347	}
ad63d80f	348	if ( !sv_derived_from(sv, "version"))
	349	sv = new_version(sv);
	350
	351	if ( !sv_derived_from(req, "version"))
	352	req = new_version(req);
1571675a	353
ad63d80f	354	if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
e3feee4e	355	Perl_croak(aTHX_
e3feee4e	356	"%s version %"SVf" required--this is only version %"SVf,
0773b1f0	357	HvNAME(pkg), req, sv);
2d8e6c8d	358	}
6d4a7be2	359
	360	ST(0) = sv;
	361
	362	XSRETURN(1);
	363	}
	364
439cb1c4	365	XS(XS_version_new)
	366	{
	367	dXSARGS;
129318bd	368	if (items > 3)
439cb1c4	369	Perl_croak(aTHX_ "Usage: version::new(class, version)");
	370	SP -= items;
	371	{
	372	/* char * class = (char )SvPV_nolen(ST(0)); /
129318bd	373	SV *version = ST(1);
	374	if (items == 3 )
	375	{
	376	char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
9be22fdc	377	version = Perl_newSVpvf(aTHX_ "v%s",vs);
129318bd	378	}
439cb1c4	379
129318bd	380	PUSHs(new_version(version));
439cb1c4	381	PUTBACK;
	382	return;
	383	}
	384	}
	385
	386	XS(XS_version_stringify)
	387	{
	388	dXSARGS;
	389	if (items < 1)
	390	Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
	391	SP -= items;
	392	{
	393	SV * lobj;
	394
	395	if (sv_derived_from(ST(0), "version")) {
	396	SV *tmp = SvRV(ST(0));
	397	lobj = tmp;
	398	}
	399	else
ba329e04	400	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	401
439cb1c4	402	{
ad63d80f	403	PUSHs(vstringify(lobj));
439cb1c4	404	}
	405
	406	PUTBACK;
	407	return;
	408	}
	409	}
	410
	411	XS(XS_version_numify)
	412	{
	413	dXSARGS;
	414	if (items < 1)
	415	Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
	416	SP -= items;
	417	{
	418	SV * lobj;
	419
	420	if (sv_derived_from(ST(0), "version")) {
	421	SV *tmp = SvRV(ST(0));
	422	lobj = tmp;
	423	}
	424	else
ba329e04	425	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	426
439cb1c4	427	{
ad63d80f	428	PUSHs(vnumify(lobj));
439cb1c4	429	}
	430
	431	PUTBACK;
	432	return;
	433	}
	434	}
	435
	436	XS(XS_version_vcmp)
	437	{
	438	dXSARGS;
	439	if (items < 1)
	440	Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
	441	SP -= items;
	442	{
	443	SV * lobj;
	444
	445	if (sv_derived_from(ST(0), "version")) {
	446	SV *tmp = SvRV(ST(0));
	447	lobj = tmp;
	448	}
	449	else
ba329e04	450	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	451
	452	{
	453	SV *rs;
	454	SV *rvs;
	455	SV * robj = ST(1);
	456	IV swap = (IV)SvIV(ST(2));
	457
	458	if ( ! sv_derived_from(robj, "version") )
	459	{
	460	robj = new_version(robj);
	461	}
	462	rvs = SvRV(robj);
	463
	464	if ( swap )
	465	{
ad63d80f	466	rs = newSViv(vcmp(rvs,lobj));
439cb1c4	467	}
	468	else
	469	{
ad63d80f	470	rs = newSViv(vcmp(lobj,rvs));
439cb1c4	471	}
	472
	473	PUSHs(rs);
	474	}
	475
	476	PUTBACK;
	477	return;
	478	}
	479	}
	480
	481	XS(XS_version_boolean)
	482	{
	483	dXSARGS;
	484	if (items < 1)
	485	Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
	486	SP -= items;
	487	{
	488	SV * lobj;
	489
	490	if (sv_derived_from(ST(0), "version")) {
	491	SV *tmp = SvRV(ST(0));
	492	lobj = tmp;
	493	}
	494	else
ba329e04	495	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	496
	497	{
	498	SV *rs;
ad63d80f	499	rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
439cb1c4	500	PUSHs(rs);
	501	}
	502
	503	PUTBACK;
	504	return;
	505	}
	506	}
	507
	508	XS(XS_version_noop)
	509	{
	510	dXSARGS;
	511	if (items < 1)
	512	Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
	513	{
	514	SV * lobj;
	515
	516	if (sv_derived_from(ST(0), "version")) {
	517	SV *tmp = SvRV(ST(0));
	518	lobj = tmp;
	519	}
	520	else
ba329e04	521	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	522
439cb1c4	523	{
ba329e04	524	Perl_croak(aTHX_ "operation not supported with version object");
439cb1c4	525	}
	526
	527	}
	528	XSRETURN_EMPTY;
	529	}
	530
8800c35a	531	XS(XS_utf8_is_utf8)
	532	{
	533	dXSARGS;
	534	if (items != 1)
	535	Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
	536	{
	537	SV * sv = ST(0);
	538	{
	539	STRLEN len;
	540	if (SvUTF8(sv))
	541	XSRETURN_YES;
	542	else
	543	XSRETURN_NO;
	544	}
	545	}
	546	XSRETURN_EMPTY;
	547	}
	548
1b026014	549	XS(XS_utf8_valid)
	550	{
	551	dXSARGS;
	552	if (items != 1)
	553	Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
	554	{
	555	SV * sv = ST(0);
	556	{
	557	STRLEN len;
	558	char *s = SvPV(sv,len);
	559	if (!SvUTF8(sv) \|\| is_utf8_string((U8*)s,len))
	560	XSRETURN_YES;
	561	else
	562	XSRETURN_NO;
	563	}
	564	}
	565	XSRETURN_EMPTY;
	566	}
	567
	568	XS(XS_utf8_encode)
	569	{
	570	dXSARGS;
	571	if (items != 1)
	572	Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
	573	{
	574	SV * sv = ST(0);
	575
	576	sv_utf8_encode(sv);
	577	}
	578	XSRETURN_EMPTY;
	579	}
	580
	581	XS(XS_utf8_decode)
	582	{
	583	dXSARGS;
	584	if (items != 1)
	585	Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
	586	{
	587	SV * sv = ST(0);
	588	bool RETVAL;
	589
	590	RETVAL = sv_utf8_decode(sv);
	591	ST(0) = boolSV(RETVAL);
	592	sv_2mortal(ST(0));
	593	}
	594	XSRETURN(1);
	595	}
	596
	597	XS(XS_utf8_upgrade)
	598	{
	599	dXSARGS;
	600	if (items != 1)
	601	Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
	602	{
	603	SV * sv = ST(0);
	604	STRLEN RETVAL;
	605	dXSTARG;
	606
	607	RETVAL = sv_utf8_upgrade(sv);
	608	XSprePUSH; PUSHi((IV)RETVAL);
	609	}
	610	XSRETURN(1);
	611	}
	612
613	XS(XS_utf8_downgrade)
614	{
615	dXSARGS;
616	if (items < 1 \|\| items > 2)
617	Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
618	{
619	SV * sv = ST(0);
620	bool failok;
621	bool RETVAL;
622
623	if (items < 2)
624	failok = 0;
625	else {
626	failok = (int)SvIV(ST(1));
627	}
628
629	RETVAL = sv_utf8_downgrade(sv, failok);
630	ST(0) = boolSV(RETVAL);
631	sv_2mortal(ST(0));
632	}
633	XSRETURN(1);
634	}
635
636	XS(XS_utf8_native_to_unicode)
637	{
638	dXSARGS;
639	UV uv = SvUV(ST(0));
b7953727	640
	641	if (items > 1)
	642	Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
	643
1b026014	644	ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
	645	XSRETURN(1);
	646	}
	647
	648	XS(XS_utf8_unicode_to_native)
	649	{
	650	dXSARGS;
	651	UV uv = SvUV(ST(0));
b7953727	652
	653	if (items > 1)
	654	Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
	655
1b026014	656	ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
	657	XSRETURN(1);
	658	}
	659
14a976d6	660	XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577	661	{
	662	dXSARGS;
	663	SV *sv = SvRV(ST(0));
	664	if (items == 1) {
	665	if (SvREADONLY(sv))
	666	XSRETURN_YES;
	667	else
	668	XSRETURN_NO;
	669	}
	670	else if (items == 2) {
	671	if (SvTRUE(ST(1))) {
	672	SvREADONLY_on(sv);
	673	XSRETURN_YES;
	674	}
	675	else {
14a976d6	676	/* I hope you really know what you are doing. */
29569577	677	SvREADONLY_off(sv);
	678	XSRETURN_NO;
	679	}
	680	}
14a976d6	681	XSRETURN_UNDEF; /* Can't happen. */
29569577	682	}
29569577	683
14a976d6	684	XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577	685	{
	686	dXSARGS;
	687	SV *sv = SvRV(ST(0));
	688	if (items == 1)
14a976d6	689	XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577	690	else if (items == 2) {
14a976d6	691	/* I hope you really know what you are doing. */
29569577	692	SvREFCNT(sv) = SvIV(ST(1));
	693	XSRETURN_IV(SvREFCNT(sv));
	694	}
14a976d6	695	XSRETURN_UNDEF; /* Can't happen. */
29569577	696	}
29569577	697
dfd4ef2f	698	/* Maybe this should return the number of placeholders found in scalar context,
dfd4ef2f	699	and a list of them in list context. */
f044d0d1	700	XS(XS_Internals_hv_clear_placehold)
dfd4ef2f	701	{
	702	dXSARGS;
	703	HV hv = (HV ) SvRV(ST(0));
	704
	705	/* I don't care how many parameters were passed in, but I want to avoid
	706	the unused variable warning. */
	707
eb160463	708	items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f	709
	710	if (items) {
	711	HE *entry;
	712	I32 riter = HvRITER(hv);
	713	HE *eiter = HvEITER(hv);
	714	hv_iterinit(hv);
fe7bca90	715	/* This may look suboptimal with the items after the iternext, but
	716	it's quite deliberate. We only get here with items==0 if we've
	717	just deleted the last placeholder in the hash. If we've just done
	718	that then it means that the hash is in lazy delete mode, and the
	719	HE is now only referenced in our iterator. If we just quit the loop
	720	and discarded our iterator then the HE leaks. So we do the && the
	721	other way to ensure iternext is called just one more time, which
	722	has the side effect of triggering the lazy delete. */
	723	while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
	724	&& items) {
dfd4ef2f	725	SV *val = hv_iterval(hv, entry);
	726
	727	if (val == &PL_sv_undef) {
	728
	729	/* It seems that I have to go back in the front of the hash
	730	API to delete a hash, even though I have a HE structure
	731	pointing to the very entry I want to delete, and could hold
	732	onto the previous HE that points to it. And it's easier to
	733	go in with SVs as I can then specify the precomputed hash,
	734	and don't have fun and games with utf8 keys. */
	735	SV *key = hv_iterkeysv(entry);
	736
	737	hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
	738	items--;
	739	}
	740	}
	741	HvRITER(hv) = riter;
	742	HvEITER(hv) = eiter;
	743	}
	744
	745	XSRETURN(0);
	746	}
39f7a870	747
39cff0d9	748	XS(XS_Regexp_DESTROY)
	749	{
	750
	751	}
	752
39f7a870	753	XS(XS_PerlIO_get_layers)
	754	{
	755	dXSARGS;
	756	if (items < 1 \|\| items % 2 == 0)
	757	Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
5fef3b4a	758	#ifdef USE_PERLIO
39f7a870	759	{
	760	SV * sv;
	761	GV * gv;
	762	IO * io;
	763	bool input = TRUE;
	764	bool details = FALSE;
	765
	766	if (items > 1) {
39f7a870	767	SV **svp;
	768
	769	for (svp = MARK + 2; svp <= SP; svp += 2) {
	770	SV **varp = svp;
	771	SV **valp = svp + 1;
	772	STRLEN klen;
	773	char key = SvPV(varp, klen);
	774
	775	switch (*key) {
	776	case 'i':
	777	if (klen == 5 && memEQ(key, "input", 5)) {
	778	input = SvTRUE(*valp);
	779	break;
	780	}
	781	goto fail;
	782	case 'o':
	783	if (klen == 6 && memEQ(key, "output", 6)) {
	784	input = !SvTRUE(*valp);
	785	break;
	786	}
	787	goto fail;
	788	case 'd':
	789	if (klen == 7 && memEQ(key, "details", 7)) {
	790	details = SvTRUE(*valp);
	791	break;
	792	}
	793	goto fail;
	794	default:
	795	fail:
	796	Perl_croak(aTHX_
	797	"get_layers: unknown argument '%s'",
	798	key);
	799	}
	800	}
	801
	802	SP -= (items - 1);
	803	}
	804
	805	sv = POPs;
	806	gv = (GV*)sv;
	807
	808	if (!isGV(sv)) {
	809	if (SvROK(sv) && isGV(SvRV(sv)))
	810	gv = (GV*)SvRV(sv);
	811	else
	812	gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
	813	}
	814
	815	if (gv && (io = GvIO(gv))) {
	816	dTARGET;
	817	AV* av = PerlIO_get_layers(aTHX_ input ?
	818	IoIFP(io) : IoOFP(io));
	819	I32 i;
	820	I32 last = av_len(av);
	821	I32 nitem = 0;
	822
	823	for (i = last; i >= 0; i -= 3) {
	824	SV **namsvp;
	825	SV **argsvp;
	826	SV **flgsvp;
	827	bool namok, argok, flgok;
	828
	829	namsvp = av_fetch(av, i - 2, FALSE);
	830	argsvp = av_fetch(av, i - 1, FALSE);
831	flgsvp = av_fetch(av, i, FALSE);
832
833	namok = namsvp && namsvp && SvPOK(namsvp);
834	argok = argsvp && argsvp && SvPOK(argsvp);
835	flgok = flgsvp && flgsvp && SvIOK(flgsvp);
836
837	if (details) {
838	XPUSHs(namok ?
839	newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
840	XPUSHs(argok ?
841	newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
842	if (flgok)
843	XPUSHi(SvIVX(*flgsvp));
844	else
845	XPUSHs(&PL_sv_undef);
846	nitem += 3;
847	}
848	else {
849	if (namok && argok)
850	XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
851	namsvp, argsvp));
852	else if (namok)
853	XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
854	else
855	XPUSHs(&PL_sv_undef);
856	nitem++;
857	if (flgok) {
858	IV flags = SvIVX(*flgsvp);
859
860	if (flags & PERLIO_F_UTF8) {
861	XPUSHs(newSVpvn("utf8", 4));
862	nitem++;
863	}
864	}
865	}
866	}
867
868	SvREFCNT_dec(av);
869
870	XSRETURN(nitem);
871	}
872	}
5fef3b4a	873	#endif
39f7a870	874
	875	XSRETURN(0);
	876	}
	877