This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
4914fda8f461395db36aac9ba46e92edc52a0ac3
[perl5.git] / ext / attrs / attrs.xs
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(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         CV *cv;
26     PPCODE:
27        if (items < 1)
28            Perl_croak(aTHX_ "Usage: %s(Class, ...)", GvNAME(CvGV(cv)));
29         if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
30             croak("can't set attributes outside a subroutine scope");
31         if (ckWARN(WARN_DEPRECATED))
32             Perl_warner(aTHX_ WARN_DEPRECATED,
33                         "pragma \"attrs\" is deprecated, "
34                         "use \"sub NAME : ATTRS\" instead");
35         for (i = 1; i < items; i++) {
36             STRLEN n_a;
37             char *attr = SvPV(ST(i), n_a);
38             cv_flags_t flag = get_flag(attr);
39             if (!flag)
40                 croak("invalid attribute name %s", attr);
41             if (ix)
42                 CvFLAGS(cv) &= ~flag;
43             else
44                 CvFLAGS(cv) |= flag;
45         }
46
47 void
48 get(sub)
49 SV *    sub
50     PPCODE:
51         if (SvROK(sub)) {
52             sub = SvRV(sub);
53             if (SvTYPE(sub) != SVt_PVCV)
54                 sub = Nullsv;
55         }
56         else {
57             STRLEN n_a;
58             char *name = SvPV(sub, n_a);
59             sub = (SV*)perl_get_cv(name, FALSE);
60         }
61         if (!sub)
62             croak("invalid subroutine reference or name");
63         if (CvFLAGS(sub) & CVf_METHOD)
64             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
65         if (CvFLAGS(sub) & CVf_LOCKED)
66             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
67