[perl5.git] / xsutils.c

/*    xsutils.c
 *
 *    Copyright (C) 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.
 *
 */

/*
 * "Perilous to us all are the devices of an art deeper than we possess
 * ourselves." --Gandalf
 */


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

/*
 * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
 */

/* package attributes; */
void XS_attributes__warn_reserved(pTHX_ CV *cv);
void XS_attributes_reftype(pTHX_ CV *cv);
void XS_attributes__modify_attrs(pTHX_ CV *cv);
void XS_attributes__guess_stash(pTHX_ CV *cv);
void XS_attributes__fetch_attrs(pTHX_ CV *cv);
void XS_attributes_bootstrap(pTHX_ CV *cv);


/*
 * Note that only ${pkg}::bootstrap definitions should go here.
 * This helps keep down the start-up time, which is especially
 * relevant for users who don't invoke any features which are
 * (partially) implemented here.
 *
 * The various bootstrap definitions can take care of doing
 * package-specific newXS() calls.  Since the layout of the
 * bundled *.pm files is in a version-specific directory,
 * version checks in these bootstrap calls are optional.
 */

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

    newXS("attributes::bootstrap",	XS_attributes_bootstrap,	file);
}

#include "XSUB.h"

static int
modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
{
    SV *attr;
    char *name;
    STRLEN len;
    bool negated;
    int nret;

    for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
	name = SvPV(attr, len);
	if ((negated = (*name == '-'))) {
	    name++;
	    len--;
	}
	switch (SvTYPE(sv)) {
	case SVt_PVCV:
	    switch ((int)len) {
	    case 6:
		switch (*name) {
		case 'a':
		    if (strEQ(name, "assertion")) {
			if (negated)
			    CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
			else
			    CvFLAGS((CV*)sv) |= CVf_ASSERTION;
			continue;
		    }
		    break;
		case 'l':
#ifdef CVf_LVALUE
		    if (strEQ(name, "lvalue")) {
			if (negated)
			    CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
			else
			    CvFLAGS((CV*)sv) |= CVf_LVALUE;
			continue;
		    }
#endif /* defined CVf_LVALUE */
		    if (strEQ(name, "locked")) {
			if (negated)
			    CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
			else
			    CvFLAGS((CV*)sv) |= CVf_LOCKED;
			continue;
		    }
		    break;
		case 'm':
		    if (strEQ(name, "method")) {
			if (negated)
			    CvFLAGS((CV*)sv) &= ~CVf_METHOD;
			else
			    CvFLAGS((CV*)sv) |= CVf_METHOD;
			continue;
		    }
		    break;
		case 'u':
		    if (strEQ(name, "unique")) {
			if (negated)
			    GvUNIQUE_off(CvGV((CV*)sv));
			else
			    GvUNIQUE_on(CvGV((CV*)sv));
			continue;
		    }
		    break;
		}
		break;
	    }
	    break;
	default:
	    switch ((int)len) {
	    case 6:
		switch (*name) {
		case 's':
		    if (strEQ(name, "shared")) {
			if (negated)
			    Perl_croak(aTHX_ "A variable may not be unshared");
			SvSHARE(sv);
                        continue;
                    }
		    break;
		case 'u':
		    if (strEQ(name, "unique")) {
			if (SvTYPE(sv) == SVt_PVGV) {
			    if (negated)
				GvUNIQUE_off(sv);
			    else
				GvUNIQUE_on(sv);
			}
			/* Hope this came from toke.c if not a GV. */
                        continue;
                    }
                }
            }
	    break;
	}
	/* anything recognized had a 'continue' above */
	*retlist++ = attr;
	nret++;
    }

    return nret;
}


/* package attributes; */

XS(XS_attributes_bootstrap)
{
    dXSARGS;
    char *file = __FILE__;

    if( items > 1 )
        Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");

    newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
    newXS("attributes::_modify_attrs",	XS_attributes__modify_attrs,	file);
    newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
    newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
    newXSproto("attributes::reftype",	XS_attributes_reftype,	file, "$");

    XSRETURN(0);
}

