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