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)) {
99 /* rafl says that this wastes memory savings that GvSVs have
100 in 5.8.9 and 5.10.x. But without it some tests fail. rafl
101 says the right thing to do is to handle GvSVs differently
103 gv_init((GV*)gv, stash, method_name, method_name_len, GV_ADDMULTI);
109 if ( SvTYPE(gv) == SVt_PVGV && (cv = GvCVu(gv)) ) {
110 GV* const cvgv = CvGV(cv);
111 /* ($cvpkg_name, $cv_name) = get_code_info($cv) */
112 const char* const cvpkg_name = HvNAME(GvSTASH(cvgv));
113 const char* const cv_name = GvNAME(cvgv);
117 /* this checks to see that the subroutine is actually from our package */
118 if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
119 if ( strNE(cvpkg_name, class_name_pv) ) {
124 method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
125 if ( SvOK(method_slot) ) {
126 SV* const body = call0(method_slot, key_body); /* $method_object->body() */
127 if ( SvROK(body) && ((CV*) SvRV(body)) == cv ) {
132 method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */
135 $method_object = $method_metaclass->wrap(
137 associated_metaclass => $self,
138 package_name => $class_name,
147 PUSHs(method_metaclass_name); /* invocant */
148 mPUSHs(newRV_inc((SV*)cv));
149 PUSHs(associated_metaclass);
151 PUSHs(key_package_name);
154 mPUSHs(newSVpv(method_name, method_name_len));
157 call_sv(wrap, G_SCALAR | G_METHOD);
159 method_object = POPs;
161 /* $map->{$method_name} = $method_object */
162 sv_setsv(method_slot, method_object);
173 Pass in a coderef, returns:
174 [ $pkg_name, $coderef_name ] ie:
175 [ 'Foo::Bar', 'new' ]
178 MODULE = Class::MOP PACKAGE = Class::MOP
181 key_name = newSVpvs("name");
182 key_body = newSVpvs("body");
183 key_package = newSVpvs("package");
184 key_package_name = newSVpvs("package_name");
186 PERL_HASH(hash_name, "name", 4);
187 PERL_HASH(hash_body, "body", 4);
188 PERL_HASH(hash_package, "package", 7);
189 PERL_HASH(hash_package_name, "package_name", 12);
191 method_metaclass = newSVpvs("method_metaclass");
192 wrap = newSVpvs("wrap");
193 associated_metaclass = newSVpvs("associated_metaclass");
200 get_code_info(coderef)
206 if ( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV ) {
207 coderef = SvRV(coderef);
208 /* I think this only gets triggered with a mangled coderef, but if
209 we hit it without the guard, we segfault. The slightly odd return
210 value strikes me as an improvement (mst)
213 if ( isGV_with_GP(CvGV(coderef)) ) {
215 pkg = HvNAME( GvSTASH(CvGV(coderef)) );
216 name = GvNAME( CvGV(coderef) );
225 PUSHs(newSVpvn(pkg, strlen(pkg)));
226 PUSHs(newSVpvn(name, strlen(name)));
230 MODULE = Class::MOP PACKAGE = Class::MOP::Package
233 get_all_package_symbols(self, ...)
238 SV *type_filter = NULL;
241 if ( ! SvROK(self) ) {
242 die("Cannot call get_all_package_symbols as a class method");
246 case G_VOID: return; break;
247 case G_SCALAR: ST(0) = &PL_sv_undef; return; break;
250 if ( items > 1 ) type_filter = ST(1);
254 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
255 stash = gv_stashsv(HeVAL(he),0);
259 (void)hv_iterinit(stash);
261 if ( type_filter && SvPOK(type_filter) ) {
262 const char *const type = SvPV_nolen(type_filter);
264 while ( (he = hv_iternext(stash)) ) {
265 SV *const gv = HeVAL(he);
272 switch( SvTYPE(gv) ) {
278 /* expand the gv into a real typeglob if it
279 * contains stub functions and we were asked to
280 * return CODE symbols */
283 /* we don't really care about the length,
284 but that's the API */
285 key = HePV(he, keylen);
286 package = HvNAME(stash);
287 fq = newSVpvf("%s::%s", package, key);
288 sv = (SV*)get_cv(SvPV_nolen(fq), 0);
292 key = HePV(he, keylen);
293 gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI);
298 case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */
299 case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */
300 case 'I': sv = (SV *)GvIO(gv); break; /* IO */
301 case 'H': sv = (SV *)GvHV(gv); break; /* HASH */
302 case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */
304 croak("Unknown type %s\n", type);
312 SV *key = hv_iterkeysv(he);
316 PUSHs(sv_2mortal(newRV_inc(sv)));
321 EXTEND(SP, HvKEYS(stash) * 2);
323 while ( (he = hv_iternext(stash)) ) {
324 SV *key = hv_iterkeysv(he);
341 if ( ! SvROK(self) ) {
342 die("Cannot call name as a class method");
345 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
348 ST(0) = &PL_sv_undef;
350 MODULE = Class::MOP PACKAGE = Class::MOP::Attribute
358 if ( ! SvROK(self) ) {
359 die("Cannot call name as a class method");
362 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
365 ST(0) = &PL_sv_undef;
367 MODULE = Class::MOP PACKAGE = Class::MOP::Method
375 if ( ! SvROK(self) ) {
376 die("Cannot call name as a class method");
379 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
382 ST(0) = &PL_sv_undef;
390 if ( ! SvROK(self) ) {
391 die("Cannot call package_name as a class method");
394 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
397 ST(0) = &PL_sv_undef;
405 if ( ! SvROK(self) ) {
406 die("Cannot call body as a class method");
409 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
412 ST(0) = &PL_sv_undef;
415 MODULE = Class::MOP PACKAGE = Class::MOP::Class
421 SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) );
422 HV* const stash = gv_stashsv(class_name, TRUE);
423 UV const current = check_package_cache_flag(stash);
424 SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
425 SV* const map_ref = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
427 if ( ! SvRV(self) ) {
428 die("Cannot call get_method_map as a class method");
431 /* in $self->{methods} does not yet exist (or got deleted) */
432 if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
433 SV* new_map_ref = newRV_noinc((SV*)newHV());
434 sv_2mortal(new_map_ref);
435 sv_setsv(map_ref, new_map_ref);
438 if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
442 mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
443 sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */