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
CommitLineData
77a005ab
MB
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
5static cv_flags_t
f0f333f4 6get_flag(char *attr)
77a005ab
MB
7{
8 if (strnEQ(attr, "method", 6))
9 return CVf_METHOD;
10 else if (strnEQ(attr, "locked", 6))
11 return CVf_LOCKED;
74efa5a2
NIS
12 else if (strnEQ(attr, "package", 7))
13 return CVf_PACKAGE;
77a005ab
MB
14 else
15 return 0;
16}
17
18MODULE = attrs PACKAGE = attrs
19
20void
f0f333f4
NIS
21import(Class, ...)
22char * Class
77a005ab
MB
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
42void
43get(sub)
44SV * 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)));
74efa5a2
NIS
61 if (CvFLAGS(sub) & CVf_PACKAGE)
62 XPUSHs(sv_2mortal(newSVpv("package", 0)));
77a005ab 63