5 #define NEED_sv_2pv_flags
6 #define NEED_sv_2pv_nolen
16 U32 hash_package_name;
22 SV* associated_metaclass;
26 #define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash)
27 #ifdef HvMROMETA /* 5.10.0 */
30 #define mro_meta_init(stash) Perl_mro_meta_init(aTHX_ stash) /* used in HvMROMETA macro */
31 #endif /* !mro_meta_init */
34 mop_check_package_cache_flag(pTHX_ HV* stash) {
35 assert(SvTYPE(stash) == SVt_PVHV);
37 return HvMROMETA(stash)->pkg_gen; /* mro::get_pkg_gen($pkg) */
40 #else /* pre 5.10.0 */
43 mop_check_package_cache_flag(pTHX_ HV* stash) {
44 PERL_UNUSED_ARG(stash);
45 assert(SvTYPE(stash) == SVt_PVHV);
47 return PL_sub_generation;
51 #define call0(s, m) mop_call0(aTHX_ s, m)
53 mop_call0(pTHX_ SV* const self, SV* const method) {
61 call_sv(method, G_SCALAR | G_METHOD);
71 mop_update_method_map(pTHX_ SV* const self, SV* const class_name, HV* const stash, HV* const map) {
72 const char* const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
73 SV* method_metaclass_name;
80 while((gv = (GV*)hv_iternextsv(stash, &method_name, &method_name_len))) {
83 /* rafl says that this wastes memory savings that GvSVs have
84 in 5.8.9 and 5.10.x. But without it some tests fail. rafl
85 says the right thing to do is to handle GvSVs differently
87 gv_init((GV*)gv, stash, method_name, method_name_len, GV_ADDMULTI);
90 if ( SvTYPE(gv) == SVt_PVGV && (cv = GvCVu(gv)) ) {
91 GV* const cvgv = CvGV(cv);
92 /* ($cvpkg_name, $cv_name) = get_code_info($cv) */
93 const char* const cvpkg_name = HvNAME(GvSTASH(cvgv));
94 const char* const cv_name = GvNAME(cvgv);
98 /* this checks to see that the subroutine is actually from our package */
99 if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
100 if ( strNE(cvpkg_name, class_name_pv) ) {
105 method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
106 if ( SvOK(method_slot) ) {
107 SV* const body = call0(method_slot, key_body); /* $method_object->body() */
108 if ( SvROK(body) && ((CV*) SvRV(body)) == cv ) {
113 method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */
116 $method_object = $method_metaclass->wrap(
118 associated_metaclass => $self,
119 package_name => $class_name,
128 PUSHs(method_metaclass_name); /* invocant */
129 mPUSHs(newRV_inc((SV*)cv));
130 PUSHs(associated_metaclass);
132 PUSHs(key_package_name);
135 mPUSHs(newSVpv(method_name, method_name_len));
138 call_sv(wrap, G_SCALAR | G_METHOD);
140 method_object = POPs;
142 /* $map->{$method_name} = $method_object */
143 sv_setsv(method_slot, method_object);
154 Pass in a coderef, returns:
155 [ $pkg_name, $coderef_name ] ie:
156 [ 'Foo::Bar', 'new' ]
159 MODULE = Class::MOP PACKAGE = Class::MOP
162 key_name = newSVpvs("name");
163 key_body = newSVpvs("body");
164 key_package = newSVpvs("package");
165 key_package_name = newSVpvs("package_name");
167 PERL_HASH(hash_name, "name", 4);
168 PERL_HASH(hash_body, "body", 4);
169 PERL_HASH(hash_package, "package", 7);
170 PERL_HASH(hash_package_name, "package_name", 12);
172 method_metaclass = newSVpvs("method_metaclass");
173 wrap = newSVpvs("wrap");
174 associated_metaclass = newSVpvs("associated_metaclass");
181 get_code_info(coderef)
187 if( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV) {
188 coderef = SvRV(coderef);
189 /* I think this only gets triggered with a mangled coderef, but if
190 we hit it without the guard, we segfault. The slightly odd return
191 value strikes me as an improvement (mst)
194 if ( isGV_with_GP(CvGV(coderef))) {
196 pkg = HvNAME( GvSTASH(CvGV(coderef)) );
197 name = GvNAME( CvGV(coderef) );
206 PUSHs(newSVpvn(pkg, strlen(pkg)));
207 PUSHs(newSVpvn(name, strlen(name)));
211 MODULE = Class::MOP PACKAGE = Class::MOP::Package
214 get_all_package_symbols(self, ...)
219 SV *type_filter = NULL;
223 die("Cannot call get_all_package_symbols as a class method");
227 case G_VOID: return; break;
228 case G_SCALAR: ST(0) = &PL_sv_undef; return; break;
231 if ( items > 1 ) type_filter = ST(1);
235 if ((he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)))
236 stash = gv_stashsv(HeVAL(he),0);
240 (void)hv_iterinit(stash);
242 if ( type_filter && SvPOK(type_filter) ) {
243 const char *const type = SvPV_nolen(type_filter);
245 while ((he = hv_iternext(stash))) {
246 SV *const gv = HeVAL(he);
253 switch( SvTYPE(gv) ) {
256 case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */
257 case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */
258 case 'I': sv = (SV *)GvIO(gv); break; /* IO */
259 case 'H': sv = (SV *)GvHV(gv); break; /* HASH */
260 case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */
262 croak("Unknown type %s\n", type);
266 /* BAH! constants are horrible */
272 /* we don't really care about the length,
273 but that's the API */
274 key = HePV(he, keylen);
275 package = HvNAME(stash);
276 fq = newSVpvf("%s::%s", package, key);
277 sv = (SV*)get_cv(SvPV_nolen(fq), 0);
284 SV *key = hv_iterkeysv(he);
288 PUSHs(sv_2mortal(newRV_inc(sv)));
293 EXTEND(SP, HvKEYS(stash) * 2);
295 while ((he = hv_iternext(stash))) {
296 SV *key = hv_iterkeysv(he);
314 die("Cannot call name as a class method");
317 if ((he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)))
320 ST(0) = &PL_sv_undef;
322 MODULE = Class::MOP PACKAGE = Class::MOP::Attribute
331 die("Cannot call name as a class method");
334 if ((he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)))
337 ST(0) = &PL_sv_undef;
339 MODULE = Class::MOP PACKAGE = Class::MOP::Method
348 die("Cannot call name as a class method");
351 if ((he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)))
354 ST(0) = &PL_sv_undef;
363 die("Cannot call package_name as a class method");
366 if ((he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)))
369 ST(0) = &PL_sv_undef;
378 die("Cannot call body as a class method");
381 if ((he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)))
384 ST(0) = &PL_sv_undef;
387 MODULE = Class::MOP PACKAGE = Class::MOP::Class
394 die("Cannot call get_method_map as a class method");
397 HE* const he = hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package); /* $self->name() */
398 SV* const class_name = HeVAL(he);
399 HV* const stash = gv_stashsv(class_name, TRUE);
400 UV const current = check_package_cache_flag(stash);
401 SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
402 SV* const map_ref = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
404 /* in $self->{methods} does not yet exist (or got deleted) */
405 if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
406 SV* new_map_ref = newRV_noinc((SV*)newHV());
407 sv_2mortal(new_map_ref);
408 sv_setsv(map_ref, new_map_ref);
411 if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
415 mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
416 sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */
421 ST(0) = map_ref; /* map_ref is already mortal */