This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
First steps of making builds outside the source
[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
f0f333f4
NIS
20import(Class, ...)
21char * Class
77a005ab
MB
22 ALIAS:
23 unimport = 1
24 PREINIT:
25 int i;
26 CV *cv;
27 PPCODE:
3280af22 28 if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
77a005ab
MB
29 croak("can't set attributes outside a subroutine scope");
30 for (i = 1; i < items; i++) {
2d8e6c8d
GS
31 STRLEN n_a;
32 char *attr = SvPV(ST(i), n_a);
77a005ab
MB
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 {
2d8e6c8d
GS
52 STRLEN n_a;
53 char *name = SvPV(sub, n_a);
77a005ab
MB
54 sub = (SV*)perl_get_cv(name, FALSE);
55 }
56 if (!sub)
57 croak("invalid subroutine reference or name");
58 if (CvFLAGS(sub) & CVf_METHOD)
79cb57f6 59 XPUSHs(sv_2mortal(newSVpvn("method", 6)));
77a005ab 60 if (CvFLAGS(sub) & CVf_LOCKED)
79cb57f6 61 XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
77a005ab 62