This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Reset isa caches on nonexistent substashes when stash trees are moved
[perl5.git] / ext / XS-APItest / APItest.xs
CommitLineData
6a93a7e5 1#define PERL_IN_XS_APITEST
3e61d65a
JH
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
36c2b1d0
NC
6typedef SV *SVREF;
7typedef PTR_TBL_t *XS__APItest__PtrTable;
85ce96a1 8
11f9f0ed
NC
9#define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__)
10
85ce96a1
DM
11/* for my_cxt tests */
12
13#define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
14
15typedef struct {
16 int i;
17 SV *sv;
03569ecf
BM
18 GV *cscgv;
19 AV *cscav;
13b6b3bc
BM
20 AV *bhkav;
21 bool bhk_record;
201c7e1f
FR
22 peep_t orig_peep;
23 peep_t orig_rpeep;
24 int peep_recording;
25 AV *peep_recorder;
26 AV *rpeep_recorder;
85ce96a1
DM
27} my_cxt_t;
28
29START_MY_CXT
30
31/* indirect functions to test the [pa]MY_CXT macros */
f16dd614 32
85ce96a1
DM
33int
34my_cxt_getint_p(pMY_CXT)
35{
36 return MY_CXT.i;
37}
f16dd614 38
85ce96a1
DM
39void
40my_cxt_setint_p(pMY_CXT_ int i)
41{
42 MY_CXT.i = i;
43}
f16dd614
DM
44
45SV*
9568a123 46my_cxt_getsv_interp_context(void)
f16dd614 47{
f16dd614
DM
48 dTHX;
49 dMY_CXT_INTERP(my_perl);
9568a123
NC
50 return MY_CXT.sv;
51}
52
53SV*
54my_cxt_getsv_interp(void)
55{
f16dd614 56 dMY_CXT;
f16dd614
DM
57 return MY_CXT.sv;
58}
59
85ce96a1
DM
60void
61my_cxt_setsv_p(SV* sv _pMY_CXT)
62{
63 MY_CXT.sv = sv;
64}
65
66
9b5c3821 67/* from exception.c */
7a646707 68int apitest_exception(int);
0314122a 69
ff66e713
SH
70/* from core_or_not.inc */
71bool sv_setsv_cow_hashkey_core(void);
72bool sv_setsv_cow_hashkey_notcore(void);
73
2dc92170
NC
74/* A routine to test hv_delayfree_ent
75 (which itself is tested by testing on hv_free_ent */
76
77typedef void (freeent_function)(pTHX_ HV *, register HE *);
78
79void
80test_freeent(freeent_function *f) {
81 dTHX;
82 dSP;
83 HV *test_hash = newHV();
84 HE *victim;
85 SV *test_scalar;
86 U32 results[4];
87 int i;
88
8afd2d2e
NC
89#ifdef PURIFY
90 victim = (HE*)safemalloc(sizeof(HE));
91#else
2dc92170
NC
92 /* Storing then deleting something should ensure that a hash entry is
93 available. */
94 hv_store(test_hash, "", 0, &PL_sv_yes, 0);
95 hv_delete(test_hash, "", 0, 0);
96
97 /* We need to "inline" new_he here as it's static, and the functions we
98 test expect to be able to call del_HE on the HE */
6a93a7e5 99 if (!PL_body_roots[HE_SVSLOT])
2dc92170 100 croak("PL_he_root is 0");
8a722a80 101 victim = (HE*) PL_body_roots[HE_SVSLOT];
6a93a7e5 102 PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
8afd2d2e 103#endif
2dc92170
NC
104
105 victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
106
107 test_scalar = newSV(0);
108 SvREFCNT_inc(test_scalar);
de616631 109 HeVAL(victim) = test_scalar;
2dc92170
NC
110
111 /* Need this little game else we free the temps on the return stack. */
112 results[0] = SvREFCNT(test_scalar);
113 SAVETMPS;
114 results[1] = SvREFCNT(test_scalar);
115 f(aTHX_ test_hash, victim);
116 results[2] = SvREFCNT(test_scalar);
117 FREETMPS;
118 results[3] = SvREFCNT(test_scalar);
119
120 i = 0;
121 do {
122 mPUSHu(results[i]);
123 } while (++i < sizeof(results)/sizeof(results[0]));
124
125 /* Goodbye to our extra reference. */
126 SvREFCNT_dec(test_scalar);
127}
128
b54b4831
NC
129
130static I32
53c40a8f
NC
131bitflip_key(pTHX_ IV action, SV *field) {
132 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
133 SV *keysv;
134 if (mg && (keysv = mg->mg_obj)) {
135 STRLEN len;
136 const char *p = SvPV(keysv, len);
137
138 if (len) {
139 SV *newkey = newSV(len);
140 char *new_p = SvPVX(newkey);
141
142 if (SvUTF8(keysv)) {
143 const char *const end = p + len;
144 while (p < end) {
145 STRLEN len;
a75fcbca
SP
146 UV chr = utf8_to_uvuni((U8 *)p, &len);
147 new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
53c40a8f
NC
148 p += len;
149 }
150 SvUTF8_on(newkey);
151 } else {
152 while (len--)
153 *new_p++ = *p++ ^ 32;
154 }
155 *new_p = '\0';
156 SvCUR_set(newkey, SvCUR(keysv));
157 SvPOK_on(newkey);
158
159 mg->mg_obj = newkey;
160 }
161 }
162 return 0;
163}
164
165static I32
b54b4831
NC
166rot13_key(pTHX_ IV action, SV *field) {
167 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
168 SV *keysv;
169 if (mg && (keysv = mg->mg_obj)) {
170 STRLEN len;
171 const char *p = SvPV(keysv, len);
172
173 if (len) {
174 SV *newkey = newSV(len);
175 char *new_p = SvPVX(newkey);
176
177 /* There's a deliberate fencepost error here to loop len + 1 times
178 to copy the trailing \0 */
179 do {
180 char new_c = *p++;
181 /* Try doing this cleanly and clearly in EBCDIC another way: */
182 switch (new_c) {
183 case 'A': new_c = 'N'; break;
184 case 'B': new_c = 'O'; break;
185 case 'C': new_c = 'P'; break;
186 case 'D': new_c = 'Q'; break;
187 case 'E': new_c = 'R'; break;
188 case 'F': new_c = 'S'; break;
189 case 'G': new_c = 'T'; break;
190 case 'H': new_c = 'U'; break;
191 case 'I': new_c = 'V'; break;
192 case 'J': new_c = 'W'; break;
193 case 'K': new_c = 'X'; break;
194 case 'L': new_c = 'Y'; break;
195 case 'M': new_c = 'Z'; break;
196 case 'N': new_c = 'A'; break;
197 case 'O': new_c = 'B'; break;
198 case 'P': new_c = 'C'; break;
199 case 'Q': new_c = 'D'; break;
200 case 'R': new_c = 'E'; break;
201 case 'S': new_c = 'F'; break;
202 case 'T': new_c = 'G'; break;
203 case 'U': new_c = 'H'; break;
204 case 'V': new_c = 'I'; break;
205 case 'W': new_c = 'J'; break;
206 case 'X': new_c = 'K'; break;
207 case 'Y': new_c = 'L'; break;
208 case 'Z': new_c = 'M'; break;
209 case 'a': new_c = 'n'; break;
210 case 'b': new_c = 'o'; break;
211 case 'c': new_c = 'p'; break;
212 case 'd': new_c = 'q'; break;
213 case 'e': new_c = 'r'; break;
214 case 'f': new_c = 's'; break;
215 case 'g': new_c = 't'; break;
216 case 'h': new_c = 'u'; break;
217 case 'i': new_c = 'v'; break;
218 case 'j': new_c = 'w'; break;
219 case 'k': new_c = 'x'; break;
220 case 'l': new_c = 'y'; break;
221 case 'm': new_c = 'z'; break;
222 case 'n': new_c = 'a'; break;
223 case 'o': new_c = 'b'; break;
224 case 'p': new_c = 'c'; break;
225 case 'q': new_c = 'd'; break;
226 case 'r': new_c = 'e'; break;
227 case 's': new_c = 'f'; break;
228 case 't': new_c = 'g'; break;
229 case 'u': new_c = 'h'; break;
230 case 'v': new_c = 'i'; break;
231 case 'w': new_c = 'j'; break;
232 case 'x': new_c = 'k'; break;
233 case 'y': new_c = 'l'; break;
234 case 'z': new_c = 'm'; break;
235 }
236 *new_p++ = new_c;
237 } while (len--);
238 SvCUR_set(newkey, SvCUR(keysv));
239 SvPOK_on(newkey);
240 if (SvUTF8(keysv))
241 SvUTF8_on(newkey);
242
243 mg->mg_obj = newkey;
244 }
245 }
246 return 0;
247}
248
218787bd
VP
249STATIC I32
250rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
251 return 0;
252}
253
254STATIC MGVTBL rmagical_b = { 0 };
255
03569ecf 256STATIC void
13b6b3bc 257blockhook_csc_start(pTHX_ int full)
03569ecf
BM
258{
259 dMY_CXT;
260 AV *const cur = GvAV(MY_CXT.cscgv);
261
262 SAVEGENERICSV(GvAV(MY_CXT.cscgv));
263
264 if (cur) {
265 I32 i;
d024465f 266 AV *const new_av = newAV();
03569ecf
BM
267
268 for (i = 0; i <= av_len(cur); i++) {
d024465f 269 av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
03569ecf
BM
270 }
271
d024465f 272 GvAV(MY_CXT.cscgv) = new_av;
03569ecf
BM
273 }
274}
275
276STATIC void
13b6b3bc 277blockhook_csc_pre_end(pTHX_ OP **o)
03569ecf
BM
278{
279 dMY_CXT;
280
281 /* if we hit the end of a scope we missed the start of, we need to
282 * unconditionally clear @CSC */
52db365a 283 if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
03569ecf 284 av_clear(MY_CXT.cscav);
52db365a 285 }
03569ecf
BM
286
287}
288
13b6b3bc
BM
289STATIC void
290blockhook_test_start(pTHX_ int full)
291{
292 dMY_CXT;
293 AV *av;
294
295 if (MY_CXT.bhk_record) {
296 av = newAV();
297 av_push(av, newSVpvs("start"));
298 av_push(av, newSViv(full));
299 av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
300 }
301}
302
303STATIC void
304blockhook_test_pre_end(pTHX_ OP **o)
305{
306 dMY_CXT;
307
308 if (MY_CXT.bhk_record)
309 av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
310}
311
312STATIC void
313blockhook_test_post_end(pTHX_ OP **o)
314{
315 dMY_CXT;
316
317 if (MY_CXT.bhk_record)
318 av_push(MY_CXT.bhkav, newSVpvs("post_end"));
319}
320
321STATIC void
322blockhook_test_eval(pTHX_ OP *const o)
323{
324 dMY_CXT;
325 AV *av;
326
327 if (MY_CXT.bhk_record) {
328 av = newAV();
329 av_push(av, newSVpvs("eval"));
330 av_push(av, newSVpv(OP_NAME(o), 0));
331 av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
332 }
333}
334
335STATIC BHK bhk_csc, bhk_test;
336
201c7e1f
FR
337STATIC void
338my_peep (pTHX_ OP *o)
339{
340 dMY_CXT;
341
342 if (!o)
343 return;
344
345 MY_CXT.orig_peep(aTHX_ o);
346
347 if (!MY_CXT.peep_recording)
348 return;
349
350 for (; o; o = o->op_next) {
351 if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
352 av_push(MY_CXT.peep_recorder, newSVsv(cSVOPx_sv(o)));
353 }
354 }
355}
356
357STATIC void
358my_rpeep (pTHX_ OP *o)
359{
360 dMY_CXT;
361
362 if (!o)
363 return;
364
365 MY_CXT.orig_rpeep(aTHX_ o);
366
367 if (!MY_CXT.peep_recording)
368 return;
369
370 for (; o; o = o->op_next) {
371 if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
372 av_push(MY_CXT.rpeep_recorder, newSVsv(cSVOPx_sv(o)));
373 }
374 }
375}
376
d9088386
Z
377STATIC OP *
378THX_ck_entersub_args_lists(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
379{
380 return ck_entersub_args_list(entersubop);
381}
382
383STATIC OP *
384THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
385{
386 OP *aop = cUNOPx(entersubop)->op_first;
387 if (!aop->op_sibling)
388 aop = cUNOPx(aop)->op_first;
389 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
390 op_contextualize(aop, G_SCALAR);
391 }
392 return entersubop;
393}
394
395STATIC OP *
396THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
397{
398 OP *sumop = NULL;
399 OP *pushop = cUNOPx(entersubop)->op_first;
400 if (!pushop->op_sibling)
401 pushop = cUNOPx(pushop)->op_first;
402 while (1) {
403 OP *aop = pushop->op_sibling;
404 if (!aop->op_sibling)
405 break;
406 pushop->op_sibling = aop->op_sibling;
407 aop->op_sibling = NULL;
408 op_contextualize(aop, G_SCALAR);
409 if (sumop) {
410 sumop = newBINOP(OP_ADD, 0, sumop, aop);
411 } else {
412 sumop = aop;
413 }
414 }
415 if (!sumop)
416 sumop = newSVOP(OP_CONST, 0, newSViv(0));
417 op_free(entersubop);
418 return sumop;
419}
420
83f8bb56
Z
421/** RPN keyword parser **/
422
423#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
424#define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
425#define sv_is_string(sv) \
426 (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
427 (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
428
429static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
07ffcb73 430static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
83f8bb56
Z
431static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
432
433/* low-level parser helpers */
434
435#define PL_bufptr (PL_parser->bufptr)
436#define PL_bufend (PL_parser->bufend)
437
438/* RPN parser */
439
440#define parse_var() THX_parse_var(aTHX)
441static OP *THX_parse_var(pTHX)
442{
443 char *s = PL_bufptr;
444 char *start = s;
445 PADOFFSET varpos;
446 OP *padop;
447 if(*s != '$') croak("RPN syntax error");
448 while(1) {
449 char c = *++s;
450 if(!isALNUM(c)) break;
451 }
452 if(s-start < 2) croak("RPN syntax error");
453 lex_read_to(s);
454 {
455 /* because pad_findmy() doesn't really use length yet */
456 SV *namesv = sv_2mortal(newSVpvn(start, s-start));
457 varpos = pad_findmy(SvPVX(namesv), s-start, 0);
458 }
459 if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
460 croak("RPN only supports \"my\" variables");
461 padop = newOP(OP_PADSV, 0);
462 padop->op_targ = varpos;
463 return padop;
464}
465
466#define push_rpn_item(o) \
467 (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
468#define pop_rpn_item() \
469 (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \
470 (tmpop = stack, stack = stack->op_sibling, \
471 tmpop->op_sibling = NULL, tmpop))
472
473#define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
474static OP *THX_parse_rpn_expr(pTHX)
475{
476 OP *stack = NULL, *tmpop;
477 while(1) {
478 I32 c;
479 lex_read_space(0);
480 c = lex_peek_unichar(0);
481 switch(c) {
482 case /*(*/')': case /*{*/'}': {
483 OP *result = pop_rpn_item();
484 if(stack) croak("RPN expression must return a single value");
485 return result;
486 } break;
487 case '0': case '1': case '2': case '3': case '4':
488 case '5': case '6': case '7': case '8': case '9': {
489 UV val = 0;
490 do {
491 lex_read_unichar(0);
492 val = 10*val + (c - '0');
493 c = lex_peek_unichar(0);
494 } while(c >= '0' && c <= '9');
495 push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val)));
496 } break;
497 case '$': {
498 push_rpn_item(parse_var());
499 } break;
500 case '+': {
501 OP *b = pop_rpn_item();
502 OP *a = pop_rpn_item();
503 lex_read_unichar(0);
504 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
505 } break;
506 case '-': {
507 OP *b = pop_rpn_item();
508 OP *a = pop_rpn_item();
509 lex_read_unichar(0);
510 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
511 } break;
512 case '*': {
513 OP *b = pop_rpn_item();
514 OP *a = pop_rpn_item();
515 lex_read_unichar(0);
516 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
517 } break;
518 case '/': {
519 OP *b = pop_rpn_item();
520 OP *a = pop_rpn_item();
521 lex_read_unichar(0);
522 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
523 } break;
524 case '%': {
525 OP *b = pop_rpn_item();
526 OP *a = pop_rpn_item();
527 lex_read_unichar(0);
528 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
529 } break;
530 default: {
531 croak("RPN syntax error");
532 } break;
533 }
534 }
535}
536
537#define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
538static OP *THX_parse_keyword_rpn(pTHX)
539{
540 OP *op;
541 lex_read_space(0);
542 if(lex_peek_unichar(0) != '('/*)*/)
543 croak("RPN expression must be parenthesised");
544 lex_read_unichar(0);
545 op = parse_rpn_expr();
546 if(lex_peek_unichar(0) != /*(*/')')
547 croak("RPN expression must be parenthesised");
548 lex_read_unichar(0);
549 return op;
550}
551
552#define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
553static OP *THX_parse_keyword_calcrpn(pTHX)
554{
555 OP *varop, *exprop;
556 lex_read_space(0);
557 varop = parse_var();
558 lex_read_space(0);
559 if(lex_peek_unichar(0) != '{'/*}*/)
560 croak("RPN expression must be braced");
561 lex_read_unichar(0);
562 exprop = parse_rpn_expr();
563 if(lex_peek_unichar(0) != /*{*/'}')
564 croak("RPN expression must be braced");
565 lex_read_unichar(0);
566 return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
567}
568
569#define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
570static OP *THX_parse_keyword_stufftest(pTHX)
571{
572 I32 c;
573 bool do_stuff;
574 lex_read_space(0);
575 do_stuff = lex_peek_unichar(0) == '+';
576 if(do_stuff) {
577 lex_read_unichar(0);
578 lex_read_space(0);
579 }
580 c = lex_peek_unichar(0);
581 if(c == ';') {
582 lex_read_unichar(0);
583 } else if(c != /*{*/'}') {
584 croak("syntax error");
585 }
586 if(do_stuff) lex_stuff_pvs(" ", 0);
587 return newOP(OP_NULL, 0);
588}
589
590#define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
591static OP *THX_parse_keyword_swaptwostmts(pTHX)
592{
593 OP *a, *b;
594 a = parse_fullstmt(0);
595 b = parse_fullstmt(0);
596 if(a && b)
597 PL_hints |= HINT_BLOCK_SCOPE;
598 /* should use append_list(), but that's not part of the public API */
599 return !a ? b : !b ? a : newLISTOP(OP_LINESEQ, 0, b, a);
600}
601
07ffcb73
Z
602#define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
603static OP *THX_parse_keyword_looprest(pTHX)
604{
605 I32 condline;
606 OP *body;
607 condline = CopLINE(PL_curcop);
608 body = parse_stmtseq(0);
609 return newWHILEOP(0, 1, NULL, condline, newSVOP(OP_CONST, 0, &PL_sv_yes),
610 body, NULL, 1);
611}
612
83f8bb56
Z
613/* plugin glue */
614
615#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
616static int THX_keyword_active(pTHX_ SV *hintkey_sv)
617{
618 HE *he;
619 if(!GvHV(PL_hintgv)) return 0;
620 he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
621 SvSHARED_HASH(hintkey_sv));
622 return he && SvTRUE(HeVAL(he));
623}
624
625static int my_keyword_plugin(pTHX_
626 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
627{
628 if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
629 keyword_active(hintkey_rpn_sv)) {
630 *op_ptr = parse_keyword_rpn();
631 return KEYWORD_PLUGIN_EXPR;
632 } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
633 keyword_active(hintkey_calcrpn_sv)) {
634 *op_ptr = parse_keyword_calcrpn();
635 return KEYWORD_PLUGIN_STMT;
636 } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) &&
637 keyword_active(hintkey_stufftest_sv)) {
638 *op_ptr = parse_keyword_stufftest();
639 return KEYWORD_PLUGIN_STMT;
640 } else if(keyword_len == 12 &&
641 strnEQ(keyword_ptr, "swaptwostmts", 12) &&
642 keyword_active(hintkey_swaptwostmts_sv)) {
643 *op_ptr = parse_keyword_swaptwostmts();
644 return KEYWORD_PLUGIN_STMT;
07ffcb73
Z
645 } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) &&
646 keyword_active(hintkey_looprest_sv)) {
647 *op_ptr = parse_keyword_looprest();
648 return KEYWORD_PLUGIN_STMT;
83f8bb56
Z
649 } else {
650 return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
651 }
652}
653
7b20c7cd 654XS(XS_XS__APItest__XSUB_XS_VERSION_undef);
f9cc56fa 655XS(XS_XS__APItest__XSUB_XS_VERSION_empty);
88c4b02d 656XS(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
7b20c7cd 657
55289a74
NC
658#include "const-c.inc"
659
ffe53d21 660MODULE = XS::APItest PACKAGE = XS::APItest
0314122a 661
55289a74
NC
662INCLUDE: const-xs.inc
663
ffe53d21
NC
664INCLUDE: numeric.xs
665
7b20c7cd
NC
666MODULE = XS::APItest PACKAGE = XS::APItest::XSUB
667
668BOOT:
669 newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
f9cc56fa 670 newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
88c4b02d 671 newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
7b20c7cd
NC
672
673void
674XS_VERSION_defined(...)
675 PPCODE:
676 XS_VERSION_BOOTCHECK;
677 XSRETURN_EMPTY;
678
88c4b02d
NC
679void
680XS_APIVERSION_valid(...)
681 PPCODE:
682 XS_APIVERSION_BOOTCHECK;
683 XSRETURN_EMPTY;
684
ffe53d21
NC
685MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
686
b54b4831
NC
687void
688rot13_hash(hash)
689 HV *hash
690 CODE:
691 {
692 struct ufuncs uf;
693 uf.uf_val = rot13_key;
694 uf.uf_set = 0;
695 uf.uf_index = 0;
696
697 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
698 }
699
53c40a8f
NC
700void
701bitflip_hash(hash)
702 HV *hash
703 CODE:
704 {
705 struct ufuncs uf;
706 uf.uf_val = bitflip_key;
707 uf.uf_set = 0;
708 uf.uf_index = 0;
709
710 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
711 }
712
028f8eaa
MHM
713#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
714
0314122a
NC
715bool
716exists(hash, key_sv)
717 PREINIT:
718 STRLEN len;
719 const char *key;
720 INPUT:
721 HV *hash
722 SV *key_sv
723 CODE:
724 key = SvPV(key_sv, len);
028f8eaa 725 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a
NC
726 OUTPUT:
727 RETVAL
728
bdee33e4
NC
729bool
730exists_ent(hash, key_sv)
731 PREINIT:
732 INPUT:
733 HV *hash
734 SV *key_sv
735 CODE:
736 RETVAL = hv_exists_ent(hash, key_sv, 0);
737 OUTPUT:
738 RETVAL
739
b60cf05a 740SV *
55289a74 741delete(hash, key_sv, flags = 0)
b60cf05a
NC
742 PREINIT:
743 STRLEN len;
744 const char *key;
745 INPUT:
746 HV *hash
747 SV *key_sv
55289a74 748 I32 flags;
b60cf05a
NC
749 CODE:
750 key = SvPV(key_sv, len);
751 /* It's already mortal, so need to increase reference count. */
55289a74
NC
752 RETVAL
753 = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
754 OUTPUT:
755 RETVAL
756
757SV *
758delete_ent(hash, key_sv, flags = 0)
759 INPUT:
760 HV *hash
761 SV *key_sv
762 I32 flags;
763 CODE:
764 /* It's already mortal, so need to increase reference count. */
765 RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
b60cf05a
NC
766 OUTPUT:
767 RETVAL
768
769SV *
858117f8
NC
770store_ent(hash, key, value)
771 PREINIT:
772 SV *copy;
773 HE *result;
774 INPUT:
775 HV *hash
776 SV *key
777 SV *value
778 CODE:
779 copy = newSV(0);
780 result = hv_store_ent(hash, key, copy, 0);
781 SvSetMagicSV(copy, value);
782 if (!result) {
783 SvREFCNT_dec(copy);
784 XSRETURN_EMPTY;
785 }
786 /* It's about to become mortal, so need to increase reference count.
787 */
788 RETVAL = SvREFCNT_inc(HeVAL(result));
789 OUTPUT:
790 RETVAL
791
858117f8 792SV *
b60cf05a
NC
793store(hash, key_sv, value)
794 PREINIT:
795 STRLEN len;
796 const char *key;
797 SV *copy;
798 SV **result;
799 INPUT:
800 HV *hash
801 SV *key_sv
802 SV *value
803 CODE:
804 key = SvPV(key_sv, len);
805 copy = newSV(0);
028f8eaa 806 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8 807 SvSetMagicSV(copy, value);
b60cf05a
NC
808 if (!result) {
809 SvREFCNT_dec(copy);
810 XSRETURN_EMPTY;
811 }
812 /* It's about to become mortal, so need to increase reference count.
813 */
814 RETVAL = SvREFCNT_inc(*result);
815 OUTPUT:
816 RETVAL
817
bdee33e4
NC
818SV *
819fetch_ent(hash, key_sv)
820 PREINIT:
821 HE *result;
822 INPUT:
823 HV *hash
824 SV *key_sv
825 CODE:
826 result = hv_fetch_ent(hash, key_sv, 0, 0);
827 if (!result) {
828 XSRETURN_EMPTY;
829 }
830 /* Force mg_get */
831 RETVAL = newSVsv(HeVAL(result));
832 OUTPUT:
833 RETVAL
b60cf05a
NC
834
835SV *
836fetch(hash, key_sv)
837 PREINIT:
838 STRLEN len;
839 const char *key;
840 SV **result;
841 INPUT:
842 HV *hash
843 SV *key_sv
844 CODE:
845 key = SvPV(key_sv, len);
028f8eaa 846 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a
NC
847 if (!result) {
848 XSRETURN_EMPTY;
849 }
850 /* Force mg_get */
851 RETVAL = newSVsv(*result);
852 OUTPUT:
853 RETVAL
2dc92170 854
9568a123
NC
855#if defined (hv_common)
856
6b4de907
NC
857SV *
858common(params)
859 INPUT:
860 HV *params
861 PREINIT:
862 HE *result;
863 HV *hv = NULL;
864 SV *keysv = NULL;
865 const char *key = NULL;
866 STRLEN klen = 0;
867 int flags = 0;
868 int action = 0;
869 SV *val = NULL;
870 U32 hash = 0;
871 SV **svp;
872 CODE:
873 if ((svp = hv_fetchs(params, "hv", 0))) {
874 SV *const rv = *svp;
875 if (!SvROK(rv))
876 croak("common passed a non-reference for parameter hv");
877 hv = (HV *)SvRV(rv);
878 }
879 if ((svp = hv_fetchs(params, "keysv", 0)))
880 keysv = *svp;
881 if ((svp = hv_fetchs(params, "keypv", 0))) {
882 key = SvPV_const(*svp, klen);
883 if (SvUTF8(*svp))
884 flags = HVhek_UTF8;
885 }
886 if ((svp = hv_fetchs(params, "action", 0)))
887 action = SvIV(*svp);
888 if ((svp = hv_fetchs(params, "val", 0)))
527df579 889 val = newSVsv(*svp);
6b4de907 890 if ((svp = hv_fetchs(params, "hash", 0)))
a44093a9 891 hash = SvUV(*svp);
6b4de907 892
527df579
NC
893 if ((svp = hv_fetchs(params, "hash_pv", 0))) {
894 PERL_HASH(hash, key, klen);
895 }
58ca560a
NC
896 if ((svp = hv_fetchs(params, "hash_sv", 0))) {
897 STRLEN len;
898 const char *const p = SvPV(keysv, len);
899 PERL_HASH(hash, p, len);
900 }
527df579 901
a75fcbca 902 result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
6b4de907
NC
903 if (!result) {
904 XSRETURN_EMPTY;
905 }
906 /* Force mg_get */
907 RETVAL = newSVsv(HeVAL(result));
908 OUTPUT:
909 RETVAL
910
9568a123
NC
911#endif
912
439efdfe 913void
2dc92170
NC
914test_hv_free_ent()
915 PPCODE:
916 test_freeent(&Perl_hv_free_ent);
917 XSRETURN(4);
918
439efdfe 919void
2dc92170
NC
920test_hv_delayfree_ent()
921 PPCODE:
922 test_freeent(&Perl_hv_delayfree_ent);
923 XSRETURN(4);
35ab5632
NC
924
925SV *
926test_share_unshare_pvn(input)
927 PREINIT:
35ab5632
NC
928 STRLEN len;
929 U32 hash;
930 char *pvx;
931 char *p;
932 INPUT:
933 SV *input
934 CODE:
935 pvx = SvPV(input, len);
936 PERL_HASH(hash, pvx, len);
937 p = sharepvn(pvx, len, hash);
938 RETVAL = newSVpvn(p, len);
939 unsharepvn(p, len, hash);
940 OUTPUT:
941 RETVAL
d8c5b3c5 942
9568a123
NC
943#if PERL_VERSION >= 9
944
d8c5b3c5
NC
945bool
946refcounted_he_exists(key, level=0)
947 SV *key
948 IV level
949 CODE:
950 if (level) {
951 croak("level must be zero, not %"IVdf, level);
952 }
953 RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
954 key, NULL, 0, 0, 0)
955 != &PL_sv_placeholder);
956 OUTPUT:
957 RETVAL
958
d8c5b3c5
NC
959SV *
960refcounted_he_fetch(key, level=0)
961 SV *key
962 IV level
963 CODE:
964 if (level) {
965 croak("level must be zero, not %"IVdf, level);
966 }
967 RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
968 NULL, 0, 0, 0);
969 SvREFCNT_inc(RETVAL);
970 OUTPUT:
971 RETVAL
65bfe90c 972
9568a123 973#endif
65bfe90c 974
0314122a
NC
975=pod
976
977sub TIEHASH { bless {}, $_[0] }
978sub STORE { $_[0]->{$_[1]} = $_[2] }
979sub FETCH { $_[0]->{$_[1]} }
980sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
981sub NEXTKEY { each %{$_[0]} }
982sub EXISTS { exists $_[0]->{$_[1]} }
983sub DELETE { delete $_[0]->{$_[1]} }
984sub CLEAR { %{$_[0]} = () }
985
986=cut
987
e2fe06dd
EB
988MODULE = XS::APItest:TempLv PACKAGE = XS::APItest::TempLv
989
990void
991make_temp_mg_lv(sv)
992SV* sv
993 PREINIT:
994 SV * const lv = newSV_type(SVt_PVLV);
995 STRLEN len;
996 PPCODE:
997 SvPV(sv, len);
998
999 sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
1000 LvTYPE(lv) = 'x';
1001 LvTARG(lv) = SvREFCNT_inc_simple(sv);
1002 LvTARGOFF(lv) = len == 0 ? 0 : 1;
1003 LvTARGLEN(lv) = len < 2 ? 0 : len-2;
1004
1005 EXTEND(SP, 1);
1006 ST(0) = sv_2mortal(lv);
1007 XSRETURN(1);
1008
1009
36c2b1d0
NC
1010MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
1011
1012void
1013ptr_table_new(classname)
1014const char * classname
1015 PPCODE:
1016 PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
1017
1018void
1019DESTROY(table)
1020XS::APItest::PtrTable table
1021 CODE:
1022 ptr_table_free(table);
1023
1024void
992b2363 1025ptr_table_store(table, from, to)
36c2b1d0 1026XS::APItest::PtrTable table
992b2363
NC
1027SVREF from
1028SVREF to
36c2b1d0 1029 CODE:
992b2363 1030 ptr_table_store(table, from, to);
36c2b1d0
NC
1031
1032UV
992b2363 1033ptr_table_fetch(table, from)
36c2b1d0 1034XS::APItest::PtrTable table
992b2363 1035SVREF from
36c2b1d0 1036 CODE:
992b2363 1037 RETVAL = PTR2UV(ptr_table_fetch(table, from));
36c2b1d0
NC
1038 OUTPUT:
1039 RETVAL
1040
1041void
1042ptr_table_split(table)
1043XS::APItest::PtrTable table
1044
1045void
1046ptr_table_clear(table)
1047XS::APItest::PtrTable table
1048
3e61d65a
JH
1049MODULE = XS::APItest PACKAGE = XS::APItest
1050
1051PROTOTYPES: DISABLE
1052
85ce96a1
DM
1053BOOT:
1054{
1055 MY_CXT_INIT;
03569ecf 1056
85ce96a1
DM
1057 MY_CXT.i = 99;
1058 MY_CXT.sv = newSVpv("initial",0);
13b6b3bc
BM
1059
1060 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1061 MY_CXT.bhk_record = 0;
1062
a88d97bf
BM
1063 BhkENTRY_set(&bhk_test, bhk_start, blockhook_test_start);
1064 BhkENTRY_set(&bhk_test, bhk_pre_end, blockhook_test_pre_end);
1065 BhkENTRY_set(&bhk_test, bhk_post_end, blockhook_test_post_end);
1066 BhkENTRY_set(&bhk_test, bhk_eval, blockhook_test_eval);
13b6b3bc
BM
1067 Perl_blockhook_register(aTHX_ &bhk_test);
1068
65bfe90c 1069 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
13b6b3bc 1070 GV_ADDMULTI, SVt_PVAV);
03569ecf
BM
1071 MY_CXT.cscav = GvAV(MY_CXT.cscgv);
1072
a88d97bf
BM
1073 BhkENTRY_set(&bhk_csc, bhk_start, blockhook_csc_start);
1074 BhkENTRY_set(&bhk_csc, bhk_pre_end, blockhook_csc_pre_end);
13b6b3bc 1075 Perl_blockhook_register(aTHX_ &bhk_csc);
201c7e1f
FR
1076
1077 MY_CXT.peep_recorder = newAV();
1078 MY_CXT.rpeep_recorder = newAV();
1079
1080 MY_CXT.orig_peep = PL_peepp;
1081 MY_CXT.orig_rpeep = PL_rpeepp;
1082 PL_peepp = my_peep;
1083 PL_rpeepp = my_rpeep;
65bfe90c 1084}
85ce96a1
DM
1085
1086void
1087CLONE(...)
1088 CODE:
1089 MY_CXT_CLONE;
1090 MY_CXT.sv = newSVpv("initial_clone",0);
65bfe90c 1091 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
13b6b3bc 1092 GV_ADDMULTI, SVt_PVAV);
03569ecf 1093 MY_CXT.cscav = NULL;
13b6b3bc
BM
1094 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1095 MY_CXT.bhk_record = 0;
201c7e1f
FR
1096 MY_CXT.peep_recorder = newAV();
1097 MY_CXT.rpeep_recorder = newAV();
85ce96a1 1098
3e61d65a
JH
1099void
1100print_double(val)
1101 double val
1102 CODE:
1103 printf("%5.3f\n",val);
1104
1105int
1106have_long_double()
1107 CODE:
1108#ifdef HAS_LONG_DOUBLE
1109 RETVAL = 1;
1110#else
1111 RETVAL = 0;
1112#endif
cabb36f0
CN
1113 OUTPUT:
1114 RETVAL
3e61d65a
JH
1115
1116void
1117print_long_double()
1118 CODE:
1119#ifdef HAS_LONG_DOUBLE
fc0bf671 1120# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH
1121 long double val = 7.0;
1122 printf("%5.3" PERL_PRIfldbl "\n",val);
1123# else
1124 double val = 7.0;
1125 printf("%5.3f\n",val);
1126# endif
1127#endif
1128
1129void
3e61d65a
JH
1130print_int(val)
1131 int val
1132 CODE:
1133 printf("%d\n",val);
1134
1135void
1136print_long(val)
1137 long val
1138 CODE:
1139 printf("%ld\n",val);
1140
1141void
1142print_float(val)
1143 float val
1144 CODE:
1145 printf("%5.3f\n",val);
9d911683
NIS
1146
1147void
1148print_flush()
1149 CODE:
1150 fflush(stdout);
d4b90eee
SH
1151
1152void
1153mpushp()
1154 PPCODE:
1155 EXTEND(SP, 3);
1156 mPUSHp("one", 3);
1157 mPUSHp("two", 3);
1158 mPUSHp("three", 5);
1159 XSRETURN(3);
1160
1161void
1162mpushn()
1163 PPCODE:
1164 EXTEND(SP, 3);
1165 mPUSHn(0.5);
1166 mPUSHn(-0.25);
1167 mPUSHn(0.125);
1168 XSRETURN(3);
1169
1170void
1171mpushi()
1172 PPCODE:
1173 EXTEND(SP, 3);
d75b63cf
MHM
1174 mPUSHi(-1);
1175 mPUSHi(2);
1176 mPUSHi(-3);
d4b90eee
SH
1177 XSRETURN(3);
1178
1179void
1180mpushu()
1181 PPCODE:
1182 EXTEND(SP, 3);
d75b63cf
MHM
1183 mPUSHu(1);
1184 mPUSHu(2);
1185 mPUSHu(3);
d4b90eee
SH
1186 XSRETURN(3);
1187
1188void
1189mxpushp()
1190 PPCODE:
1191 mXPUSHp("one", 3);
1192 mXPUSHp("two", 3);
1193 mXPUSHp("three", 5);
1194 XSRETURN(3);
1195
1196void
1197mxpushn()
1198 PPCODE:
1199 mXPUSHn(0.5);
1200 mXPUSHn(-0.25);
1201 mXPUSHn(0.125);
1202 XSRETURN(3);
1203
1204void
1205mxpushi()
1206 PPCODE:
d75b63cf
MHM
1207 mXPUSHi(-1);
1208 mXPUSHi(2);
1209 mXPUSHi(-3);
d4b90eee
SH
1210 XSRETURN(3);
1211
1212void
1213mxpushu()
1214 PPCODE:
d75b63cf
MHM
1215 mXPUSHu(1);
1216 mXPUSHu(2);
1217 mXPUSHu(3);
d4b90eee 1218 XSRETURN(3);
d1f347d7
DM
1219
1220
1221void
1222call_sv(sv, flags, ...)
1223 SV* sv
1224 I32 flags
1225 PREINIT:
1226 I32 i;
1227 PPCODE:
1228 for (i=0; i<items-2; i++)
1229 ST(i) = ST(i+2); /* pop first two args */
1230 PUSHMARK(SP);
1231 SP += items - 2;
1232 PUTBACK;
1233 i = call_sv(sv, flags);
1234 SPAGAIN;
1235 EXTEND(SP, 1);
1236 PUSHs(sv_2mortal(newSViv(i)));
1237
1238void
1239call_pv(subname, flags, ...)
1240 char* subname
1241 I32 flags
1242 PREINIT:
1243 I32 i;
1244 PPCODE:
1245 for (i=0; i<items-2; i++)
1246 ST(i) = ST(i+2); /* pop first two args */
1247 PUSHMARK(SP);
1248 SP += items - 2;
1249 PUTBACK;
1250 i = call_pv(subname, flags);
1251 SPAGAIN;
1252 EXTEND(SP, 1);
1253 PUSHs(sv_2mortal(newSViv(i)));
1254
1255void
1256call_method(methname, flags, ...)
1257 char* methname
1258 I32 flags
1259 PREINIT:
1260 I32 i;
1261 PPCODE:
1262 for (i=0; i<items-2; i++)
1263 ST(i) = ST(i+2); /* pop first two args */
1264 PUSHMARK(SP);
1265 SP += items - 2;
1266 PUTBACK;
1267 i = call_method(methname, flags);
1268 SPAGAIN;
1269 EXTEND(SP, 1);
1270 PUSHs(sv_2mortal(newSViv(i)));
1271
1272void
1273eval_sv(sv, flags)
1274 SV* sv
1275 I32 flags
1276 PREINIT:
1277 I32 i;
1278 PPCODE:
1279 PUTBACK;
1280 i = eval_sv(sv, flags);
1281 SPAGAIN;
1282 EXTEND(SP, 1);
1283 PUSHs(sv_2mortal(newSViv(i)));
1284
b8e65a9b 1285void
d1f347d7
DM
1286eval_pv(p, croak_on_error)
1287 const char* p
1288 I32 croak_on_error
d1f347d7
DM
1289 PPCODE:
1290 PUTBACK;
1291 EXTEND(SP, 1);
1292 PUSHs(eval_pv(p, croak_on_error));
1293
1294void
1295require_pv(pv)
1296 const char* pv
d1f347d7
DM
1297 PPCODE:
1298 PUTBACK;
1299 require_pv(pv);
1300
0ca3a874 1301int
7a646707 1302apitest_exception(throw_e)
0ca3a874
MHM
1303 int throw_e
1304 OUTPUT:
1305 RETVAL
d1f347d7 1306
ef469b03 1307void
7e7a3dfc
GA
1308mycroak(sv)
1309 SV* sv
ef469b03 1310 CODE:
7e7a3dfc
GA
1311 if (SvOK(sv)) {
1312 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
1313 }
1314 else {
1315 Perl_croak(aTHX_ NULL);
1316 }
5d2b1485
NC
1317
1318SV*
1319strtab()
1320 CODE:
1321 RETVAL = newRV_inc((SV*)PL_strtab);
1322 OUTPUT:
1323 RETVAL
85ce96a1
DM
1324
1325int
1326my_cxt_getint()
1327 CODE:
1328 dMY_CXT;
1329 RETVAL = my_cxt_getint_p(aMY_CXT);
1330 OUTPUT:
1331 RETVAL
1332
1333void
1334my_cxt_setint(i)
1335 int i;
1336 CODE:
1337 dMY_CXT;
1338 my_cxt_setint_p(aMY_CXT_ i);
1339
1340void
9568a123
NC
1341my_cxt_getsv(how)
1342 bool how;
85ce96a1 1343 PPCODE:
85ce96a1 1344 EXTEND(SP, 1);
9568a123 1345 ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
85ce96a1
DM
1346 XSRETURN(1);
1347
1348void
1349my_cxt_setsv(sv)
1350 SV *sv;
1351 CODE:
1352 dMY_CXT;
1353 SvREFCNT_dec(MY_CXT.sv);
1354 my_cxt_setsv_p(sv _aMY_CXT);
1355 SvREFCNT_inc(sv);
34482cd6
NC
1356
1357bool
1358sv_setsv_cow_hashkey_core()
1359
1360bool
1361sv_setsv_cow_hashkey_notcore()
84ac5fd7
NC
1362
1363void
218787bd
VP
1364rmagical_cast(sv, type)
1365 SV *sv;
1366 SV *type;
1367 PREINIT:
1368 struct ufuncs uf;
1369 PPCODE:
1370 if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
1371 sv = SvRV(sv);
1372 if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
1373 uf.uf_val = rmagical_a_dummy;
1374 uf.uf_set = NULL;
1375 uf.uf_index = 0;
1376 if (SvTRUE(type)) { /* b */
1377 sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
1378 } else { /* a */
1379 sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
1380 }
1381 XSRETURN_YES;
1382
1383void
1384rmagical_flags(sv)
1385 SV *sv;
1386 PPCODE:
1387 if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
1388 sv = SvRV(sv);
1389 EXTEND(SP, 3);
1390 mXPUSHu(SvFLAGS(sv) & SVs_GMG);
1391 mXPUSHu(SvFLAGS(sv) & SVs_SMG);
1392 mXPUSHu(SvFLAGS(sv) & SVs_RMG);
1393 XSRETURN(3);
1394
1395void
90d1f214
BM
1396my_caller(level)
1397 I32 level
1398 PREINIT:
1399 const PERL_CONTEXT *cx, *dbcx;
1400 const char *pv;
1401 const GV *gv;
1402 HV *hv;
1403 PPCODE:
1404 cx = caller_cx(level, &dbcx);
1405 EXTEND(SP, 8);
1406
1407 pv = CopSTASHPV(cx->blk_oldcop);
1408 ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1409 gv = CvGV(cx->blk_sub.cv);
1410 ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1411
1412 pv = CopSTASHPV(dbcx->blk_oldcop);
1413 ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1414 gv = CvGV(dbcx->blk_sub.cv);
1415 ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1416
1417 ST(4) = cop_hints_fetchpvs(cx->blk_oldcop, "foo");
1418 ST(5) = cop_hints_fetchpvn(cx->blk_oldcop, "foo", 3, 0, 0);
1419 ST(6) = cop_hints_fetchsv(cx->blk_oldcop,
1420 sv_2mortal(newSVpvn("foo", 3)), 0);
1421
1422 hv = cop_hints_2hv(cx->blk_oldcop);
1423 ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
1424
1425 XSRETURN(8);
1426
1427void
f9c17636
MB
1428DPeek (sv)
1429 SV *sv
1430
1431 PPCODE:
5b1f7359 1432 ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
f9c17636
MB
1433 XSRETURN (1);
1434
1435void
84ac5fd7
NC
1436BEGIN()
1437 CODE:
1438 sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1439
1440void
1441CHECK()
1442 CODE:
1443 sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1444
1445void
1446UNITCHECK()
1447 CODE:
0932863f 1448 sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
84ac5fd7
NC
1449
1450void
1451INIT()
1452 CODE:
1453 sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1454
1455void
1456END()
1457 CODE:
1458 sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
30685b56
NC
1459
1460void
1461utf16_to_utf8 (sv, ...)
1462 SV* sv
1463 ALIAS:
1464 utf16_to_utf8_reversed = 1
1465 PREINIT:
1466 STRLEN len;
1467 U8 *source;
1468 SV *dest;
1469 I32 got; /* Gah, badly thought out APIs */
1470 CODE:
1471 source = (U8 *)SvPVbyte(sv, len);
1472 /* Optionally only convert part of the buffer. */
1473 if (items > 1) {
1474 len = SvUV(ST(1));
1475 }
1476 /* Mortalise this right now, as we'll be testing croak()s */
1477 dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1478 if (ix) {
25f2e844 1479 utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
30685b56 1480 } else {
25f2e844 1481 utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
30685b56
NC
1482 }
1483 SvCUR_set(dest, got);
1484 SvPVX(dest)[got] = '\0';
1485 SvPOK_on(dest);
1486 ST(0) = dest;
1487 XSRETURN(1);
879d0c72 1488
6bd7445c
GG
1489void
1490my_exit(int exitcode)
1491 PPCODE:
1492 my_exit(exitcode);
d97c33b5
DM
1493
1494I32
1495sv_count()
1496 CODE:
1497 RETVAL = PL_sv_count;
1498 OUTPUT:
1499 RETVAL
13b6b3bc
BM
1500
1501void
1502bhk_record(bool on)
1503 CODE:
1504 dMY_CXT;
1505 MY_CXT.bhk_record = on;
1506 if (on)
1507 av_clear(MY_CXT.bhkav);
65bfe90c 1508
defdfed5 1509void
d9088386
Z
1510test_magic_chain()
1511 PREINIT:
1512 SV *sv;
1513 MAGIC *callmg, *uvarmg;
1514 CODE:
1515 sv = sv_2mortal(newSV(0));
11f9f0ed
NC
1516 if (SvTYPE(sv) >= SVt_PVMG) croak_fail();
1517 if (SvMAGICAL(sv)) croak_fail();
d9088386 1518 sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0);
11f9f0ed
NC
1519 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1520 if (!SvMAGICAL(sv)) croak_fail();
1521 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
d9088386 1522 callmg = mg_find(sv, PERL_MAGIC_checkcall);
11f9f0ed 1523 if (!callmg) croak_fail();
d9088386 1524 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 1525 croak_fail();
d9088386 1526 sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
11f9f0ed
NC
1527 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1528 if (!SvMAGICAL(sv)) croak_fail();
1529 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
d9088386 1530 uvarmg = mg_find(sv, PERL_MAGIC_uvar);
11f9f0ed 1531 if (!uvarmg) croak_fail();
d9088386 1532 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 1533 croak_fail();
d9088386 1534 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 1535 croak_fail();
d9088386 1536 mg_free_type(sv, PERL_MAGIC_vec);
11f9f0ed
NC
1537 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1538 if (!SvMAGICAL(sv)) croak_fail();
1539 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
1540 if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
d9088386 1541 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 1542 croak_fail();
d9088386 1543 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 1544 croak_fail();
d9088386 1545 mg_free_type(sv, PERL_MAGIC_uvar);
11f9f0ed
NC
1546 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1547 if (!SvMAGICAL(sv)) croak_fail();
1548 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
1549 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
d9088386 1550 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 1551 croak_fail();
d9088386 1552 sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
11f9f0ed
NC
1553 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1554 if (!SvMAGICAL(sv)) croak_fail();
1555 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
d9088386 1556 uvarmg = mg_find(sv, PERL_MAGIC_uvar);
11f9f0ed 1557 if (!uvarmg) croak_fail();
d9088386 1558 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 1559 croak_fail();
d9088386 1560 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 1561 croak_fail();
d9088386 1562 mg_free_type(sv, PERL_MAGIC_checkcall);
11f9f0ed
NC
1563 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1564 if (!SvMAGICAL(sv)) croak_fail();
1565 if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
1566 if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
d9088386 1567 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 1568 croak_fail();
d9088386 1569 mg_free_type(sv, PERL_MAGIC_uvar);
11f9f0ed
NC
1570 if (SvMAGICAL(sv)) croak_fail();
1571 if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
1572 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
d9088386
Z
1573
1574void
1575test_op_contextualize()
1576 PREINIT:
1577 OP *o;
1578 CODE:
1579 o = newSVOP(OP_CONST, 0, newSViv(0));
1580 o->op_flags &= ~OPf_WANT;
1581 o = op_contextualize(o, G_SCALAR);
1582 if (o->op_type != OP_CONST ||
1583 (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
11f9f0ed 1584 croak_fail();
d9088386
Z
1585 op_free(o);
1586 o = newSVOP(OP_CONST, 0, newSViv(0));
1587 o->op_flags &= ~OPf_WANT;
1588 o = op_contextualize(o, G_ARRAY);
1589 if (o->op_type != OP_CONST ||
1590 (o->op_flags & OPf_WANT) != OPf_WANT_LIST)
11f9f0ed 1591 croak_fail();
d9088386
Z
1592 op_free(o);
1593 o = newSVOP(OP_CONST, 0, newSViv(0));
1594 o->op_flags &= ~OPf_WANT;
1595 o = op_contextualize(o, G_VOID);
11f9f0ed 1596 if (o->op_type != OP_NULL) croak_fail();
d9088386
Z
1597 op_free(o);
1598
1599void
1600test_rv2cv_op_cv()
1601 PROTOTYPE:
1602 PREINIT:
1603 GV *troc_gv, *wibble_gv;
1604 CV *troc_cv;
1605 OP *o;
1606 CODE:
1607 troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
1608 troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
1609 wibble_gv = gv_fetchpv("XS::APItest::wibble", 0, SVt_PVGV);
1610 o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
11f9f0ed 1611 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
d9088386 1612 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
11f9f0ed 1613 croak_fail();
d9088386 1614 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC
1615 if (rv2cv_op_cv(o, 0)) croak_fail();
1616 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 1617 o->op_private &= ~OPpENTERSUB_AMPER;
11f9f0ed
NC
1618 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1619 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
1620 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
d9088386
Z
1621 op_free(o);
1622 o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0));
1623 o->op_private = OPpCONST_BARE;
1624 o = newCVREF(0, o);
11f9f0ed 1625 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
d9088386 1626 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
11f9f0ed 1627 croak_fail();
d9088386 1628 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC
1629 if (rv2cv_op_cv(o, 0)) croak_fail();
1630 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386
Z
1631 op_free(o);
1632 o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv)));
11f9f0ed 1633 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
d9088386 1634 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
11f9f0ed 1635 croak_fail();
d9088386 1636 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC
1637 if (rv2cv_op_cv(o, 0)) croak_fail();
1638 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 1639 o->op_private &= ~OPpENTERSUB_AMPER;
11f9f0ed
NC
1640 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1641 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
1642 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
d9088386
Z
1643 op_free(o);
1644 o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))));
11f9f0ed
NC
1645 if (rv2cv_op_cv(o, 0)) croak_fail();
1646 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 1647 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC
1648 if (rv2cv_op_cv(o, 0)) croak_fail();
1649 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 1650 o->op_private &= ~OPpENTERSUB_AMPER;
11f9f0ed
NC
1651 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1652 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail();
1653 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
d9088386
Z
1654 op_free(o);
1655 o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)));
11f9f0ed
NC
1656 if (rv2cv_op_cv(o, 0)) croak_fail();
1657 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386
Z
1658 op_free(o);
1659
1660void
1661test_cv_getset_call_checker()
1662 PREINIT:
1663 CV *troc_cv, *tsh_cv;
1664 Perl_call_checker ckfun;
1665 SV *ckobj;
1666 CODE:
1667#define check_cc(cv, xckfun, xckobj) \
1668 do { \
1669 cv_get_call_checker((cv), &ckfun, &ckobj); \
11f9f0ed 1670 if (ckfun != (xckfun) || ckobj != (xckobj)) croak_fail(); \
d9088386
Z
1671 } while(0)
1672 troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
1673 tsh_cv = get_cv("XS::APItest::test_savehints", 0);
1674 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
1675 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
1676 cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
1677 &PL_sv_yes);
1678 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
1679 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
1680 cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
1681 check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
1682 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
1683 cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
1684 (SV*)tsh_cv);
1685 check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
1686 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
1687 cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list,
1688 (SV*)troc_cv);
1689 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
1690 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
11f9f0ed
NC
1691 if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail();
1692 if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
d9088386
Z
1693#undef check_cc
1694
1695void
1696cv_set_call_checker_lists(CV *cv)
1697 CODE:
1698 cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
1699
1700void
1701cv_set_call_checker_scalars(CV *cv)
1702 CODE:
1703 cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
1704
1705void
1706cv_set_call_checker_proto(CV *cv, SV *proto)
1707 CODE:
1708 if (SvROK(proto))
1709 proto = SvRV(proto);
1710 cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
1711
1712void
1713cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
1714 CODE:
1715 if (SvROK(proto))
1716 proto = SvRV(proto);
1717 cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
1718
1719void
1720cv_set_call_checker_multi_sum(CV *cv)
1721 CODE:
1722 cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
1723
1724void
defdfed5
Z
1725test_savehints()
1726 PREINIT:
1727 SV **svp, *sv;
1728 CODE:
1729#define store_hint(KEY, VALUE) \
1730 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
1731#define hint_ok(KEY, EXPECT) \
1732 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
1733 (sv = *svp) && SvIV(sv) == (EXPECT) && \
1734 (sv = cop_hints_fetchpvs(&PL_compiling, KEY)) && \
1735 SvIV(sv) == (EXPECT))
1736#define check_hint(KEY, EXPECT) \
11f9f0ed 1737 do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0)
defdfed5
Z
1738 PL_hints |= HINT_LOCALIZE_HH;
1739 ENTER;
1740 SAVEHINTS();
1741 PL_hints &= HINT_INTEGER;
1742 store_hint("t0", 123);
1743 store_hint("t1", 456);
11f9f0ed 1744 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
1745 check_hint("t0", 123); check_hint("t1", 456);
1746 ENTER;
1747 SAVEHINTS();
11f9f0ed 1748 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
1749 check_hint("t0", 123); check_hint("t1", 456);
1750 PL_hints |= HINT_INTEGER;
1751 store_hint("t0", 321);
11f9f0ed 1752 if (!(PL_hints & HINT_INTEGER)) croak_fail();
defdfed5
Z
1753 check_hint("t0", 321); check_hint("t1", 456);
1754 LEAVE;
11f9f0ed 1755 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
1756 check_hint("t0", 123); check_hint("t1", 456);
1757 ENTER;
1758 SAVEHINTS();
11f9f0ed 1759 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
1760 check_hint("t0", 123); check_hint("t1", 456);
1761 store_hint("t1", 654);
11f9f0ed 1762 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
1763 check_hint("t0", 123); check_hint("t1", 654);
1764 LEAVE;
11f9f0ed 1765 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
1766 check_hint("t0", 123); check_hint("t1", 456);
1767 LEAVE;
1768#undef store_hint
1769#undef hint_ok
1770#undef check_hint
1771
1772void
1773test_copyhints()
1774 PREINIT:
1775 HV *a, *b;
1776 CODE:
1777 PL_hints |= HINT_LOCALIZE_HH;
1778 ENTER;
1779 SAVEHINTS();
1780 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
11f9f0ed 1781 if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak_fail();
defdfed5
Z
1782 a = newHVhv(GvHV(PL_hintgv));
1783 sv_2mortal((SV*)a);
1784 sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
11f9f0ed 1785 if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak_fail();
defdfed5
Z
1786 b = hv_copy_hints_hv(a);
1787 sv_2mortal((SV*)b);
1788 sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
11f9f0ed 1789 if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 789) croak_fail();
defdfed5
Z
1790 LEAVE;
1791
201c7e1f
FR
1792void
1793peep_enable ()
1794 PREINIT:
1795 dMY_CXT;
1796 CODE:
1797 av_clear(MY_CXT.peep_recorder);
1798 av_clear(MY_CXT.rpeep_recorder);
1799 MY_CXT.peep_recording = 1;
1800
1801void
1802peep_disable ()
1803 PREINIT:
1804 dMY_CXT;
1805 CODE:
1806 MY_CXT.peep_recording = 0;
1807
1808SV *
1809peep_record ()
1810 PREINIT:
1811 dMY_CXT;
1812 CODE:
95d2461a 1813 RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
201c7e1f
FR
1814 OUTPUT:
1815 RETVAL
1816
1817SV *
1818rpeep_record ()
1819 PREINIT:
1820 dMY_CXT;
1821 CODE:
95d2461a 1822 RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
201c7e1f
FR
1823 OUTPUT:
1824 RETVAL
1825
e2fe06dd
EB
1826BOOT:
1827 {
1828 HV* stash;
1829 SV** meth = NULL;
1830 CV* cv;
1831 stash = gv_stashpv("XS::APItest::TempLv", 0);
1832 if (stash)
1833 meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
1834 if (!meth)
1835 croak("lost method 'make_temp_mg_lv'");
1836 cv = GvCV(*meth);
1837 CvLVALUE_on(cv);
1838 }
83f8bb56
Z
1839
1840BOOT:
1841{
1842 hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
1843 hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
1844 hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
1845 hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
07ffcb73 1846 hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
83f8bb56
Z
1847 next_keyword_plugin = PL_keyword_plugin;
1848 PL_keyword_plugin = my_keyword_plugin;
1849}