This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Rewrite synchronisation of subs/methods and add attrs
[perl5.git] / ext / attrs / attrs.xs
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4
5 static cv_flags_t
6 get_flag(attr)
7 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 (!compcv || !(cv = CvOUTSIDE(compcv)))
29             croak("can't set attributes outside a subroutine scope");
30         for (i = 1; i < items; i++) {
31             char *attr = SvPV(ST(i), na);
32             cv_flags_t flag = get_flag(attr);
33             if (!flag)
34                 croak("invalid attribute name %s", attr);
35             if (ix)
36                 CvFLAGS(cv) &= ~flag;
37             else
38                 CvFLAGS(cv) |= flag;
39         }
40
41 void
42 get(sub)
43 SV *    sub
44     PPCODE:
45         if (SvROK(sub)) {
46             sub = SvRV(sub);
47             if (SvTYPE(sub) != SVt_PVCV)
48                 sub = Nullsv;
49         }
50         else {
51             char *name = SvPV(sub, na);
52             sub = (SV*)perl_get_cv(name, FALSE);
53         }
54         if (!sub)
55             croak("invalid subroutine reference or name");
56         if (CvFLAGS(sub) & CVf_METHOD)
57             XPUSHs(sv_2mortal(newSVpv("method", 0)));
58         if (CvFLAGS(sub) & CVf_LOCKED)
59             XPUSHs(sv_2mortal(newSVpv("locked", 0)));
60