Commit | Line | Data |
646c0371 |
1 | #include "mouse.h" |
2 | |
fd168725 |
3 | #define MY_CXT_KEY "Mouse::Util::_guts" XS_VERSION |
4 | typedef struct { |
5 | HV* metas; |
6 | } my_cxt_t; |
7 | START_MY_CXT |
8 | |
646c0371 |
9 | #define ISA_CACHE "::LINEALIZED_ISA_CACHE::" |
10 | |
11 | #ifdef no_mro_get_linear_isa |
12 | AV* |
13 | mouse_mro_get_linear_isa(pTHX_ HV* const stash){ |
6582d0e3 |
14 | GV* const cachegv = *(GV**)hv_fetchs(stash, ISA_CACHE, TRUE); |
15 | AV* isa; |
16 | SV* gen; |
17 | CV* get_linear_isa; |
18 | |
19 | if(!isGV(cachegv)) |
20 | gv_init(cachegv, stash, ISA_CACHE, sizeof(ISA_CACHE)-1, TRUE); |
21 | |
22 | isa = GvAVn(cachegv); |
23 | gen = GvSVn(cachegv); |
24 | |
25 | |
26 | if(SvIOK(gen) && SvIVX(gen) == (IV)mro_get_pkg_gen(stash)){ |
27 | return isa; /* returns the cache if available */ |
28 | } |
29 | else{ |
cd658d1f |
30 | SvREFCNT_dec(isa); |
31 | GvAV(cachegv) = isa = newAV(); |
6582d0e3 |
32 | } |
33 | |
34 | get_linear_isa = get_cv("Mouse::Util::get_linear_isa", TRUE); |
35 | |
36 | { |
37 | SV* avref; |
38 | dSP; |
39 | |
40 | ENTER; |
41 | SAVETMPS; |
42 | |
43 | PUSHMARK(SP); |
44 | mXPUSHp(HvNAME_get(stash), HvNAMELEN_get(stash)); |
45 | PUTBACK; |
46 | |
47 | call_sv((SV*)get_linear_isa, G_SCALAR); |
48 | |
49 | SPAGAIN; |
50 | avref = POPs; |
51 | PUTBACK; |
52 | |
80aa5731 |
53 | if(IsArrayRef(avref)){ |
6582d0e3 |
54 | AV* const av = (AV*)SvRV(avref); |
55 | I32 const len = AvFILLp(av) + 1; |
56 | I32 i; |
57 | |
58 | for(i = 0; i < len; i++){ |
59 | HV* const stash = gv_stashsv(AvARRAY(av)[i], FALSE); |
60 | if(stash) |
61 | av_push(isa, newSVpv(HvNAME(stash), 0)); |
62 | } |
63 | SvREADONLY_on(isa); |
64 | } |
65 | else{ |
66 | Perl_croak(aTHX_ "Mouse:Util::get_linear_isa() didn't return an ARRAY reference"); |
67 | } |
68 | |
69 | FREETMPS; |
70 | LEAVE; |
71 | } |
72 | |
73 | sv_setiv(gen, (IV)mro_get_pkg_gen(stash)); |
cd658d1f |
74 | return isa; |
646c0371 |
75 | } |
76 | #endif /* !no_mor_get_linear_isa */ |
77 | |
78 | #ifdef DEBUGGING |
79 | SV** |
80 | mouse_av_at_safe(pTHX_ AV* const av, I32 const ix){ |
81 | assert(av); |
82 | assert(SvTYPE(av) == SVt_PVAV); |
83 | assert(AvMAX(av) >= ix); |
84 | return &AvARRAY(av)[ix]; |
85 | } |
86 | #endif |
87 | |
88 | void |
89 | mouse_throw_error(SV* const metaobject, SV* const data /* not used */, const char* const fmt, ...){ |
90 | dTHX; |
91 | va_list args; |
92 | SV* message; |
93 | |
646c0371 |
94 | assert(metaobject); |
95 | assert(fmt); |
96 | |
97 | va_start(args, fmt); |
98 | message = vnewSVpvf(fmt, &args); |
99 | va_end(args); |
100 | |
101 | { |
102 | dSP; |
103 | PUSHMARK(SP); |
077f2efd |
104 | EXTEND(SP, 6); |
646c0371 |
105 | |
106 | PUSHs(metaobject); |
107 | mPUSHs(message); |
108 | |
431e4817 |
109 | if(data){ /* extra arg, might be useful for debugging */ |
077f2efd |
110 | mPUSHs(newSVpvs("data")); |
431e4817 |
111 | PUSHs(data); |
112 | mPUSHs(newSVpvs("depth")); |
113 | mPUSHi(-1); |
114 | } |
646c0371 |
115 | |
116 | PUTBACK; |
117 | |
118 | call_method("throw_error", G_VOID); |
119 | croak("throw_error() did not throw the error (%"SVf")", message); |
120 | } |
121 | } |
122 | |
5433f845 |
123 | static I32 |
124 | S_dopoptosub(pTHX_ I32 const startingblock) |
125 | { |
126 | const PERL_CONTEXT* const cxstk = cxstack; |
127 | I32 i; |
128 | for (i = startingblock; i >= 0; i--) { |
129 | const PERL_CONTEXT* const cx = &cxstk[i]; |
130 | |
131 | switch (CxTYPE(cx)) { |
132 | case CXt_EVAL: |
133 | case CXt_SUB: |
134 | case CXt_FORMAT: |
135 | return i; |
136 | } |
137 | } |
138 | return i; |
139 | } |
140 | |
8fcdb997 |
141 | /* workaround Perl-RT #69939 */ |
b3cd4c14 |
142 | I32 |
143 | mouse_call_sv_safe(pTHX_ SV* const sv, I32 const flags) { |
5433f845 |
144 | const PERL_CONTEXT* const cx = &cxstack[S_dopoptosub(aTHX_ cxstack_ix)]; |
b3cd4c14 |
145 | assert( (flags & G_EVAL) == 0 ); |
5433f845 |
146 | |
147 | //warn("cx_type=0x%02x PL_eval=0x%02x (%"SVf")", (unsigned)cx->cx_type, (unsigned)PL_in_eval, sv); |
8fcdb997 |
148 | if(cx->cx_type & CXp_TRYBLOCK) { |
149 | return Perl_call_sv(aTHX_ sv, flags); |
150 | } |
151 | else { |
b3cd4c14 |
152 | I32 count; |
8fcdb997 |
153 | ENTER; |
154 | /* Don't do SAVETMPS */ |
155 | |
156 | SAVESPTR(ERRSV); |
157 | ERRSV = sv_newmortal(); |
b3cd4c14 |
158 | |
159 | count = Perl_call_sv(aTHX_ sv, flags | G_EVAL); |
160 | |
161 | if(sv_true(ERRSV)){ |
8fcdb997 |
162 | SV* const err = sv_mortalcopy(ERRSV); |
163 | LEAVE; |
f07982df |
164 | sv_setsv(ERRSV, err); |
165 | croak(NULL); /* rethrow */ |
b3cd4c14 |
166 | } |
8fcdb997 |
167 | |
168 | LEAVE; |
169 | |
b3cd4c14 |
170 | return count; |
171 | } |
b3cd4c14 |
172 | } |
173 | |
d06d9266 |
174 | void |
175 | mouse_must_defined(pTHX_ SV* const value, const char* const name) { |
176 | assert(value); |
177 | assert(name); |
178 | |
179 | SvGETMAGIC(value); |
180 | if(!SvOK(value)){ |
181 | croak("You must define %s", name); |
182 | } |
183 | } |
184 | |
185 | void |
186 | mouse_must_ref(pTHX_ SV* const value, const char* const name, svtype const t) { |
187 | assert(value); |
188 | assert(name); |
189 | |
190 | SvGETMAGIC(value); |
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"); |
194 | } |
195 | } |
196 | |
197 | |
646c0371 |
198 | bool |
199 | mouse_is_class_loaded(pTHX_ SV * const klass){ |
200 | HV *stash; |
201 | GV** gvp; |
202 | HE* he; |
203 | |
204 | if (!(SvPOKp(klass) && SvCUR(klass))) { /* XXX: SvPOK does not work with magical scalars */ |
205 | return FALSE; |
206 | } |
207 | |
208 | stash = gv_stashsv(klass, FALSE); |
209 | if (!stash) { |
210 | return FALSE; |
211 | } |
212 | |
213 | if (( gvp = (GV**)hv_fetchs(stash, "VERSION", FALSE) )) { |
214 | if(isGV(*gvp) && GvSV(*gvp) && SvOK(GvSV(*gvp))){ |
215 | return TRUE; |
216 | } |
217 | } |
218 | |
219 | if (( gvp = (GV**)hv_fetchs(stash, "ISA", FALSE) )) { |
220 | if(isGV(*gvp) && GvAV(*gvp) && av_len(GvAV(*gvp)) != -1){ |
221 | return TRUE; |
222 | } |
223 | } |
224 | |
225 | hv_iterinit(stash); |
226 | while(( he = hv_iternext(stash) )){ |
227 | GV* const gv = (GV*)HeVAL(he); |
228 | |
229 | if(isGV(gv)){ |
fa4ac648 |
230 | if(GvCVu(gv)){ /* is GV and has CV */ |
231 | hv_iterinit(stash); /* reset */ |
646c0371 |
232 | return TRUE; |
233 | } |
234 | } |
fa4ac648 |
235 | else if(SvOK(gv)){ /* is a stub or constant */ |
236 | hv_iterinit(stash); /* reset */ |
646c0371 |
237 | return TRUE; |
238 | } |
239 | } |
240 | return FALSE; |
241 | } |
242 | |
243 | |
0aad0266 |
244 | SV* |
245 | mouse_call0 (pTHX_ SV* const self, SV* const method) { |
646c0371 |
246 | dSP; |
247 | SV *ret; |
248 | |
249 | PUSHMARK(SP); |
250 | XPUSHs(self); |
251 | PUTBACK; |
252 | |
b3cd4c14 |
253 | call_sv_safe(method, G_SCALAR | G_METHOD); |
646c0371 |
254 | |
255 | SPAGAIN; |
256 | ret = POPs; |
257 | PUTBACK; |
258 | |
259 | return ret; |
260 | } |
261 | |
0aad0266 |
262 | SV* |
263 | mouse_call1 (pTHX_ SV* const self, SV* const method, SV* const arg1) { |
646c0371 |
264 | dSP; |
265 | SV *ret; |
266 | |
267 | PUSHMARK(SP); |
268 | EXTEND(SP, 2); |
269 | PUSHs(self); |
270 | PUSHs(arg1); |
271 | PUTBACK; |
272 | |
b3cd4c14 |
273 | call_sv_safe(method, G_SCALAR | G_METHOD); |
646c0371 |
274 | |
275 | SPAGAIN; |
276 | ret = POPs; |
277 | PUTBACK; |
278 | |
279 | return ret; |
280 | } |
281 | |
0aad0266 |
282 | int |
283 | mouse_predicate_call(pTHX_ SV* const self, SV* const method) { |
6ad77996 |
284 | return sv_true( mcall0(self, method) ); |
0aad0266 |
285 | } |
286 | |
a39e9541 |
287 | SV* |
aa2d2e2c |
288 | mouse_get_metaclass(pTHX_ SV* metaclass_name){ |
fd168725 |
289 | dMY_CXT; |
290 | HE* he; |
a39e9541 |
291 | |
aa2d2e2c |
292 | assert(metaclass_name); |
fd168725 |
293 | assert(MY_CXT.metas); |
294 | |
aa2d2e2c |
295 | if(IsObject(metaclass_name)){ |
a5c683f6 |
296 | HV* const stash = SvSTASH(SvRV(metaclass_name)); |
aa2d2e2c |
297 | |
298 | metaclass_name = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U); |
299 | sv_2mortal(metaclass_name); |
300 | } |
301 | |
fd168725 |
302 | he = hv_fetch_ent(MY_CXT.metas, metaclass_name, FALSE, 0U); |
a39e9541 |
303 | |
fd168725 |
304 | return he ? HeVAL(he) : &PL_sv_undef; |
a39e9541 |
305 | } |
306 | |
646c0371 |
307 | MAGIC* |
308 | mouse_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags){ |
309 | MAGIC* mg; |
310 | |
311 | assert(sv != NULL); |
312 | for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){ |
313 | if(mg->mg_virtual == vtbl){ |
314 | return mg; |
315 | } |
316 | } |
317 | |
318 | if(flags & MOUSEf_DIE_ON_FAIL){ |
319 | croak("mouse_mg_find: no MAGIC found for %"SVf, sv_2mortal(newRV_inc(sv))); |
320 | } |
321 | return NULL; |
322 | } |
323 | |
a39e9541 |
324 | GV* |
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); |
327 | |
328 | if(gvp){ |
329 | if(!isGV(*gvp)){ |
330 | gv_init(*gvp, stash, name, namelen, GV_ADDMULTI); |
331 | } |
332 | return *gvp; |
333 | } |
334 | else{ |
335 | return NULL; |
336 | } |
337 | } |
338 | |
d67f600d |
339 | void |
340 | mouse_install_sub(pTHX_ GV* const gv, SV* const code_ref) { |
341 | CV* cv; |
342 | |
343 | assert(gv != NULL); |
344 | assert(code_ref != NULL); |
345 | assert(isGV(gv)); |
346 | assert(IsCodeRef(code_ref)); |
347 | |
348 | if(GvCVu(gv)){ /* delete *slot{gv} to work around "redefine" warning */ |
349 | SvREFCNT_dec(GvCV(gv)); |
350 | GvCV(gv) = NULL; |
351 | } |
d06d9266 |
352 | |
d67f600d |
353 | sv_setsv_mg((SV*)gv, code_ref); /* *gv = $code_ref */ |
354 | |
355 | /* name the CODE ref if it's anonymous */ |
356 | cv = (CV*)SvRV(code_ref); |
357 | if(CvANON(cv) |
358 | && CvGV(cv) /* a cv under construction has no gv */ ){ |
359 | HV* dbsub; |
360 | |
361 | /* update %DB::sub to make NYTProf happy */ |
362 | if((PL_perldb & (PERLDBf_SUBLINE|PERLDB_NAMEANON)) |
363 | && PL_DBsub && (dbsub = GvHV(PL_DBsub)) |
364 | ){ |
365 | /* see Perl_newATTRSUB() in op.c */ |
366 | SV* const subname = sv_newmortal(); |
367 | HE* orig; |
368 | |
369 | gv_efullname3(subname, CvGV(cv), NULL); |
370 | orig = hv_fetch_ent(dbsub, subname, FALSE, 0U); |
371 | if(orig){ |
372 | gv_efullname3(subname, gv, NULL); |
373 | (void)hv_store_ent(dbsub, subname, HeVAL(orig), 0U); |
374 | SvREFCNT_inc_simple_void_NN(HeVAL(orig)); |
375 | } |
376 | } |
377 | |
378 | CvGV(cv) = gv; |
379 | CvANON_off(cv); |
380 | } |
381 | } |
382 | |
646c0371 |
383 | MODULE = Mouse::Util PACKAGE = Mouse::Util |
384 | |
385 | PROTOTYPES: DISABLE |
386 | VERSIONCHECK: DISABLE |
387 | |
fd168725 |
388 | BOOT: |
389 | { |
390 | MY_CXT_INIT; |
391 | MY_CXT.metas = NULL; |
392 | } |
393 | |
394 | void |
395 | __register_metaclass_storage(HV* metas, bool cloning) |
396 | CODE: |
397 | { |
398 | if(cloning){ |
399 | MY_CXT_CLONE; |
400 | MY_CXT.metas = NULL; |
401 | } |
402 | { |
403 | dMY_CXT; |
25ba356e |
404 | if(MY_CXT.metas && ckWARN(WARN_REDEFINE)){ |
405 | Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Metaclass storage more than once"); |
406 | } |
fd168725 |
407 | MY_CXT.metas = metas; |
408 | SvREFCNT_inc_simple_void_NN(metas); |
409 | } |
410 | } |
411 | |
646c0371 |
412 | bool |
0ffc4183 |
413 | is_valid_class_name(SV* sv) |
414 | CODE: |
415 | { |
416 | SvGETMAGIC(sv); |
417 | if(SvPOKp(sv) && SvCUR(sv) > 0){ |
418 | UV i; |
419 | RETVAL = TRUE; |
420 | for(i = 0; i < SvCUR(sv); i++){ |
421 | char const c = SvPVX(sv)[i]; |
422 | if(!(isALNUM(c) || c == ':')){ |
423 | RETVAL = FALSE; |
424 | break; |
425 | } |
426 | } |
427 | } |
428 | else{ |
429 | RETVAL = SvNIOKp(sv) ? TRUE : FALSE; |
430 | } |
431 | } |
432 | OUTPUT: |
433 | RETVAL |
434 | |
435 | bool |
646c0371 |
436 | is_class_loaded(SV* sv) |
437 | |
438 | void |
439 | get_code_info(CV* code) |
440 | PREINIT: |
441 | GV* gv; |
442 | HV* stash; |
443 | PPCODE: |
444 | if((gv = CvGV(code)) && isGV(gv) && (stash = GvSTASH(gv))){ |
445 | EXTEND(SP, 2); |
446 | mPUSHs(newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U)); |
447 | mPUSHs(newSVpvn_share(GvNAME_get(gv), GvNAMELEN_get(gv), 0U)); |
448 | } |
449 | |
450 | SV* |
451 | get_code_package(CV* code) |
452 | PREINIT: |
453 | HV* stash; |
454 | CODE: |
455 | if(CvGV(code) && isGV(CvGV(code)) && (stash = GvSTASH(CvGV(code)))){ |
456 | RETVAL = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U); |
457 | } |
458 | else{ |
459 | RETVAL = &PL_sv_no; |
460 | } |
461 | OUTPUT: |
462 | RETVAL |
463 | |
464 | CV* |
465 | get_code_ref(SV* package, SV* name) |
466 | CODE: |
467 | { |
468 | HV* stash; |
a39e9541 |
469 | STRLEN name_len; |
470 | const char* name_pv; |
471 | GV* gv; |
646c0371 |
472 | |
d06d9266 |
473 | must_defined(package, "a package name"); |
474 | must_defined(name, "a subroutine name"); |
646c0371 |
475 | |
476 | stash = gv_stashsv(package, FALSE); |
477 | if(!stash){ |
478 | XSRETURN_UNDEF; |
479 | } |
a39e9541 |
480 | |
481 | name_pv = SvPV_const(name, name_len); |
482 | gv = stash_fetch(stash, name_pv, name_len, FALSE); |
483 | RETVAL = gv ? GvCVu(gv) : NULL; |
646c0371 |
484 | |
485 | if(!RETVAL){ |
486 | XSRETURN_UNDEF; |
487 | } |
488 | } |
489 | OUTPUT: |
490 | RETVAL |
491 | |
492 | void |
ebe91068 |
493 | generate_isa_predicate_for(SV* arg, SV* predicate_name = NULL) |
494 | ALIAS: |
495 | generate_isa_predicate_for = 0 |
496 | generate_can_predicate_for = 1 |
646c0371 |
497 | PPCODE: |
498 | { |
441964ce |
499 | const char* name_pv = NULL; |
646c0371 |
500 | CV* xsub; |
501 | |
d06d9266 |
502 | must_defined(arg, ix == 0 ? "a class_name" : "method names"); |
646c0371 |
503 | |
441964ce |
504 | if(predicate_name){ |
d06d9266 |
505 | must_defined(predicate_name, "a predicate name"); |
441964ce |
506 | name_pv = SvPV_nolen_const(predicate_name); |
646c0371 |
507 | } |
508 | |
ebe91068 |
509 | if(ix == 0){ |
510 | xsub = mouse_generate_isa_predicate_for(aTHX_ arg, name_pv); |
511 | } |
512 | else{ |
513 | xsub = mouse_generate_can_predicate_for(aTHX_ arg, name_pv); |
514 | } |
441964ce |
515 | |
646c0371 |
516 | if(predicate_name == NULL){ /* anonymous predicate */ |
73337709 |
517 | mXPUSHs( newRV_inc((SV*)xsub) ); |
646c0371 |
518 | } |
519 | } |
d67f600d |
520 | |
521 | # This xsub will redefine &Mouse::Util::install_subroutines() |
522 | void |
523 | install_subroutines(SV* into, ...) |
524 | CODE: |
525 | { |
526 | HV* stash; |
527 | I32 i; |
528 | |
d06d9266 |
529 | must_defined(into, "a package name"); |
d67f600d |
530 | stash = gv_stashsv(into, TRUE); |
531 | |
532 | if( ((items-1) % 2) != 0 ){ |
533 | croak_xs_usage(cv, "into, name => coderef [, other_name, other_coderef ...]"); |
534 | } |
535 | |
536 | for(i = 1; i < items; i += 2) { |
537 | SV* const name = ST(i); |
538 | SV* const code = ST(i+1); |
539 | STRLEN len; |
540 | const char* pv; |
541 | GV* gv; |
542 | |
d06d9266 |
543 | must_defined(name, "a subroutine name"); |
544 | must_ref(code, "a CODE reference", SVt_PVCV); |
d67f600d |
545 | |
546 | pv = SvPV_const(name, len); |
547 | gv = stash_fetch(stash, pv, len, TRUE); |
548 | |
549 | mouse_install_sub(aTHX_ gv, code); |
550 | } |
551 | } |