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