1 /* There's a lot of cases of doubled parens in here like this:
5 This shuts up warnings from gcc -Wall
12 #define NEED_sv_2pv_flags
13 #define NEED_sv_2pv_nolen
23 U32 hash_package_name;
29 SV* associated_metaclass;
33 #define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash)
34 #ifdef HvMROMETA /* 5.10.0 */
37 #define mro_meta_init(stash) Perl_mro_meta_init(aTHX_ stash) /* used in HvMROMETA macro */
38 #endif /* !mro_meta_init */
41 mop_check_package_cache_flag(pTHX_ HV* stash) {
42 assert(SvTYPE(stash) == SVt_PVHV);
44 return HvMROMETA(stash)->pkg_gen; /* mro::get_pkg_gen($pkg) */
47 #else /* pre 5.10.0 */
50 mop_check_package_cache_flag(pTHX_ HV* stash) {
51 PERL_UNUSED_ARG(stash);
52 assert(SvTYPE(stash) == SVt_PVHV);
54 return PL_sub_generation;
58 #define call0(s, m) mop_call0(aTHX_ s, m)
60 mop_call0(pTHX_ SV* const self, SV* const method) {
68 call_sv(method, G_SCALAR | G_METHOD);
78 mop_update_method_map(pTHX_ SV* const self, SV* const class_name, HV* const stash, HV* const map) {
79 const char* const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
80 SV* method_metaclass_name;
86 /* this function massivly overlaps with the xs version of
87 * get_all_package_symbols. a common c function to walk the symbol table
88 * should be factored out and used by both. --rafl */
91 while ( (gv = (GV*)hv_iternextsv(stash, &method_name, &method_name_len)) ) {
93 switch (SvTYPE (gv)) {
101 /* rafl says that this wastes memory savings that GvSVs have
102 in 5.8.9 and 5.10.x. But without it some tests fail. rafl
103 says the right thing to do is to handle GvSVs differently
105 gv_init((GV*)gv, stash, method_name, method_name_len, GV_ADDMULTI);
111 if ( SvTYPE(gv) == SVt_PVGV && (cv = GvCVu(gv)) ) {
112 GV* const cvgv = CvGV(cv);
113 /* ($cvpkg_name, $cv_name) = get_code_info($cv) */
114 const char* const cvpkg_name = HvNAME(GvSTASH(cvgv));
115 const char* const cv_name = GvNAME(cvgv);
119 /* this checks to see that the subroutine is actually from our package */
120 if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
121 if ( strNE(cvpkg_name, class_name_pv) ) {
126 method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
127 if ( SvOK(method_slot) ) {
128 SV* const body = call0(method_slot, key_body); /* $method_object->body() */
129 if ( SvROK(body) && ((CV*) SvRV(body)) == cv ) {
134 method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */
137 $method_object = $method_metaclass->wrap(
139 associated_metaclass => $self,
140 package_name => $class_name,
149 PUSHs(method_metaclass_name); /* invocant */
150 mPUSHs(newRV_inc((SV*)cv));
151 PUSHs(associated_metaclass);
153 PUSHs(key_package_name);
156 mPUSHs(newSVpv(method_name, method_name_len));
159 call_sv(wrap, G_SCALAR | G_METHOD);
161 method_object = POPs;
163 /* $map->{$method_name} = $method_object */
164 sv_setsv(method_slot, method_object);
175 Pass in a coderef, returns:
176 [ $pkg_name, $coderef_name ] ie:
177 [ 'Foo::Bar', 'new' ]
180 MODULE = Class::MOP PACKAGE = Class::MOP
183 key_name = newSVpvs("name");
184 key_body = newSVpvs("body");
185 key_package = newSVpvs("package");
186 key_package_name = newSVpvs("package_name");
188 PERL_HASH(hash_name, "name", 4);
189 PERL_HASH(hash_body, "body", 4);
190 PERL_HASH(hash_package, "package", 7);
191 PERL_HASH(hash_package_name, "package_name", 12);
193 method_metaclass = newSVpvs("method_metaclass");
194 wrap = newSVpvs("wrap");
195 associated_metaclass = newSVpvs("associated_metaclass");
202 get_code_info(coderef)
208 if ( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV ) {
209 coderef = SvRV(coderef);
210 /* I think this only gets triggered with a mangled coderef, but if
211 we hit it without the guard, we segfault. The slightly odd return
212 value strikes me as an improvement (mst)
215 if ( isGV_with_GP(CvGV(coderef)) ) {
217 pkg = HvNAME( GvSTASH(CvGV(coderef)) );
218 name = GvNAME( CvGV(coderef) );
227 PUSHs(newSVpvn(pkg, strlen(pkg)));
228 PUSHs(newSVpvn(name, strlen(name)));
232 MODULE = Class::MOP PACKAGE = Class::MOP::Package
235 get_all_package_symbols(self, ...)
240 SV *type_filter = NULL;
243 if ( ! SvROK(self) ) {
244 die("Cannot call get_all_package_symbols as a class method");
248 case G_VOID: return; break;
249 case G_SCALAR: ST(0) = &PL_sv_undef; return; break;
252 if ( items > 1 ) type_filter = ST(1);
256 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
257 stash = gv_stashsv(HeVAL(he),0);
261 (void)hv_iterinit(stash);
263 if ( type_filter && SvPOK(type_filter) ) {
264 const char *const type = SvPV_nolen(type_filter);
266 while ( (he = hv_iternext(stash)) ) {
267 SV *const gv = HeVAL(he);
274 switch( SvTYPE(gv) ) {
277 /* expand the gv into a real typeglob if it
278 * contains stub functions and we were asked to
279 * return CODE symbols */
281 key = HePV(he, keylen);
282 gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI);
287 case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */
288 case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */
289 case 'I': sv = (SV *)GvIO(gv); break; /* IO */
290 case 'H': sv = (SV *)GvHV(gv); break; /* HASH */
291 case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */
293 croak("Unknown type %s\n", type);
297 /* BAH! constants are horrible */
303 /* we don't really care about the length,
304 but that's the API */
305 key = HePV(he, keylen);
306 package = HvNAME(stash);
307 fq = newSVpvf("%s::%s", package, key);
308 sv = (SV*)get_cv(SvPV_nolen(fq), 0);
315 SV *key = hv_iterkeysv(he);
319 PUSHs(sv_2mortal(newRV_inc(sv)));
324 EXTEND(SP, HvKEYS(stash) * 2);
326 while ( (he = hv_iternext(stash)) ) {
327 SV *key = hv_iterkeysv(he);
344 if ( ! SvROK(self) ) {
345 die("Cannot call name as a class method");
348 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
351 ST(0) = &PL_sv_undef;
353 MODULE = Class::MOP PACKAGE = Class::MOP::Attribute
361 if ( ! SvROK(self) ) {
362 die("Cannot call name as a class method");
365 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
368 ST(0) = &PL_sv_undef;
370 MODULE = Class::MOP PACKAGE = Class::MOP::Method
378 if ( ! SvROK(self) ) {
379 die("Cannot call name as a class method");
382 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
385 ST(0) = &PL_sv_undef;
393 if ( ! SvROK(self) ) {
394 die("Cannot call package_name as a class method");
397 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
400 ST(0) = &PL_sv_undef;
408 if ( ! SvROK(self) ) {
409 die("Cannot call body as a class method");
412 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
415 ST(0) = &PL_sv_undef;
418 MODULE = Class::MOP PACKAGE = Class::MOP::Class
424 SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) );
425 HV* const stash = gv_stashsv(class_name, TRUE);
426 UV const current = check_package_cache_flag(stash);
427 SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
428 SV* const map_ref = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
430 if ( ! SvRV(self) ) {
431 die("Cannot call get_method_map as a class method");
434 /* in $self->{methods} does not yet exist (or got deleted) */
435 if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
436 SV* new_map_ref = newRV_noinc((SV*)newHV());
437 sv_2mortal(new_map_ref);
438 sv_setsv(map_ref, new_map_ref);
441 if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
445 mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
446 sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */