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