XS(XS_attributes__modify_attrs)
{
    dXSARGS;
    SV *rv, *sv;

    if (items < 1) {
usage:
	Perl_croak(aTHX_
		   "Usage: attributes::_modify_attrs $reference, @attributes");
    }

    rv = ST(0);
    if (!(SvOK(rv) && SvROK(rv)))
	goto usage;
    sv = SvRV(rv);
    if (items > 1)
	XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));

    XSRETURN(0);
}

XS(XS_attributes__fetch_attrs)
{
    dXSARGS;
    SV *rv, *sv;
    cv_flags_t cvflags;

    if (items != 1) {
usage:
	Perl_croak(aTHX_
		   "Usage: attributes::_fetch_attrs $reference");
    }

    rv = ST(0);
    SP -= items;
    if (!(SvOK(rv) && SvROK(rv)))
	goto usage;
    sv = SvRV(rv);

    switch (SvTYPE(sv)) {
    case SVt_PVCV:
	cvflags = CvFLAGS((CV*)sv);
	if (cvflags & CVf_LOCKED)
	    XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
#ifdef CVf_LVALUE
	if (cvflags & CVf_LVALUE)
	    XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
#endif
	if (cvflags & CVf_METHOD)
	    XPUSHs(sv_2mortal(newSVpvn("method", 6)));
        if (GvUNIQUE(CvGV((CV*)sv)))
	    XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
	if (cvflags & CVf_ASSERTION)
	    XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
	break;
    case SVt_PVGV:
	if (GvUNIQUE(sv))
	    XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
	break;
    default:
	break;
    }

    PUTBACK;
}

XS(XS_attributes__guess_stash)
{
    dXSARGS;
    SV *rv, *sv;
#ifdef dXSTARGET
    dXSTARGET;
#else
    SV * TARG = sv_newmortal();
#endif

    if (items != 1) {
usage:
	Perl_croak(aTHX_
		   "Usage: attributes::_guess_stash $reference");
    }

    rv = ST(0);
    ST(0) = TARG;
    if (!(SvOK(rv) && SvROK(rv)))
	goto usage;
    sv = SvRV(rv);

    if (SvOBJECT(sv))
	sv_setpv(TARG, HvNAME(SvSTASH(sv)));
#if 0	/* this was probably a bad idea */
    else if (SvPADMY(sv))
	sv_setsv(TARG, &PL_sv_no);	/* unblessed lexical */
#endif
    else {
	HV *stash = Nullhv;
	switch (SvTYPE(sv)) {
	case SVt_PVCV:
	    if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
		stash = GvSTASH(CvGV(sv));
	    else if (/* !CvANON(sv) && */ CvSTASH(sv))
		stash = CvSTASH(sv);
	    break;
	case SVt_PVMG:
	    if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
		break;
	    /*FALLTHROUGH*/
	case SVt_PVGV:
	    if (GvGP(sv) && GvESTASH((GV*)sv))
		stash = GvESTASH((GV*)sv);
	    break;
	default:
	    break;
	}
	if (stash)
	    sv_setpv(TARG, HvNAME(stash));
    }

#ifdef dXSTARGET
    SvSETMAGIC(TARG);
#endif
    XSRETURN(1);
}

XS(XS_attributes_reftype)
{
    dXSARGS;
    SV *rv, *sv;
#ifdef dXSTARGET
    dXSTARGET;
#else
    SV * TARG = sv_newmortal();
#endif

    if (items != 1) {
usage:
	Perl_croak(aTHX_
		   "Usage: attributes::reftype $reference");
    }

    rv = ST(0);
    ST(0) = TARG;
    if (SvGMAGICAL(rv))
	mg_get(rv);
    if (!(SvOK(rv) && SvROK(rv)))
	goto usage;
    sv = SvRV(rv);
    sv_setpv(TARG, sv_reftype(sv, 0));
#ifdef dXSTARGET
    SvSETMAGIC(TARG);
#endif

    XSRETURN(1);
}

