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