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