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;
87 while ( (gv = (GV*)hv_iternextsv(stash, &method_name, &method_name_len)) ) {
90 /* rafl says that this wastes memory savings that GvSVs have
91 in 5.8.9 and 5.10.x. But without it some tests fail. rafl
92 says the right thing to do is to handle GvSVs differently
94 gv_init((GV*)gv, stash, method_name, method_name_len, GV_ADDMULTI);
97 if ( SvTYPE(gv) == SVt_PVGV && (cv = GvCVu(gv)) ) {
98 GV* const cvgv = CvGV(cv);
99 /* ($cvpkg_name, $cv_name) = get_code_info($cv) */
100 const char* const cvpkg_name = HvNAME(GvSTASH(cvgv));
101 const char* const cv_name = GvNAME(cvgv);
105 /* this checks to see that the subroutine is actually from our package */
106 if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
107 if ( strNE(cvpkg_name, class_name_pv) ) {
112 method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
113 if ( SvOK(method_slot) ) {
114 SV* const body = call0(method_slot, key_body); /* $method_object->body() */
115 if ( SvROK(body) && ((CV*) SvRV(body)) == cv ) {
120 method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */
123 $method_object = $method_metaclass->wrap(
125 associated_metaclass => $self,
126 package_name => $class_name,
135 PUSHs(method_metaclass_name); /* invocant */
136 mPUSHs(newRV_inc((SV*)cv));
137 PUSHs(associated_metaclass);
139 PUSHs(key_package_name);
142 mPUSHs(newSVpv(method_name, method_name_len));
145 call_sv(wrap, G_SCALAR | G_METHOD);
147 method_object = POPs;
149 /* $map->{$method_name} = $method_object */
150 sv_setsv(method_slot, method_object);
161 Pass in a coderef, returns:
162 [ $pkg_name, $coderef_name ] ie:
163 [ 'Foo::Bar', 'new' ]
166 MODULE = Class::MOP PACKAGE = Class::MOP
169 key_name = newSVpvs("name");
170 key_body = newSVpvs("body");
171 key_package = newSVpvs("package");
172 key_package_name = newSVpvs("package_name");
174 PERL_HASH(hash_name, "name", 4);
175 PERL_HASH(hash_body, "body", 4);
176 PERL_HASH(hash_package, "package", 7);
177 PERL_HASH(hash_package_name, "package_name", 12);
179 method_metaclass = newSVpvs("method_metaclass");
180 wrap = newSVpvs("wrap");
181 associated_metaclass = newSVpvs("associated_metaclass");
188 get_code_info(coderef)
194 if ( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV ) {
195 coderef = SvRV(coderef);
196 /* I think this only gets triggered with a mangled coderef, but if
197 we hit it without the guard, we segfault. The slightly odd return
198 value strikes me as an improvement (mst)
201 if ( isGV_with_GP(CvGV(coderef)) ) {
203 pkg = HvNAME( GvSTASH(CvGV(coderef)) );
204 name = GvNAME( CvGV(coderef) );
213 PUSHs(newSVpvn(pkg, strlen(pkg)));
214 PUSHs(newSVpvn(name, strlen(name)));
218 MODULE = Class::MOP PACKAGE = Class::MOP::Package
221 get_all_package_symbols(self, ...)
226 SV *type_filter = NULL;
229 if ( ! SvROK(self) ) {
230 die("Cannot call get_all_package_symbols as a class method");
234 case G_VOID: return; break;
235 case G_SCALAR: ST(0) = &PL_sv_undef; return; break;
238 if ( items > 1 ) type_filter = ST(1);
242 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
243 stash = gv_stashsv(HeVAL(he),0);
247 (void)hv_iterinit(stash);
249 if ( type_filter && SvPOK(type_filter) ) {
250 const char *const type = SvPV_nolen(type_filter);
252 while ( (he = hv_iternext(stash)) ) {
253 SV *const gv = HeVAL(he);
260 switch( SvTYPE(gv) ) {
263 case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */
264 case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */
265 case 'I': sv = (SV *)GvIO(gv); break; /* IO */
266 case 'H': sv = (SV *)GvHV(gv); break; /* HASH */
267 case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */
269 croak("Unknown type %s\n", type);
273 /* BAH! constants are horrible */
279 /* we don't really care about the length,
280 but that's the API */
281 key = HePV(he, keylen);
282 package = HvNAME(stash);
283 fq = newSVpvf("%s::%s", package, key);
284 sv = (SV*)get_cv(SvPV_nolen(fq), 0);
291 SV *key = hv_iterkeysv(he);
295 PUSHs(sv_2mortal(newRV_inc(sv)));
300 EXTEND(SP, HvKEYS(stash) * 2);
302 while ( (he = hv_iternext(stash)) ) {
303 SV *key = hv_iterkeysv(he);
320 if ( ! SvROK(self) ) {
321 die("Cannot call name as a class method");
324 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
327 ST(0) = &PL_sv_undef;
329 MODULE = Class::MOP PACKAGE = Class::MOP::Attribute
337 if ( ! SvROK(self) ) {
338 die("Cannot call name as a class method");
341 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
344 ST(0) = &PL_sv_undef;
346 MODULE = Class::MOP PACKAGE = Class::MOP::Method
354 if ( ! SvROK(self) ) {
355 die("Cannot call name as a class method");
358 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
361 ST(0) = &PL_sv_undef;
369 if ( ! SvROK(self) ) {
370 die("Cannot call package_name as a class method");
373 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
376 ST(0) = &PL_sv_undef;
384 if ( ! SvROK(self) ) {
385 die("Cannot call body as a class method");
388 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
391 ST(0) = &PL_sv_undef;
394 MODULE = Class::MOP PACKAGE = Class::MOP::Class
400 SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) );
401 HV* const stash = gv_stashsv(class_name, TRUE);
402 UV const current = check_package_cache_flag(stash);
403 SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
404 SV* const map_ref = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
406 if ( ! SvRV(self) ) {
407 die("Cannot call get_method_map as a class method");
410 /* in $self->{methods} does not yet exist (or got deleted) */
411 if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
412 SV* new_map_ref = newRV_noinc((SV*)newHV());
413 sv_2mortal(new_map_ref);
414 sv_setsv(map_ref, new_map_ref);
417 if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
421 mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
422 sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */