This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Implement use attrs qw(locked package);
[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(char *attr)
7 {
8     if (strnEQ(attr, "method", 6))
9         return CVf_METHOD;
10     else if (strnEQ(attr, "locked", 6))
11         return CVf_LOCKED;
12     else if (strnEQ(attr, "package", 7))
13         return CVf_PACKAGE;
14     else
15         return 0;
16 }
17
18 MODULE = attrs          PACKAGE = attrs
19
20 void
21 import(Class, ...)
22 char *  Class
23     ALIAS:
24         unimport = 1
25     PREINIT:
26         int i;
27         CV *cv;
28     PPCODE:
29         if (!compcv || !(cv = CvOUTSIDE(compcv)))
30             croak("can't set attributes outside a subroutine scope");
31         for (i = 1; i < items; i++) {
32             char *attr = SvPV(ST(i), na);
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             char *name = SvPV(sub, na);
53             sub = (SV*)perl_get_cv(name, FALSE);
54         }
55         if (!sub)
56             croak("invalid subroutine reference or name");
57         if (CvFLAGS(sub) & CVf_METHOD)
58             XPUSHs(sv_2mortal(newSVpv("method", 0)));
59         if (CvFLAGS(sub) & CVf_LOCKED)
60             XPUSHs(sv_2mortal(newSVpv("locked", 0)));
61         if (CvFLAGS(sub) & CVf_PACKAGE)
62             XPUSHs(sv_2mortal(newSVpv("package", 0)));
63