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
CommitLineData
c5be433b 1#define PERL_NO_GET_CONTEXT
77a005ab
MB
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
6static cv_flags_t
f0f333f4 7get_flag(char *attr)
77a005ab
MB
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
17MODULE = attrs PACKAGE = attrs
18
19void
c6c619a9 20import(...)
77a005ab
MB
21 ALIAS:
22 unimport = 1
23 PREINIT:
24 int i;
77a005ab 25 PPCODE:
c6c619a9
DM
26 if (items < 1)
27 Perl_croak(aTHX_ "Usage: %s(Class, ...)", GvNAME(CvGV(cv)));
3280af22 28 if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
77a005ab 29 croak("can't set attributes outside a subroutine scope");
a98df962
GS
30 if (ckWARN(WARN_DEPRECATED))
31 Perl_warner(aTHX_ WARN_DEPRECATED,
32 "pragma \"attrs\" is deprecated, "
33 "use \"sub NAME : ATTRS\" instead");
77a005ab 34 for (i = 1; i < items; i++) {
2d8e6c8d
GS
35 STRLEN n_a;
36 char *attr = SvPV(ST(i), n_a);
77a005ab
MB
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
46void
47get(sub)
48SV * sub
49 PPCODE:
50 if (SvROK(sub)) {
51 sub = SvRV(sub);
52 if (SvTYPE(sub) != SVt_PVCV)
53 sub = Nullsv;
54 }
55 else {
2d8e6c8d
GS
56 STRLEN n_a;
57 char *name = SvPV(sub, n_a);
77a005ab
MB
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)
79cb57f6 63 XPUSHs(sv_2mortal(newSVpvn("method", 6)));
77a005ab 64 if (CvFLAGS(sub) & CVf_LOCKED)
79cb57f6 65 XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
77a005ab 66