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