3 #define MY_CXT_KEY "Mouse::Util::_guts" XS_VERSION
9 #define ISA_CACHE "::LINEALIZED_ISA_CACHE::"
11 #ifdef no_mro_get_linear_isa
13 mouse_mro_get_linear_isa(pTHX_ HV* const stash){
14 GV* const cachegv = *(GV**)hv_fetchs(stash, ISA_CACHE, TRUE);
20 gv_init(cachegv, stash, ISA_CACHE, sizeof(ISA_CACHE)-1, TRUE);
26 if(SvIOK(gen) && SvIVX(gen) == (IV)mro_get_pkg_gen(stash)){
27 return isa; /* returns the cache if available */
31 GvAV(cachegv) = isa = newAV();
34 get_linear_isa = get_cv("Mouse::Util::get_linear_isa", TRUE);
44 mXPUSHp(HvNAME_get(stash), HvNAMELEN_get(stash));
47 call_sv((SV*)get_linear_isa, G_SCALAR);
53 if(IsArrayRef(avref)){
54 AV* const av = (AV*)SvRV(avref);
55 I32 const len = AvFILLp(av) + 1;
58 for(i = 0; i < len; i++){
59 HV* const stash = gv_stashsv(AvARRAY(av)[i], FALSE);
61 av_push(isa, newSVpv(HvNAME(stash), 0));
66 Perl_croak(aTHX_ "Mouse:Util::get_linear_isa() didn't return an ARRAY reference");
73 sv_setiv(gen, (IV)mro_get_pkg_gen(stash));
76 #endif /* !no_mor_get_linear_isa */
80 mouse_av_at_safe(pTHX_ AV* const av, I32 const ix){
82 assert(SvTYPE(av) == SVt_PVAV);
83 assert(AvMAX(av) >= ix);
84 return &AvARRAY(av)[ix];
89 mouse_throw_error(SV* const metaobject, SV* const data /* not used */, const char* const fmt, ...){
98 message = vnewSVpvf(fmt, &args);
109 if(data){ /* extra arg, might be useful for debugging */
110 mPUSHs(newSVpvs("data"));
112 mPUSHs(newSVpvs("depth"));
118 call_method("throw_error", G_VOID);
119 croak("throw_error() did not throw the error (%"SVf")", message);
124 S_dopoptosub(pTHX_ I32 const startingblock)
126 const PERL_CONTEXT* const cxstk = cxstack;
128 for (i = startingblock; i >= 0; i--) {
129 const PERL_CONTEXT* const cx = &cxstk[i];
131 switch (CxTYPE(cx)) {
141 /* workaround Perl-RT #69939 */
143 mouse_call_sv_safe(pTHX_ SV* const sv, I32 const flags) {
144 const PERL_CONTEXT* const cx = &cxstack[S_dopoptosub(aTHX_ cxstack_ix)];
145 assert( (flags & G_EVAL) == 0 );
147 //warn("cx_type=0x%02x PL_eval=0x%02x (%"SVf")", (unsigned)cx->cx_type, (unsigned)PL_in_eval, sv);
148 if(cx->cx_type & CXp_TRYBLOCK) {
149 return Perl_call_sv(aTHX_ sv, flags);
154 /* Don't do SAVETMPS */
157 ERRSV = sv_newmortal();
159 count = Perl_call_sv(aTHX_ sv, flags | G_EVAL);
162 SV* const err = sv_mortalcopy(ERRSV);
164 sv_setsv(ERRSV, err);
165 croak(NULL); /* rethrow */
175 mouse_must_defined(pTHX_ SV* const value, const char* const name) {
181 croak("You must define %s", name);
186 mouse_must_ref(pTHX_ SV* const value, const char* const name, svtype const t) {
191 if(!(SvROK(value) && (t == SVt_NULL || SvTYPE(SvRV(value)) == t))) {
192 croak("You must pass %s, not %s",
193 name, SvOK(value) ? SvPV_nolen(value) : "undef");
199 mouse_is_class_loaded(pTHX_ SV * const klass){
204 if (!(SvPOKp(klass) && SvCUR(klass))) { /* XXX: SvPOK does not work with magical scalars */
208 stash = gv_stashsv(klass, FALSE);
213 if (( gvp = (GV**)hv_fetchs(stash, "VERSION", FALSE) )) {
214 if(isGV(*gvp) && GvSV(*gvp) && SvOK(GvSV(*gvp))){
219 if (( gvp = (GV**)hv_fetchs(stash, "ISA", FALSE) )) {
220 if(isGV(*gvp) && GvAV(*gvp) && av_len(GvAV(*gvp)) != -1){
226 while(( he = hv_iternext(stash) )){
227 GV* const gv = (GV*)HeVAL(he);
230 if(GvCVu(gv)){ /* is GV and has CV */
231 hv_iterinit(stash); /* reset */
235 else if(SvOK(gv)){ /* is a stub or constant */
236 hv_iterinit(stash); /* reset */
245 mouse_call0 (pTHX_ SV* const self, SV* const method) {
253 call_sv_safe(method, G_SCALAR | G_METHOD);
263 mouse_call1 (pTHX_ SV* const self, SV* const method, SV* const arg1) {
273 call_sv_safe(method, G_SCALAR | G_METHOD);
283 mouse_predicate_call(pTHX_ SV* const self, SV* const method) {
284 return sv_true( mcall0(self, method) );
288 mouse_get_metaclass(pTHX_ SV* metaclass_name){
292 assert(metaclass_name);
293 assert(MY_CXT.metas);
295 if(IsObject(metaclass_name)){
296 HV* const stash = SvSTASH(SvRV(metaclass_name));
298 metaclass_name = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
299 sv_2mortal(metaclass_name);
302 he = hv_fetch_ent(MY_CXT.metas, metaclass_name, FALSE, 0U);
304 return he ? HeVAL(he) : &PL_sv_undef;
308 mouse_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags){
312 for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){
313 if(mg->mg_virtual == vtbl){
318 if(flags & MOUSEf_DIE_ON_FAIL){
319 croak("mouse_mg_find: no MAGIC found for %"SVf, sv_2mortal(newRV_inc(sv)));
325 mouse_stash_fetch(pTHX_ HV* const stash, const char* const name, I32 const namelen, I32 const create) {
326 GV** const gvp = (GV**)hv_fetch(stash, name, namelen, create);
330 gv_init(*gvp, stash, name, namelen, GV_ADDMULTI);
340 mouse_install_sub(pTHX_ GV* const gv, SV* const code_ref) {
344 assert(code_ref != NULL);
346 assert(IsCodeRef(code_ref));
348 if(GvCVu(gv)){ /* delete *slot{gv} to work around "redefine" warning */
349 SvREFCNT_dec(GvCV(gv));
353 sv_setsv_mg((SV*)gv, code_ref); /* *gv = $code_ref */
355 /* name the CODE ref if it's anonymous */
356 cv = (CV*)SvRV(code_ref);
358 && CvGV(cv) /* a cv under construction has no gv */ ){
361 /* update %DB::sub to make NYTProf happy */
362 if((PL_perldb & (PERLDBf_SUBLINE|PERLDB_NAMEANON))
363 && PL_DBsub && (dbsub = GvHV(PL_DBsub))
365 /* see Perl_newATTRSUB() in op.c */
366 SV* const subname = sv_newmortal();
369 gv_efullname3(subname, CvGV(cv), NULL);
370 orig = hv_fetch_ent(dbsub, subname, FALSE, 0U);
372 gv_efullname3(subname, gv, NULL);
373 (void)hv_store_ent(dbsub, subname, HeVAL(orig), 0U);
374 SvREFCNT_inc_simple_void_NN(HeVAL(orig));
383 MODULE = Mouse::Util PACKAGE = Mouse::Util
386 VERSIONCHECK: DISABLE
395 __register_metaclass_storage(HV* metas, bool cloning)
404 if(MY_CXT.metas && ckWARN(WARN_REDEFINE)){
405 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Metaclass storage more than once");
407 MY_CXT.metas = metas;
408 SvREFCNT_inc_simple_void_NN(metas);
413 is_valid_class_name(SV* sv)
417 if(SvPOKp(sv) && SvCUR(sv) > 0){
420 for(i = 0; i < SvCUR(sv); i++){
421 char const c = SvPVX(sv)[i];
422 if(!(isALNUM(c) || c == ':')){
429 RETVAL = SvNIOKp(sv) ? TRUE : FALSE;
436 is_class_loaded(SV* sv)
439 get_code_info(CV* code)
444 if((gv = CvGV(code)) && isGV(gv) && (stash = GvSTASH(gv))){
446 mPUSHs(newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U));
447 mPUSHs(newSVpvn_share(GvNAME_get(gv), GvNAMELEN_get(gv), 0U));
451 get_code_package(CV* code)
455 if(CvGV(code) && isGV(CvGV(code)) && (stash = GvSTASH(CvGV(code)))){
456 RETVAL = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
465 get_code_ref(SV* package, SV* name)
473 must_defined(package, "a package name");
474 must_defined(name, "a subroutine name");
476 stash = gv_stashsv(package, FALSE);
481 name_pv = SvPV_const(name, name_len);
482 gv = stash_fetch(stash, name_pv, name_len, FALSE);
483 RETVAL = gv ? GvCVu(gv) : NULL;
493 generate_isa_predicate_for(SV* arg, SV* predicate_name = NULL)
495 generate_isa_predicate_for = 0
496 generate_can_predicate_for = 1
499 const char* name_pv = NULL;
502 must_defined(arg, ix == 0 ? "a class_name" : "method names");
505 must_defined(predicate_name, "a predicate name");
506 name_pv = SvPV_nolen_const(predicate_name);
510 xsub = mouse_generate_isa_predicate_for(aTHX_ arg, name_pv);
513 xsub = mouse_generate_can_predicate_for(aTHX_ arg, name_pv);
516 if(predicate_name == NULL){ /* anonymous predicate */
517 mXPUSHs( newRV_inc((SV*)xsub) );
521 # This xsub will redefine &Mouse::Util::install_subroutines()
523 install_subroutines(SV* into, ...)
529 must_defined(into, "a package name");
530 stash = gv_stashsv(into, TRUE);
532 if( ((items-1) % 2) != 0 ){
533 croak_xs_usage(cv, "into, name => coderef [, other_name, other_coderef ...]");
536 for(i = 1; i < items; i += 2) {
537 SV* const name = ST(i);
538 SV* const code = ST(i+1);
543 must_defined(name, "a subroutine name");
544 must_ref(code, "a CODE reference", SVt_PVCV);
546 pv = SvPV_const(name, len);
547 gv = stash_fetch(stash, pv, len, TRUE);
549 mouse_install_sub(aTHX_ gv, code);