This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add skeleton testing for the MULTICALL macros
[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
2fcb4757
Z
421STATIC void test_op_list_describe_part(SV *res, OP *o);
422STATIC void
423test_op_list_describe_part(SV *res, OP *o)
424{
425 sv_catpv(res, PL_op_name[o->op_type]);
426 switch (o->op_type) {
427 case OP_CONST: {
428 sv_catpvf(res, "(%d)", (int)SvIV(cSVOPx(o)->op_sv));
429 } break;
430 }
431 if (o->op_flags & OPf_KIDS) {
432 OP *k;
433 sv_catpvs(res, "[");
434 for (k = cUNOPx(o)->op_first; k; k = k->op_sibling)
435 test_op_list_describe_part(res, k);
436 sv_catpvs(res, "]");
437 } else {
438 sv_catpvs(res, ".");
439 }
440}
441
442STATIC char *
443test_op_list_describe(OP *o)
444{
445 SV *res = sv_2mortal(newSVpvs(""));
446 if (o)
447 test_op_list_describe_part(res, o);
448 return SvPVX(res);
449}
450
5983a79d
BM
451/* the real new*OP functions have a tendancy to call fold_constants, and
452 * other such unhelpful things, so we need our own versions for testing */
453
454#define mkUNOP(t, f) THX_mkUNOP(aTHX_ (t), (f))
455static OP *
456THX_mkUNOP(pTHX_ U32 type, OP *first)
457{
458 UNOP *unop;
459 NewOp(1103, unop, 1, UNOP);
460 unop->op_type = (OPCODE)type;
461 unop->op_first = first;
462 unop->op_flags = OPf_KIDS;
463 return (OP *)unop;
464}
465
466#define mkBINOP(t, f, l) THX_mkBINOP(aTHX_ (t), (f), (l))
467static OP *
468THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last)
469{
470 BINOP *binop;
471 NewOp(1103, binop, 1, BINOP);
472 binop->op_type = (OPCODE)type;
473 binop->op_first = first;
474 binop->op_flags = OPf_KIDS;
475 binop->op_last = last;
476 first->op_sibling = last;
477 return (OP *)binop;
478}
479
480#define mkLISTOP(t, f, s, l) THX_mkLISTOP(aTHX_ (t), (f), (s), (l))
481static OP *
482THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last)
483{
484 LISTOP *listop;
485 NewOp(1103, listop, 1, LISTOP);
486 listop->op_type = (OPCODE)type;
487 listop->op_flags = OPf_KIDS;
488 listop->op_first = first;
489 first->op_sibling = sib;
490 sib->op_sibling = last;
491 listop->op_last = last;
492 return (OP *)listop;
493}
494
495static char *
496test_op_linklist_describe(OP *start)
497{
498 SV *rv = sv_2mortal(newSVpvs(""));
499 OP *o;
500 o = start = LINKLIST(start);
501 do {
502 sv_catpvs(rv, ".");
503 sv_catpv(rv, OP_NAME(o));
504 if (o->op_type == OP_CONST)
505 sv_catsv(rv, cSVOPo->op_sv);
506 o = o->op_next;
507 } while (o && o != start);
508 return SvPVX(rv);
509}
510
83f8bb56
Z
511/** RPN keyword parser **/
512
513#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
514#define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
515#define sv_is_string(sv) \
516 (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
517 (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
518
519static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
07ffcb73 520static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
83f8bb56
Z
521static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
522
523/* low-level parser helpers */
524
525#define PL_bufptr (PL_parser->bufptr)
526#define PL_bufend (PL_parser->bufend)
527
528/* RPN parser */
529
530#define parse_var() THX_parse_var(aTHX)
531static OP *THX_parse_var(pTHX)
532{
533 char *s = PL_bufptr;
534 char *start = s;
535 PADOFFSET varpos;
536 OP *padop;
537 if(*s != '$') croak("RPN syntax error");
538 while(1) {
539 char c = *++s;
540 if(!isALNUM(c)) break;
541 }
542 if(s-start < 2) croak("RPN syntax error");
543 lex_read_to(s);
544 {
545 /* because pad_findmy() doesn't really use length yet */
546 SV *namesv = sv_2mortal(newSVpvn(start, s-start));
547 varpos = pad_findmy(SvPVX(namesv), s-start, 0);
548 }
549 if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
550 croak("RPN only supports \"my\" variables");
551 padop = newOP(OP_PADSV, 0);
552 padop->op_targ = varpos;
553 return padop;
554}
555
556#define push_rpn_item(o) \
557 (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
558#define pop_rpn_item() \
559 (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \
560 (tmpop = stack, stack = stack->op_sibling, \
561 tmpop->op_sibling = NULL, tmpop))
562
563#define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
564static OP *THX_parse_rpn_expr(pTHX)
565{
566 OP *stack = NULL, *tmpop;
567 while(1) {
568 I32 c;
569 lex_read_space(0);
570 c = lex_peek_unichar(0);
571 switch(c) {
572 case /*(*/')': case /*{*/'}': {
573 OP *result = pop_rpn_item();
574 if(stack) croak("RPN expression must return a single value");
575 return result;
576 } break;
577 case '0': case '1': case '2': case '3': case '4':
578 case '5': case '6': case '7': case '8': case '9': {
579 UV val = 0;
580 do {
581 lex_read_unichar(0);
582 val = 10*val + (c - '0');
583 c = lex_peek_unichar(0);
584 } while(c >= '0' && c <= '9');
585 push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val)));
586 } break;
587 case '$': {
588 push_rpn_item(parse_var());
589 } break;
590 case '+': {
591 OP *b = pop_rpn_item();
592 OP *a = pop_rpn_item();
593 lex_read_unichar(0);
594 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
595 } break;
596 case '-': {
597 OP *b = pop_rpn_item();
598 OP *a = pop_rpn_item();
599 lex_read_unichar(0);
600 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
601 } break;
602 case '*': {
603 OP *b = pop_rpn_item();
604 OP *a = pop_rpn_item();
605 lex_read_unichar(0);
606 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
607 } break;
608 case '/': {
609 OP *b = pop_rpn_item();
610 OP *a = pop_rpn_item();
611 lex_read_unichar(0);
612 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
613 } break;
614 case '%': {
615 OP *b = pop_rpn_item();
616 OP *a = pop_rpn_item();
617 lex_read_unichar(0);
618 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
619 } break;
620 default: {
621 croak("RPN syntax error");
622 } break;
623 }
624 }
625}
626
627#define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
628static OP *THX_parse_keyword_rpn(pTHX)
629{
630 OP *op;
631 lex_read_space(0);
632 if(lex_peek_unichar(0) != '('/*)*/)
633 croak("RPN expression must be parenthesised");
634 lex_read_unichar(0);
635 op = parse_rpn_expr();
636 if(lex_peek_unichar(0) != /*(*/')')
637 croak("RPN expression must be parenthesised");
638 lex_read_unichar(0);
639 return op;
640}
641
642#define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
643static OP *THX_parse_keyword_calcrpn(pTHX)
644{
645 OP *varop, *exprop;
646 lex_read_space(0);
647 varop = parse_var();
648 lex_read_space(0);
649 if(lex_peek_unichar(0) != '{'/*}*/)
650 croak("RPN expression must be braced");
651 lex_read_unichar(0);
652 exprop = parse_rpn_expr();
653 if(lex_peek_unichar(0) != /*{*/'}')
654 croak("RPN expression must be braced");
655 lex_read_unichar(0);
656 return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
657}
658
659#define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
660static OP *THX_parse_keyword_stufftest(pTHX)
661{
662 I32 c;
663 bool do_stuff;
664 lex_read_space(0);
665 do_stuff = lex_peek_unichar(0) == '+';
666 if(do_stuff) {
667 lex_read_unichar(0);
668 lex_read_space(0);
669 }
670 c = lex_peek_unichar(0);
671 if(c == ';') {
672 lex_read_unichar(0);
673 } else if(c != /*{*/'}') {
674 croak("syntax error");
675 }
676 if(do_stuff) lex_stuff_pvs(" ", 0);
677 return newOP(OP_NULL, 0);
678}
679
680#define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
681static OP *THX_parse_keyword_swaptwostmts(pTHX)
682{
683 OP *a, *b;
684 a = parse_fullstmt(0);
685 b = parse_fullstmt(0);
686 if(a && b)
687 PL_hints |= HINT_BLOCK_SCOPE;
2fcb4757 688 return op_append_list(OP_LINESEQ, b, a);
83f8bb56
Z
689}
690
07ffcb73
Z
691#define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
692static OP *THX_parse_keyword_looprest(pTHX)
693{
694 I32 condline;
695 OP *body;
696 condline = CopLINE(PL_curcop);
697 body = parse_stmtseq(0);
698 return newWHILEOP(0, 1, NULL, condline, newSVOP(OP_CONST, 0, &PL_sv_yes),
699 body, NULL, 1);
700}
701
83f8bb56
Z
702/* plugin glue */
703
704#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
705static int THX_keyword_active(pTHX_ SV *hintkey_sv)
706{
707 HE *he;
708 if(!GvHV(PL_hintgv)) return 0;
709 he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
710 SvSHARED_HASH(hintkey_sv));
711 return he && SvTRUE(HeVAL(he));
712}
713
714static int my_keyword_plugin(pTHX_
715 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
716{
717 if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
718 keyword_active(hintkey_rpn_sv)) {
719 *op_ptr = parse_keyword_rpn();
720 return KEYWORD_PLUGIN_EXPR;
721 } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
722 keyword_active(hintkey_calcrpn_sv)) {
723 *op_ptr = parse_keyword_calcrpn();
724 return KEYWORD_PLUGIN_STMT;
725 } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) &&
726 keyword_active(hintkey_stufftest_sv)) {
727 *op_ptr = parse_keyword_stufftest();
728 return KEYWORD_PLUGIN_STMT;
729 } else if(keyword_len == 12 &&
730 strnEQ(keyword_ptr, "swaptwostmts", 12) &&
731 keyword_active(hintkey_swaptwostmts_sv)) {
732 *op_ptr = parse_keyword_swaptwostmts();
733 return KEYWORD_PLUGIN_STMT;
07ffcb73
Z
734 } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) &&
735 keyword_active(hintkey_looprest_sv)) {
736 *op_ptr = parse_keyword_looprest();
737 return KEYWORD_PLUGIN_STMT;
83f8bb56
Z
738 } else {
739 return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
740 }
741}
742
7b20c7cd 743XS(XS_XS__APItest__XSUB_XS_VERSION_undef);
f9cc56fa 744XS(XS_XS__APItest__XSUB_XS_VERSION_empty);
88c4b02d 745XS(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
7b20c7cd 746
55289a74
NC
747#include "const-c.inc"
748
ffe53d21 749MODULE = XS::APItest PACKAGE = XS::APItest
0314122a 750
55289a74
NC
751INCLUDE: const-xs.inc
752
ffe53d21
NC
753INCLUDE: numeric.xs
754
7b20c7cd
NC
755MODULE = XS::APItest PACKAGE = XS::APItest::XSUB
756
757BOOT:
758 newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
f9cc56fa 759 newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
88c4b02d 760 newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
7b20c7cd
NC
761
762void
763XS_VERSION_defined(...)
764 PPCODE:
765 XS_VERSION_BOOTCHECK;
766 XSRETURN_EMPTY;
767
88c4b02d
NC
768void
769XS_APIVERSION_valid(...)
770 PPCODE:
771 XS_APIVERSION_BOOTCHECK;
772 XSRETURN_EMPTY;
773
ffe53d21
NC
774MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
775
b54b4831
NC
776void
777rot13_hash(hash)
778 HV *hash
779 CODE:
780 {
781 struct ufuncs uf;
782 uf.uf_val = rot13_key;
783 uf.uf_set = 0;
784 uf.uf_index = 0;
785
786 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
787 }
788
53c40a8f
NC
789void
790bitflip_hash(hash)
791 HV *hash
792 CODE:
793 {
794 struct ufuncs uf;
795 uf.uf_val = bitflip_key;
796 uf.uf_set = 0;
797 uf.uf_index = 0;
798
799 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
800 }
801
028f8eaa
MHM
802#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
803
0314122a
NC
804bool
805exists(hash, key_sv)
806 PREINIT:
807 STRLEN len;
808 const char *key;
809 INPUT:
810 HV *hash
811 SV *key_sv
812 CODE:
813 key = SvPV(key_sv, len);
028f8eaa 814 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a
NC
815 OUTPUT:
816 RETVAL
817
bdee33e4
NC
818bool
819exists_ent(hash, key_sv)
820 PREINIT:
821 INPUT:
822 HV *hash
823 SV *key_sv
824 CODE:
825 RETVAL = hv_exists_ent(hash, key_sv, 0);
826 OUTPUT:
827 RETVAL
828
b60cf05a 829SV *
55289a74 830delete(hash, key_sv, flags = 0)
b60cf05a
NC
831 PREINIT:
832 STRLEN len;
833 const char *key;
834 INPUT:
835 HV *hash
836 SV *key_sv
55289a74 837 I32 flags;
b60cf05a
NC
838 CODE:
839 key = SvPV(key_sv, len);
840 /* It's already mortal, so need to increase reference count. */
55289a74
NC
841 RETVAL
842 = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
843 OUTPUT:
844 RETVAL
845
846SV *
847delete_ent(hash, key_sv, flags = 0)
848 INPUT:
849 HV *hash
850 SV *key_sv
851 I32 flags;
852 CODE:
853 /* It's already mortal, so need to increase reference count. */
854 RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
b60cf05a
NC
855 OUTPUT:
856 RETVAL
857
858SV *
858117f8
NC
859store_ent(hash, key, value)
860 PREINIT:
861 SV *copy;
862 HE *result;
863 INPUT:
864 HV *hash
865 SV *key
866 SV *value
867 CODE:
868 copy = newSV(0);
869 result = hv_store_ent(hash, key, copy, 0);
870 SvSetMagicSV(copy, value);
871 if (!result) {
872 SvREFCNT_dec(copy);
873 XSRETURN_EMPTY;
874 }
875 /* It's about to become mortal, so need to increase reference count.
876 */
877 RETVAL = SvREFCNT_inc(HeVAL(result));
878 OUTPUT:
879 RETVAL
880
858117f8 881SV *
b60cf05a
NC
882store(hash, key_sv, value)
883 PREINIT:
884 STRLEN len;
885 const char *key;
886 SV *copy;
887 SV **result;
888 INPUT:
889 HV *hash
890 SV *key_sv
891 SV *value
892 CODE:
893 key = SvPV(key_sv, len);
894 copy = newSV(0);
028f8eaa 895 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8 896 SvSetMagicSV(copy, value);
b60cf05a
NC
897 if (!result) {
898 SvREFCNT_dec(copy);
899 XSRETURN_EMPTY;
900 }
901 /* It's about to become mortal, so need to increase reference count.
902 */
903 RETVAL = SvREFCNT_inc(*result);
904 OUTPUT:
905 RETVAL
906
bdee33e4
NC
907SV *
908fetch_ent(hash, key_sv)
909 PREINIT:
910 HE *result;
911 INPUT:
912 HV *hash
913 SV *key_sv
914 CODE:
915 result = hv_fetch_ent(hash, key_sv, 0, 0);
916 if (!result) {
917 XSRETURN_EMPTY;
918 }
919 /* Force mg_get */
920 RETVAL = newSVsv(HeVAL(result));
921 OUTPUT:
922 RETVAL
b60cf05a
NC
923
924SV *
925fetch(hash, key_sv)
926 PREINIT:
927 STRLEN len;
928 const char *key;
929 SV **result;
930 INPUT:
931 HV *hash
932 SV *key_sv
933 CODE:
934 key = SvPV(key_sv, len);
028f8eaa 935 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a
NC
936 if (!result) {
937 XSRETURN_EMPTY;
938 }
939 /* Force mg_get */
940 RETVAL = newSVsv(*result);
941 OUTPUT:
942 RETVAL
2dc92170 943
9568a123
NC
944#if defined (hv_common)
945
6b4de907
NC
946SV *
947common(params)
948 INPUT:
949 HV *params
950 PREINIT:
951 HE *result;
952 HV *hv = NULL;
953 SV *keysv = NULL;
954 const char *key = NULL;
955 STRLEN klen = 0;
956 int flags = 0;
957 int action = 0;
958 SV *val = NULL;
959 U32 hash = 0;
960 SV **svp;
961 CODE:
962 if ((svp = hv_fetchs(params, "hv", 0))) {
963 SV *const rv = *svp;
964 if (!SvROK(rv))
965 croak("common passed a non-reference for parameter hv");
966 hv = (HV *)SvRV(rv);
967 }
968 if ((svp = hv_fetchs(params, "keysv", 0)))
969 keysv = *svp;
970 if ((svp = hv_fetchs(params, "keypv", 0))) {
971 key = SvPV_const(*svp, klen);
972 if (SvUTF8(*svp))
973 flags = HVhek_UTF8;
974 }
975 if ((svp = hv_fetchs(params, "action", 0)))
976 action = SvIV(*svp);
977 if ((svp = hv_fetchs(params, "val", 0)))
527df579 978 val = newSVsv(*svp);
6b4de907 979 if ((svp = hv_fetchs(params, "hash", 0)))
a44093a9 980 hash = SvUV(*svp);
6b4de907 981
527df579
NC
982 if ((svp = hv_fetchs(params, "hash_pv", 0))) {
983 PERL_HASH(hash, key, klen);
984 }
58ca560a
NC
985 if ((svp = hv_fetchs(params, "hash_sv", 0))) {
986 STRLEN len;
987 const char *const p = SvPV(keysv, len);
988 PERL_HASH(hash, p, len);
989 }
527df579 990
a75fcbca 991 result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
6b4de907
NC
992 if (!result) {
993 XSRETURN_EMPTY;
994 }
995 /* Force mg_get */
996 RETVAL = newSVsv(HeVAL(result));
997 OUTPUT:
998 RETVAL
999
9568a123
NC
1000#endif
1001
439efdfe 1002void
2dc92170
NC
1003test_hv_free_ent()
1004 PPCODE:
1005 test_freeent(&Perl_hv_free_ent);
1006 XSRETURN(4);
1007
439efdfe 1008void
2dc92170
NC
1009test_hv_delayfree_ent()
1010 PPCODE:
1011 test_freeent(&Perl_hv_delayfree_ent);
1012 XSRETURN(4);
35ab5632
NC
1013
1014SV *
1015test_share_unshare_pvn(input)
1016 PREINIT:
35ab5632
NC
1017 STRLEN len;
1018 U32 hash;
1019 char *pvx;
1020 char *p;
1021 INPUT:
1022 SV *input
1023 CODE:
1024 pvx = SvPV(input, len);
1025 PERL_HASH(hash, pvx, len);
1026 p = sharepvn(pvx, len, hash);
1027 RETVAL = newSVpvn(p, len);
1028 unsharepvn(p, len, hash);
1029 OUTPUT:
1030 RETVAL
d8c5b3c5 1031
9568a123
NC
1032#if PERL_VERSION >= 9
1033
d8c5b3c5
NC
1034bool
1035refcounted_he_exists(key, level=0)
1036 SV *key
1037 IV level
1038 CODE:
1039 if (level) {
1040 croak("level must be zero, not %"IVdf, level);
1041 }
1042 RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
1043 key, NULL, 0, 0, 0)
1044 != &PL_sv_placeholder);
1045 OUTPUT:
1046 RETVAL
1047
d8c5b3c5
NC
1048SV *
1049refcounted_he_fetch(key, level=0)
1050 SV *key
1051 IV level
1052 CODE:
1053 if (level) {
1054 croak("level must be zero, not %"IVdf, level);
1055 }
1056 RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
1057 NULL, 0, 0, 0);
1058 SvREFCNT_inc(RETVAL);
1059 OUTPUT:
1060 RETVAL
65bfe90c 1061
9568a123 1062#endif
65bfe90c 1063
0314122a
NC
1064=pod
1065
1066sub TIEHASH { bless {}, $_[0] }
1067sub STORE { $_[0]->{$_[1]} = $_[2] }
1068sub FETCH { $_[0]->{$_[1]} }
1069sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
1070sub NEXTKEY { each %{$_[0]} }
1071sub EXISTS { exists $_[0]->{$_[1]} }
1072sub DELETE { delete $_[0]->{$_[1]} }
1073sub CLEAR { %{$_[0]} = () }
1074
1075=cut
1076
e2fe06dd
EB
1077MODULE = XS::APItest:TempLv PACKAGE = XS::APItest::TempLv
1078
1079void
1080make_temp_mg_lv(sv)
1081SV* sv
1082 PREINIT:
1083 SV * const lv = newSV_type(SVt_PVLV);
1084 STRLEN len;
1085 PPCODE:
1086 SvPV(sv, len);
1087
1088 sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
1089 LvTYPE(lv) = 'x';
1090 LvTARG(lv) = SvREFCNT_inc_simple(sv);
1091 LvTARGOFF(lv) = len == 0 ? 0 : 1;
1092 LvTARGLEN(lv) = len < 2 ? 0 : len-2;
1093
1094 EXTEND(SP, 1);
1095 ST(0) = sv_2mortal(lv);
1096 XSRETURN(1);
1097
1098
36c2b1d0
NC
1099MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
1100
1101void
1102ptr_table_new(classname)
1103const char * classname
1104 PPCODE:
1105 PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
1106
1107void
1108DESTROY(table)
1109XS::APItest::PtrTable table
1110 CODE:
1111 ptr_table_free(table);
1112
1113void
992b2363 1114ptr_table_store(table, from, to)
36c2b1d0 1115XS::APItest::PtrTable table
992b2363
NC
1116SVREF from
1117SVREF to
36c2b1d0 1118 CODE:
992b2363 1119 ptr_table_store(table, from, to);
36c2b1d0
NC
1120
1121UV
992b2363 1122ptr_table_fetch(table, from)
36c2b1d0 1123XS::APItest::PtrTable table
992b2363 1124SVREF from
36c2b1d0 1125 CODE:
992b2363 1126 RETVAL = PTR2UV(ptr_table_fetch(table, from));
36c2b1d0
NC
1127 OUTPUT:
1128 RETVAL
1129
1130void
1131ptr_table_split(table)
1132XS::APItest::PtrTable table
1133
1134void
1135ptr_table_clear(table)
1136XS::APItest::PtrTable table
1137
3e61d65a
JH
1138MODULE = XS::APItest PACKAGE = XS::APItest
1139
1140PROTOTYPES: DISABLE
1141
85ce96a1
DM
1142BOOT:
1143{
1144 MY_CXT_INIT;
03569ecf 1145
85ce96a1
DM
1146 MY_CXT.i = 99;
1147 MY_CXT.sv = newSVpv("initial",0);
13b6b3bc
BM
1148
1149 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1150 MY_CXT.bhk_record = 0;
1151
a88d97bf
BM
1152 BhkENTRY_set(&bhk_test, bhk_start, blockhook_test_start);
1153 BhkENTRY_set(&bhk_test, bhk_pre_end, blockhook_test_pre_end);
1154 BhkENTRY_set(&bhk_test, bhk_post_end, blockhook_test_post_end);
1155 BhkENTRY_set(&bhk_test, bhk_eval, blockhook_test_eval);
13b6b3bc
BM
1156 Perl_blockhook_register(aTHX_ &bhk_test);
1157
65bfe90c 1158 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
13b6b3bc 1159 GV_ADDMULTI, SVt_PVAV);
03569ecf
BM
1160 MY_CXT.cscav = GvAV(MY_CXT.cscgv);
1161
a88d97bf
BM
1162 BhkENTRY_set(&bhk_csc, bhk_start, blockhook_csc_start);
1163 BhkENTRY_set(&bhk_csc, bhk_pre_end, blockhook_csc_pre_end);
13b6b3bc 1164 Perl_blockhook_register(aTHX_ &bhk_csc);
201c7e1f
FR
1165
1166 MY_CXT.peep_recorder = newAV();
1167 MY_CXT.rpeep_recorder = newAV();
1168
1169 MY_CXT.orig_peep = PL_peepp;
1170 MY_CXT.orig_rpeep = PL_rpeepp;
1171 PL_peepp = my_peep;
1172 PL_rpeepp = my_rpeep;
65bfe90c 1173}
85ce96a1
DM
1174
1175void
1176CLONE(...)
1177 CODE:
1178 MY_CXT_CLONE;
1179 MY_CXT.sv = newSVpv("initial_clone",0);
65bfe90c 1180 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
13b6b3bc 1181 GV_ADDMULTI, SVt_PVAV);
03569ecf 1182 MY_CXT.cscav = NULL;
13b6b3bc
BM
1183 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1184 MY_CXT.bhk_record = 0;
201c7e1f
FR
1185 MY_CXT.peep_recorder = newAV();
1186 MY_CXT.rpeep_recorder = newAV();
85ce96a1 1187
3e61d65a
JH
1188void
1189print_double(val)
1190 double val
1191 CODE:
1192 printf("%5.3f\n",val);
1193
1194int
1195have_long_double()
1196 CODE:
1197#ifdef HAS_LONG_DOUBLE
1198 RETVAL = 1;
1199#else
1200 RETVAL = 0;
1201#endif
cabb36f0
CN
1202 OUTPUT:
1203 RETVAL
3e61d65a
JH
1204
1205void
1206print_long_double()
1207 CODE:
1208#ifdef HAS_LONG_DOUBLE
fc0bf671 1209# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH
1210 long double val = 7.0;
1211 printf("%5.3" PERL_PRIfldbl "\n",val);
1212# else
1213 double val = 7.0;
1214 printf("%5.3f\n",val);
1215# endif
1216#endif
1217
1218void
3e61d65a
JH
1219print_int(val)
1220 int val
1221 CODE:
1222 printf("%d\n",val);
1223
1224void
1225print_long(val)
1226 long val
1227 CODE:
1228 printf("%ld\n",val);
1229
1230void
1231print_float(val)
1232 float val
1233 CODE:
1234 printf("%5.3f\n",val);
9d911683
NIS
1235
1236void
1237print_flush()
1238 CODE:
1239 fflush(stdout);
d4b90eee
SH
1240
1241void
1242mpushp()
1243 PPCODE:
1244 EXTEND(SP, 3);
1245 mPUSHp("one", 3);
1246 mPUSHp("two", 3);
1247 mPUSHp("three", 5);
1248 XSRETURN(3);
1249
1250void
1251mpushn()
1252 PPCODE:
1253 EXTEND(SP, 3);
1254 mPUSHn(0.5);
1255 mPUSHn(-0.25);
1256 mPUSHn(0.125);
1257 XSRETURN(3);
1258
1259void
1260mpushi()
1261 PPCODE:
1262 EXTEND(SP, 3);
d75b63cf
MHM
1263 mPUSHi(-1);
1264 mPUSHi(2);
1265 mPUSHi(-3);
d4b90eee
SH
1266 XSRETURN(3);
1267
1268void
1269mpushu()
1270 PPCODE:
1271 EXTEND(SP, 3);
d75b63cf
MHM
1272 mPUSHu(1);
1273 mPUSHu(2);
1274 mPUSHu(3);
d4b90eee
SH
1275 XSRETURN(3);
1276
1277void
1278mxpushp()
1279 PPCODE:
1280 mXPUSHp("one", 3);
1281 mXPUSHp("two", 3);
1282 mXPUSHp("three", 5);
1283 XSRETURN(3);
1284
1285void
1286mxpushn()
1287 PPCODE:
1288 mXPUSHn(0.5);
1289 mXPUSHn(-0.25);
1290 mXPUSHn(0.125);
1291 XSRETURN(3);
1292
1293void
1294mxpushi()
1295 PPCODE:
d75b63cf
MHM
1296 mXPUSHi(-1);
1297 mXPUSHi(2);
1298 mXPUSHi(-3);
d4b90eee
SH
1299 XSRETURN(3);
1300
1301void
1302mxpushu()
1303 PPCODE:
d75b63cf
MHM
1304 mXPUSHu(1);
1305 mXPUSHu(2);
1306 mXPUSHu(3);
d4b90eee 1307 XSRETURN(3);
d1f347d7
DM
1308
1309
1310void
1311call_sv(sv, flags, ...)
1312 SV* sv
1313 I32 flags
1314 PREINIT:
1315 I32 i;
1316 PPCODE:
1317 for (i=0; i<items-2; i++)
1318 ST(i) = ST(i+2); /* pop first two args */
1319 PUSHMARK(SP);
1320 SP += items - 2;
1321 PUTBACK;
1322 i = call_sv(sv, flags);
1323 SPAGAIN;
1324 EXTEND(SP, 1);
1325 PUSHs(sv_2mortal(newSViv(i)));
1326
1327void
1328call_pv(subname, flags, ...)
1329 char* subname
1330 I32 flags
1331 PREINIT:
1332 I32 i;
1333 PPCODE:
1334 for (i=0; i<items-2; i++)
1335 ST(i) = ST(i+2); /* pop first two args */
1336 PUSHMARK(SP);
1337 SP += items - 2;
1338 PUTBACK;
1339 i = call_pv(subname, flags);
1340 SPAGAIN;
1341 EXTEND(SP, 1);
1342 PUSHs(sv_2mortal(newSViv(i)));
1343
1344void
1345call_method(methname, flags, ...)
1346 char* methname
1347 I32 flags
1348 PREINIT:
1349 I32 i;
1350 PPCODE:
1351 for (i=0; i<items-2; i++)
1352 ST(i) = ST(i+2); /* pop first two args */
1353 PUSHMARK(SP);
1354 SP += items - 2;
1355 PUTBACK;
1356 i = call_method(methname, flags);
1357 SPAGAIN;
1358 EXTEND(SP, 1);
1359 PUSHs(sv_2mortal(newSViv(i)));
1360
1361void
1362eval_sv(sv, flags)
1363 SV* sv
1364 I32 flags
1365 PREINIT:
1366 I32 i;
1367 PPCODE:
1368 PUTBACK;
1369 i = eval_sv(sv, flags);
1370 SPAGAIN;
1371 EXTEND(SP, 1);
1372 PUSHs(sv_2mortal(newSViv(i)));
1373
b8e65a9b 1374void
d1f347d7
DM
1375eval_pv(p, croak_on_error)
1376 const char* p
1377 I32 croak_on_error
d1f347d7
DM
1378 PPCODE:
1379 PUTBACK;
1380 EXTEND(SP, 1);
1381 PUSHs(eval_pv(p, croak_on_error));
1382
1383void
1384require_pv(pv)
1385 const char* pv
d1f347d7
DM
1386 PPCODE:
1387 PUTBACK;
1388 require_pv(pv);
1389
0ca3a874 1390int
7a646707 1391apitest_exception(throw_e)
0ca3a874
MHM
1392 int throw_e
1393 OUTPUT:
1394 RETVAL
d1f347d7 1395
ef469b03 1396void
7e7a3dfc
GA
1397mycroak(sv)
1398 SV* sv
ef469b03 1399 CODE:
7e7a3dfc
GA
1400 if (SvOK(sv)) {
1401 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
1402 }
1403 else {
1404 Perl_croak(aTHX_ NULL);
1405 }
5d2b1485
NC
1406
1407SV*
1408strtab()
1409 CODE:
1410 RETVAL = newRV_inc((SV*)PL_strtab);
1411 OUTPUT:
1412 RETVAL
85ce96a1
DM
1413
1414int
1415my_cxt_getint()
1416 CODE:
1417 dMY_CXT;
1418 RETVAL = my_cxt_getint_p(aMY_CXT);
1419 OUTPUT:
1420 RETVAL
1421
1422void
1423my_cxt_setint(i)
1424 int i;
1425 CODE:
1426 dMY_CXT;
1427 my_cxt_setint_p(aMY_CXT_ i);
1428
1429void
9568a123
NC
1430my_cxt_getsv(how)
1431 bool how;
85ce96a1 1432 PPCODE:
85ce96a1 1433 EXTEND(SP, 1);
9568a123 1434 ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
85ce96a1
DM
1435 XSRETURN(1);
1436
1437void
1438my_cxt_setsv(sv)
1439 SV *sv;
1440 CODE:
1441 dMY_CXT;
1442 SvREFCNT_dec(MY_CXT.sv);
1443 my_cxt_setsv_p(sv _aMY_CXT);
1444 SvREFCNT_inc(sv);
34482cd6
NC
1445
1446bool
1447sv_setsv_cow_hashkey_core()
1448
1449bool
1450sv_setsv_cow_hashkey_notcore()
84ac5fd7
NC
1451
1452void
218787bd
VP
1453rmagical_cast(sv, type)
1454 SV *sv;
1455 SV *type;
1456 PREINIT:
1457 struct ufuncs uf;
1458 PPCODE:
1459 if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
1460 sv = SvRV(sv);
1461 if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
1462 uf.uf_val = rmagical_a_dummy;
1463 uf.uf_set = NULL;
1464 uf.uf_index = 0;
1465 if (SvTRUE(type)) { /* b */
1466 sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
1467 } else { /* a */
1468 sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
1469 }
1470 XSRETURN_YES;
1471
1472void
1473rmagical_flags(sv)
1474 SV *sv;
1475 PPCODE:
1476 if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
1477 sv = SvRV(sv);
1478 EXTEND(SP, 3);
1479 mXPUSHu(SvFLAGS(sv) & SVs_GMG);
1480 mXPUSHu(SvFLAGS(sv) & SVs_SMG);
1481 mXPUSHu(SvFLAGS(sv) & SVs_RMG);
1482 XSRETURN(3);
1483
1484void
90d1f214
BM
1485my_caller(level)
1486 I32 level
1487 PREINIT:
1488 const PERL_CONTEXT *cx, *dbcx;
1489 const char *pv;
1490 const GV *gv;
1491 HV *hv;
1492 PPCODE:
1493 cx = caller_cx(level, &dbcx);
1494 EXTEND(SP, 8);
1495
1496 pv = CopSTASHPV(cx->blk_oldcop);
1497 ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1498 gv = CvGV(cx->blk_sub.cv);
1499 ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1500
1501 pv = CopSTASHPV(dbcx->blk_oldcop);
1502 ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1503 gv = CvGV(dbcx->blk_sub.cv);
1504 ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1505
1506 ST(4) = cop_hints_fetchpvs(cx->blk_oldcop, "foo");
1507 ST(5) = cop_hints_fetchpvn(cx->blk_oldcop, "foo", 3, 0, 0);
1508 ST(6) = cop_hints_fetchsv(cx->blk_oldcop,
1509 sv_2mortal(newSVpvn("foo", 3)), 0);
1510
1511 hv = cop_hints_2hv(cx->blk_oldcop);
1512 ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
1513
1514 XSRETURN(8);
1515
1516void
f9c17636
MB
1517DPeek (sv)
1518 SV *sv
1519
1520 PPCODE:
5b1f7359 1521 ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
f9c17636
MB
1522 XSRETURN (1);
1523
1524void
84ac5fd7
NC
1525BEGIN()
1526 CODE:
1527 sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1528
1529void
1530CHECK()
1531 CODE:
1532 sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1533
1534void
1535UNITCHECK()
1536 CODE:
0932863f 1537 sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
84ac5fd7
NC
1538
1539void
1540INIT()
1541 CODE:
1542 sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1543
1544void
1545END()
1546 CODE:
1547 sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
30685b56
NC
1548
1549void
1550utf16_to_utf8 (sv, ...)
1551 SV* sv
1552 ALIAS:
1553 utf16_to_utf8_reversed = 1
1554 PREINIT:
1555 STRLEN len;
1556 U8 *source;
1557 SV *dest;
1558 I32 got; /* Gah, badly thought out APIs */
1559 CODE:
1560 source = (U8 *)SvPVbyte(sv, len);
1561 /* Optionally only convert part of the buffer. */
1562 if (items > 1) {
1563 len = SvUV(ST(1));
1564 }
1565 /* Mortalise this right now, as we'll be testing croak()s */
1566 dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1567 if (ix) {
25f2e844 1568 utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
30685b56 1569 } else {
25f2e844 1570 utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
30685b56
NC
1571 }
1572 SvCUR_set(dest, got);
1573 SvPVX(dest)[got] = '\0';
1574 SvPOK_on(dest);
1575 ST(0) = dest;
1576 XSRETURN(1);
879d0c72 1577
6bd7445c
GG
1578void
1579my_exit(int exitcode)
1580 PPCODE:
1581 my_exit(exitcode);
d97c33b5
DM
1582
1583I32
1584sv_count()
1585 CODE:
1586 RETVAL = PL_sv_count;
1587 OUTPUT:
1588 RETVAL
13b6b3bc
BM
1589
1590void
1591bhk_record(bool on)
1592 CODE:
1593 dMY_CXT;
1594 MY_CXT.bhk_record = on;
1595 if (on)
1596 av_clear(MY_CXT.bhkav);
65bfe90c 1597
defdfed5 1598void
d9088386
Z
1599test_magic_chain()
1600 PREINIT:
1601 SV *sv;
1602 MAGIC *callmg, *uvarmg;
1603 CODE:
1604 sv = sv_2mortal(newSV(0));
11f9f0ed
NC
1605 if (SvTYPE(sv) >= SVt_PVMG) croak_fail();
1606 if (SvMAGICAL(sv)) croak_fail();
d9088386 1607 sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0);
11f9f0ed
NC
1608 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1609 if (!SvMAGICAL(sv)) croak_fail();
1610 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
d9088386 1611 callmg = mg_find(sv, PERL_MAGIC_checkcall);
11f9f0ed 1612 if (!callmg) croak_fail();
d9088386 1613 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 1614 croak_fail();
d9088386 1615 sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
11f9f0ed
NC
1616 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1617 if (!SvMAGICAL(sv)) croak_fail();
1618 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
d9088386 1619 uvarmg = mg_find(sv, PERL_MAGIC_uvar);
11f9f0ed 1620 if (!uvarmg) croak_fail();
d9088386 1621 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 1622 croak_fail();
d9088386 1623 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 1624 croak_fail();
d9088386 1625 mg_free_type(sv, PERL_MAGIC_vec);
11f9f0ed
NC
1626 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1627 if (!SvMAGICAL(sv)) croak_fail();
1628 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
1629 if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
d9088386 1630 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 1631 croak_fail();
d9088386 1632 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 1633 croak_fail();
d9088386 1634 mg_free_type(sv, PERL_MAGIC_uvar);
11f9f0ed
NC
1635 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1636 if (!SvMAGICAL(sv)) croak_fail();
1637 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
1638 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
d9088386 1639 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 1640 croak_fail();
d9088386 1641 sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
11f9f0ed
NC
1642 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1643 if (!SvMAGICAL(sv)) croak_fail();
1644 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
d9088386 1645 uvarmg = mg_find(sv, PERL_MAGIC_uvar);
11f9f0ed 1646 if (!uvarmg) croak_fail();
d9088386 1647 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 1648 croak_fail();
d9088386 1649 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 1650 croak_fail();
d9088386 1651 mg_free_type(sv, PERL_MAGIC_checkcall);
11f9f0ed
NC
1652 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1653 if (!SvMAGICAL(sv)) croak_fail();
1654 if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
1655 if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
d9088386 1656 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 1657 croak_fail();
d9088386 1658 mg_free_type(sv, PERL_MAGIC_uvar);
11f9f0ed
NC
1659 if (SvMAGICAL(sv)) croak_fail();
1660 if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
1661 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
d9088386
Z
1662
1663void
1664test_op_contextualize()
1665 PREINIT:
1666 OP *o;
1667 CODE:
1668 o = newSVOP(OP_CONST, 0, newSViv(0));
1669 o->op_flags &= ~OPf_WANT;
1670 o = op_contextualize(o, G_SCALAR);
1671 if (o->op_type != OP_CONST ||
1672 (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
11f9f0ed 1673 croak_fail();
d9088386
Z
1674 op_free(o);
1675 o = newSVOP(OP_CONST, 0, newSViv(0));
1676 o->op_flags &= ~OPf_WANT;
1677 o = op_contextualize(o, G_ARRAY);
1678 if (o->op_type != OP_CONST ||
1679 (o->op_flags & OPf_WANT) != OPf_WANT_LIST)
11f9f0ed 1680 croak_fail();
d9088386
Z
1681 op_free(o);
1682 o = newSVOP(OP_CONST, 0, newSViv(0));
1683 o->op_flags &= ~OPf_WANT;
1684 o = op_contextualize(o, G_VOID);
11f9f0ed 1685 if (o->op_type != OP_NULL) croak_fail();
d9088386
Z
1686 op_free(o);
1687
1688void
1689test_rv2cv_op_cv()
1690 PROTOTYPE:
1691 PREINIT:
1692 GV *troc_gv, *wibble_gv;
1693 CV *troc_cv;
1694 OP *o;
1695 CODE:
1696 troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
1697 troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
1698 wibble_gv = gv_fetchpv("XS::APItest::wibble", 0, SVt_PVGV);
1699 o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
11f9f0ed 1700 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
d9088386 1701 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
11f9f0ed 1702 croak_fail();
d9088386 1703 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC
1704 if (rv2cv_op_cv(o, 0)) croak_fail();
1705 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 1706 o->op_private &= ~OPpENTERSUB_AMPER;
11f9f0ed
NC
1707 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1708 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
1709 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
d9088386
Z
1710 op_free(o);
1711 o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0));
1712 o->op_private = OPpCONST_BARE;
1713 o = newCVREF(0, o);
11f9f0ed 1714 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
d9088386 1715 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
11f9f0ed 1716 croak_fail();
d9088386 1717 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC
1718 if (rv2cv_op_cv(o, 0)) croak_fail();
1719 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386
Z
1720 op_free(o);
1721 o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv)));
11f9f0ed 1722 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
d9088386 1723 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
11f9f0ed 1724 croak_fail();
d9088386 1725 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC
1726 if (rv2cv_op_cv(o, 0)) croak_fail();
1727 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 1728 o->op_private &= ~OPpENTERSUB_AMPER;
11f9f0ed
NC
1729 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1730 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
1731 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
d9088386
Z
1732 op_free(o);
1733 o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))));
11f9f0ed
NC
1734 if (rv2cv_op_cv(o, 0)) croak_fail();
1735 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 1736 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC
1737 if (rv2cv_op_cv(o, 0)) croak_fail();
1738 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 1739 o->op_private &= ~OPpENTERSUB_AMPER;
11f9f0ed
NC
1740 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1741 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail();
1742 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
d9088386
Z
1743 op_free(o);
1744 o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)));
11f9f0ed
NC
1745 if (rv2cv_op_cv(o, 0)) croak_fail();
1746 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386
Z
1747 op_free(o);
1748
1749void
1750test_cv_getset_call_checker()
1751 PREINIT:
1752 CV *troc_cv, *tsh_cv;
1753 Perl_call_checker ckfun;
1754 SV *ckobj;
1755 CODE:
1756#define check_cc(cv, xckfun, xckobj) \
1757 do { \
1758 cv_get_call_checker((cv), &ckfun, &ckobj); \
11f9f0ed 1759 if (ckfun != (xckfun) || ckobj != (xckobj)) croak_fail(); \
d9088386
Z
1760 } while(0)
1761 troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
1762 tsh_cv = get_cv("XS::APItest::test_savehints", 0);
1763 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
1764 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
1765 cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
1766 &PL_sv_yes);
1767 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
1768 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
1769 cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
1770 check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
1771 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
1772 cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
1773 (SV*)tsh_cv);
1774 check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
1775 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
1776 cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list,
1777 (SV*)troc_cv);
1778 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
1779 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
11f9f0ed
NC
1780 if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail();
1781 if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
d9088386
Z
1782#undef check_cc
1783
1784void
1785cv_set_call_checker_lists(CV *cv)
1786 CODE:
1787 cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
1788
1789void
1790cv_set_call_checker_scalars(CV *cv)
1791 CODE:
1792 cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
1793
1794void
1795cv_set_call_checker_proto(CV *cv, SV *proto)
1796 CODE:
1797 if (SvROK(proto))
1798 proto = SvRV(proto);
1799 cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
1800
1801void
1802cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
1803 CODE:
1804 if (SvROK(proto))
1805 proto = SvRV(proto);
1806 cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
1807
1808void
1809cv_set_call_checker_multi_sum(CV *cv)
1810 CODE:
1811 cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
1812
1813void
defdfed5
Z
1814test_savehints()
1815 PREINIT:
1816 SV **svp, *sv;
1817 CODE:
1818#define store_hint(KEY, VALUE) \
1819 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
1820#define hint_ok(KEY, EXPECT) \
1821 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
1822 (sv = *svp) && SvIV(sv) == (EXPECT) && \
1823 (sv = cop_hints_fetchpvs(&PL_compiling, KEY)) && \
1824 SvIV(sv) == (EXPECT))
1825#define check_hint(KEY, EXPECT) \
11f9f0ed 1826 do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0)
defdfed5
Z
1827 PL_hints |= HINT_LOCALIZE_HH;
1828 ENTER;
1829 SAVEHINTS();
1830 PL_hints &= HINT_INTEGER;
1831 store_hint("t0", 123);
1832 store_hint("t1", 456);
11f9f0ed 1833 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
1834 check_hint("t0", 123); check_hint("t1", 456);
1835 ENTER;
1836 SAVEHINTS();
11f9f0ed 1837 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
1838 check_hint("t0", 123); check_hint("t1", 456);
1839 PL_hints |= HINT_INTEGER;
1840 store_hint("t0", 321);
11f9f0ed 1841 if (!(PL_hints & HINT_INTEGER)) croak_fail();
defdfed5
Z
1842 check_hint("t0", 321); check_hint("t1", 456);
1843 LEAVE;
11f9f0ed 1844 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
1845 check_hint("t0", 123); check_hint("t1", 456);
1846 ENTER;
1847 SAVEHINTS();
11f9f0ed 1848 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
1849 check_hint("t0", 123); check_hint("t1", 456);
1850 store_hint("t1", 654);
11f9f0ed 1851 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
1852 check_hint("t0", 123); check_hint("t1", 654);
1853 LEAVE;
11f9f0ed 1854 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
1855 check_hint("t0", 123); check_hint("t1", 456);
1856 LEAVE;
1857#undef store_hint
1858#undef hint_ok
1859#undef check_hint
1860
1861void
1862test_copyhints()
1863 PREINIT:
1864 HV *a, *b;
1865 CODE:
1866 PL_hints |= HINT_LOCALIZE_HH;
1867 ENTER;
1868 SAVEHINTS();
1869 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
11f9f0ed 1870 if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak_fail();
defdfed5
Z
1871 a = newHVhv(GvHV(PL_hintgv));
1872 sv_2mortal((SV*)a);
1873 sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
11f9f0ed 1874 if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak_fail();
defdfed5
Z
1875 b = hv_copy_hints_hv(a);
1876 sv_2mortal((SV*)b);
1877 sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
11f9f0ed 1878 if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 789) croak_fail();
defdfed5
Z
1879 LEAVE;
1880
201c7e1f 1881void
2fcb4757
Z
1882test_op_list()
1883 PREINIT:
1884 OP *a;
1885 CODE:
1886#define iv_op(iv) newSVOP(OP_CONST, 0, newSViv(iv))
1887#define check_op(o, expect) \
1888 do { \
1889 if (strcmp(test_op_list_describe(o), (expect))) \
1890 croak("fail %s %s", test_op_list_describe(o), (expect)); \
1891 } while(0)
1892 a = op_append_elem(OP_LIST, NULL, NULL);
1893 check_op(a, "");
1894 a = op_append_elem(OP_LIST, iv_op(1), a);
1895 check_op(a, "const(1).");
1896 a = op_append_elem(OP_LIST, NULL, a);
1897 check_op(a, "const(1).");
1898 a = op_append_elem(OP_LIST, a, iv_op(2));
1899 check_op(a, "list[pushmark.const(1).const(2).]");
1900 a = op_append_elem(OP_LIST, a, iv_op(3));
1901 check_op(a, "list[pushmark.const(1).const(2).const(3).]");
1902 a = op_append_elem(OP_LIST, a, NULL);
1903 check_op(a, "list[pushmark.const(1).const(2).const(3).]");
1904 a = op_append_elem(OP_LIST, NULL, a);
1905 check_op(a, "list[pushmark.const(1).const(2).const(3).]");
1906 a = op_append_elem(OP_LIST, iv_op(4), a);
1907 check_op(a, "list[pushmark.const(4)."
1908 "list[pushmark.const(1).const(2).const(3).]]");
1909 a = op_append_elem(OP_LIST, a, iv_op(5));
1910 check_op(a, "list[pushmark.const(4)."
1911 "list[pushmark.const(1).const(2).const(3).]const(5).]");
1912 a = op_append_elem(OP_LIST, a,
1913 op_append_elem(OP_LIST, iv_op(7), iv_op(6)));
1914 check_op(a, "list[pushmark.const(4)."
1915 "list[pushmark.const(1).const(2).const(3).]const(5)."
1916 "list[pushmark.const(7).const(6).]]");
1917 op_free(a);
1918 a = op_append_elem(OP_LINESEQ, iv_op(1), iv_op(2));
1919 check_op(a, "lineseq[const(1).const(2).]");
1920 a = op_append_elem(OP_LINESEQ, a, iv_op(3));
1921 check_op(a, "lineseq[const(1).const(2).const(3).]");
1922 op_free(a);
1923 a = op_append_elem(OP_LINESEQ,
1924 op_append_elem(OP_LIST, iv_op(1), iv_op(2)),
1925 iv_op(3));
1926 check_op(a, "lineseq[list[pushmark.const(1).const(2).]const(3).]");
1927 op_free(a);
1928 a = op_prepend_elem(OP_LIST, NULL, NULL);
1929 check_op(a, "");
1930 a = op_prepend_elem(OP_LIST, a, iv_op(1));
1931 check_op(a, "const(1).");
1932 a = op_prepend_elem(OP_LIST, a, NULL);
1933 check_op(a, "const(1).");
1934 a = op_prepend_elem(OP_LIST, iv_op(2), a);
1935 check_op(a, "list[pushmark.const(2).const(1).]");
1936 a = op_prepend_elem(OP_LIST, iv_op(3), a);
1937 check_op(a, "list[pushmark.const(3).const(2).const(1).]");
1938 a = op_prepend_elem(OP_LIST, NULL, a);
1939 check_op(a, "list[pushmark.const(3).const(2).const(1).]");
1940 a = op_prepend_elem(OP_LIST, a, NULL);
1941 check_op(a, "list[pushmark.const(3).const(2).const(1).]");
1942 a = op_prepend_elem(OP_LIST, a, iv_op(4));
1943 check_op(a, "list[pushmark."
1944 "list[pushmark.const(3).const(2).const(1).]const(4).]");
1945 a = op_prepend_elem(OP_LIST, iv_op(5), a);
1946 check_op(a, "list[pushmark.const(5)."
1947 "list[pushmark.const(3).const(2).const(1).]const(4).]");
1948 a = op_prepend_elem(OP_LIST,
1949 op_prepend_elem(OP_LIST, iv_op(6), iv_op(7)), a);
1950 check_op(a, "list[pushmark.list[pushmark.const(6).const(7).]const(5)."
1951 "list[pushmark.const(3).const(2).const(1).]const(4).]");
1952 op_free(a);
1953 a = op_prepend_elem(OP_LINESEQ, iv_op(2), iv_op(1));
1954 check_op(a, "lineseq[const(2).const(1).]");
1955 a = op_prepend_elem(OP_LINESEQ, iv_op(3), a);
1956 check_op(a, "lineseq[const(3).const(2).const(1).]");
1957 op_free(a);
1958 a = op_prepend_elem(OP_LINESEQ, iv_op(3),
1959 op_prepend_elem(OP_LIST, iv_op(2), iv_op(1)));
1960 check_op(a, "lineseq[const(3).list[pushmark.const(2).const(1).]]");
1961 op_free(a);
1962 a = op_append_list(OP_LINESEQ, NULL, NULL);
1963 check_op(a, "");
1964 a = op_append_list(OP_LINESEQ, iv_op(1), a);
1965 check_op(a, "const(1).");
1966 a = op_append_list(OP_LINESEQ, NULL, a);
1967 check_op(a, "const(1).");
1968 a = op_append_list(OP_LINESEQ, a, iv_op(2));
1969 check_op(a, "lineseq[const(1).const(2).]");
1970 a = op_append_list(OP_LINESEQ, a, iv_op(3));
1971 check_op(a, "lineseq[const(1).const(2).const(3).]");
1972 a = op_append_list(OP_LINESEQ, iv_op(4), a);
1973 check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
1974 a = op_append_list(OP_LINESEQ, a, NULL);
1975 check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
1976 a = op_append_list(OP_LINESEQ, NULL, a);
1977 check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
1978 a = op_append_list(OP_LINESEQ, a,
1979 op_append_list(OP_LINESEQ, iv_op(5), iv_op(6)));
1980 check_op(a, "lineseq[const(4).const(1).const(2).const(3)."
1981 "const(5).const(6).]");
1982 op_free(a);
1983 a = op_append_list(OP_LINESEQ,
1984 op_append_list(OP_LINESEQ, iv_op(1), iv_op(2)),
1985 op_append_list(OP_LIST, iv_op(3), iv_op(4)));
1986 check_op(a, "lineseq[const(1).const(2)."
1987 "list[pushmark.const(3).const(4).]]");
1988 op_free(a);
1989 a = op_append_list(OP_LINESEQ,
1990 op_append_list(OP_LIST, iv_op(1), iv_op(2)),
1991 op_append_list(OP_LINESEQ, iv_op(3), iv_op(4)));
1992 check_op(a, "lineseq[list[pushmark.const(1).const(2).]"
1993 "const(3).const(4).]");
1994 op_free(a);
2fcb4757
Z
1995#undef check_op
1996
1997void
5983a79d
BM
1998test_op_linklist ()
1999 PREINIT:
2000 OP *o;
2001 CODE:
2002#define check_ll(o, expect) \
2003 STMT_START { \
2004 if (strNE(test_op_linklist_describe(o), (expect))) \
2005 croak("fail %s %s", test_op_linklist_describe(o), (expect)); \
2006 } STMT_END
2007 o = iv_op(1);
2008 check_ll(o, ".const1");
2009 op_free(o);
2010
2011 o = mkUNOP(OP_NOT, iv_op(1));
2012 check_ll(o, ".const1.not");
2013 op_free(o);
2014
2015 o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1)));
2016 check_ll(o, ".const1.negate.not");
2017 op_free(o);
2018
2019 o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
2020 check_ll(o, ".const1.const2.add");
2021 op_free(o);
2022
2023 o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2));
2024 check_ll(o, ".const1.not.const2.add");
2025 op_free(o);
2026
2027 o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2)));
2028 check_ll(o, ".const1.const2.add.not");
2029 op_free(o);
2030
2031 o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3));
2032 check_ll(o, ".const1.const2.const3.lineseq");
2033 op_free(o);
2034
2035 o = mkLISTOP(OP_LINESEQ,
2036 mkBINOP(OP_ADD, iv_op(1), iv_op(2)),
2037 mkUNOP(OP_NOT, iv_op(3)),
2038 mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6)));
2039 check_ll(o, ".const1.const2.add.const3.not"
2040 ".const4.const5.const6.substr.lineseq");
2041 op_free(o);
2042
2043 o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
2044 LINKLIST(o);
2045 o = mkBINOP(OP_SUBTRACT, o, iv_op(3));
2046 check_ll(o, ".const1.const2.add.const3.subtract");
2047 op_free(o);
2048#undef check_ll
2049#undef iv_op
2050
2051void
201c7e1f
FR
2052peep_enable ()
2053 PREINIT:
2054 dMY_CXT;
2055 CODE:
2056 av_clear(MY_CXT.peep_recorder);
2057 av_clear(MY_CXT.rpeep_recorder);
2058 MY_CXT.peep_recording = 1;
2059
2060void
2061peep_disable ()
2062 PREINIT:
2063 dMY_CXT;
2064 CODE:
2065 MY_CXT.peep_recording = 0;
2066
2067SV *
2068peep_record ()
2069 PREINIT:
2070 dMY_CXT;
2071 CODE:
95d2461a 2072 RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
201c7e1f
FR
2073 OUTPUT:
2074 RETVAL
2075
2076SV *
2077rpeep_record ()
2078 PREINIT:
2079 dMY_CXT;
2080 CODE:
95d2461a 2081 RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
201c7e1f
FR
2082 OUTPUT:
2083 RETVAL
2084
9c540340
DM
2085=pod
2086
2087multicall_each: call a sub for each item in the list. Used to test MULTICALL
2088
2089=cut
2090
2091void
2092multicall_each(block,...)
2093 SV * block
2094PROTOTYPE: &@
2095CODE:
2096{
2097 dMULTICALL;
2098 int index;
2099 GV *gv;
2100 HV *stash;
2101 I32 gimme = G_SCALAR;
2102 SV **args = &PL_stack_base[ax];
2103 CV *cv;
2104
2105 if(items <= 1) {
2106 XSRETURN_UNDEF;
2107 }
2108 cv = sv_2cv(block, &stash, &gv, 0);
2109 if (cv == Nullcv) {
2110 croak("multicall_each: not a subroutine reference");
2111 }
2112 PUSH_MULTICALL(cv);
2113 SAVESPTR(GvSV(PL_defgv));
2114
2115 for(index = 1 ; index < items ; index++) {
2116 GvSV(PL_defgv) = args[index];
2117 MULTICALL;
2118 }
2119 POP_MULTICALL;
2120 XSRETURN_UNDEF;
2121}
2122
2123
e2fe06dd
EB
2124BOOT:
2125 {
2126 HV* stash;
2127 SV** meth = NULL;
2128 CV* cv;
2129 stash = gv_stashpv("XS::APItest::TempLv", 0);
2130 if (stash)
2131 meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
2132 if (!meth)
2133 croak("lost method 'make_temp_mg_lv'");
2134 cv = GvCV(*meth);
2135 CvLVALUE_on(cv);
2136 }
83f8bb56
Z
2137
2138BOOT:
2139{
2140 hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
2141 hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
2142 hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
2143 hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
07ffcb73 2144 hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
83f8bb56
Z
2145 next_keyword_plugin = PL_keyword_plugin;
2146 PL_keyword_plugin = my_keyword_plugin;
2147}