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

/*    universal.c
 *
 *    Copyright (c) 1997-2003, Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 * "The roots of those mountains must be roots indeed; there must be
 * great secrets buried there which have not been discovered since the
 * beginning." --Gandalf, relating Gollum's story
 */

#include "EXTERN.h"
#define PERL_IN_UNIVERSAL_C
#include "perl.h"

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