| 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 |
| f0f333f4 |
7 | get_flag(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)) |
| 31 | Perl_warner(aTHX_ WARN_DEPRECATED, |
| 32 | "pragma \"attrs\" is deprecated, " |
| 33 | "use \"sub NAME : ATTRS\" instead"); |
| 77a005ab |
34 | for (i = 1; i < items; i++) { |
| 2d8e6c8d |
35 | STRLEN n_a; |
| 36 | char *attr = SvPV(ST(i), n_a); |
| 77a005ab |
37 | cv_flags_t flag = get_flag(attr); |
| 38 | if (!flag) |
| 39 | croak("invalid attribute name %s", attr); |
| 40 | if (ix) |
| 41 | CvFLAGS(cv) &= ~flag; |
| 42 | else |
| 43 | CvFLAGS(cv) |= flag; |
| 44 | } |
| 45 | |
| 46 | void |
| 47 | get(sub) |
| 48 | SV * sub |
| 49 | PPCODE: |
| 50 | if (SvROK(sub)) { |
| 51 | sub = SvRV(sub); |
| 52 | if (SvTYPE(sub) != SVt_PVCV) |
| 53 | sub = Nullsv; |
| 54 | } |
| 55 | else { |
| 2d8e6c8d |
56 | STRLEN n_a; |
| 57 | char *name = SvPV(sub, n_a); |
| 77a005ab |
58 | sub = (SV*)perl_get_cv(name, FALSE); |
| 59 | } |
| 60 | if (!sub) |
| 61 | croak("invalid subroutine reference or name"); |
| 62 | if (CvFLAGS(sub) & CVf_METHOD) |
| 79cb57f6 |
63 | XPUSHs(sv_2mortal(newSVpvn("method", 6))); |
| 77a005ab |
64 | if (CvFLAGS(sub) & CVf_LOCKED) |
| 79cb57f6 |
65 | XPUSHs(sv_2mortal(newSVpvn("locked", 6))); |
| 77a005ab |
66 | |
projects / p5sagit/p5-mst-13.2.git / blame