XS(XS_attributes__warn_reserved)
{
    dXSARGS;
#ifdef dXSTARGET
    dXSTARGET;
#else
    SV * TARG = sv_newmortal();
#endif

    if (items != 0) {
	Perl_croak(aTHX_
		   "Usage: attributes::_warn_reserved ()");
    }

    EXTEND(SP,1);
    ST(0) = TARG;
    sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
#ifdef dXSTARGET
    SvSETMAGIC(TARG);
#endif

    XSRETURN(1);
}
Commit	Line	Data
d6376244 JH	1	/* xsutils.c
d6376244 JH	2	*
4bb101f2	3	* Copyright (C) 1999, 2000, 2001, 2002, 2003, by Larry Wall and others
d6376244 JH	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 AT	10	/*
	11	* "Perilous to us all are the devices of an art deeper than we possess
	12	* ourselves." --Gandalf
	13	*/
	14
	15
09bef843 SB	16	#include "EXTERN.h"
	17	#define PERL_IN_XSUTILS_C
	18	#include "perl.h"
	19
	20	/*
	21	* Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
	22	*/
	23
349fd7b7	24	/* package attributes; */
acfe0abc GS	25	void XS_attributes__warn_reserved(pTHX_ CV *cv);
	26	void XS_attributes_reftype(pTHX_ CV *cv);
	27	void XS_attributes__modify_attrs(pTHX_ CV *cv);
	28	void XS_attributes__guess_stash(pTHX_ CV *cv);
	29	void XS_attributes__fetch_attrs(pTHX_ CV *cv);
	30	void XS_attributes_bootstrap(pTHX_ CV *cv);
349fd7b7 GS	31
	32
	33	/*
	34	* Note that only ${pkg}::bootstrap definitions should go here.
	35	* This helps keep down the start-up time, which is especially
	36	* relevant for users who don't invoke any features which are
	37	* (partially) implemented here.
	38	*
	39	* The various bootstrap definitions can take care of doing
	40	* package-specific newXS() calls. Since the layout of the
6a34af38	41	* bundled *.pm files is in a version-specific directory,
349fd7b7 GS	42	* version checks in these bootstrap calls are optional.
	43	*/
	44
	45	void
	46	Perl_boot_core_xsutils(pTHX)
	47	{
	48	char *file = __FILE__;
	49
	50	newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
	51	}
	52
349fd7b7 GS	53	#include "XSUB.h"
	54
	55	static int
