This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
First steps of making builds outside the source
[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(Class, ...)
21 char *  Class
22     ALIAS:
23         unimport = 1
24     PREINIT:
25         int i;
26         CV *cv;
27     PPCODE:
28         if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
29             croak("can't set attributes outside a subroutine scope");
30         for (i = 1; i < items; i++) {
31             STRLEN n_a;
32             char *attr = SvPV(ST(i), n_a);
33             cv_flags_t flag = get_flag(attr);
34             if (!flag)
35                 croak("invalid attribute name %s", attr);
36             if (ix)
37                 CvFLAGS(cv) &= ~flag;
38             else
39                 CvFLAGS(cv) |= flag;
40         }
41
42 void
43 get(sub)
44 SV *    sub
45     PPCODE:
46         if (SvROK(sub)) {
47             sub = SvRV(sub);
48             if (SvTYPE(sub) != SVt_PVCV)
49                 sub = Nullsv;
50         }
51         else {
52             STRLEN n_a;
53             char *name = SvPV(sub, n_a);
54             sub = (SV*)perl_get_cv(name, FALSE);
55         }
56         if (!sub)
57             croak("invalid subroutine reference or name");
58         if (CvFLAGS(sub) & CVf_METHOD)
59             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
60         if (CvFLAGS(sub) & CVf_LOCKED)
61             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
62