/*    xsutils.c
		 *
		 *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005
		 *    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; */
		PERL_XS_EXPORT_C void XS_attributes__warn_reserved(pTHX_ CV *cv);
		PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
		PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
		PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
		PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
		PERL_XS_EXPORT_C 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)
        4500    {
        4500        const char file[] = __FILE__;
		
        4500        newXS("attributes::bootstrap",	XS_attributes_bootstrap,	file);
		}
		
		#include "XSUB.h"
		
		static int
		modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
         126    {
         126        SV *attr;
         126        int nret;
		
         256        for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
         133    	STRLEN len;
         133    	const char *name = SvPV_const(attr, len);
         133    	const bool negated = (*name == '-');
		
         133    	if (negated) {
          24    	    name++;
          24    	    len--;
			}
         133    	switch (SvTYPE(sv)) {
			case SVt_PVCV:
          46    	    switch ((int)len) {
		#ifdef CVf_ASSERTION
			    case 9:
           9    		if (memEQ(name, "assertion", 9)) {
           2    		    if (negated)
           1    			CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
				    else
           1    			CvFLAGS((CV*)sv) |= CVf_ASSERTION;
           1    		    continue;
				}
          11    		break;
		#endif
			    case 6:
          11    		switch (name[3]) {
				case 'l':
		#ifdef CVf_LVALUE
           2    		    if (memEQ(name, "lvalue", 6)) {
           2    			if (negated)
           1    			    CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
					else
           1    			    CvFLAGS((CV*)sv) |= CVf_LVALUE;
           1    			continue;
				    }
           2    		    break;
				case 'k':
		#endif /* defined CVf_LVALUE */
           2    		    if (memEQ(name, "locked", 6)) {
           2    			if (negated)
           1    			    CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
					else
           1    			    CvFLAGS((CV*)sv) |= CVf_LOCKED;
           1    			continue;
				    }
           2    		    break;
				case 'h':
           2    		    if (memEQ(name, "method", 6)) {
           2    			if (negated)
           1    			    CvFLAGS((CV*)sv) &= ~CVf_METHOD;
					else
           1    			    CvFLAGS((CV*)sv) |= CVf_METHOD;
           1    			continue;
				    }
          87    		    break;
				}
          87    		break;
			    }
          87    	    break;
			default:
          87    	    switch ((int)len) {
			    case 6:
          35    		switch (name[5]) {
				case 'd':
          20    		    if (memEQ(name, "share", 5)) {
           6    			if (negated)
           3    			    Perl_croak(aTHX_ "A variable may not be unshared");
           3    			SvSHARE(sv);
           3                            continue;
		                    }
          13    		    break;
				case 'e':
          13    		    if (memEQ(name, "uniqu", 5)) {
           6    			if (SvTYPE(sv) == SVt_PVGV) {
      ######    			    if (negated)
         113    				GvUNIQUE_off(sv);
					    else
         113    				GvUNIQUE_on(sv);
					}
					/* Hope this came from toke.c if not a GV. */
         113                            continue;
		                    }
		                }
		            }
         113    	    break;
			}
			/* anything recognized had a 'continue' above */
         113    	*retlist++ = attr;
         113    	nret++;
		    }
		
         123        return nret;
		}
		
		
		
		/* package attributes; */
		
		XS(XS_attributes_bootstrap)
           3    {
           3        dXSARGS;
           3        const char file[] = __FILE__;
		
           3        if( items > 1 )
      ######            Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
		
           3        newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
           3        newXS("attributes::_modify_attrs",	XS_attributes__modify_attrs,	file);
           3        newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
           3        newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
           3        newXSproto("attributes::reftype",	XS_attributes_reftype,	file, "$");
		
           3        XSRETURN(0);
		}
		
		XS(XS_attributes__modify_attrs)
         126    {
         126        dXSARGS;
         126        SV *rv, *sv;
		
         126        if (items < 1) {
		usage:
      ######    	Perl_croak(aTHX_
				   "Usage: attributes::_modify_attrs $reference, @attributes");
		    }
		
         126        rv = ST(0);
         126        if (!(SvOK(rv) && SvROK(rv)))
      ######    	goto usage;
         126        sv = SvRV(rv);
         126        if (items > 1)
         126    	XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
		
      ######        XSRETURN(0);
		}
		
		XS(XS_attributes__fetch_attrs)
           6    {
           6        dXSARGS;
           6        SV *rv, *sv;
           6        cv_flags_t cvflags;
		
           6        if (items != 1) {
		usage:
      ######    	Perl_croak(aTHX_
				   "Usage: attributes::_fetch_attrs $reference");
		    }
		
           6        rv = ST(0);
           6        SP -= items;
           6        if (!(SvOK(rv) && SvROK(rv)))
      ######    	goto usage;
           6        sv = SvRV(rv);
		
           6        switch (SvTYPE(sv)) {
		    case SVt_PVCV:
           6    	cvflags = CvFLAGS((CV*)sv);
           6    	if (cvflags & CVf_LOCKED)
           3    	    XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
		#ifdef CVf_LVALUE
           6    	if (cvflags & CVf_LVALUE)
           3    	    XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
		#endif
           6    	if (cvflags & CVf_METHOD)
           2    	    XPUSHs(sv_2mortal(newSVpvn("method", 6)));
           6            if (GvUNIQUE(CvGV((CV*)sv)))
           6    	    XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
           6    	if (cvflags & CVf_ASSERTION)
      ######    	    XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
			break;
		    case SVt_PVGV:
           6    	if (GvUNIQUE(sv))
           6    	    XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
           6    	break;
		    default:
           6    	break;
		    }
		
           6        PUTBACK;
		}
		
		XS(XS_attributes__guess_stash)
           6    {
           6        dXSARGS;
           6        SV *rv, *sv;
           6        dXSTARG;
		
           6        if (items != 1) {
		usage:
      ######    	Perl_croak(aTHX_
				   "Usage: attributes::_guess_stash $reference");
		    }
		
           6        rv = ST(0);
           6        ST(0) = TARG;
           6        if (!(SvOK(rv) && SvROK(rv)))
      ######    	goto usage;
           6        sv = SvRV(rv);
		
           6        if (SvOBJECT(sv))
           1    	sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
		#if 0	/* this was probably a bad idea */
		    else if (SvPADMY(sv))
			sv_setsv(TARG, &PL_sv_no);	/* unblessed lexical */
		#endif
		    else {
           5    	const HV *stash = Nullhv;
           5    	switch (SvTYPE(sv)) {
			case SVt_PVCV:
           5    	    if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
           5    		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:
           5    	    break;
			}
           5    	if (stash)
           5    	    sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
		    }
		
           6        SvSETMAGIC(TARG);
           6        XSRETURN(1);
		}
		
		XS(XS_attributes_reftype)
         132    {
         132        dXSARGS;
         132        SV *rv, *sv;
         132        dXSTARG;
		
         132        if (items != 1) {
		usage:
      ######    	Perl_croak(aTHX_
				   "Usage: attributes::reftype $reference");
		    }
		
         132        rv = ST(0);
         132        ST(0) = TARG;
         132        if (SvGMAGICAL(rv))
      ######    	mg_get(rv);
         132        if (!(SvOK(rv) && SvROK(rv)))
      ######    	goto usage;
         132        sv = SvRV(rv);
         132        sv_setpv(TARG, sv_reftype(sv, 0));
         132        SvSETMAGIC(TARG);
		
         132        XSRETURN(1);
		}
		
		XS(XS_attributes__warn_reserved)
          62    {
          62        dXSARGS;
		
          62        if (items != 0) {
      ######    	Perl_croak(aTHX_
				   "Usage: attributes::_warn_reserved ()");
		    }
		
          62        EXTEND(SP,1);
          62        ST(0) = boolSV(ckWARN(WARN_RESERVED));
		
          62        XSRETURN(1);
		}
		
		/*
		 * Local variables:
		 * c-indentation-style: bsd
		 * c-basic-offset: 4
		 * indent-tabs-mode: t
		 * End:
		 *
		 * ex: set ts=8 sts=4 sw=4 noet:
		 */