Commit | Line | Data |
e0e4674a |
1 | |
2 | #include "EXTERN.h" |
3 | #include "perl.h" |
4 | #include "XSUB.h" |
15273f3c |
5 | |
599791aa |
6 | #define NEED_sv_2pv_flags |
15273f3c |
7 | #define NEED_sv_2pv_nolen |
b0e94057 |
8 | #include "ppport.h" |
e0e4674a |
9 | |
cc856b56 |
10 | SV *key_name; |
11 | U32 hash_name; |
12 | |
13 | SV *key_package; |
14 | U32 hash_package; |
15 | |
16 | SV *key_body; |
17 | U32 hash_body; |
18 | |
e0e4674a |
19 | /* |
e0e4674a |
20 | get_code_info: |
21 | Pass in a coderef, returns: |
22 | [ $pkg_name, $coderef_name ] ie: |
23 | [ 'Foo::Bar', 'new' ] |
24 | */ |
25 | |
26 | MODULE = Class::MOP PACKAGE = Class::MOP |
27 | |
cc856b56 |
28 | BOOT: |
29 | key_name = newSVpvs("name"); |
30 | key_body = newSVpvs("body"); |
31 | key_package = newSVpvs("package"); |
32 | |
33 | PERL_HASH(hash_name, "name", 4); |
34 | PERL_HASH(hash_body, "body", 4); |
35 | PERL_HASH(hash_package, "package", 7); |
36 | |
37 | |
d7bf3478 |
38 | PROTOTYPES: ENABLE |
39 | |
cc856b56 |
40 | |
e0e4674a |
41 | void |
42 | get_code_info(coderef) |
43 | SV* coderef |
44 | PREINIT: |
45 | char* name; |
46 | char* pkg; |
47 | PPCODE: |
e0e4674a |
48 | if( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV){ |
49 | coderef = SvRV(coderef); |
7b62d87f |
50 | /* I think this only gets triggered with a mangled coderef, but if |
51 | we hit it without the guard, we segfault. The slightly odd return |
52 | value strikes me as an improvement (mst) |
53 | */ |
a4f4221a |
54 | #ifdef isGV_with_GP |
55 | if ( isGV_with_GP(CvGV(coderef))) { |
56 | #endif |
7b62d87f |
57 | pkg = HvNAME( GvSTASH(CvGV(coderef)) ); |
58 | name = GvNAME( CvGV(coderef) ); |
a4f4221a |
59 | #ifdef isGV_with_GP |
60 | } else { |
61 | pkg = "__UNKNOWN__"; |
62 | name = "__ANON__"; |
63 | } |
64 | #endif |
e0e4674a |
65 | |
66 | EXTEND(SP, 2); |
67 | PUSHs(newSVpvn(pkg, strlen(pkg))); |
68 | PUSHs(newSVpvn(name, strlen(name))); |
69 | } |
70 | |
15273f3c |
71 | |
72 | MODULE = Class::MOP PACKAGE = Class::MOP::Package |
73 | |
74 | void |
cc856b56 |
75 | get_all_package_symbols(self, ...) |
76 | SV *self |
15273f3c |
77 | PROTOTYPE: $;$ |
78 | PREINIT: |
cc856b56 |
79 | HV *stash = NULL; |
15273f3c |
80 | SV *type_filter = NULL; |
75705e60 |
81 | register HE *he; |
15273f3c |
82 | PPCODE: |
83 | |
84 | switch ( GIMME_V ) { |
85 | case G_VOID: return; break; |
86 | case G_SCALAR: ST(0) = &PL_sv_undef; return; break; |
87 | } |
88 | |
89 | if ( items > 1 ) type_filter = ST(1); |
90 | |
91 | PUTBACK; |
92 | |
75705e60 |
93 | if (SvROK(self) && (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package))) |
94 | stash = gv_stashsv(HeVAL(he),0); |
15273f3c |
95 | |
96 | if ( stash ) { |
15273f3c |
97 | |
98 | (void)hv_iterinit(stash); |
99 | |
100 | if ( type_filter && SvPOK(type_filter) ) { |
101 | const char *const type = SvPV_nolen(type_filter); |
102 | |
75705e60 |
103 | while ((he = hv_iternext(stash))) { |
104 | SV *const gv = HeVAL(he); |
15273f3c |
105 | SV *sv; |
75705e60 |
106 | char *key; |
107 | STRLEN keylen; |
9457b596 |
108 | char *package; |
fd27f6e9 |
109 | SV *fq; |
15273f3c |
110 | |
15273f3c |
111 | switch( SvTYPE(gv) ) { |
112 | case SVt_PVGV: |
113 | switch (*type) { |
114 | case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */ |
115 | case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */ |
116 | case 'I': sv = (SV *)GvIO(gv); break; /* IO */ |
117 | case 'H': sv = (SV *)GvHV(gv); break; /* HASH */ |
118 | case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */ |
119 | default: |
120 | croak("Unknown type %s\n", type); |
121 | } |
122 | break; |
123 | case SVt_RV: |
124 | /* BAH! constants are horrible */ |
fd27f6e9 |
125 | |
126 | /* we don't really care about the length, |
127 | but that's the API */ |
75705e60 |
128 | key = HePV(he, keylen); |
9457b596 |
129 | package = HvNAME(stash); |
fd27f6e9 |
130 | fq = newSVpvf("%s::%s", package, key); |
131 | sv = sv_2mortal((SV*)get_cv(SvPV_nolen(fq), 0)); |
15273f3c |
132 | break; |
133 | default: |
134 | continue; |
135 | } |
136 | |
137 | if ( sv ) { |
75705e60 |
138 | SV *key = hv_iterkeysv(he); |
15273f3c |
139 | SPAGAIN; |
140 | EXTEND(SP, 2); |
141 | PUSHs(key); |
66af67fe |
142 | PUSHs(sv_2mortal(newRV_inc(sv))); |
15273f3c |
143 | PUTBACK; |
144 | } |
145 | } |
146 | } else { |
147 | EXTEND(SP, HvKEYS(stash) * 2); |
148 | |
75705e60 |
149 | while ((he = hv_iternext(stash))) { |
150 | SV *key = hv_iterkeysv(he); |
599791aa |
151 | SV *sv = HeVAL(he); |
15273f3c |
152 | SPAGAIN; |
0eb2957d |
153 | PUSHs(key); |
15273f3c |
154 | PUSHs(sv); |
155 | PUTBACK; |
156 | } |
157 | } |
158 | |
159 | } |
160 | |
cc856b56 |
161 | SV * |
162 | name(self) |
163 | SV *self |
164 | PREINIT: |
165 | register HE *he; |
166 | PPCODE: |
167 | if (SvROK(self) && (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package))) |
168 | XPUSHs(HeVAL(he)); |
169 | else |
170 | ST(0) = &PL_sv_undef; |
171 | |
172 | MODULE = Class::MOP PACKAGE = Class::Attribute |
173 | |
174 | SV * |
175 | name(self) |
176 | SV *self |
177 | PREINIT: |
178 | register HE *he; |
179 | PPCODE: |
180 | if (SvROK(self) && (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name))) |
181 | XPUSHs(HeVAL(he)); |
182 | else |
183 | ST(0) = &PL_sv_undef; |
184 | |
185 | MODULE = Class::MOP PACKAGE = Class::Method |
186 | |
187 | SV * |
188 | name(self) |
189 | SV *self |
190 | PREINIT: |
191 | register HE *he; |
192 | PPCODE: |
193 | if (SvROK(self) && (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name))) |
194 | XPUSHs(HeVAL(he)); |
195 | else |
196 | ST(0) = &PL_sv_undef; |
197 | |
198 | SV * |
199 | body(self) |
200 | SV *self |
201 | PREINIT: |
202 | register HE *he; |
203 | PPCODE: |
204 | if (SvROK(self) && (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body))) |
205 | XPUSHs(HeVAL(he)); |
206 | else |
207 | ST(0) = &PL_sv_undef; |