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

/*    universal.c
 *
 *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
 *    by Larry Wall and others
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

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

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

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

/*
 * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
 * The main guts of traverse_isa was actually copied from gv_fetchmeth
 */

STATIC SV *
S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
             int len, int level)
{
    AV* av;
    GV* gv;
    GV** gvp;
    HV* hv = Nullhv;
    SV* subgen = Nullsv;

    /* A stash/class can go by many names (ie. User == main::User), so 
       we compare the stash itself just in case */
    if (name_stash && (stash == name_stash))
        return &PL_sv_yes;

    if (strEQ(HvNAME(stash), name))
	return &PL_sv_yes;

    if (level > 100)
	Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
		   HvNAME(stash));

    gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);

    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
	&& (hv = GvHV(gv)))
    {
	if (SvIV(subgen) == (IV)PL_sub_generation) {
	    SV* sv;
	    SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
	    if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
	        DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
				  name, HvNAME(stash)) );
		return sv;
	    }
	}
	else {
	    DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
			      HvNAME(stash)) );
	    hv_clear(hv);
	    sv_setiv(subgen, PL_sub_generation);
	}
    }

    gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);

    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
	if (!hv || !subgen) {
	    gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);

	    gv = *gvp;

	    if (SvTYPE(gv) != SVt_PVGV)
		gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);

	    if (!hv)
		hv = GvHVn(gv);
	    if (!subgen) {
		subgen = newSViv(PL_sub_generation);
		GvSV(gv) = subgen;
	    }
	}
	if (hv) {
	    SV** svp = AvARRAY(av);
	    /* NOTE: No support for tied ISA */
	    I32 items = AvFILLp(av) + 1;
	    while (items--) {
		SV* sv = *svp++;
		HV* basestash = gv_stashsv(sv, FALSE);
		if (!basestash) {
		    if (ckWARN(WARN_MISC))
			Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
		             "Can't locate package %"SVf" for @%s::ISA",
			    sv, HvNAME(stash));
		    continue;
		}
		if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, 
                                             len, level + 1)) {
		    (void)hv_store(hv,name,len,&PL_sv_yes,0);
		    return &PL_sv_yes;
		}
	    }
	    (void)hv_store(hv,name,len,&PL_sv_no,0);
	}
    }

    return boolSV(strEQ(name, "UNIVERSAL"));
}

/*
=head1 SV Manipulation Functions

=for apidoc sv_derived_from

Returns a boolean indicating whether the SV is derived from the specified
class.  This is the function that implements C<UNIVERSAL::isa>.  It works
for class names as well as for objects.

=cut
*/

bool
Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
{
    char *type;
    HV *stash;
    HV *name_stash;

    stash = Nullhv;
    type = Nullch;

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

    if (SvROK(sv)) {
        sv = SvRV(sv);
        type = sv_reftype(sv,0);
        if (SvOBJECT(sv))
            stash = SvSTASH(sv);
    }
    else {
        stash = gv_stashsv(sv, FALSE);
    }

    name_stash = gv_stashpv(name, FALSE);

    return (type && strEQ(type,name)) ||
            (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) 
             == &PL_sv_yes)
        ? TRUE
        : FALSE ;
}

#include "XSUB.h"

void XS_UNIVERSAL_isa(pTHX_ CV *cv);
void XS_UNIVERSAL_can(pTHX_ CV *cv);
void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
XS(XS_version_new);
XS(XS_version_stringify);
XS(XS_version_numify);
XS(XS_version_vcmp);
XS(XS_version_boolean);
XS(XS_version_noop);
XS(XS_utf8_is_utf8);
XS(XS_utf8_valid);
XS(XS_utf8_encode);
XS(XS_utf8_decode);
XS(XS_utf8_upgrade);
XS(XS_utf8_downgrade);
XS(XS_utf8_unicode_to_native);
XS(XS_utf8_native_to_unicode);
XS(XS_Internals_SvREADONLY);
XS(XS_Internals_SvREFCNT);
XS(XS_Internals_hv_clear_placehold);
XS(XS_PerlIO_get_layers);
XS(XS_Regexp_DESTROY);

