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