This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix various details in win32 makefiles and Config.pm setup.
[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
13         return 0;
14 }
15
16 MODULE = attrs          PACKAGE = attrs
17
18 void
19 import(Class, ...)
20 char *  Class
21     ALIAS:
22         unimport = 1
23     PREINIT:
24         int i;
25         CV *cv;
26     PPCODE:
27         if (!compcv || !(cv = CvOUTSIDE(compcv)))
28             croak("can't set attributes outside a subroutine scope");
29         for (i = 1; i < items; i++) {
30             char *attr = SvPV(ST(i), na);
31             cv_flags_t flag = get_flag(attr);
32             if (!flag)
33                 croak("invalid attribute name %s", attr);
34             if (ix)
35                 CvFLAGS(cv) &= ~flag;
36             else
37                 CvFLAGS(cv) |= flag;
38         }
39
40 void
41 get(sub)
42 SV *    sub
43     PPCODE:
44         if (SvROK(sub)) {
45             sub = SvRV(sub);
46             if (SvTYPE(sub) != SVt_PVCV)
47                 sub = Nullsv;
48         }
49         else {
50             char *name = SvPV(sub, na);
51             sub = (SV*)perl_get_cv(name, FALSE);
52         }
53         if (!sub)
54             croak("invalid subroutine reference or name");
55         if (CvFLAGS(sub) & CVf_METHOD)
56             XPUSHs(sv_2mortal(newSVpv("method", 0)));
57         if (CvFLAGS(sub) & CVf_LOCKED)
58             XPUSHs(sv_2mortal(newSVpv("locked", 0)));
59