| 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 | {
|
|---|
| 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
|
|---|
| 20 | import(...)
|
|---|
| 21 | ALIAS:
|
|---|
| 22 | unimport = 1
|
|---|
| 23 | PREINIT:
|
|---|
| 24 | int i;
|
|---|
| 25 | PPCODE:
|
|---|
| 26 | if (items < 1)
|
|---|
| 27 | Perl_croak(aTHX_ "Usage: %s(Class, ...)", GvNAME(CvGV(cv)));
|
|---|
| 28 | if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
|
|---|
| 29 | croak("can't set attributes outside a subroutine scope");
|
|---|
| 30 | if (ckWARN(WARN_DEPRECATED))
|
|---|
| 31 | Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
|
|---|
| 32 | "pragma \"attrs\" is deprecated, "
|
|---|
| 33 | "use \"sub NAME : ATTRS\" instead");
|
|---|
| 34 | for (i = 1; i < items; i++) {
|
|---|
| 35 | const char * const attr = SvPV_nolen(ST(i));
|
|---|
| 36 | const cv_flags_t flag = get_flag(attr);
|
|---|
| 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 {
|
|---|
| 55 | const char * const name = SvPV_nolen(sub);
|
|---|
| 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)
|
|---|
| 61 | XPUSHs(sv_2mortal(newSVpvn("method", 6)));
|
|---|
| 62 | if (CvFLAGS(sub) & CVf_LOCKED)
|
|---|
| 63 | XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
|
|---|
| 64 |
|
|---|
