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