acfe0abc	56	modify_SV_attributes(pTHX_ SV sv, SV retlist, SV *attrlist, int numattrs)
09bef843 SB	57	{
	58	SV *attr;
	59	char *name;
	60	STRLEN len;
	61	bool negated;
	62	int nret;
	63
	64	for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
	65	name = SvPV(attr, len);
155aba94	66	if ((negated = (*name == '-'))) {
09bef843 SB	67	name++;
	68	len--;
	69	}
	70	switch (SvTYPE(sv)) {
	71	case SVt_PVCV:
	72	switch ((int)len) {
	73	case 6:
	74	switch (*name) {
06492da6 SF	75	case 'a':
	76	if (strEQ(name, "assertion")) {
	77	if (negated)
	78	CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
	79	else
	80	CvFLAGS((CV*)sv) \|= CVf_ASSERTION;
	81	continue;
	82	}
	83	break;
09bef843 SB	84	case 'l':
	85	#ifdef CVf_LVALUE
	86	if (strEQ(name, "lvalue")) {
	87	if (negated)
	88	CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
	89	else
	90	CvFLAGS((CV*)sv) \|= CVf_LVALUE;
	91	continue;
	92	}
	93	#endif /* defined CVf_LVALUE */
	94	if (strEQ(name, "locked")) {
	95	if (negated)
	96	CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
	97	else
	98	CvFLAGS((CV*)sv) \|= CVf_LOCKED;
	99	continue;
	100	}
	101	break;
	102	case 'm':
	103	if (strEQ(name, "method")) {
	104	if (negated)
	105	CvFLAGS((CV*)sv) &= ~CVf_METHOD;
	106	else
	107	CvFLAGS((CV*)sv) \|= CVf_METHOD;
	108	continue;
	109	}
	110	break;
95f0a2f1 SB	111	case 'u':
95f0a2f1 SB	112	if (strEQ(name, "unique")) {
0256094b	113	if (negated)
7fb37951	114	GvUNIQUE_off(CvGV((CV*)sv));
0256094b	115	else
7fb37951	116	GvUNIQUE_on(CvGV((CV*)sv));
0256094b DM	117	continue;
	118	}
	119	break;
09bef843 SB	120	}
	121	break;
	122	}
	123	break;
	124	default:
0256094b	125	switch ((int)len) {
95f0a2f1	126	case 6:
0256094b	127	switch (*name) {
13c1b207 DM	128	case 's':
	129	if (strEQ(name, "shared")) {
	130	if (negated)
	131	Perl_croak(aTHX_ "A variable may not be unshared");
	132	SvSHARE(sv);
	133	continue;
	134	}
	135	break;
95f0a2f1 SB	136	case 'u':
	137	if (strEQ(name, "unique")) {
	138	if (SvTYPE(sv) == SVt_PVGV) {
	139	if (negated)
	140	GvUNIQUE_off(sv);
	141	else
	142	GvUNIQUE_on(sv);
	143	}
	144	/* Hope this came from toke.c if not a GV. */
0256094b DM	145	continue;
	146	}
	147	}
	148	}
09bef843 SB	149	break;
	150	}
	151	/* anything recognized had a 'continue' above */
	152	*retlist++ = attr;
	153	nret++;
	154	}
	155
	156	return nret;
	157	}
	158
	159
