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