void
Perl_boot_core_UNIVERSAL(pTHX)
{
    char *file = __FILE__;

    newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
    newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
    newXS("UNIVERSAL::VERSION", 	XS_UNIVERSAL_VERSION, 	  file);
    {
	/* register the overloading (type 'A') magic */
	PL_amagic_generation++;
	/* Make it findable via fetchmethod */
	newXS("version::()", XS_version_noop, file);
	newXS("version::new", XS_version_new, file);
	newXS("version::(\"\"", XS_version_stringify, file);
	newXS("version::stringify", XS_version_stringify, file);
	newXS("version::(0+", XS_version_numify, file);
	newXS("version::numify", XS_version_numify, file);
	newXS("version::(cmp", XS_version_vcmp, file);
	newXS("version::(<=>", XS_version_vcmp, file);
	newXS("version::vcmp", XS_version_vcmp, file);
	newXS("version::(bool", XS_version_boolean, file);
	newXS("version::boolean", XS_version_boolean, file);
	newXS("version::(nomethod", XS_version_noop, file);
	newXS("version::noop", XS_version_noop, file);
    }
    newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
    newXS("utf8::valid", XS_utf8_valid, file);
    newXS("utf8::encode", XS_utf8_encode, file);
    newXS("utf8::decode", XS_utf8_decode, file);
    newXS("utf8::upgrade", XS_utf8_upgrade, file);
    newXS("utf8::downgrade", XS_utf8_downgrade, file);
    newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
    newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
    newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
    newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
    newXSproto("Internals::hv_clear_placeholders",
               XS_Internals_hv_clear_placehold, file, "\\%");
    newXSproto("PerlIO::get_layers",
               XS_PerlIO_get_layers, file, "*;@");
    newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
}


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

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

    sv = ST(0);

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

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

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

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

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

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

    sv = ST(0);

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

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

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

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

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

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

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

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

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

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

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

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

		  Perl_croak(aTHX_
			     "%s defines neither package nor VERSION--version check failed", str);
	     }
	}
	if ( !sv_derived_from(sv, "version"))
	    sv = new_version(sv);

	if ( !sv_derived_from(req, "version"))
	    req = new_version(req);

	if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
	    Perl_croak(aTHX_
		"%s version %"SVf" required--this is only version %"SVf,
		HvNAME(pkg), req, sv);
    }

    ST(0) = sv;

    XSRETURN(1);
}

XS(XS_version_new)
{
    dXSARGS;
    if (items > 3)
	Perl_croak(aTHX_ "Usage: version::new(class, version)");
    SP -= items;
    {
/*	char *	class = (char *)SvPV_nolen(ST(0)); */
        SV *version = ST(1);
	if (items == 3 )
	{
	    char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
	    version = Perl_newSVpvf(aTHX_ "v%s",vs);
	}

	PUSHs(new_version(version));
	PUTBACK;
	return;
    }
}

XS(XS_version_stringify)
{
    dXSARGS;
    if (items < 1)
	Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
    SP -= items;
    {
	SV *	lobj;

        if (sv_derived_from(ST(0), "version")) {
                SV *tmp = SvRV(ST(0));
        	lobj = tmp;
        }
        else
                Perl_croak(aTHX_ "lobj is not of type version");

{
    PUSHs(vstringify(lobj));
}

	PUTBACK;
	return;
    }
}

XS(XS_version_numify)
{
    dXSARGS;
    if (items < 1)
	Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
    SP -= items;
    {
	SV *	lobj;

        if (sv_derived_from(ST(0), "version")) {
                SV *tmp = SvRV(ST(0));
        	lobj = tmp;
        }
        else
                Perl_croak(aTHX_ "lobj is not of type version");

{
    PUSHs(vnumify(lobj));
}

	PUTBACK;
	return;
    }
}

XS(XS_version_vcmp)
{
    dXSARGS;
    if (items < 1)
	Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
    SP -= items;
    {
	SV *	lobj;

        if (sv_derived_from(ST(0), "version")) {
                SV *tmp = SvRV(ST(0));
        	lobj = tmp;
        }
        else
                Perl_croak(aTHX_ "lobj is not of type version");

{
    SV	*rs;
    SV	*rvs;
    SV * robj = ST(1);
    IV	 swap = (IV)SvIV(ST(2));

    if ( ! sv_derived_from(robj, "version") )
    {
	robj = new_version(robj);
    }
    rvs = SvRV(robj);

    if ( swap )
    {
        rs = newSViv(vcmp(rvs,lobj));
    }
    else
    {
        rs = newSViv(vcmp(lobj,rvs));
    }

    PUSHs(rs);
}

	PUTBACK;
	return;
    }
}

XS(XS_version_boolean)
{
    dXSARGS;
    if (items < 1)
	Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
    SP -= items;
    {
	SV *	lobj;

        if (sv_derived_from(ST(0), "version")) {
                SV *tmp = SvRV(ST(0));
        	lobj = tmp;
        }
        else
                Perl_croak(aTHX_ "lobj is not of type version");

{
    SV	*rs;
    rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
    PUSHs(rs);
}

	PUTBACK;
	return;
    }
}

XS(XS_version_noop)
{
    dXSARGS;
    if (items < 1)
	Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
    {
	SV *	lobj;

        if (sv_derived_from(ST(0), "version")) {
                SV *tmp = SvRV(ST(0));
        	lobj = tmp;
        }
        else
                Perl_croak(aTHX_ "lobj is not of type version");

{
    Perl_croak(aTHX_ "operation not supported with version object");
}

    }
    XSRETURN_EMPTY;
}

XS(XS_utf8_is_utf8)
{
    dXSARGS;
    if (items != 1)
	Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
    {
	SV *	sv = ST(0);
 {
  if (SvUTF8(sv))
   XSRETURN_YES;
  else
   XSRETURN_NO;
 }
    }
    XSRETURN_EMPTY;
}