09bef843 SB	160
	161	/* package attributes; */
	162
	163	XS(XS_attributes_bootstrap)
	164	{
	165	dXSARGS;
	166	char *file = __FILE__;
	167
592f5969 MS	168	if( items > 1 )
592f5969 MS	169	Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
b7953727	170
09bef843 SB	171	newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
	172	newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
	173	newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
	174	newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
	175	newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
	176
	177	XSRETURN(0);
	178	}
	179
	180	XS(XS_attributes__modify_attrs)
	181	{
	182	dXSARGS;
	183	SV rv, sv;
	184
	185	if (items < 1) {
	186	usage:
	187	Perl_croak(aTHX_
	188	"Usage: attributes::_modify_attrs $reference, @attributes");
	189	}
	190
	191	rv = ST(0);
	192	if (!(SvOK(rv) && SvROK(rv)))
	193	goto usage;
	194	sv = SvRV(rv);
	195	if (items > 1)
acfe0abc	196	XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
09bef843 SB	197
	198	XSRETURN(0);
	199	}
	200
	201	XS(XS_attributes__fetch_attrs)
	202	{
	203	dXSARGS;
	204	SV rv, sv;
	205	cv_flags_t cvflags;
	206
	207	if (items != 1) {
	208	usage:
	209	Perl_croak(aTHX_
	210	"Usage: attributes::_fetch_attrs $reference");
	211	}
	212
	213	rv = ST(0);
	214	SP -= items;
	215	if (!(SvOK(rv) && SvROK(rv)))
	216	goto usage;
	217	sv = SvRV(rv);
	218
	219	switch (SvTYPE(sv)) {
	220	case SVt_PVCV:
	221	cvflags = CvFLAGS((CV*)sv);
	222	if (cvflags & CVf_LOCKED)
	223	XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
	224	#ifdef CVf_LVALUE
	225	if (cvflags & CVf_LVALUE)
	226	XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
	227	#endif
	228	if (cvflags & CVf_METHOD)
	229	XPUSHs(sv_2mortal(newSVpvn("method", 6)));
7fb37951	230	if (GvUNIQUE(CvGV((CV*)sv)))
95f0a2f1	231	XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
06492da6 SF	232	if (cvflags & CVf_ASSERTION)
06492da6 SF	233	XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
95f0a2f1 SB	234	break;
	235	case SVt_PVGV:
	236	if (GvUNIQUE(sv))
	237	XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
09bef843 SB	238	break;
	239	default:
	240	break;
	241	}
	242
	243	PUTBACK;
	244	}
	245
	246	XS(XS_attributes__guess_stash)
	247	{
	248	dXSARGS;
	249	SV rv, sv;
	250	#ifdef dXSTARGET
	251	dXSTARGET;
	252	#else
	253	SV * TARG = sv_newmortal();
	254	#endif
	255
	256	if (items != 1) {
	257	usage:
	258	Perl_croak(aTHX_
	259	"Usage: attributes::_guess_stash $reference");
	260	}
	261
	262	rv = ST(0);
	263	ST(0) = TARG;
	264	if (!(SvOK(rv) && SvROK(rv)))
	265	goto usage;
	266	sv = SvRV(rv);
	267
	268	if (SvOBJECT(sv))
	269	sv_setpv(TARG, HvNAME(SvSTASH(sv)));
	270	#if 0 /* this was probably a bad idea */
	271	else if (SvPADMY(sv))
	272	sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
	273	#endif
	274	else {
	275	HV *stash = Nullhv;
	276	switch (SvTYPE(sv)) {
	277	case SVt_PVCV:
6676db26	278	if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
09bef843	279	stash = GvSTASH(CvGV(sv));
6676db26	280	else if (/* !CvANON(sv) && */ CvSTASH(sv))
09bef843 SB	281	stash = CvSTASH(sv);
	282	break;
	283	case SVt_PVMG:
14befaf4	284	if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
09bef843 SB	285	break;
	286	/FALLTHROUGH/
	287	case SVt_PVGV:
6676db26	288	if (GvGP(sv) && GvESTASH((GV*)sv))
09bef843 SB	289	stash = GvESTASH((GV*)sv);
	290	break;
	291	default:
	292	break;
	293	}
	294	if (stash)
	295	sv_setpv(TARG, HvNAME(stash));
	296	}
	297
	298	#ifdef dXSTARGET
	299	SvSETMAGIC(TARG);
	300	#endif
	301	XSRETURN(1);
	302	}
	303
	304	XS(XS_attributes_reftype)
	305	{
	306	dXSARGS;
	307	SV rv, sv;
	308	#ifdef dXSTARGET
	309	dXSTARGET;
	310	#else
	311	SV * TARG = sv_newmortal();
	312	#endif
	313
	314	if (items != 1) {
	315	usage:
	316	Perl_croak(aTHX_
	317	"Usage: attributes::reftype $reference");
	318	}
	319
	320	rv = ST(0);
	321	ST(0) = TARG;
4694d0ea GS	322	if (SvGMAGICAL(rv))
4694d0ea GS	323	mg_get(rv);
121e869f	324	if (!(SvOK(rv) && SvROK(rv)))
09bef843 SB	325	goto usage;
	326	sv = SvRV(rv);
	327	sv_setpv(TARG, sv_reftype(sv, 0));
	328	#ifdef dXSTARGET
	329	SvSETMAGIC(TARG);
	330	#endif
	331
	332	XSRETURN(1);
	333	}
	334
	335	XS(XS_attributes__warn_reserved)
	336	{
	337	dXSARGS;
09bef843 SB	338	#ifdef dXSTARGET
	339	dXSTARGET;
	340	#else
	341	SV * TARG = sv_newmortal();
	342	#endif
	343
	344	if (items != 0) {
	345	Perl_croak(aTHX_
	346	"Usage: attributes::_warn_reserved ()");
	347	}
	348
	349	EXTEND(SP,1);
	350	ST(0) = TARG;
	351	sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
	352	#ifdef dXSTARGET
	353	SvSETMAGIC(TARG);
	354	#endif
	355
	356	XSRETURN(1);
	357	}
	358