1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
static cv_flags_t
get_flag(char *attr)
{
if (strnEQ(attr, "method", 6))
return CVf_METHOD;
else if (strnEQ(attr, "locked", 6))
return CVf_LOCKED;
else
return 0;
}
MODULE = attrs PACKAGE = attrs
void
import(...)
ALIAS:
unimport = 1
PREINIT:
int i;
PPCODE:
if (items < 1)
Perl_croak(aTHX_ "Usage: %s(Class, ...)", GvNAME(CvGV(cv)));
if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
croak("can't set attributes outside a subroutine scope");
if (ckWARN(WARN_DEPRECATED))
Perl_warner(aTHX_ WARN_DEPRECATED,
"pragma \"attrs\" is deprecated, "
"use \"sub NAME : ATTRS\" instead");
for (i = 1; i < items; i++) {
STRLEN n_a;
char *attr = SvPV(ST(i), n_a);
cv_flags_t flag = get_flag(attr);
if (!flag)
croak("invalid attribute name %s", attr);
if (ix)
CvFLAGS(cv) &= ~flag;
else
CvFLAGS(cv) |= flag;
}
void
get(sub)
SV * sub
PPCODE:
if (SvROK(sub)) {
sub = SvRV(sub);
if (SvTYPE(sub) != SVt_PVCV)
sub = Nullsv;
}
else {
STRLEN n_a;
char *name = SvPV(sub, n_a);
sub = (SV*)perl_get_cv(name, FALSE);
}
if (!sub)
croak("invalid subroutine reference or name");
if (CvFLAGS(sub) & CVf_METHOD)
XPUSHs(sv_2mortal(newSVpvn("method", 6)));
if (CvFLAGS(sub) & CVf_LOCKED)
XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
|