XS(XS_utf8_valid)
{
    dXSARGS;
    if (items != 1)
	Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
    {
	SV *	sv = ST(0);
 {
  STRLEN len;
  char *s = SvPV(sv,len);
  if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
   XSRETURN_YES;
  else
   XSRETURN_NO;
 }
    }
    XSRETURN_EMPTY;
}

XS(XS_utf8_encode)
{
    dXSARGS;
    if (items != 1)
	Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
    {
	SV *	sv = ST(0);

	sv_utf8_encode(sv);
    }
    XSRETURN_EMPTY;
}

XS(XS_utf8_decode)
{
    dXSARGS;
    if (items != 1)
	Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
    {
	SV *	sv = ST(0);
	bool	RETVAL;

	RETVAL = sv_utf8_decode(sv);
	ST(0) = boolSV(RETVAL);
	sv_2mortal(ST(0));
    }
    XSRETURN(1);
}

XS(XS_utf8_upgrade)
{
    dXSARGS;
    if (items != 1)
	Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
    {
	SV *	sv = ST(0);
	STRLEN	RETVAL;
	dXSTARG;

	RETVAL = sv_utf8_upgrade(sv);
	XSprePUSH; PUSHi((IV)RETVAL);
    }
    XSRETURN(1);
}

XS(XS_utf8_downgrade)
{
    dXSARGS;
    if (items < 1 || items > 2)
	Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
    {
	SV *	sv = ST(0);
	bool	failok;
	bool	RETVAL;

	if (items < 2)
	    failok = 0;
	else {
	    failok = (int)SvIV(ST(1));
	}

	RETVAL = sv_utf8_downgrade(sv, failok);
	ST(0) = boolSV(RETVAL);
	sv_2mortal(ST(0));
    }
    XSRETURN(1);
}

XS(XS_utf8_native_to_unicode)
{
 dXSARGS;
 UV uv = SvUV(ST(0));

 if (items > 1)
     Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");

 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 XSRETURN(1);
}

XS(XS_utf8_unicode_to_native)
{
 dXSARGS;
 UV uv = SvUV(ST(0));

 if (items > 1)
     Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");

 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 XSRETURN(1);
}

XS(XS_Internals_SvREADONLY)	/* This is dangerous stuff. */
{
    dXSARGS;
    SV *sv = SvRV(ST(0));
    if (items == 1) {
	 if (SvREADONLY(sv))
	     XSRETURN_YES;
	 else
	     XSRETURN_NO;
    }
    else if (items == 2) {
	if (SvTRUE(ST(1))) {
	    SvREADONLY_on(sv);
	    XSRETURN_YES;
	}
	else {
	    /* I hope you really know what you are doing. */
	    SvREADONLY_off(sv);
	    XSRETURN_NO;
	}
    }
    XSRETURN_UNDEF; /* Can't happen. */
}

XS(XS_Internals_SvREFCNT)	/* This is dangerous stuff. */
{
    dXSARGS;
    SV *sv = SvRV(ST(0));
    if (items == 1)
	 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
    else if (items == 2) {
         /* I hope you really know what you are doing. */
	 SvREFCNT(sv) = SvIV(ST(1));
	 XSRETURN_IV(SvREFCNT(sv));
    }
    XSRETURN_UNDEF; /* Can't happen. */
}

/* Maybe this should return the number of placeholders found in scalar context,
   and a list of them in list context.  */
XS(XS_Internals_hv_clear_placehold)
{
    dXSARGS;
    HV *hv = (HV *) SvRV(ST(0));

    /* I don't care how many parameters were passed in, but I want to avoid
       the unused variable warning. */

    items = (I32)HvPLACEHOLDERS(hv);

    if (items) {
        HE *entry;
        I32 riter = HvRITER(hv);
        HE *eiter = HvEITER(hv);
        hv_iterinit(hv);
        /* This may look suboptimal with the items *after* the iternext, but
           it's quite deliberate. We only get here with items==0 if we've
           just deleted the last placeholder in the hash. If we've just done
           that then it means that the hash is in lazy delete mode, and the
           HE is now only referenced in our iterator. If we just quit the loop
           and discarded our iterator then the HE leaks. So we do the && the
           other way to ensure iternext is called just one more time, which
           has the side effect of triggering the lazy delete.  */
        while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
            && items) {
            SV *val = hv_iterval(hv, entry);

            if (val == &PL_sv_undef) {

                /* It seems that I have to go back in the front of the hash
                   API to delete a hash, even though I have a HE structure
                   pointing to the very entry I want to delete, and could hold
                   onto the previous HE that points to it. And it's easier to
                   go in with SVs as I can then specify the precomputed hash,
                   and don't have fun and games with utf8 keys.  */
                SV *key = hv_iterkeysv(entry);

                hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
                items--;
            }
        }
        HvRITER(hv) = riter;
        HvEITER(hv) = eiter;
    }

    XSRETURN(0);
}

XS(XS_Regexp_DESTROY)
{

}

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

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

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

	     SP -= (items - 1);
	}

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

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

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

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

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

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

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

	     SvREFCNT_dec(av);

	     XSRETURN(nitem);
	}
    }
#endif

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