[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_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);

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, "\\%");
    newXSproto("PerlIO::get_layers",
               XS_PerlIO_get_layers, 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);
}

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);
1b026014	174	XS(XS_utf8_valid);
	175	XS(XS_utf8_encode);
	176	XS(XS_utf8_decode);
	177	XS(XS_utf8_upgrade);
	178	XS(XS_utf8_downgrade);
	179	XS(XS_utf8_unicode_to_native);
	180	XS(XS_utf8_native_to_unicode);
29569577	181	XS(XS_Internals_SvREADONLY);
29569577	182	XS(XS_Internals_SvREFCNT);
f044d0d1	183	XS(XS_Internals_hv_clear_placehold);
39f7a870	184	XS(XS_PerlIO_get_layers);
0cb96387	185
	186	void
	187	Perl_boot_core_UNIVERSAL(pTHX)
	188	{
	189	char *file = __FILE__;
	190
	191	newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
	192	newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
	193	newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
439cb1c4	194	{
ad63d80f	195	/* register the overloading (type 'A') magic */
ad63d80f	196	PL_amagic_generation++;
439cb1c4	197	/* Make it findable via fetchmethod */
be2ebcad	198	newXS("version::()", XS_version_noop, file);
439cb1c4	199	newXS("version::new", XS_version_new, file);
	200	newXS("version::(\"\"", XS_version_stringify, file);
	201	newXS("version::stringify", XS_version_stringify, file);
	202	newXS("version::(0+", XS_version_numify, file);
	203	newXS("version::numify", XS_version_numify, file);
	204	newXS("version::(cmp", XS_version_vcmp, file);
	205	newXS("version::(<=>", XS_version_vcmp, file);
	206	newXS("version::vcmp", XS_version_vcmp, file);
	207	newXS("version::(bool", XS_version_boolean, file);
	208	newXS("version::boolean", XS_version_boolean, file);
	209	newXS("version::(nomethod", XS_version_noop, file);
	210	newXS("version::noop", XS_version_noop, file);
	211	}
1b026014	212	newXS("utf8::valid", XS_utf8_valid, file);
	213	newXS("utf8::encode", XS_utf8_encode, file);
	214	newXS("utf8::decode", XS_utf8_decode, file);
	215	newXS("utf8::upgrade", XS_utf8_upgrade, file);
	216	newXS("utf8::downgrade", XS_utf8_downgrade, file);
	217	newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
	218	newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577	219	newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
29569577	220	newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f	221	newXSproto("Internals::hv_clear_placeholders",
f044d0d1	222	XS_Internals_hv_clear_placehold, file, "\\%");
9d569fce	223	newXSproto("PerlIO::get_layers",
9d569fce	224	XS_PerlIO_get_layers, file, "*;@");
0cb96387	225	}
0cb96387	226
55497cff	227
6d4a7be2	228	XS(XS_UNIVERSAL_isa)
	229	{
	230	dXSARGS;
55497cff	231	SV *sv;
55497cff	232	char *name;
2d8e6c8d	233	STRLEN n_a;
6d4a7be2	234
6d4a7be2	235	if (items != 2)
cea2e8a9	236	Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2	237
6d4a7be2	238	sv = ST(0);
f8f70380	239
d3f7f2b2	240	if (SvGMAGICAL(sv))
	241	mg_get(sv);
	242
253ecd6d	243	if (!SvOK(sv) \|\| !(SvROK(sv) \|\| (SvPOK(sv) && SvCUR(sv))
253ecd6d	244	\|\| (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380	245	XSRETURN_UNDEF;
f8f70380	246
2d8e6c8d	247	name = (char *)SvPV(ST(1),n_a);
6d4a7be2	248
54310121	249	ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2	250	XSRETURN(1);
	251	}
	252
6d4a7be2	253	XS(XS_UNIVERSAL_can)
	254	{
	255	dXSARGS;
	256	SV *sv;
	257	char *name;
	258	SV *rv;
6f08146e	259	HV *pkg = NULL;
2d8e6c8d	260	STRLEN n_a;
6d4a7be2	261
6d4a7be2	262	if (items != 2)
cea2e8a9	263	Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2	264
6d4a7be2	265	sv = ST(0);
f8f70380	266
d3f7f2b2	267	if (SvGMAGICAL(sv))
	268	mg_get(sv);
	269
253ecd6d	270	if (!SvOK(sv) \|\| !(SvROK(sv) \|\| (SvPOK(sv) && SvCUR(sv))
253ecd6d	271	\|\| (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380	272	XSRETURN_UNDEF;
f8f70380	273
2d8e6c8d	274	name = (char *)SvPV(ST(1),n_a);
3280af22	275	rv = &PL_sv_undef;
6d4a7be2	276
46e4b22b	277	if (SvROK(sv)) {
6f08146e	278	sv = (SV*)SvRV(sv);
46e4b22b	279	if (SvOBJECT(sv))
6f08146e	280	pkg = SvSTASH(sv);
	281	}
	282	else {
	283	pkg = gv_stashsv(sv, FALSE);
	284	}
	285
	286	if (pkg) {
dc848c6f	287	GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
	288	if (gv && isGV(gv))
	289	rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2	290	}
	291
	292	ST(0) = rv;
	293	XSRETURN(1);
	294	}
	295
6d4a7be2	296	XS(XS_UNIVERSAL_VERSION)
	297	{
	298	dXSARGS;
	299	HV *pkg;
	300	GV **gvp;
	301	GV *gv;
	302	SV *sv;
	303	char *undef;
	304
1571675a	305	if (SvROK(ST(0))) {
6d4a7be2	306	sv = (SV*)SvRV(ST(0));
1571675a	307	if (!SvOBJECT(sv))
cea2e8a9	308	Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2	309	pkg = SvSTASH(sv);
	310	}
	311	else {
	312	pkg = gv_stashsv(ST(0), FALSE);
	313	}
	314
	315	gvp = pkg ? (GV)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV);
	316
d4bea2fb	317	if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2	318	SV *nsv = sv_newmortal();
	319	sv_setsv(nsv, sv);
	320	sv = nsv;
	321	undef = Nullch;
	322	}
	323	else {
3280af22	324	sv = (SV*)&PL_sv_undef;
6d4a7be2	325	undef = "(undef)";
	326	}
	327
1571675a	328	if (items > 1) {
	329	STRLEN len;
	330	SV *req = ST(1);
	331
62658f4d	332	if (undef) {
	333	if (pkg)
	334	Perl_croak(aTHX_
	335	"%s does not define $%s::VERSION--version check failed",
	336	HvNAME(pkg), HvNAME(pkg));
	337	else {
	338	char *str = SvPVx(ST(0), len);
	339
	340	Perl_croak(aTHX_
	341	"%s defines neither package nor VERSION--version check failed", str);
	342	}
	343	}
ad63d80f	344	if ( !sv_derived_from(sv, "version"))
	345	sv = new_version(sv);
	346
	347	if ( !sv_derived_from(req, "version"))
	348	req = new_version(req);
1571675a	349
ad63d80f	350	if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
e3feee4e	351	Perl_croak(aTHX_
e3feee4e	352	"%s version %"SVf" required--this is only version %"SVf,
0773b1f0	353	HvNAME(pkg), req, sv);
2d8e6c8d	354	}
6d4a7be2	355
	356	ST(0) = sv;
	357
	358	XSRETURN(1);
	359	}
	360
439cb1c4	361	XS(XS_version_new)
	362	{
	363	dXSARGS;
129318bd	364	if (items > 3)
439cb1c4	365	Perl_croak(aTHX_ "Usage: version::new(class, version)");
	366	SP -= items;
	367	{
	368	/* char * class = (char )SvPV_nolen(ST(0)); /
129318bd	369	SV *version = ST(1);
	370	if (items == 3 )
	371	{
	372	char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
9be22fdc	373	version = Perl_newSVpvf(aTHX_ "v%s",vs);
129318bd	374	}
439cb1c4	375
129318bd	376	PUSHs(new_version(version));
439cb1c4	377	PUTBACK;
	378	return;
	379	}
	380	}
	381
	382	XS(XS_version_stringify)
	383	{
	384	dXSARGS;
	385	if (items < 1)
	386	Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
	387	SP -= items;
	388	{
	389	SV * lobj;
	390
	391	if (sv_derived_from(ST(0), "version")) {
	392	SV *tmp = SvRV(ST(0));
	393	lobj = tmp;
	394	}
	395	else
ba329e04	396	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	397
439cb1c4	398	{
ad63d80f	399	PUSHs(vstringify(lobj));
439cb1c4	400	}
	401
	402	PUTBACK;
	403	return;
	404	}
	405	}
	406
	407	XS(XS_version_numify)
	408	{
	409	dXSARGS;
	410	if (items < 1)
	411	Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
	412	SP -= items;
	413	{
	414	SV * lobj;
	415
	416	if (sv_derived_from(ST(0), "version")) {
	417	SV *tmp = SvRV(ST(0));
	418	lobj = tmp;
	419	}
	420	else
ba329e04	421	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	422
439cb1c4	423	{
ad63d80f	424	PUSHs(vnumify(lobj));
439cb1c4	425	}
	426
	427	PUTBACK;
	428	return;
	429	}
	430	}
	431
	432	XS(XS_version_vcmp)
	433	{
	434	dXSARGS;
	435	if (items < 1)
	436	Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
	437	SP -= items;
	438	{
	439	SV * lobj;
	440
	441	if (sv_derived_from(ST(0), "version")) {
	442	SV *tmp = SvRV(ST(0));
	443	lobj = tmp;
	444	}
	445	else
ba329e04	446	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	447
	448	{
	449	SV *rs;
	450	SV *rvs;
	451	SV * robj = ST(1);
	452	IV swap = (IV)SvIV(ST(2));
	453
	454	if ( ! sv_derived_from(robj, "version") )
	455	{
	456	robj = new_version(robj);
	457	}
	458	rvs = SvRV(robj);
	459
	460	if ( swap )
	461	{
ad63d80f	462	rs = newSViv(vcmp(rvs,lobj));
439cb1c4	463	}
	464	else
	465	{
ad63d80f	466	rs = newSViv(vcmp(lobj,rvs));
439cb1c4	467	}
	468
	469	PUSHs(rs);
	470	}
	471
	472	PUTBACK;
	473	return;
	474	}
	475	}
	476
	477	XS(XS_version_boolean)
	478	{
	479	dXSARGS;
	480	if (items < 1)
	481	Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
	482	SP -= items;
	483	{
	484	SV * lobj;
	485
	486	if (sv_derived_from(ST(0), "version")) {
	487	SV *tmp = SvRV(ST(0));
	488	lobj = tmp;
	489	}
	490	else
ba329e04	491	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	492
	493	{
	494	SV *rs;
ad63d80f	495	rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
439cb1c4	496	PUSHs(rs);
	497	}
	498
	499	PUTBACK;
	500	return;
	501	}
	502	}
	503
	504	XS(XS_version_noop)
	505	{
	506	dXSARGS;
	507	if (items < 1)
	508	Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
	509	{
	510	SV * lobj;
	511
	512	if (sv_derived_from(ST(0), "version")) {
	513	SV *tmp = SvRV(ST(0));
	514	lobj = tmp;
	515	}
	516	else
ba329e04	517	Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4	518
439cb1c4	519	{
ba329e04	520	Perl_croak(aTHX_ "operation not supported with version object");
439cb1c4	521	}
	522
	523	}
	524	XSRETURN_EMPTY;
	525	}
	526
1b026014	527	XS(XS_utf8_valid)
	528	{
	529	dXSARGS;
	530	if (items != 1)
	531	Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
	532	{
	533	SV * sv = ST(0);
	534	{
	535	STRLEN len;
	536	char *s = SvPV(sv,len);
	537	if (!SvUTF8(sv) \|\| is_utf8_string((U8*)s,len))
	538	XSRETURN_YES;
	539	else
	540	XSRETURN_NO;
	541	}
	542	}
	543	XSRETURN_EMPTY;
	544	}
	545
	546	XS(XS_utf8_encode)
	547	{
	548	dXSARGS;
	549	if (items != 1)
	550	Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
	551	{
	552	SV * sv = ST(0);
	553
	554	sv_utf8_encode(sv);
	555	}
	556	XSRETURN_EMPTY;
	557	}
	558
	559	XS(XS_utf8_decode)
	560	{
	561	dXSARGS;
	562	if (items != 1)
	563	Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
	564	{
	565	SV * sv = ST(0);
	566	bool RETVAL;
	567
	568	RETVAL = sv_utf8_decode(sv);
	569	ST(0) = boolSV(RETVAL);
	570	sv_2mortal(ST(0));
	571	}
	572	XSRETURN(1);
	573	}
	574
	575	XS(XS_utf8_upgrade)
	576	{
	577	dXSARGS;
	578	if (items != 1)
	579	Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
	580	{
	581	SV * sv = ST(0);
	582	STRLEN RETVAL;
	583	dXSTARG;
	584
	585	RETVAL = sv_utf8_upgrade(sv);
	586	XSprePUSH; PUSHi((IV)RETVAL);
	587	}
	588	XSRETURN(1);
	589	}
	590
591	XS(XS_utf8_downgrade)
592	{
593	dXSARGS;
594	if (items < 1 \|\| items > 2)
595	Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
596	{
597	SV * sv = ST(0);
598	bool failok;
599	bool RETVAL;
600
601	if (items < 2)
602	failok = 0;
603	else {
604	failok = (int)SvIV(ST(1));
605	}
606
607	RETVAL = sv_utf8_downgrade(sv, failok);
608	ST(0) = boolSV(RETVAL);
609	sv_2mortal(ST(0));
610	}
611	XSRETURN(1);
612	}
613
614	XS(XS_utf8_native_to_unicode)
615	{
616	dXSARGS;
617	UV uv = SvUV(ST(0));
b7953727	618
	619	if (items > 1)
	620	Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
	621
1b026014	622	ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
	623	XSRETURN(1);
	624	}
	625
	626	XS(XS_utf8_unicode_to_native)
	627	{
	628	dXSARGS;
	629	UV uv = SvUV(ST(0));
b7953727	630
	631	if (items > 1)
	632	Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
	633
1b026014	634	ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
	635	XSRETURN(1);
	636	}
	637
14a976d6	638	XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577	639	{
	640	dXSARGS;
	641	SV *sv = SvRV(ST(0));
	642	if (items == 1) {
	643	if (SvREADONLY(sv))
	644	XSRETURN_YES;
	645	else
	646	XSRETURN_NO;
	647	}
	648	else if (items == 2) {
	649	if (SvTRUE(ST(1))) {
	650	SvREADONLY_on(sv);
	651	XSRETURN_YES;
	652	}
	653	else {
14a976d6	654	/* I hope you really know what you are doing. */
29569577	655	SvREADONLY_off(sv);
	656	XSRETURN_NO;
	657	}
	658	}
14a976d6	659	XSRETURN_UNDEF; /* Can't happen. */
29569577	660	}
29569577	661
14a976d6	662	XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577	663	{
	664	dXSARGS;
	665	SV *sv = SvRV(ST(0));
	666	if (items == 1)
14a976d6	667	XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577	668	else if (items == 2) {
14a976d6	669	/* I hope you really know what you are doing. */
29569577	670	SvREFCNT(sv) = SvIV(ST(1));
	671	XSRETURN_IV(SvREFCNT(sv));
	672	}
14a976d6	673	XSRETURN_UNDEF; /* Can't happen. */
29569577	674	}
29569577	675
dfd4ef2f	676	/* Maybe this should return the number of placeholders found in scalar context,
dfd4ef2f	677	and a list of them in list context. */
f044d0d1	678	XS(XS_Internals_hv_clear_placehold)
dfd4ef2f	679	{
	680	dXSARGS;
	681	HV hv = (HV ) SvRV(ST(0));
	682
	683	/* I don't care how many parameters were passed in, but I want to avoid
	684	the unused variable warning. */
	685
eb160463	686	items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f	687
	688	if (items) {
	689	HE *entry;
	690	I32 riter = HvRITER(hv);
	691	HE *eiter = HvEITER(hv);
	692	hv_iterinit(hv);
fe7bca90	693	/* This may look suboptimal with the items after the iternext, but
	694	it's quite deliberate. We only get here with items==0 if we've
	695	just deleted the last placeholder in the hash. If we've just done
	696	that then it means that the hash is in lazy delete mode, and the
	697	HE is now only referenced in our iterator. If we just quit the loop
	698	and discarded our iterator then the HE leaks. So we do the && the
	699	other way to ensure iternext is called just one more time, which
	700	has the side effect of triggering the lazy delete. */
	701	while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
	702	&& items) {
dfd4ef2f	703	SV *val = hv_iterval(hv, entry);
	704
	705	if (val == &PL_sv_undef) {
	706
	707	/* It seems that I have to go back in the front of the hash
	708	API to delete a hash, even though I have a HE structure
	709	pointing to the very entry I want to delete, and could hold
	710	onto the previous HE that points to it. And it's easier to
	711	go in with SVs as I can then specify the precomputed hash,
	712	and don't have fun and games with utf8 keys. */
	713	SV *key = hv_iterkeysv(entry);
	714
	715	hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
	716	items--;
	717	}
	718	}
	719	HvRITER(hv) = riter;
	720	HvEITER(hv) = eiter;
	721	}
	722
	723	XSRETURN(0);
	724	}
39f7a870	725
	726	XS(XS_PerlIO_get_layers)
	727	{
	728	dXSARGS;
	729	if (items < 1 \|\| items % 2 == 0)
	730	Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
5fef3b4a	731	#ifdef USE_PERLIO
39f7a870	732	{
	733	SV * sv;
	734	GV * gv;
	735	IO * io;
	736	bool input = TRUE;
	737	bool details = FALSE;
	738
	739	if (items > 1) {
39f7a870	740	SV **svp;
	741
	742	for (svp = MARK + 2; svp <= SP; svp += 2) {
	743	SV **varp = svp;
	744	SV **valp = svp + 1;
	745	STRLEN klen;
	746	char key = SvPV(varp, klen);
	747
	748	switch (*key) {
	749	case 'i':
	750	if (klen == 5 && memEQ(key, "input", 5)) {
	751	input = SvTRUE(*valp);
	752	break;
	753	}
	754	goto fail;
	755	case 'o':
	756	if (klen == 6 && memEQ(key, "output", 6)) {
	757	input = !SvTRUE(*valp);
	758	break;
	759	}
	760	goto fail;
	761	case 'd':
	762	if (klen == 7 && memEQ(key, "details", 7)) {
	763	details = SvTRUE(*valp);
	764	break;
	765	}
	766	goto fail;
	767	default:
	768	fail:
	769	Perl_croak(aTHX_
	770	"get_layers: unknown argument '%s'",
	771	key);
	772	}
	773	}
	774
	775	SP -= (items - 1);
	776	}
	777
	778	sv = POPs;
	779	gv = (GV*)sv;
	780
	781	if (!isGV(sv)) {
	782	if (SvROK(sv) && isGV(SvRV(sv)))
	783	gv = (GV*)SvRV(sv);
	784	else
	785	gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
	786	}
	787
	788	if (gv && (io = GvIO(gv))) {
	789	dTARGET;
	790	AV* av = PerlIO_get_layers(aTHX_ input ?
	791	IoIFP(io) : IoOFP(io));
	792	I32 i;
	793	I32 last = av_len(av);
	794	I32 nitem = 0;
	795
	796	for (i = last; i >= 0; i -= 3) {
	797	SV **namsvp;
	798	SV **argsvp;
	799	SV **flgsvp;
	800	bool namok, argok, flgok;
	801
	802	namsvp = av_fetch(av, i - 2, FALSE);
	803	argsvp = av_fetch(av, i - 1, FALSE);
804	flgsvp = av_fetch(av, i, FALSE);
805
806	namok = namsvp && namsvp && SvPOK(namsvp);
807	argok = argsvp && argsvp && SvPOK(argsvp);
808	flgok = flgsvp && flgsvp && SvIOK(flgsvp);
809
810	if (details) {
811	XPUSHs(namok ?
812	newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
813	XPUSHs(argok ?
814	newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
815	if (flgok)
816	XPUSHi(SvIVX(*flgsvp));
817	else
818	XPUSHs(&PL_sv_undef);
819	nitem += 3;
820	}
821	else {
822	if (namok && argok)
823	XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
824	namsvp, argsvp));
825	else if (namok)
826	XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
827	else
828	XPUSHs(&PL_sv_undef);
829	nitem++;
830	if (flgok) {
831	IV flags = SvIVX(*flgsvp);
832
833	if (flags & PERLIO_F_UTF8) {
834	XPUSHs(newSVpvn("utf8", 4));
835	nitem++;
836	}
837	}
838	}
839	}
840
841	SvREFCNT_dec(av);
842
843	XSRETURN(nitem);
844	}
845	}
5fef3b4a	846	#endif
39f7a870	847
	848	XSRETURN(0);
	849	}
	850