1			#define PERL_NO_GET_CONTEXT
     2			#include "EXTERN.h"
     3			#include "perl.h"
     4			#include "XSUB.h"
     5			
     6			static cv_flags_t
     7			get_flag(const char *attr)
     8	           8    {
     9	           8        if (strnEQ(attr, "method", 6))
    10	           3    	return CVf_METHOD;
    11	           5        else if (strnEQ(attr, "locked", 6))
    12	           5    	return CVf_LOCKED;
    13			    else
    14	      ######    	return 0;
    15			}
    16			
    17			MODULE = attrs		PACKAGE = attrs
    18			
    19			void
    20			import(...)
    21			    ALIAS:
    22				unimport = 1
    23			    PREINIT:
    24	           6    	int i;
    25			    PPCODE:
    26	           6           if (items < 1)
    27	      ######               Perl_croak(aTHX_ "Usage: %s(Class, ...)", GvNAME(CvGV(cv)));
    28	           6    	if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
    29	      ######    	    croak("can't set attributes outside a subroutine scope");
    30	           6    	if (ckWARN(WARN_DEPRECATED))
    31	           1    	    Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
    32						"pragma \"attrs\" is deprecated, "
    33						"use \"sub NAME : ATTRS\" instead");
    34	          14    	for (i = 1; i < items; i++) {
    35	           8    	    const char * const attr = SvPV_nolen(ST(i));
    36	           8    	    const cv_flags_t flag = get_flag(attr);
    37	           8    	    if (!flag)
    38	      ######    		croak("invalid attribute name %s", attr);
    39	           8    	    if (ix)
    40	      ######        		CvFLAGS(cv) &= ~flag;
    41				    else
    42	           8    		CvFLAGS(cv) |= flag;
    43				}
    44			
    45			void
    46			get(sub)
    47			SV *	sub
    48			    PPCODE:
    49	           3    	if (SvROK(sub)) {
    50	           3    	    sub = SvRV(sub);
    51	           3    	    if (SvTYPE(sub) != SVt_PVCV)
    52	      ######    		sub = Nullsv;
    53				}
    54				else {
    55	      ######    	    const char * const name = SvPV_nolen(sub);
    56	      ######    	    sub = (SV*)perl_get_cv(name, FALSE);
    57				}
    58	           3    	if (!sub)
    59	      ######    	    croak("invalid subroutine reference or name");
    60	           3    	if (CvFLAGS(sub) & CVf_METHOD)
    61	           3    	    XPUSHs(sv_2mortal(newSVpvn("method", 6)));
    62	           3    	if (CvFLAGS(sub) & CVf_LOCKED)
    63	           2    	    XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
    64