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