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