This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix some 32/64-bit compiler warnings
[perl5.git] / ext / XS-APItest / APItest.xs
CommitLineData
6a93a7e5 1#define PERL_IN_XS_APITEST
73e43954
HS
2
3/* We want to be able to test things that aren't API yet. */
4#define PERL_EXT
5
3e61d65a
JH
6#include "EXTERN.h"
7#include "perl.h"
8#include "XSUB.h"
62df7c7d 9#include "fakesdio.h" /* Causes us to use PerlIO below */
3e61d65a 10
36c2b1d0
NC
11typedef SV *SVREF;
12typedef PTR_TBL_t *XS__APItest__PtrTable;
85ce96a1 13
11f9f0ed 14#define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__)
779bc08a 15#define croak_fail_ne(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__)
11f9f0ed 16
72900640
KW
17#ifdef EBCDIC
18
19void
20cat_utf8a2n(SV* sv, const char * const ascii_utf8, STRLEN len)
21{
22 /* Converts variant UTF-8 text pointed to by 'ascii_utf8' of length 'len',
23 * to UTF-EBCDIC, appending that text to the text already in 'sv'.
24 * Currently doesn't work on invariants, as that is unneeded here, and we
25 * could get double translations if we did.
26 *
27 * It has the algorithm for strict UTF-8 hard-coded in to find the code
28 * point it represents, then calls uvchr_to_utf8() to convert to
29 * UTF-EBCDIC).
30 *
31 * Note that this uses code points, not characters. Thus if the input is
32 * the UTF-8 for the code point 0xFF, the output will be the UTF-EBCDIC for
33 * 0xFF, even though that code point represents different characters on
34 * ASCII vs EBCDIC platforms. */
35
36 dTHX;
37 char * p = (char *) ascii_utf8;
38 const char * const e = p + len;
39
40 while (p < e) {
41 UV code_point;
42 U8 native_utf8[UTF8_MAXBYTES + 1];
43 U8 * char_end;
44 U8 start = (U8) *p;
45
46 /* Start bytes are the same in both UTF-8 and I8, therefore we can
47 * treat this ASCII UTF-8 byte as an I8 byte. But PL_utf8skip[] is
48 * indexed by NATIVE_UTF8 bytes, so transform to that */
49 STRLEN char_bytes_len = PL_utf8skip[I8_TO_NATIVE_UTF8(start)];
50
51 if (start < 0xc2) {
52 croak("fail: Expecting start byte, instead got 0x%X at %s line %d",
53 (U8) *p, __FILE__, __LINE__);
54 }
55 code_point = (start & (((char_bytes_len) >= 7)
56 ? 0x00
57 : (0x1F >> ((char_bytes_len)-2))));
58 p++;
59 while (p < e && ((( (U8) *p) & 0xC0) == 0x80)) {
60
61 code_point = (code_point << 6) | (( (U8) *p) & 0x3F);
62 p++;
63 }
64
65 char_end = uvchr_to_utf8(native_utf8, code_point);
66 sv_catpvn(sv, (char *) native_utf8, char_end - native_utf8);
67 }
68}
69
70#endif
71
85ce96a1
DM
72/* for my_cxt tests */
73
74#define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
75
76typedef struct {
77 int i;
78 SV *sv;
03569ecf
BM
79 GV *cscgv;
80 AV *cscav;
13b6b3bc
BM
81 AV *bhkav;
82 bool bhk_record;
201c7e1f
FR
83 peep_t orig_peep;
84 peep_t orig_rpeep;
85 int peep_recording;
86 AV *peep_recorder;
87 AV *rpeep_recorder;
f568d64d 88 AV *xop_record;
85ce96a1
DM
89} my_cxt_t;
90
91START_MY_CXT
92
26ab20ee
FR
93MGVTBL vtbl_foo, vtbl_bar;
94
85ce96a1 95/* indirect functions to test the [pa]MY_CXT macros */
f16dd614 96
85ce96a1
DM
97int
98my_cxt_getint_p(pMY_CXT)
99{
100 return MY_CXT.i;
101}
f16dd614 102
85ce96a1
DM
103void
104my_cxt_setint_p(pMY_CXT_ int i)
105{
106 MY_CXT.i = i;
107}
f16dd614
DM
108
109SV*
9568a123 110my_cxt_getsv_interp_context(void)
f16dd614 111{
f16dd614
DM
112 dTHX;
113 dMY_CXT_INTERP(my_perl);
9568a123
NC
114 return MY_CXT.sv;
115}
116
117SV*
118my_cxt_getsv_interp(void)
119{
f16dd614 120 dMY_CXT;
f16dd614
DM
121 return MY_CXT.sv;
122}
123
85ce96a1
DM
124void
125my_cxt_setsv_p(SV* sv _pMY_CXT)
126{
127 MY_CXT.sv = sv;
128}
129
130
9b5c3821 131/* from exception.c */
7a646707 132int apitest_exception(int);
0314122a 133
ff66e713
SH
134/* from core_or_not.inc */
135bool sv_setsv_cow_hashkey_core(void);
136bool sv_setsv_cow_hashkey_notcore(void);
137
2dc92170
NC
138/* A routine to test hv_delayfree_ent
139 (which itself is tested by testing on hv_free_ent */
140
5aaab254 141typedef void (freeent_function)(pTHX_ HV *, HE *);
2dc92170
NC
142
143void
144test_freeent(freeent_function *f) {
2dc92170
NC
145 dSP;
146 HV *test_hash = newHV();
147 HE *victim;
148 SV *test_scalar;
149 U32 results[4];
150 int i;
151
8afd2d2e
NC
152#ifdef PURIFY
153 victim = (HE*)safemalloc(sizeof(HE));
154#else
2dc92170
NC
155 /* Storing then deleting something should ensure that a hash entry is
156 available. */
c33e8be1
Z
157 (void) hv_store(test_hash, "", 0, &PL_sv_yes, 0);
158 (void) hv_delete(test_hash, "", 0, 0);
2dc92170
NC
159
160 /* We need to "inline" new_he here as it's static, and the functions we
161 test expect to be able to call del_HE on the HE */
6a93a7e5 162 if (!PL_body_roots[HE_SVSLOT])
2dc92170 163 croak("PL_he_root is 0");
8a722a80 164 victim = (HE*) PL_body_roots[HE_SVSLOT];
6a93a7e5 165 PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
8afd2d2e 166#endif
2dc92170
NC
167
168 victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
169
170 test_scalar = newSV(0);
171 SvREFCNT_inc(test_scalar);
de616631 172 HeVAL(victim) = test_scalar;
2dc92170
NC
173
174 /* Need this little game else we free the temps on the return stack. */
175 results[0] = SvREFCNT(test_scalar);
176 SAVETMPS;
177 results[1] = SvREFCNT(test_scalar);
178 f(aTHX_ test_hash, victim);
179 results[2] = SvREFCNT(test_scalar);
180 FREETMPS;
181 results[3] = SvREFCNT(test_scalar);
182
183 i = 0;
184 do {
185 mPUSHu(results[i]);
c33e8be1 186 } while (++i < (int)(sizeof(results)/sizeof(results[0])));
2dc92170
NC
187
188 /* Goodbye to our extra reference. */
189 SvREFCNT_dec(test_scalar);
190}
191
b54b4831
NC
192
193static I32
53c40a8f
NC
194bitflip_key(pTHX_ IV action, SV *field) {
195 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
196 SV *keysv;
c33e8be1 197 PERL_UNUSED_ARG(action);
53c40a8f
NC
198 if (mg && (keysv = mg->mg_obj)) {
199 STRLEN len;
200 const char *p = SvPV(keysv, len);
201
202 if (len) {
203 SV *newkey = newSV(len);
204 char *new_p = SvPVX(newkey);
205
206 if (SvUTF8(keysv)) {
207 const char *const end = p + len;
208 while (p < end) {
209 STRLEN len;
bd70aaaf
KW
210 UV chr = utf8_to_uvchr_buf((U8 *)p, (U8 *) end, &len);
211 new_p = (char *)uvchr_to_utf8((U8 *)new_p, chr ^ 32);
53c40a8f
NC
212 p += len;
213 }
214 SvUTF8_on(newkey);
215 } else {
216 while (len--)
217 *new_p++ = *p++ ^ 32;
218 }
219 *new_p = '\0';
220 SvCUR_set(newkey, SvCUR(keysv));
221 SvPOK_on(newkey);
222
223 mg->mg_obj = newkey;
224 }
225 }
226 return 0;
227}
228
229static I32
b54b4831
NC
230rot13_key(pTHX_ IV action, SV *field) {
231 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
232 SV *keysv;
c33e8be1 233 PERL_UNUSED_ARG(action);
b54b4831
NC
234 if (mg && (keysv = mg->mg_obj)) {
235 STRLEN len;
236 const char *p = SvPV(keysv, len);
237
238 if (len) {
239 SV *newkey = newSV(len);
240 char *new_p = SvPVX(newkey);
241
242 /* There's a deliberate fencepost error here to loop len + 1 times
243 to copy the trailing \0 */
244 do {
245 char new_c = *p++;
246 /* Try doing this cleanly and clearly in EBCDIC another way: */
247 switch (new_c) {
248 case 'A': new_c = 'N'; break;
249 case 'B': new_c = 'O'; break;
250 case 'C': new_c = 'P'; break;
251 case 'D': new_c = 'Q'; break;
252 case 'E': new_c = 'R'; break;
253 case 'F': new_c = 'S'; break;
254 case 'G': new_c = 'T'; break;
255 case 'H': new_c = 'U'; break;
256 case 'I': new_c = 'V'; break;
257 case 'J': new_c = 'W'; break;
258 case 'K': new_c = 'X'; break;
259 case 'L': new_c = 'Y'; break;
260 case 'M': new_c = 'Z'; break;
261 case 'N': new_c = 'A'; break;
262 case 'O': new_c = 'B'; break;
263 case 'P': new_c = 'C'; break;
264 case 'Q': new_c = 'D'; break;
265 case 'R': new_c = 'E'; break;
266 case 'S': new_c = 'F'; break;
267 case 'T': new_c = 'G'; break;
268 case 'U': new_c = 'H'; break;
269 case 'V': new_c = 'I'; break;
270 case 'W': new_c = 'J'; break;
271 case 'X': new_c = 'K'; break;
272 case 'Y': new_c = 'L'; break;
273 case 'Z': new_c = 'M'; break;
274 case 'a': new_c = 'n'; break;
275 case 'b': new_c = 'o'; break;
276 case 'c': new_c = 'p'; break;
277 case 'd': new_c = 'q'; break;
278 case 'e': new_c = 'r'; break;
279 case 'f': new_c = 's'; break;
280 case 'g': new_c = 't'; break;
281 case 'h': new_c = 'u'; break;
282 case 'i': new_c = 'v'; break;
283 case 'j': new_c = 'w'; break;
284 case 'k': new_c = 'x'; break;
285 case 'l': new_c = 'y'; break;
286 case 'm': new_c = 'z'; break;
287 case 'n': new_c = 'a'; break;
288 case 'o': new_c = 'b'; break;
289 case 'p': new_c = 'c'; break;
290 case 'q': new_c = 'd'; break;
291 case 'r': new_c = 'e'; break;
292 case 's': new_c = 'f'; break;
293 case 't': new_c = 'g'; break;
294 case 'u': new_c = 'h'; break;
295 case 'v': new_c = 'i'; break;
296 case 'w': new_c = 'j'; break;
297 case 'x': new_c = 'k'; break;
298 case 'y': new_c = 'l'; break;
299 case 'z': new_c = 'm'; break;
300 }
301 *new_p++ = new_c;
302 } while (len--);
303 SvCUR_set(newkey, SvCUR(keysv));
304 SvPOK_on(newkey);
305 if (SvUTF8(keysv))
306 SvUTF8_on(newkey);
307
308 mg->mg_obj = newkey;
309 }
310 }
311 return 0;
312}
313
218787bd
VP
314STATIC I32
315rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
c33e8be1
Z
316 PERL_UNUSED_ARG(idx);
317 PERL_UNUSED_ARG(sv);
218787bd
VP
318 return 0;
319}
320
50495f39
JH
321/* We could do "= { 0 };" but some versions of gcc do warn
322 * (with -Wextra) about missing initializer, this is probably gcc
323 * being a bit too paranoid. But since this is file-static, we can
324 * just have it without initializer, since it should get
325 * zero-initialized. */
326STATIC MGVTBL rmagical_b;
218787bd 327
03569ecf 328STATIC void
13b6b3bc 329blockhook_csc_start(pTHX_ int full)
03569ecf
BM
330{
331 dMY_CXT;
332 AV *const cur = GvAV(MY_CXT.cscgv);
333
c33e8be1 334 PERL_UNUSED_ARG(full);
03569ecf
BM
335 SAVEGENERICSV(GvAV(MY_CXT.cscgv));
336
337 if (cur) {
338 I32 i;
d024465f 339 AV *const new_av = newAV();
03569ecf 340
b9f2b683 341 for (i = 0; i <= av_tindex(cur); i++) {
d024465f 342 av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
03569ecf
BM
343 }
344
d024465f 345 GvAV(MY_CXT.cscgv) = new_av;
03569ecf
BM
346 }
347}
348
349STATIC void
13b6b3bc 350blockhook_csc_pre_end(pTHX_ OP **o)
03569ecf
BM
351{
352 dMY_CXT;
353
c33e8be1 354 PERL_UNUSED_ARG(o);
03569ecf
BM
355 /* if we hit the end of a scope we missed the start of, we need to
356 * unconditionally clear @CSC */
52db365a 357 if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
03569ecf 358 av_clear(MY_CXT.cscav);
52db365a 359 }
03569ecf
BM
360
361}
362
13b6b3bc
BM
363STATIC void
364blockhook_test_start(pTHX_ int full)
365{
366 dMY_CXT;
367 AV *av;
368
369 if (MY_CXT.bhk_record) {
370 av = newAV();
371 av_push(av, newSVpvs("start"));
372 av_push(av, newSViv(full));
373 av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
374 }
375}
376
377STATIC void
378blockhook_test_pre_end(pTHX_ OP **o)
379{
380 dMY_CXT;
381
c33e8be1 382 PERL_UNUSED_ARG(o);
13b6b3bc
BM
383 if (MY_CXT.bhk_record)
384 av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
385}
386
387STATIC void
388blockhook_test_post_end(pTHX_ OP **o)
389{
390 dMY_CXT;
391
c33e8be1 392 PERL_UNUSED_ARG(o);
13b6b3bc
BM
393 if (MY_CXT.bhk_record)
394 av_push(MY_CXT.bhkav, newSVpvs("post_end"));
395}
396
397STATIC void
398blockhook_test_eval(pTHX_ OP *const o)
399{
400 dMY_CXT;
401 AV *av;
402
403 if (MY_CXT.bhk_record) {
404 av = newAV();
405 av_push(av, newSVpvs("eval"));
406 av_push(av, newSVpv(OP_NAME(o), 0));
407 av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
408 }
409}
410
411STATIC BHK bhk_csc, bhk_test;
412
201c7e1f
FR
413STATIC void
414my_peep (pTHX_ OP *o)
415{
416 dMY_CXT;
417
418 if (!o)
419 return;
420
421 MY_CXT.orig_peep(aTHX_ o);
422
423 if (!MY_CXT.peep_recording)
424 return;
425
426 for (; o; o = o->op_next) {
427 if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
428 av_push(MY_CXT.peep_recorder, newSVsv(cSVOPx_sv(o)));
429 }
430 }
431}
432
433STATIC void
434my_rpeep (pTHX_ OP *o)
435{
436 dMY_CXT;
437
438 if (!o)
439 return;
440
441 MY_CXT.orig_rpeep(aTHX_ o);
442
443 if (!MY_CXT.peep_recording)
444 return;
445
446 for (; o; o = o->op_next) {
447 if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
448 av_push(MY_CXT.rpeep_recorder, newSVsv(cSVOPx_sv(o)));
449 }
450 }
451}
452
d9088386
Z
453STATIC OP *
454THX_ck_entersub_args_lists(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
455{
c33e8be1
Z
456 PERL_UNUSED_ARG(namegv);
457 PERL_UNUSED_ARG(ckobj);
d9088386
Z
458 return ck_entersub_args_list(entersubop);
459}
460
461STATIC OP *
462THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
463{
464 OP *aop = cUNOPx(entersubop)->op_first;
c33e8be1
Z
465 PERL_UNUSED_ARG(namegv);
466 PERL_UNUSED_ARG(ckobj);
e6dae479 467 if (!OpHAS_SIBLING(aop))
d9088386 468 aop = cUNOPx(aop)->op_first;
e6dae479 469 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
d9088386
Z
470 op_contextualize(aop, G_SCALAR);
471 }
472 return entersubop;
473}
474
475STATIC OP *
476THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
477{
478 OP *sumop = NULL;
3253bf85 479 OP *parent = entersubop;
d9088386 480 OP *pushop = cUNOPx(entersubop)->op_first;
c33e8be1
Z
481 PERL_UNUSED_ARG(namegv);
482 PERL_UNUSED_ARG(ckobj);
e6dae479 483 if (!OpHAS_SIBLING(pushop)) {
3253bf85 484 parent = pushop;
d9088386 485 pushop = cUNOPx(pushop)->op_first;
3253bf85 486 }
d9088386 487 while (1) {
e6dae479
FC
488 OP *aop = OpSIBLING(pushop);
489 if (!OpHAS_SIBLING(aop))
d9088386 490 break;
3253bf85
DM
491 /* cut out first arg */
492 op_sibling_splice(parent, pushop, 1, NULL);
d9088386
Z
493 op_contextualize(aop, G_SCALAR);
494 if (sumop) {
495 sumop = newBINOP(OP_ADD, 0, sumop, aop);
496 } else {
497 sumop = aop;
498 }
499 }
500 if (!sumop)
501 sumop = newSVOP(OP_CONST, 0, newSViv(0));
502 op_free(entersubop);
503 return sumop;
504}
505
2fcb4757
Z
506STATIC void test_op_list_describe_part(SV *res, OP *o);
507STATIC void
508test_op_list_describe_part(SV *res, OP *o)
509{
510 sv_catpv(res, PL_op_name[o->op_type]);
511 switch (o->op_type) {
512 case OP_CONST: {
513 sv_catpvf(res, "(%d)", (int)SvIV(cSVOPx(o)->op_sv));
514 } break;
515 }
516 if (o->op_flags & OPf_KIDS) {
517 OP *k;
518 sv_catpvs(res, "[");
e6dae479 519 for (k = cUNOPx(o)->op_first; k; k = OpSIBLING(k))
2fcb4757
Z
520 test_op_list_describe_part(res, k);
521 sv_catpvs(res, "]");
522 } else {
523 sv_catpvs(res, ".");
524 }
525}
526
527STATIC char *
528test_op_list_describe(OP *o)
529{
530 SV *res = sv_2mortal(newSVpvs(""));
531 if (o)
532 test_op_list_describe_part(res, o);
533 return SvPVX(res);
534}
535
b7b1e41b 536/* the real new*OP functions have a tendency to call fold_constants, and
5983a79d
BM
537 * other such unhelpful things, so we need our own versions for testing */
538
539#define mkUNOP(t, f) THX_mkUNOP(aTHX_ (t), (f))
540static OP *
541THX_mkUNOP(pTHX_ U32 type, OP *first)
542{
543 UNOP *unop;
544 NewOp(1103, unop, 1, UNOP);
545 unop->op_type = (OPCODE)type;
29e61fd9 546 op_sibling_splice((OP*)unop, NULL, 0, first);
5983a79d
BM
547 return (OP *)unop;
548}
549
550#define mkBINOP(t, f, l) THX_mkBINOP(aTHX_ (t), (f), (l))
551static OP *
552THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last)
553{
554 BINOP *binop;
555 NewOp(1103, binop, 1, BINOP);
556 binop->op_type = (OPCODE)type;
29e61fd9
DM
557 op_sibling_splice((OP*)binop, NULL, 0, last);
558 op_sibling_splice((OP*)binop, NULL, 0, first);
5983a79d
BM
559 return (OP *)binop;
560}
561
562#define mkLISTOP(t, f, s, l) THX_mkLISTOP(aTHX_ (t), (f), (s), (l))
563static OP *
564THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last)
565{
566 LISTOP *listop;
567 NewOp(1103, listop, 1, LISTOP);
568 listop->op_type = (OPCODE)type;
29e61fd9
DM
569 op_sibling_splice((OP*)listop, NULL, 0, last);
570 op_sibling_splice((OP*)listop, NULL, 0, sib);
571 op_sibling_splice((OP*)listop, NULL, 0, first);
5983a79d
BM
572 return (OP *)listop;
573}
574
575static char *
576test_op_linklist_describe(OP *start)
577{
578 SV *rv = sv_2mortal(newSVpvs(""));
579 OP *o;
580 o = start = LINKLIST(start);
581 do {
582 sv_catpvs(rv, ".");
583 sv_catpv(rv, OP_NAME(o));
584 if (o->op_type == OP_CONST)
585 sv_catsv(rv, cSVOPo->op_sv);
586 o = o->op_next;
587 } while (o && o != start);
588 return SvPVX(rv);
589}
590
8f89e5a9
Z
591/** establish_cleanup operator, ripped off from Scope::Cleanup **/
592
593STATIC void
594THX_run_cleanup(pTHX_ void *cleanup_code_ref)
595{
596 dSP;
a59fa18f 597 PUSHSTACK;
8f89e5a9
Z
598 ENTER;
599 SAVETMPS;
600 PUSHMARK(SP);
601 call_sv((SV*)cleanup_code_ref, G_VOID|G_DISCARD);
602 FREETMPS;
603 LEAVE;
a59fa18f 604 POPSTACK;
8f89e5a9
Z
605}
606
607STATIC OP *
608THX_pp_establish_cleanup(pTHX)
609{
610 dSP;
611 SV *cleanup_code_ref;
612 cleanup_code_ref = newSVsv(POPs);
613 SAVEFREESV(cleanup_code_ref);
614 SAVEDESTRUCTOR_X(THX_run_cleanup, cleanup_code_ref);
615 if(GIMME_V != G_VOID) PUSHs(&PL_sv_undef);
616 RETURN;
617}
618
619STATIC OP *
620THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
621{
3253bf85 622 OP *parent, *pushop, *argop, *estop;
8f89e5a9 623 ck_entersub_args_proto(entersubop, namegv, ckobj);
3253bf85 624 parent = entersubop;
8f89e5a9 625 pushop = cUNOPx(entersubop)->op_first;
e6dae479 626 if(!OpHAS_SIBLING(pushop)) {
3253bf85 627 parent = pushop;
1ed44841 628 pushop = cUNOPx(pushop)->op_first;
3253bf85
DM
629 }
630 /* extract out first arg, then delete the rest of the tree */
e6dae479 631 argop = OpSIBLING(pushop);
3253bf85 632 op_sibling_splice(parent, pushop, 1, NULL);
8f89e5a9 633 op_free(entersubop);
3253bf85
DM
634
635 estop = mkUNOP(OP_RAND, argop);
8f89e5a9 636 estop->op_ppaddr = THX_pp_establish_cleanup;
8f89e5a9
Z
637 PL_hints |= HINT_BLOCK_SCOPE;
638 return estop;
639}
640
3ad73efd
Z
641STATIC OP *
642THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
643{
3253bf85 644 OP *parent, *pushop, *argop;
3ad73efd 645 ck_entersub_args_proto(entersubop, namegv, ckobj);
3253bf85 646 parent = entersubop;
3ad73efd 647 pushop = cUNOPx(entersubop)->op_first;
e6dae479 648 if(!OpHAS_SIBLING(pushop)) {
3253bf85 649 parent = pushop;
1ed44841 650 pushop = cUNOPx(pushop)->op_first;
3253bf85 651 }
e6dae479 652 argop = OpSIBLING(pushop);
3253bf85 653 op_sibling_splice(parent, pushop, 1, NULL);
3ad73efd
Z
654 op_free(entersubop);
655 return newUNOP(OP_POSTINC, 0,
656 op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC));
657}
658
15103811
Z
659STATIC OP *
660THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
661{
662 OP *pushop, *argop;
663 PADOFFSET padoff = NOT_IN_PAD;
664 SV *a0, *a1;
665 ck_entersub_args_proto(entersubop, namegv, ckobj);
666 pushop = cUNOPx(entersubop)->op_first;
e6dae479 667 if(!OpHAS_SIBLING(pushop))
1ed44841 668 pushop = cUNOPx(pushop)->op_first;
e6dae479
FC
669 argop = OpSIBLING(pushop);
670 if(argop->op_type != OP_CONST || OpSIBLING(argop)->op_type != OP_CONST)
15103811
Z
671 croak("bad argument expression type for pad_scalar()");
672 a0 = cSVOPx_sv(argop);
e6dae479 673 a1 = cSVOPx_sv(OpSIBLING(argop));
15103811
Z
674 switch(SvIV(a0)) {
675 case 1: {
676 SV *namesv = sv_2mortal(newSVpvs("$"));
677 sv_catsv(namesv, a1);
678 padoff = pad_findmy_sv(namesv, 0);
679 } break;
680 case 2: {
681 char *namepv;
682 STRLEN namelen;
683 SV *namesv = sv_2mortal(newSVpvs("$"));
684 sv_catsv(namesv, a1);
685 namepv = SvPV(namesv, namelen);
ab8f91e9 686 padoff = pad_findmy_pvn(namepv, namelen, SvUTF8(namesv));
15103811
Z
687 } break;
688 case 3: {
689 char *namepv;
690 SV *namesv = sv_2mortal(newSVpvs("$"));
691 sv_catsv(namesv, a1);
692 namepv = SvPV_nolen(namesv);
ab8f91e9 693 padoff = pad_findmy_pv(namepv, SvUTF8(namesv));
15103811
Z
694 } break;
695 case 4: {
696 padoff = pad_findmy_pvs("$foo", 0);
697 } break;
698 default: croak("bad type value for pad_scalar()");
699 }
700 op_free(entersubop);
701 if(padoff == NOT_IN_PAD) {
702 return newSVOP(OP_CONST, 0, newSVpvs("NOT_IN_PAD"));
703 } else if(PAD_COMPNAME_FLAGS_isOUR(padoff)) {
704 return newSVOP(OP_CONST, 0, newSVpvs("NOT_MY"));
705 } else {
706 OP *padop = newOP(OP_PADSV, 0);
707 padop->op_targ = padoff;
708 return padop;
709 }
710}
711
83f8bb56
Z
712/** RPN keyword parser **/
713
714#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
715#define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
716#define sv_is_string(sv) \
717 (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
718 (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
719
720static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
07ffcb73 721static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
a7aaec61 722static SV *hintkey_scopelessblock_sv;
e53d8f76
Z
723static SV *hintkey_stmtasexpr_sv, *hintkey_stmtsasexpr_sv;
724static SV *hintkey_loopblock_sv, *hintkey_blockasexpr_sv;
361d9b55 725static SV *hintkey_swaplabel_sv, *hintkey_labelconst_sv;
78cdf107
Z
726static SV *hintkey_arrayfullexpr_sv, *hintkey_arraylistexpr_sv;
727static SV *hintkey_arraytermexpr_sv, *hintkey_arrayarithexpr_sv;
728static SV *hintkey_arrayexprflags_sv;
ce409cc8 729static SV *hintkey_DEFSV_sv;
25f5d540 730static SV *hintkey_with_vars_sv;
03d05f6e 731static SV *hintkey_join_with_space_sv;
83f8bb56
Z
732static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
733
734/* low-level parser helpers */
735
736#define PL_bufptr (PL_parser->bufptr)
737#define PL_bufend (PL_parser->bufend)
738
739/* RPN parser */
740
741#define parse_var() THX_parse_var(aTHX)
742static OP *THX_parse_var(pTHX)
743{
744 char *s = PL_bufptr;
745 char *start = s;
746 PADOFFSET varpos;
747 OP *padop;
748 if(*s != '$') croak("RPN syntax error");
749 while(1) {
750 char c = *++s;
751 if(!isALNUM(c)) break;
752 }
753 if(s-start < 2) croak("RPN syntax error");
754 lex_read_to(s);
cc76b5cc 755 varpos = pad_findmy_pvn(start, s-start, 0);
83f8bb56
Z
756 if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
757 croak("RPN only supports \"my\" variables");
758 padop = newOP(OP_PADSV, 0);
759 padop->op_targ = varpos;
760 return padop;
761}
762
763#define push_rpn_item(o) \
3253bf85
DM
764 op_sibling_splice(parent, NULL, 0, o);
765#define pop_rpn_item() ( \
766 (tmpop = op_sibling_splice(parent, NULL, 1, NULL)) \
767 ? tmpop : (croak("RPN stack underflow"), (OP*)NULL))
83f8bb56
Z
768
769#define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
770static OP *THX_parse_rpn_expr(pTHX)
771{
3253bf85
DM
772 OP *tmpop;
773 /* fake parent for splice to mess with */
774 OP *parent = mkBINOP(OP_NULL, NULL, NULL);
775
83f8bb56
Z
776 while(1) {
777 I32 c;
778 lex_read_space(0);
779 c = lex_peek_unichar(0);
780 switch(c) {
781 case /*(*/')': case /*{*/'}': {
782 OP *result = pop_rpn_item();
3253bf85
DM
783 if(cLISTOPx(parent)->op_first)
784 croak("RPN expression must return a single value");
785 op_free(parent);
83f8bb56
Z
786 return result;
787 } break;
788 case '0': case '1': case '2': case '3': case '4':
789 case '5': case '6': case '7': case '8': case '9': {
790 UV val = 0;
791 do {
792 lex_read_unichar(0);
793 val = 10*val + (c - '0');
794 c = lex_peek_unichar(0);
795 } while(c >= '0' && c <= '9');
796 push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val)));
797 } break;
798 case '$': {
799 push_rpn_item(parse_var());
800 } break;
801 case '+': {
802 OP *b = pop_rpn_item();
803 OP *a = pop_rpn_item();
804 lex_read_unichar(0);
805 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
806 } break;
807 case '-': {
808 OP *b = pop_rpn_item();
809 OP *a = pop_rpn_item();
810 lex_read_unichar(0);
811 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
812 } break;
813 case '*': {
814 OP *b = pop_rpn_item();
815 OP *a = pop_rpn_item();
816 lex_read_unichar(0);
817 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
818 } break;
819 case '/': {
820 OP *b = pop_rpn_item();
821 OP *a = pop_rpn_item();
822 lex_read_unichar(0);
823 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
824 } break;
825 case '%': {
826 OP *b = pop_rpn_item();
827 OP *a = pop_rpn_item();
828 lex_read_unichar(0);
829 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
830 } break;
831 default: {
832 croak("RPN syntax error");
833 } break;
834 }
835 }
836}
837
838#define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
839static OP *THX_parse_keyword_rpn(pTHX)
840{
841 OP *op;
842 lex_read_space(0);
843 if(lex_peek_unichar(0) != '('/*)*/)
844 croak("RPN expression must be parenthesised");
845 lex_read_unichar(0);
846 op = parse_rpn_expr();
847 if(lex_peek_unichar(0) != /*(*/')')
848 croak("RPN expression must be parenthesised");
849 lex_read_unichar(0);
850 return op;
851}
852
853#define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
854static OP *THX_parse_keyword_calcrpn(pTHX)
855{
856 OP *varop, *exprop;
857 lex_read_space(0);
858 varop = parse_var();
859 lex_read_space(0);
860 if(lex_peek_unichar(0) != '{'/*}*/)
861 croak("RPN expression must be braced");
862 lex_read_unichar(0);
863 exprop = parse_rpn_expr();
864 if(lex_peek_unichar(0) != /*{*/'}')
865 croak("RPN expression must be braced");
866 lex_read_unichar(0);
867 return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
868}
869
870#define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
871static OP *THX_parse_keyword_stufftest(pTHX)
872{
873 I32 c;
874 bool do_stuff;
875 lex_read_space(0);
876 do_stuff = lex_peek_unichar(0) == '+';
877 if(do_stuff) {
878 lex_read_unichar(0);
879 lex_read_space(0);
880 }
881 c = lex_peek_unichar(0);
882 if(c == ';') {
883 lex_read_unichar(0);
884 } else if(c != /*{*/'}') {
885 croak("syntax error");
886 }
887 if(do_stuff) lex_stuff_pvs(" ", 0);
888 return newOP(OP_NULL, 0);
889}
890
891#define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
892static OP *THX_parse_keyword_swaptwostmts(pTHX)
893{
894 OP *a, *b;
895 a = parse_fullstmt(0);
896 b = parse_fullstmt(0);
897 if(a && b)
898 PL_hints |= HINT_BLOCK_SCOPE;
2fcb4757 899 return op_append_list(OP_LINESEQ, b, a);
83f8bb56
Z
900}
901
07ffcb73
Z
902#define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
903static OP *THX_parse_keyword_looprest(pTHX)
904{
94bf0465
Z
905 return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes),
906 parse_stmtseq(0), NULL, 1);
07ffcb73
Z
907}
908
a7aaec61
Z
909#define parse_keyword_scopelessblock() THX_parse_keyword_scopelessblock(aTHX)
910static OP *THX_parse_keyword_scopelessblock(pTHX)
911{
912 I32 c;
913 OP *body;
914 lex_read_space(0);
915 if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
916 lex_read_unichar(0);
917 body = parse_stmtseq(0);
918 c = lex_peek_unichar(0);
919 if(c != /*{*/'}' && c != /*[*/']' && c != /*(*/')') croak("syntax error");
920 lex_read_unichar(0);
921 return body;
922}
923
9eb5c532
Z
924#define parse_keyword_stmtasexpr() THX_parse_keyword_stmtasexpr(aTHX)
925static OP *THX_parse_keyword_stmtasexpr(pTHX)
926{
8359b381 927 OP *o = parse_barestmt(0);
3ad73efd
Z
928 if (!o) o = newOP(OP_STUB, 0);
929 if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
930 return op_scope(o);
9eb5c532
Z
931}
932
933#define parse_keyword_stmtsasexpr() THX_parse_keyword_stmtsasexpr(aTHX)
934static OP *THX_parse_keyword_stmtsasexpr(pTHX)
935{
936 OP *o;
937 lex_read_space(0);
938 if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
939 lex_read_unichar(0);
940 o = parse_stmtseq(0);
941 lex_read_space(0);
942 if(lex_peek_unichar(0) != /*{*/'}') croak("syntax error");
943 lex_read_unichar(0);
3ad73efd
Z
944 if (!o) o = newOP(OP_STUB, 0);
945 if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
946 return op_scope(o);
9eb5c532
Z
947}
948
e53d8f76
Z
949#define parse_keyword_loopblock() THX_parse_keyword_loopblock(aTHX)
950static OP *THX_parse_keyword_loopblock(pTHX)
951{
94bf0465
Z
952 return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes),
953 parse_block(0), NULL, 1);
e53d8f76
Z
954}
955
956#define parse_keyword_blockasexpr() THX_parse_keyword_blockasexpr(aTHX)
957static OP *THX_parse_keyword_blockasexpr(pTHX)
958{
959 OP *o = parse_block(0);
3ad73efd
Z
960 if (!o) o = newOP(OP_STUB, 0);
961 if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
962 return op_scope(o);
e53d8f76
Z
963}
964
361d9b55
Z
965#define parse_keyword_swaplabel() THX_parse_keyword_swaplabel(aTHX)
966static OP *THX_parse_keyword_swaplabel(pTHX)
967{
968 OP *sop = parse_barestmt(0);
969 SV *label = parse_label(PARSE_OPTIONAL);
970 if (label) sv_2mortal(label);
5db1eb8d
BF
971 return newSTATEOP(label ? SvUTF8(label) : 0,
972 label ? savepv(SvPVX(label)) : NULL,
973 sop);
361d9b55
Z
974}
975
976#define parse_keyword_labelconst() THX_parse_keyword_labelconst(aTHX)
977static OP *THX_parse_keyword_labelconst(pTHX)
978{
979 return newSVOP(OP_CONST, 0, parse_label(0));
980}
981
78cdf107
Z
982#define parse_keyword_arrayfullexpr() THX_parse_keyword_arrayfullexpr(aTHX)
983static OP *THX_parse_keyword_arrayfullexpr(pTHX)
984{
985 return newANONLIST(parse_fullexpr(0));
986}
987
988#define parse_keyword_arraylistexpr() THX_parse_keyword_arraylistexpr(aTHX)
989static OP *THX_parse_keyword_arraylistexpr(pTHX)
990{
991 return newANONLIST(parse_listexpr(0));
992}
993
994#define parse_keyword_arraytermexpr() THX_parse_keyword_arraytermexpr(aTHX)
995static OP *THX_parse_keyword_arraytermexpr(pTHX)
996{
997 return newANONLIST(parse_termexpr(0));
998}
999
1000#define parse_keyword_arrayarithexpr() THX_parse_keyword_arrayarithexpr(aTHX)
1001static OP *THX_parse_keyword_arrayarithexpr(pTHX)
1002{
1003 return newANONLIST(parse_arithexpr(0));
1004}
1005
1006#define parse_keyword_arrayexprflags() THX_parse_keyword_arrayexprflags(aTHX)
1007static OP *THX_parse_keyword_arrayexprflags(pTHX)
1008{
1009 U32 flags = 0;
1010 I32 c;
1011 OP *o;
1012 lex_read_space(0);
1013 c = lex_peek_unichar(0);
1014 if (c != '!' && c != '?') croak("syntax error");
1015 lex_read_unichar(0);
1016 if (c == '?') flags |= PARSE_OPTIONAL;
1017 o = parse_listexpr(flags);
1018 return o ? newANONLIST(o) : newANONHASH(newOP(OP_STUB, 0));
1019}
1020
ce409cc8
LM
1021#define parse_keyword_DEFSV() THX_parse_keyword_DEFSV(aTHX)
1022static OP *THX_parse_keyword_DEFSV(pTHX)
1023{
1024 return newDEFSVOP();
1025}
1026
1d07f51c
LM
1027#define sv_cat_c(a,b) THX_sv_cat_c(aTHX_ a, b)
1028static void THX_sv_cat_c(pTHX_ SV *sv, U32 c) {
25f5d540
LM
1029 char ds[UTF8_MAXBYTES + 1], *d;
1030 d = (char *)uvchr_to_utf8((U8 *)ds, c);
1031 if (d - ds > 1) {
1032 sv_utf8_upgrade(sv);
1033 }
1034 sv_catpvn(sv, ds, d - ds);
1035}
1036
1037#define parse_keyword_with_vars() THX_parse_keyword_with_vars(aTHX)
1038static OP *THX_parse_keyword_with_vars(pTHX)
1039{
1040 I32 c;
1041 IV count;
1042 int save_ix;
1043 OP *vardeclseq, *body;
1044
1045 save_ix = block_start(TRUE);
1046 vardeclseq = NULL;
1047
1048 count = 0;
1049
1050 lex_read_space(0);
1051 c = lex_peek_unichar(0);
1052 while (c != '{') {
1053 SV *varname;
1054 PADOFFSET padoff;
1055
1056 if (c == -1) {
1057 croak("unexpected EOF; expecting '{'");
1058 }
1059
1060 if (!isIDFIRST_uni(c)) {
1061 croak("unexpected '%c'; expecting an identifier", (int)c);
1062 }
1063
1064 varname = newSVpvs("$");
1065 if (lex_bufutf8()) {
1066 SvUTF8_on(varname);
1067 }
1068
1069 sv_cat_c(varname, c);
1070 lex_read_unichar(0);
1071
1072 while (c = lex_peek_unichar(0), c != -1 && isIDCONT_uni(c)) {
1073 sv_cat_c(varname, c);
1074 lex_read_unichar(0);
1075 }
1076
1077 padoff = pad_add_name_sv(varname, padadd_NO_DUP_CHECK, NULL, NULL);
1078
1079 {
1080 OP *my_var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
1081 my_var->op_targ = padoff;
1082
1083 vardeclseq = op_append_list(
1084 OP_LINESEQ,
1085 vardeclseq,
1086 newSTATEOP(
1087 0, NULL,
1088 newASSIGNOP(
1089 OPf_STACKED,
1090 my_var, 0,
1091 newSVOP(
1092 OP_CONST, 0,
1093 newSViv(++count)
1094 )
1095 )
1096 )
1097 );
1098 }
1099
1100 lex_read_space(0);
1101 c = lex_peek_unichar(0);
1102 }
1103
1104 intro_my();
1105
1106 body = parse_block(0);
1107
1108 return block_end(save_ix, op_append_list(OP_LINESEQ, vardeclseq, body));
1109}
1110
03d05f6e
LM
1111#define parse_join_with_space() THX_parse_join_with_space(aTHX)
1112static OP *THX_parse_join_with_space(pTHX)
1113{
1114 OP *delim, *args;
1115
1116 args = parse_listexpr(0);
1117 delim = newSVOP(OP_CONST, 0, newSVpvs(" "));
1118 return op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, delim, args));
1119}
1120
83f8bb56
Z
1121/* plugin glue */
1122
1123#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
1124static int THX_keyword_active(pTHX_ SV *hintkey_sv)
1125{
1126 HE *he;
1127 if(!GvHV(PL_hintgv)) return 0;
1128 he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
1129 SvSHARED_HASH(hintkey_sv));
1130 return he && SvTRUE(HeVAL(he));
1131}
1132
1133static int my_keyword_plugin(pTHX_
1134 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
1135{
1136 if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
1137 keyword_active(hintkey_rpn_sv)) {
1138 *op_ptr = parse_keyword_rpn();
1139 return KEYWORD_PLUGIN_EXPR;
1140 } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
1141 keyword_active(hintkey_calcrpn_sv)) {
1142 *op_ptr = parse_keyword_calcrpn();
1143 return KEYWORD_PLUGIN_STMT;
1144 } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) &&
1145 keyword_active(hintkey_stufftest_sv)) {
1146 *op_ptr = parse_keyword_stufftest();
1147 return KEYWORD_PLUGIN_STMT;
1148 } else if(keyword_len == 12 &&
1149 strnEQ(keyword_ptr, "swaptwostmts", 12) &&
1150 keyword_active(hintkey_swaptwostmts_sv)) {
1151 *op_ptr = parse_keyword_swaptwostmts();
1152 return KEYWORD_PLUGIN_STMT;
07ffcb73
Z
1153 } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) &&
1154 keyword_active(hintkey_looprest_sv)) {
1155 *op_ptr = parse_keyword_looprest();
1156 return KEYWORD_PLUGIN_STMT;
a7aaec61
Z
1157 } else if(keyword_len == 14 && strnEQ(keyword_ptr, "scopelessblock", 14) &&
1158 keyword_active(hintkey_scopelessblock_sv)) {
1159 *op_ptr = parse_keyword_scopelessblock();
1160 return KEYWORD_PLUGIN_STMT;
9eb5c532
Z
1161 } else if(keyword_len == 10 && strnEQ(keyword_ptr, "stmtasexpr", 10) &&
1162 keyword_active(hintkey_stmtasexpr_sv)) {
1163 *op_ptr = parse_keyword_stmtasexpr();
1164 return KEYWORD_PLUGIN_EXPR;
1165 } else if(keyword_len == 11 && strnEQ(keyword_ptr, "stmtsasexpr", 11) &&
1166 keyword_active(hintkey_stmtsasexpr_sv)) {
1167 *op_ptr = parse_keyword_stmtsasexpr();
1168 return KEYWORD_PLUGIN_EXPR;
e53d8f76
Z
1169 } else if(keyword_len == 9 && strnEQ(keyword_ptr, "loopblock", 9) &&
1170 keyword_active(hintkey_loopblock_sv)) {
1171 *op_ptr = parse_keyword_loopblock();
1172 return KEYWORD_PLUGIN_STMT;
1173 } else if(keyword_len == 11 && strnEQ(keyword_ptr, "blockasexpr", 11) &&
1174 keyword_active(hintkey_blockasexpr_sv)) {
1175 *op_ptr = parse_keyword_blockasexpr();
1176 return KEYWORD_PLUGIN_EXPR;
361d9b55
Z
1177 } else if(keyword_len == 9 && strnEQ(keyword_ptr, "swaplabel", 9) &&
1178 keyword_active(hintkey_swaplabel_sv)) {
1179 *op_ptr = parse_keyword_swaplabel();
1180 return KEYWORD_PLUGIN_STMT;
1181 } else if(keyword_len == 10 && strnEQ(keyword_ptr, "labelconst", 10) &&
1182 keyword_active(hintkey_labelconst_sv)) {
1183 *op_ptr = parse_keyword_labelconst();
1184 return KEYWORD_PLUGIN_EXPR;
78cdf107
Z
1185 } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arrayfullexpr", 13) &&
1186 keyword_active(hintkey_arrayfullexpr_sv)) {
1187 *op_ptr = parse_keyword_arrayfullexpr();
1188 return KEYWORD_PLUGIN_EXPR;
1189 } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraylistexpr", 13) &&
1190 keyword_active(hintkey_arraylistexpr_sv)) {
1191 *op_ptr = parse_keyword_arraylistexpr();
1192 return KEYWORD_PLUGIN_EXPR;
1193 } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraytermexpr", 13) &&
1194 keyword_active(hintkey_arraytermexpr_sv)) {
1195 *op_ptr = parse_keyword_arraytermexpr();
1196 return KEYWORD_PLUGIN_EXPR;
1197 } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayarithexpr", 14) &&
1198 keyword_active(hintkey_arrayarithexpr_sv)) {
1199 *op_ptr = parse_keyword_arrayarithexpr();
1200 return KEYWORD_PLUGIN_EXPR;
1201 } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayexprflags", 14) &&
1202 keyword_active(hintkey_arrayexprflags_sv)) {
1203 *op_ptr = parse_keyword_arrayexprflags();
1204 return KEYWORD_PLUGIN_EXPR;
ce409cc8
LM
1205 } else if(keyword_len == 5 && strnEQ(keyword_ptr, "DEFSV", 5) &&
1206 keyword_active(hintkey_DEFSV_sv)) {
1207 *op_ptr = parse_keyword_DEFSV();
1208 return KEYWORD_PLUGIN_EXPR;
25f5d540
LM
1209 } else if(keyword_len == 9 && strnEQ(keyword_ptr, "with_vars", 9) &&
1210 keyword_active(hintkey_with_vars_sv)) {
1211 *op_ptr = parse_keyword_with_vars();
1212 return KEYWORD_PLUGIN_STMT;
03d05f6e
LM
1213 } else if(keyword_len == 15 && strnEQ(keyword_ptr, "join_with_space", 15) &&
1214 keyword_active(hintkey_join_with_space_sv)) {
1215 *op_ptr = parse_join_with_space();
1216 return KEYWORD_PLUGIN_EXPR;
83f8bb56
Z
1217 } else {
1218 return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
1219 }
1220}
1221
f568d64d
BM
1222static XOP my_xop;
1223
1224static OP *
1225pp_xop(pTHX)
1226{
1227 return PL_op->op_next;
1228}
1229
1230static void
1231peep_xop(pTHX_ OP *o, OP *oldop)
1232{
1233 dMY_CXT;
b58757d5
BM
1234 av_push(MY_CXT.xop_record, newSVpvf("peep:%"UVxf, PTR2UV(o)));
1235 av_push(MY_CXT.xop_record, newSVpvf("oldop:%"UVxf, PTR2UV(oldop)));
f568d64d
BM
1236}
1237
27fcb6ee
FC
1238static I32
1239filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
1240{
27fcb6ee
FC
1241 char *p;
1242 char *end;
1243 int n = FILTER_READ(idx + 1, buf_sv, maxlen);
1244
1245 if (n<=0) return n;
1246
1247 p = SvPV_force_nolen(buf_sv);
1248 end = p + SvCUR(buf_sv);
1249 while (p < end) {
1250 if (*p == 'o') *p = 'e';
1251 p++;
1252 }
1253 return SvCUR(buf_sv);
1254}
1255
02cab674
FC
1256static AV *
1257myget_linear_isa(pTHX_ HV *stash, U32 level) {
02cab674 1258 GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0);
6dbddf4a 1259 PERL_UNUSED_ARG(level);
02cab674
FC
1260 return gvp && *gvp && GvAV(*gvp)
1261 ? GvAV(*gvp)
1262 : (AV *)sv_2mortal((SV *)newAV());
1263}
1264
27fcb6ee 1265
9777c6aa
SM
1266XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_undef);
1267XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_empty);
1268XS_EXTERNAL(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
7b20c7cd 1269
02cab674
FC
1270static struct mro_alg mymro;
1271
e8570548
Z
1272static Perl_check_t addissub_nxck_add;
1273
1274static OP *
1275addissub_myck_add(pTHX_ OP *op)
1276{
1277 SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addissub", 0);
1278 OP *aop, *bop;
1279 U8 flags;
1280 if (!(flag_svp && SvTRUE(*flag_svp) && (op->op_flags & OPf_KIDS) &&
e6dae479
FC
1281 (aop = cBINOPx(op)->op_first) && (bop = OpSIBLING(aop)) &&
1282 !OpHAS_SIBLING(bop)))
e8570548 1283 return addissub_nxck_add(aTHX_ op);
e8570548 1284 flags = op->op_flags;
3253bf85
DM
1285 op_sibling_splice(op, NULL, 1, NULL); /* excise aop */
1286 op_sibling_splice(op, NULL, 1, NULL); /* excise bop */
1287 op_free(op); /* free the empty husk */
1288 flags &= ~OPf_KIDS;
e8570548
Z
1289 return newBINOP(OP_SUBTRACT, flags, aop, bop);
1290}
02cab674 1291
39c012bc
FC
1292static Perl_check_t old_ck_rv2cv;
1293
1294static OP *
1295my_ck_rv2cv(pTHX_ OP *o)
1296{
1297 SV *ref;
1298 SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addunder", 0);
1299 OP *aop;
1300
1301 if (flag_svp && SvTRUE(*flag_svp) && (o->op_flags & OPf_KIDS)
1302 && (aop = cUNOPx(o)->op_first) && aop->op_type == OP_CONST
1303 && aop->op_private & (OPpCONST_ENTERED|OPpCONST_BARE)
1304 && (ref = cSVOPx(aop)->op_sv) && SvPOK(ref) && SvCUR(ref)
1305 && *(SvEND(ref)-1) == 'o')
1306 {
1307 SvGROW(ref, SvCUR(ref)+2);
1308 *SvEND(ref) = '_';
1309 SvCUR(ref)++;
1310 *SvEND(ref) = '\0';
1311 }
1312 return old_ck_rv2cv(aTHX_ o);
1313}
1314
55289a74
NC
1315#include "const-c.inc"
1316
ffe53d21 1317MODULE = XS::APItest PACKAGE = XS::APItest
0314122a 1318
55289a74
NC
1319INCLUDE: const-xs.inc
1320
ffe53d21
NC
1321INCLUDE: numeric.xs
1322
11f9ab1a
TC
1323void
1324assertx(int x)
1325 CODE:
1326 /* this only needs to compile and checks that assert() can be
1327 used this way syntactically */
950c540d
JH
1328 (void)(assert(x), 1);
1329 (void)(x);
11f9ab1a 1330
fed3ba5d
NC
1331MODULE = XS::APItest::utf8 PACKAGE = XS::APItest::utf8
1332
1333int
1334bytes_cmp_utf8(bytes, utf8)
1335 SV *bytes
1336 SV *utf8
1337 PREINIT:
1338 const U8 *b;
1339 STRLEN blen;
1340 const U8 *u;
1341 STRLEN ulen;
1342 CODE:
1343 b = (const U8 *)SvPVbyte(bytes, blen);
1344 u = (const U8 *)SvPVbyte(utf8, ulen);
1345 RETVAL = bytes_cmp_utf8(b, blen, u, ulen);
1346 OUTPUT:
1347 RETVAL
1348
eb83ed87 1349AV *
bd70aaaf 1350test_utf8n_to_uvchr(s, len, flags)
eb83ed87
KW
1351
1352 SV *s
1353 SV *len
1354 SV *flags
1355 PREINIT:
1356 STRLEN retlen;
1357 UV ret;
1358 STRLEN slen;
1359
1360 CODE:
bd70aaaf 1361 /* Call utf8n_to_uvchr() with the inputs. It always asks for the
eb83ed87
KW
1362 * actual length to be returned
1363 *
1364 * Length to assume <s> is; not checked, so could have buffer overflow
1365 */
1366 RETVAL = newAV();
1367 sv_2mortal((SV*)RETVAL);
1368
1369 ret
bd70aaaf 1370 = utf8n_to_uvchr((U8*) SvPV(s, slen), SvUV(len), &retlen, SvUV(flags));
eb83ed87
KW
1371
1372 /* Returns the return value in [0]; <retlen> in [1] */
1373 av_push(RETVAL, newSVuv(ret));
1374 if (retlen == (STRLEN) -1) {
1375 av_push(RETVAL, newSViv(-1));
1376 }
1377 else {
1378 av_push(RETVAL, newSVuv(retlen));
1379 }
1380
1381 OUTPUT:
1382 RETVAL
1383
7d255dc8
NC
1384MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload
1385
c33e8be1 1386void
25a9ffce 1387amagic_deref_call(sv, what)
7d255dc8
NC
1388 SV *sv
1389 int what
1390 PPCODE:
7d255dc8 1391 /* The reference is owned by something else. */
25a9ffce 1392 PUSHs(amagic_deref_call(sv, what));
7d255dc8 1393
e89bfaa6
NC
1394# I'd certainly like to discourage the use of this macro, given that we now
1395# have amagic_deref_call
1396
c33e8be1 1397void
e89bfaa6
NC
1398tryAMAGICunDEREF_var(sv, what)
1399 SV *sv
1400 int what
1401 PPCODE:
1402 {
1403 SV **sp = &sv;
1404 switch(what) {
1405 case to_av_amg:
1406 tryAMAGICunDEREF(to_av);
1407 break;
1408 case to_cv_amg:
1409 tryAMAGICunDEREF(to_cv);
1410 break;
1411 case to_gv_amg:
1412 tryAMAGICunDEREF(to_gv);
1413 break;
1414 case to_hv_amg:
1415 tryAMAGICunDEREF(to_hv);
1416 break;
1417 case to_sv_amg:
1418 tryAMAGICunDEREF(to_sv);
1419 break;
1420 default:
1421 croak("Invalid value %d passed to tryAMAGICunDEREF_var", what);
1422 }
1423 }
1424 /* The reference is owned by something else. */
1425 PUSHs(sv);
1426
7b20c7cd
NC
1427MODULE = XS::APItest PACKAGE = XS::APItest::XSUB
1428
1429BOOT:
1430 newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
f9cc56fa 1431 newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
88c4b02d 1432 newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
7b20c7cd
NC
1433
1434void
1435XS_VERSION_defined(...)
1436 PPCODE:
1437 XS_VERSION_BOOTCHECK;
1438 XSRETURN_EMPTY;
1439
88c4b02d
NC
1440void
1441XS_APIVERSION_valid(...)
1442 PPCODE:
1443 XS_APIVERSION_BOOTCHECK;
1444 XSRETURN_EMPTY;
1445
ffe53d21
NC
1446MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
1447
b54b4831
NC
1448void
1449rot13_hash(hash)
1450 HV *hash
1451 CODE:
1452 {
1453 struct ufuncs uf;
1454 uf.uf_val = rot13_key;
1455 uf.uf_set = 0;
1456 uf.uf_index = 0;
1457
1458 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
1459 }
1460
53c40a8f
NC
1461void
1462bitflip_hash(hash)
1463 HV *hash
1464 CODE:
1465 {
1466 struct ufuncs uf;
1467 uf.uf_val = bitflip_key;
1468 uf.uf_set = 0;
1469 uf.uf_index = 0;
1470
1471 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
1472 }
1473
028f8eaa
MHM
1474#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
1475
0314122a
NC
1476bool
1477exists(hash, key_sv)
1478 PREINIT:
1479 STRLEN len;
1480 const char *key;
1481 INPUT:
1482 HV *hash
1483 SV *key_sv
1484 CODE:
1485 key = SvPV(key_sv, len);
028f8eaa 1486 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a
NC
1487 OUTPUT:
1488 RETVAL
1489
bdee33e4
NC
1490bool
1491exists_ent(hash, key_sv)
1492 PREINIT:
1493 INPUT:
1494 HV *hash
1495 SV *key_sv
1496 CODE:
1497 RETVAL = hv_exists_ent(hash, key_sv, 0);
1498 OUTPUT:
1499 RETVAL
1500
b60cf05a 1501SV *
55289a74 1502delete(hash, key_sv, flags = 0)
b60cf05a
NC
1503 PREINIT:
1504 STRLEN len;
1505 const char *key;
1506 INPUT:
1507 HV *hash
1508 SV *key_sv
55289a74 1509 I32 flags;
b60cf05a
NC
1510 CODE:
1511 key = SvPV(key_sv, len);
1512 /* It's already mortal, so need to increase reference count. */
55289a74
NC
1513 RETVAL
1514 = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
1515 OUTPUT:
1516 RETVAL
1517
1518SV *
1519delete_ent(hash, key_sv, flags = 0)
1520 INPUT:
1521 HV *hash
1522 SV *key_sv
1523 I32 flags;
1524 CODE:
1525 /* It's already mortal, so need to increase reference count. */
1526 RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
b60cf05a
NC
1527 OUTPUT:
1528 RETVAL
1529
1530SV *
858117f8
NC
1531store_ent(hash, key, value)
1532 PREINIT:
1533 SV *copy;
1534 HE *result;
1535 INPUT:
1536 HV *hash
1537 SV *key
1538 SV *value
1539 CODE:
1540 copy = newSV(0);
1541 result = hv_store_ent(hash, key, copy, 0);
1542 SvSetMagicSV(copy, value);
1543 if (!result) {
1544 SvREFCNT_dec(copy);
1545 XSRETURN_EMPTY;
1546 }
1547 /* It's about to become mortal, so need to increase reference count.
1548 */
1549 RETVAL = SvREFCNT_inc(HeVAL(result));
1550 OUTPUT:
1551 RETVAL
1552
858117f8 1553SV *
b60cf05a
NC
1554store(hash, key_sv, value)
1555 PREINIT:
1556 STRLEN len;
1557 const char *key;
1558 SV *copy;
1559 SV **result;
1560 INPUT:
1561 HV *hash
1562 SV *key_sv
1563 SV *value
1564 CODE:
1565 key = SvPV(key_sv, len);
1566 copy = newSV(0);
028f8eaa 1567 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8 1568 SvSetMagicSV(copy, value);
b60cf05a
NC
1569 if (!result) {
1570 SvREFCNT_dec(copy);
1571 XSRETURN_EMPTY;
1572 }
1573 /* It's about to become mortal, so need to increase reference count.
1574 */
1575 RETVAL = SvREFCNT_inc(*result);
1576 OUTPUT:
1577 RETVAL
1578
bdee33e4
NC
1579SV *
1580fetch_ent(hash, key_sv)
1581 PREINIT:
1582 HE *result;
1583 INPUT:
1584 HV *hash
1585 SV *key_sv
1586 CODE:
1587 result = hv_fetch_ent(hash, key_sv, 0, 0);
1588 if (!result) {
1589 XSRETURN_EMPTY;
1590 }
1591 /* Force mg_get */
1592 RETVAL = newSVsv(HeVAL(result));
1593 OUTPUT:
1594 RETVAL
b60cf05a
NC
1595
1596SV *
1597fetch(hash, key_sv)
1598 PREINIT:
1599 STRLEN len;
1600 const char *key;
1601 SV **result;
1602 INPUT:
1603 HV *hash
1604 SV *key_sv
1605 CODE:
1606 key = SvPV(key_sv, len);
028f8eaa 1607 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a
NC
1608 if (!result) {
1609 XSRETURN_EMPTY;
1610 }
1611 /* Force mg_get */
1612 RETVAL = newSVsv(*result);
1613 OUTPUT:
1614 RETVAL
2dc92170 1615
9568a123
NC
1616#if defined (hv_common)
1617
6b4de907
NC
1618SV *
1619common(params)
1620 INPUT:
1621 HV *params
1622 PREINIT:
1623 HE *result;
1624 HV *hv = NULL;
1625 SV *keysv = NULL;
1626 const char *key = NULL;
1627 STRLEN klen = 0;
1628 int flags = 0;
1629 int action = 0;
1630 SV *val = NULL;
1631 U32 hash = 0;
1632 SV **svp;
1633 CODE:
1634 if ((svp = hv_fetchs(params, "hv", 0))) {
1635 SV *const rv = *svp;
1636 if (!SvROK(rv))
1637 croak("common passed a non-reference for parameter hv");
1638 hv = (HV *)SvRV(rv);
1639 }
1640 if ((svp = hv_fetchs(params, "keysv", 0)))
1641 keysv = *svp;
1642 if ((svp = hv_fetchs(params, "keypv", 0))) {
1643 key = SvPV_const(*svp, klen);
1644 if (SvUTF8(*svp))
1645 flags = HVhek_UTF8;
1646 }
1647 if ((svp = hv_fetchs(params, "action", 0)))
1648 action = SvIV(*svp);
1649 if ((svp = hv_fetchs(params, "val", 0)))
527df579 1650 val = newSVsv(*svp);
6b4de907 1651 if ((svp = hv_fetchs(params, "hash", 0)))
a44093a9 1652 hash = SvUV(*svp);
6b4de907 1653
de092133 1654 if (hv_fetchs(params, "hash_pv", 0)) {
9959d439 1655 assert(key);
527df579
NC
1656 PERL_HASH(hash, key, klen);
1657 }
de092133 1658 if (hv_fetchs(params, "hash_sv", 0)) {
9959d439
JH
1659 assert(keysv);
1660 {
1661 STRLEN len;
1662 const char *const p = SvPV(keysv, len);
1663 PERL_HASH(hash, p, len);
1664 }
58ca560a 1665 }
527df579 1666
a75fcbca 1667 result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
6b4de907
NC
1668 if (!result) {
1669 XSRETURN_EMPTY;
1670 }
1671 /* Force mg_get */
1672 RETVAL = newSVsv(HeVAL(result));
1673 OUTPUT:
1674 RETVAL
1675
9568a123
NC
1676#endif
1677
439efdfe 1678void
2dc92170
NC
1679test_hv_free_ent()
1680 PPCODE:
1681 test_freeent(&Perl_hv_free_ent);
1682 XSRETURN(4);
1683
439efdfe 1684void
2dc92170
NC
1685test_hv_delayfree_ent()
1686 PPCODE:
1687 test_freeent(&Perl_hv_delayfree_ent);
1688 XSRETURN(4);
35ab5632
NC
1689
1690SV *
1691test_share_unshare_pvn(input)
1692 PREINIT:
35ab5632
NC
1693 STRLEN len;
1694 U32 hash;
1695 char *pvx;
1696 char *p;
1697 INPUT:
1698 SV *input
1699 CODE:
1700 pvx = SvPV(input, len);
1701 PERL_HASH(hash, pvx, len);
1702 p = sharepvn(pvx, len, hash);
1703 RETVAL = newSVpvn(p, len);
1704 unsharepvn(p, len, hash);
1705 OUTPUT:
1706 RETVAL
d8c5b3c5 1707
9568a123
NC
1708#if PERL_VERSION >= 9
1709
d8c5b3c5
NC
1710bool
1711refcounted_he_exists(key, level=0)
1712 SV *key
1713 IV level
1714 CODE:
1715 if (level) {
1716 croak("level must be zero, not %"IVdf, level);
1717 }
20439bc7 1718 RETVAL = (cop_hints_fetch_sv(PL_curcop, key, 0, 0) != &PL_sv_placeholder);
d8c5b3c5
NC
1719 OUTPUT:
1720 RETVAL
1721
d8c5b3c5
NC
1722SV *
1723refcounted_he_fetch(key, level=0)
1724 SV *key
1725 IV level
1726 CODE:
1727 if (level) {
1728 croak("level must be zero, not %"IVdf, level);
1729 }
20439bc7 1730 RETVAL = cop_hints_fetch_sv(PL_curcop, key, 0, 0);
d8c5b3c5
NC
1731 SvREFCNT_inc(RETVAL);
1732 OUTPUT:
1733 RETVAL
65bfe90c 1734
9568a123 1735#endif
65bfe90c 1736
5f39160d
TC
1737void
1738test_force_keys(HV *hv)
1739 PREINIT:
1740 HE *he;
1741 STRLEN count = 0;
1742 PPCODE:
1743 hv_iterinit(hv);
1744 he = hv_iternext(hv);
1745 while (he) {
1746 SV *sv = HeSVKEY_force(he);
1747 ++count;
1748 EXTEND(SP, count);
1749 PUSHs(sv_mortalcopy(sv));
1750 he = hv_iternext(hv);
1751 }
1752
0314122a
NC
1753=pod
1754
1755sub TIEHASH { bless {}, $_[0] }
1756sub STORE { $_[0]->{$_[1]} = $_[2] }
1757sub FETCH { $_[0]->{$_[1]} }
1758sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
1759sub NEXTKEY { each %{$_[0]} }
1760sub EXISTS { exists $_[0]->{$_[1]} }
1761sub DELETE { delete $_[0]->{$_[1]} }
1762sub CLEAR { %{$_[0]} = () }
1763
1764=cut
1765
e2fe06dd
EB
1766MODULE = XS::APItest:TempLv PACKAGE = XS::APItest::TempLv
1767
1768void
1769make_temp_mg_lv(sv)
1770SV* sv
1771 PREINIT:
1772 SV * const lv = newSV_type(SVt_PVLV);
1773 STRLEN len;
1774 PPCODE:
1775 SvPV(sv, len);
1776
1777 sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
1778 LvTYPE(lv) = 'x';
1779 LvTARG(lv) = SvREFCNT_inc_simple(sv);
1780 LvTARGOFF(lv) = len == 0 ? 0 : 1;
1781 LvTARGLEN(lv) = len < 2 ? 0 : len-2;
1782
1783 EXTEND(SP, 1);
1784 ST(0) = sv_2mortal(lv);
1785 XSRETURN(1);
1786
1787
36c2b1d0
NC
1788MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
1789
1790void
1791ptr_table_new(classname)
1792const char * classname
1793 PPCODE:
1794 PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
1795
1796void
1797DESTROY(table)
1798XS::APItest::PtrTable table
1799 CODE:
1800 ptr_table_free(table);
1801
1802void
992b2363 1803ptr_table_store(table, from, to)
36c2b1d0 1804XS::APItest::PtrTable table
992b2363
NC
1805SVREF from
1806SVREF to
36c2b1d0 1807 CODE:
992b2363 1808 ptr_table_store(table, from, to);
36c2b1d0
NC
1809
1810UV
992b2363 1811ptr_table_fetch(table, from)
36c2b1d0 1812XS::APItest::PtrTable table
992b2363 1813SVREF from
36c2b1d0 1814 CODE:
992b2363 1815 RETVAL = PTR2UV(ptr_table_fetch(table, from));
36c2b1d0
NC
1816 OUTPUT:
1817 RETVAL
1818
1819void
1820ptr_table_split(table)
1821XS::APItest::PtrTable table
1822
1823void
1824ptr_table_clear(table)
1825XS::APItest::PtrTable table
1826
6911735f
FC
1827MODULE = XS::APItest::AutoLoader PACKAGE = XS::APItest::AutoLoader
1828
1829SV *
1830AUTOLOAD()
1831 CODE:
1832 RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
1833 OUTPUT:
1834 RETVAL
1835
8fa6a409
FC
1836SV *
1837AUTOLOADp(...)
1838 PROTOTYPE: *$
1839 CODE:
5f74c55e 1840 PERL_UNUSED_ARG(items);
8fa6a409
FC
1841 RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
1842 OUTPUT:
1843 RETVAL
1844
6911735f 1845
3e61d65a
JH
1846MODULE = XS::APItest PACKAGE = XS::APItest
1847
1848PROTOTYPES: DISABLE
1849
67ecba2f
FC
1850BOOT:
1851 mymro.resolve = myget_linear_isa;
1852 mymro.name = "justisa";
1853 mymro.length = 7;
1854 mymro.kflags = 0;
1855 mymro.hash = 0;
1856 Perl_mro_register(aTHX_ &mymro);
1857
f568d64d
BM
1858HV *
1859xop_custom_ops ()
1860 CODE:
1861 RETVAL = PL_custom_ops;
1862 OUTPUT:
1863 RETVAL
1864
1865HV *
1866xop_custom_op_names ()
1867 CODE:
1868 PL_custom_op_names = newHV();
1869 RETVAL = PL_custom_op_names;
1870 OUTPUT:
1871 RETVAL
1872
1873HV *
1874xop_custom_op_descs ()
1875 CODE:
1876 PL_custom_op_descs = newHV();
1877 RETVAL = PL_custom_op_descs;
1878 OUTPUT:
1879 RETVAL
1880
1881void
1882xop_register ()
1883 CODE:
1884 XopENTRY_set(&my_xop, xop_name, "my_xop");
1885 XopENTRY_set(&my_xop, xop_desc, "XOP for testing");
1886 XopENTRY_set(&my_xop, xop_class, OA_UNOP);
1887 XopENTRY_set(&my_xop, xop_peep, peep_xop);
1888 Perl_custom_op_register(aTHX_ pp_xop, &my_xop);
1889
1890void
1891xop_clear ()
1892 CODE:
1893 XopDISABLE(&my_xop, xop_name);
1894 XopDISABLE(&my_xop, xop_desc);
1895 XopDISABLE(&my_xop, xop_class);
1896 XopDISABLE(&my_xop, xop_peep);
1897
1898IV
1899xop_my_xop ()
1900 CODE:
1901 RETVAL = PTR2IV(&my_xop);
1902 OUTPUT:
1903 RETVAL
1904
1905IV
1906xop_ppaddr ()
1907 CODE:
1908 RETVAL = PTR2IV(pp_xop);
1909 OUTPUT:
1910 RETVAL
1911
1912IV
1913xop_OA_UNOP ()
1914 CODE:
1915 RETVAL = OA_UNOP;
1916 OUTPUT:
1917 RETVAL
1918
1919AV *
1920xop_build_optree ()
1921 CODE:
1922 dMY_CXT;
1923 UNOP *unop;
1924 OP *kid;
1925
1926 MY_CXT.xop_record = newAV();
1927
1928 kid = newSVOP(OP_CONST, 0, newSViv(42));
1929
3253bf85 1930 unop = (UNOP*)mkUNOP(OP_CUSTOM, kid);
f568d64d 1931 unop->op_ppaddr = pp_xop;
f568d64d 1932 unop->op_private = 0;
f568d64d
BM
1933 unop->op_next = NULL;
1934 kid->op_next = (OP*)unop;
1935
b58757d5
BM
1936 av_push(MY_CXT.xop_record, newSVpvf("unop:%"UVxf, PTR2UV(unop)));
1937 av_push(MY_CXT.xop_record, newSVpvf("kid:%"UVxf, PTR2UV(kid)));
f568d64d
BM
1938
1939 av_push(MY_CXT.xop_record, newSVpvf("NAME:%s", OP_NAME((OP*)unop)));
1940 av_push(MY_CXT.xop_record, newSVpvf("DESC:%s", OP_DESC((OP*)unop)));
c33e8be1 1941 av_push(MY_CXT.xop_record, newSVpvf("CLASS:%d", (int)OP_CLASS((OP*)unop)));
f568d64d
BM
1942
1943 PL_rpeepp(aTHX_ kid);
1944
1945 FreeOp(kid);
1946 FreeOp(unop);
1947
1948 RETVAL = MY_CXT.xop_record;
1949 MY_CXT.xop_record = NULL;
1950 OUTPUT:
1951 RETVAL
1952
ae103e09
DD
1953IV
1954xop_from_custom_op ()
1955 CODE:
1956/* author note: this test doesn't imply Perl_custom_op_xop is or isn't public
1957 API or that Perl_custom_op_xop is known to be used outside the core */
1958 UNOP *unop;
1959 XOP *xop;
1960
3253bf85 1961 unop = (UNOP*)mkUNOP(OP_CUSTOM, NULL);
ae103e09 1962 unop->op_ppaddr = pp_xop;
ae103e09 1963 unop->op_private = 0;
ae103e09
DD
1964 unop->op_next = NULL;
1965
1966 xop = Perl_custom_op_xop(aTHX_ (OP *)unop);
1967 FreeOp(unop);
1968 RETVAL = PTR2IV(xop);
1969 OUTPUT:
1970 RETVAL
1971
85ce96a1
DM
1972BOOT:
1973{
1974 MY_CXT_INIT;
03569ecf 1975
85ce96a1
DM
1976 MY_CXT.i = 99;
1977 MY_CXT.sv = newSVpv("initial",0);
13b6b3bc
BM
1978
1979 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1980 MY_CXT.bhk_record = 0;
1981
a88d97bf
BM
1982 BhkENTRY_set(&bhk_test, bhk_start, blockhook_test_start);
1983 BhkENTRY_set(&bhk_test, bhk_pre_end, blockhook_test_pre_end);
1984 BhkENTRY_set(&bhk_test, bhk_post_end, blockhook_test_post_end);
1985 BhkENTRY_set(&bhk_test, bhk_eval, blockhook_test_eval);
13b6b3bc
BM
1986 Perl_blockhook_register(aTHX_ &bhk_test);
1987
65bfe90c 1988 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
13b6b3bc 1989 GV_ADDMULTI, SVt_PVAV);
03569ecf
BM
1990 MY_CXT.cscav = GvAV(MY_CXT.cscgv);
1991
a88d97bf
BM
1992 BhkENTRY_set(&bhk_csc, bhk_start, blockhook_csc_start);
1993 BhkENTRY_set(&bhk_csc, bhk_pre_end, blockhook_csc_pre_end);
13b6b3bc 1994 Perl_blockhook_register(aTHX_ &bhk_csc);
201c7e1f
FR
1995
1996 MY_CXT.peep_recorder = newAV();
1997 MY_CXT.rpeep_recorder = newAV();
1998
1999 MY_CXT.orig_peep = PL_peepp;
2000 MY_CXT.orig_rpeep = PL_rpeepp;
2001 PL_peepp = my_peep;
2002 PL_rpeepp = my_rpeep;
65bfe90c 2003}
85ce96a1
DM
2004
2005void
2006CLONE(...)
2007 CODE:
2008 MY_CXT_CLONE;
c33e8be1 2009 PERL_UNUSED_VAR(items);
85ce96a1 2010 MY_CXT.sv = newSVpv("initial_clone",0);
65bfe90c 2011 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
13b6b3bc 2012 GV_ADDMULTI, SVt_PVAV);
03569ecf 2013 MY_CXT.cscav = NULL;
13b6b3bc
BM
2014 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
2015 MY_CXT.bhk_record = 0;
201c7e1f
FR
2016 MY_CXT.peep_recorder = newAV();
2017 MY_CXT.rpeep_recorder = newAV();
85ce96a1 2018
3e61d65a
JH
2019void
2020print_double(val)
2021 double val
2022 CODE:
2023 printf("%5.3f\n",val);
2024
2025int
2026have_long_double()
2027 CODE:
2028#ifdef HAS_LONG_DOUBLE
2029 RETVAL = 1;
2030#else
2031 RETVAL = 0;
2032#endif
cabb36f0
CN
2033 OUTPUT:
2034 RETVAL
3e61d65a
JH
2035
2036void
2037print_long_double()
2038 CODE:
2039#ifdef HAS_LONG_DOUBLE
fc0bf671 2040# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH
2041 long double val = 7.0;
2042 printf("%5.3" PERL_PRIfldbl "\n",val);
2043# else
2044 double val = 7.0;
2045 printf("%5.3f\n",val);
2046# endif
2047#endif
2048
2049void
3e61d65a
JH
2050print_int(val)
2051 int val
2052 CODE:
2053 printf("%d\n",val);
2054
2055void
2056print_long(val)
2057 long val
2058 CODE:
2059 printf("%ld\n",val);
2060
2061void
2062print_float(val)
2063 float val
2064 CODE:
2065 printf("%5.3f\n",val);
9d911683
NIS
2066
2067void
2068print_flush()
2069 CODE:
2070 fflush(stdout);
d4b90eee
SH
2071
2072void
2073mpushp()
2074 PPCODE:
2075 EXTEND(SP, 3);
2076 mPUSHp("one", 3);
2077 mPUSHp("two", 3);
2078 mPUSHp("three", 5);
2079 XSRETURN(3);
2080
2081void
2082mpushn()
2083 PPCODE:
2084 EXTEND(SP, 3);
2085 mPUSHn(0.5);
2086 mPUSHn(-0.25);
2087 mPUSHn(0.125);
2088 XSRETURN(3);
2089
2090void
2091mpushi()
2092 PPCODE:
2093 EXTEND(SP, 3);
d75b63cf
MHM
2094 mPUSHi(-1);
2095 mPUSHi(2);
2096 mPUSHi(-3);
d4b90eee
SH
2097 XSRETURN(3);
2098
2099void
2100mpushu()
2101 PPCODE:
2102 EXTEND(SP, 3);
d75b63cf
MHM
2103 mPUSHu(1);
2104 mPUSHu(2);
2105 mPUSHu(3);
d4b90eee
SH
2106 XSRETURN(3);
2107
2108void
2109mxpushp()
2110 PPCODE:
2111 mXPUSHp("one", 3);
2112 mXPUSHp("two", 3);
2113 mXPUSHp("three", 5);
2114 XSRETURN(3);
2115
2116void
2117mxpushn()
2118 PPCODE:
2119 mXPUSHn(0.5);
2120 mXPUSHn(-0.25);
2121 mXPUSHn(0.125);
2122 XSRETURN(3);
2123
2124void
2125mxpushi()
2126 PPCODE:
d75b63cf
MHM
2127 mXPUSHi(-1);
2128 mXPUSHi(2);
2129 mXPUSHi(-3);
d4b90eee
SH
2130 XSRETURN(3);
2131
2132void
2133mxpushu()
2134 PPCODE:
d75b63cf
MHM
2135 mXPUSHu(1);
2136 mXPUSHu(2);
2137 mXPUSHu(3);
d4b90eee 2138 XSRETURN(3);
d1f347d7 2139
a85ce6f0
DD
2140void
2141call_sv_C()
2142PREINIT:
2143 CV * i_sub;
2144 GV * i_gv;
2145 I32 retcnt;
2146 SV * errsv;
2147 char * errstr;
2148 SV * miscsv = sv_newmortal();
2149 HV * hv = (HV*)sv_2mortal((SV*)newHV());
2150CODE:
2151 i_sub = get_cv("i", 0);
2152 PUSHMARK(SP);
2153 /* PUTBACK not needed since this sub was called with 0 args, and is calling
2154 0 args, so global SP doesn't need to be moved before a call_* */
2155 retcnt = call_sv((SV*)i_sub, 0); /* try a CV* */
2156 SPAGAIN;
2157 SP -= retcnt; /* dont care about return count, wipe everything off */
2158 sv_setpvs(miscsv, "i");
2159 PUSHMARK(SP);
2160 retcnt = call_sv(miscsv, 0); /* try a PV */
2161 SPAGAIN;
2162 SP -= retcnt;
2163 /* no add and SVt_NULL are intentional, sub i should be defined already */
2164 i_gv = gv_fetchpvn_flags("i", sizeof("i")-1, 0, SVt_NULL);
2165 PUSHMARK(SP);
2166 retcnt = call_sv((SV*)i_gv, 0); /* try a GV* */
2167 SPAGAIN;
2168 SP -= retcnt;
2169 /* the tests below are not declaring this being public API behavior,
2170 only current internal behavior, these tests can be changed in the
2171 future if necessery */
2172 PUSHMARK(SP);
2173 retcnt = call_sv(&PL_sv_yes, 0); /* does nothing */
2174 SPAGAIN;
2175 SP -= retcnt;
2176 PUSHMARK(SP);
2177 retcnt = call_sv(&PL_sv_no, G_EVAL);
2178 SPAGAIN;
2179 SP -= retcnt;
2180 errsv = ERRSV;
2181 errstr = SvPV_nolen(errsv);
2182 if(strnEQ(errstr, "Undefined subroutine &main:: called at",
2183 sizeof("Undefined subroutine &main:: called at") - 1)) {
2184 PUSHMARK(SP);
2185 retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2186 SPAGAIN;
2187 SP -= retcnt;
2188 }
2189 PUSHMARK(SP);
2190 retcnt = call_sv(&PL_sv_undef, G_EVAL);
2191 SPAGAIN;
2192 SP -= retcnt;
2193 errsv = ERRSV;
2194 errstr = SvPV_nolen(errsv);
2195 if(strnEQ(errstr, "Can't use an undefined value as a subroutine reference at",
2196 sizeof("Can't use an undefined value as a subroutine reference at") - 1)) {
2197 PUSHMARK(SP);
2198 retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2199 SPAGAIN;
2200 SP -= retcnt;
2201 }
2202 PUSHMARK(SP);
2203 retcnt = call_sv((SV*)hv, G_EVAL);
2204 SPAGAIN;
2205 SP -= retcnt;
2206 errsv = ERRSV;
2207 errstr = SvPV_nolen(errsv);
2208 if(strnEQ(errstr, "Not a CODE reference at",
2209 sizeof("Not a CODE reference at") - 1)) {
2210 PUSHMARK(SP);
2211 retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2212 SPAGAIN;
2213 SP -= retcnt;
2214 }
d1f347d7
DM
2215
2216void
2217call_sv(sv, flags, ...)
2218 SV* sv
2219 I32 flags
2220 PREINIT:
2221 I32 i;
2222 PPCODE:
2223 for (i=0; i<items-2; i++)
2224 ST(i) = ST(i+2); /* pop first two args */
2225 PUSHMARK(SP);
2226 SP += items - 2;
2227 PUTBACK;
2228 i = call_sv(sv, flags);
2229 SPAGAIN;
2230 EXTEND(SP, 1);
2231 PUSHs(sv_2mortal(newSViv(i)));
2232
2233void
2234call_pv(subname, flags, ...)
2235 char* subname
2236 I32 flags
2237 PREINIT:
2238 I32 i;
2239 PPCODE:
2240 for (i=0; i<items-2; i++)
2241 ST(i) = ST(i+2); /* pop first two args */
2242 PUSHMARK(SP);
2243 SP += items - 2;
2244 PUTBACK;
2245 i = call_pv(subname, flags);
2246 SPAGAIN;
2247 EXTEND(SP, 1);
2248 PUSHs(sv_2mortal(newSViv(i)));
2249
2250void
2251call_method(methname, flags, ...)
2252 char* methname
2253 I32 flags
2254 PREINIT:
2255 I32 i;
2256 PPCODE:
2257 for (i=0; i<items-2; i++)
2258 ST(i) = ST(i+2); /* pop first two args */
2259 PUSHMARK(SP);
2260 SP += items - 2;
2261 PUTBACK;
2262 i = call_method(methname, flags);
2263 SPAGAIN;
2264 EXTEND(SP, 1);
2265 PUSHs(sv_2mortal(newSViv(i)));
2266
2267void
c0810f8e 2268newCONSTSUB(stash, name, flags, sv)
3453414d
BF
2269 HV* stash
2270 SV* name
2271 I32 flags
8f82b567 2272 SV* sv
c0810f8e
NC
2273 ALIAS:
2274 newCONSTSUB_flags = 1
3453414d 2275 PREINIT:
5f74c55e 2276 CV* mycv = NULL;
9c0a6090
FC
2277 STRLEN len;
2278 const char *pv = SvPV(name, len);
3453414d 2279 PPCODE:
c0810f8e 2280 switch (ix) {
3453414d 2281 case 0:
dc4b20bd 2282 mycv = newCONSTSUB(stash, pv, SvOK(sv) ? SvREFCNT_inc(sv) : NULL);
3453414d
BF
2283 break;
2284 case 1:
dc4b20bd 2285 mycv = newCONSTSUB_flags(
0fc4714a 2286 stash, pv, len, flags | SvUTF8(name), SvOK(sv) ? SvREFCNT_inc(sv) : NULL
8f82b567 2287 );
3453414d
BF
2288 break;
2289 }
2290 EXTEND(SP, 2);
316ebaf2 2291 assert(mycv);
dc4b20bd
CB
2292 PUSHs( CvCONST(mycv) ? &PL_sv_yes : &PL_sv_no );
2293 PUSHs((SV*)CvGV(mycv));
3453414d
BF
2294
2295void
e6066781
BF
2296gv_init_type(namesv, multi, flags, type)
2297 SV* namesv
2298 int multi
2299 I32 flags
2300 int type
2301 PREINIT:
2302 STRLEN len;
2303 const char * const name = SvPV_const(namesv, len);
2304 GV *gv = *(GV**)hv_fetch(PL_defstash, name, len, TRUE);
2305 PPCODE:
2306 if (SvTYPE(gv) == SVt_PVGV)
2307 Perl_croak(aTHX_ "GV is already a PVGV");
04ec7e59 2308 if (multi) flags |= GV_ADDMULTI;
e6066781
BF
2309 switch (type) {
2310 case 0:
2311 gv_init(gv, PL_defstash, name, len, multi);
2312 break;
2313 case 1:
04ec7e59 2314 gv_init_sv(gv, PL_defstash, namesv, flags);
e6066781
BF
2315 break;
2316 case 2:
04ec7e59 2317 gv_init_pv(gv, PL_defstash, name, flags | SvUTF8(namesv));
e6066781
BF
2318 break;
2319 case 3:
04ec7e59 2320 gv_init_pvn(gv, PL_defstash, name, len, flags | SvUTF8(namesv));
e6066781
BF
2321 break;
2322 }
2323 XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2324
2325void
e6919483
BF
2326gv_fetchmeth_type(stash, methname, type, level, flags)
2327 HV* stash
2328 SV* methname
2329 int type
2330 I32 level
2331 I32 flags
2332 PREINIT:
2333 STRLEN len;
2334 const char * const name = SvPV_const(methname, len);
5f74c55e 2335 GV* gv = NULL;
e6919483
BF
2336 PPCODE:
2337 switch (type) {
2338 case 0:
2339 gv = gv_fetchmeth(stash, name, len, level);
2340 break;
2341 case 1:
2342 gv = gv_fetchmeth_sv(stash, methname, level, flags);
2343 break;
2344 case 2:
2345 gv = gv_fetchmeth_pv(stash, name, level, flags | SvUTF8(methname));
2346 break;
2347 case 3:
2348 gv = gv_fetchmeth_pvn(stash, name, len, level, flags | SvUTF8(methname));
2349 break;
2350 }
2351 XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
2352
2353void
d21989ed
BF
2354gv_fetchmeth_autoload_type(stash, methname, type, level, flags)
2355 HV* stash
2356 SV* methname
2357 int type
2358 I32 level
2359 I32 flags
2360 PREINIT:
2361 STRLEN len;
2362 const char * const name = SvPV_const(methname, len);
5f74c55e 2363 GV* gv = NULL;
d21989ed
BF
2364 PPCODE:
2365 switch (type) {
2366 case 0:
2367 gv = gv_fetchmeth_autoload(stash, name, len, level);
2368 break;
2369 case 1:
2370 gv = gv_fetchmeth_sv_autoload(stash, methname, level, flags);
2371 break;
2372 case 2:
2373 gv = gv_fetchmeth_pv_autoload(stash, name, level, flags | SvUTF8(methname));
2374 break;
2375 case 3:
2376 gv = gv_fetchmeth_pvn_autoload(stash, name, len, level, flags | SvUTF8(methname));
2377 break;
2378 }
2379 XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
2380
2381void
44130a26
BF
2382gv_fetchmethod_flags_type(stash, methname, type, flags)
2383 HV* stash
2384 SV* methname
2385 int type
2386 I32 flags
2387 PREINIT:
5f74c55e 2388 GV* gv = NULL;
44130a26
BF
2389 PPCODE:
2390 switch (type) {
2391 case 0:
2392 gv = gv_fetchmethod_flags(stash, SvPVX_const(methname), flags);
2393 break;
2394 case 1:
2395 gv = gv_fetchmethod_sv_flags(stash, methname, flags);
2396 break;
2397 case 2:
2398 gv = gv_fetchmethod_pv_flags(stash, SvPV_nolen(methname), flags | SvUTF8(methname));
2399 break;
2400 case 3: {
2401 STRLEN len;
2402 const char * const name = SvPV_const(methname, len);
2403 gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname));
2404 break;
2405 }
2406 }
5fba3c91 2407 XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
44130a26 2408
5fba3c91 2409void
0eeb01b9 2410gv_autoload_type(stash, methname, type, method)
5fba3c91
BF
2411 HV* stash
2412 SV* methname
2413 int type
2414 I32 method
5fba3c91
BF
2415 PREINIT:
2416 STRLEN len;
2417 const char * const name = SvPV_const(methname, len);
5f74c55e 2418 GV* gv = NULL;
0eeb01b9 2419 I32 flags = method ? GV_AUTOLOAD_ISMETHOD : 0;
5fba3c91
BF
2420 PPCODE:
2421 switch (type) {
2422 case 0:
2423 gv = gv_autoload4(stash, name, len, method);
2424 break;
2425 case 1:
0eeb01b9 2426 gv = gv_autoload_sv(stash, methname, flags);
5fba3c91
BF
2427 break;
2428 case 2:
0eeb01b9 2429 gv = gv_autoload_pv(stash, name, flags | SvUTF8(methname));
5fba3c91
BF
2430 break;
2431 case 3:
0eeb01b9 2432 gv = gv_autoload_pvn(stash, name, len, flags | SvUTF8(methname));
5fba3c91
BF
2433 break;
2434 }
44130a26
BF
2435 XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2436
16a6e5a4
TC
2437SV *
2438gv_const_sv(SV *name)
2439 PREINIT:
2440 GV *gv;
2441 CODE:
2442 if (SvPOK(name)) {
2443 HV *stash = gv_stashpv("main",0);
2444 HE *he = hv_fetch_ent(stash, name, 0, 0);
2445 gv = (GV *)HeVAL(he);
2446 }
2447 else {
2448 gv = (GV *)name;
2449 }
2450 RETVAL = gv_const_sv(gv);
2451 if (!RETVAL)
2452 XSRETURN_EMPTY;
2453 RETVAL = newSVsv(RETVAL);
2454 OUTPUT:
2455 RETVAL
2456
44130a26 2457void
84c7b88c
BF
2458whichsig_type(namesv, type)
2459 SV* namesv
2460 int type
2461 PREINIT:
2462 STRLEN len;
2463 const char * const name = SvPV_const(namesv, len);
5f74c55e 2464 I32 i = 0;
84c7b88c
BF
2465 PPCODE:
2466 switch (type) {
2467 case 0:
2468 i = whichsig(name);
2469 break;
2470 case 1:
2471 i = whichsig_sv(namesv);
2472 break;
2473 case 2:
2474 i = whichsig_pv(name);
2475 break;
2476 case 3:
2477 i = whichsig_pvn(name, len);
2478 break;
2479 }
2480 XPUSHs(sv_2mortal(newSViv(i)));
2481
2482void
d1f347d7
DM
2483eval_sv(sv, flags)
2484 SV* sv
2485 I32 flags
2486 PREINIT:
2487 I32 i;
2488 PPCODE:
2489 PUTBACK;
2490 i = eval_sv(sv, flags);
2491 SPAGAIN;
2492 EXTEND(SP, 1);
2493 PUSHs(sv_2mortal(newSViv(i)));
2494
b8e65a9b 2495void
d1f347d7
DM
2496eval_pv(p, croak_on_error)
2497 const char* p
2498 I32 croak_on_error
d1f347d7
DM
2499 PPCODE:
2500 PUTBACK;
2501 EXTEND(SP, 1);
2502 PUSHs(eval_pv(p, croak_on_error));
2503
2504void
2505require_pv(pv)
2506 const char* pv
d1f347d7
DM
2507 PPCODE:
2508 PUTBACK;
2509 require_pv(pv);
2510
0ca3a874 2511int
7a646707 2512apitest_exception(throw_e)
0ca3a874
MHM
2513 int throw_e
2514 OUTPUT:
2515 RETVAL
d1f347d7 2516
ef469b03 2517void
7e7a3dfc
GA
2518mycroak(sv)
2519 SV* sv
ef469b03 2520 CODE:
7e7a3dfc
GA
2521 if (SvOK(sv)) {
2522 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
2523 }
2524 else {
2525 Perl_croak(aTHX_ NULL);
2526 }
5d2b1485
NC
2527
2528SV*
2529strtab()
2530 CODE:
2531 RETVAL = newRV_inc((SV*)PL_strtab);
2532 OUTPUT:
2533 RETVAL
85ce96a1
DM
2534
2535int
2536my_cxt_getint()
2537 CODE:
2538 dMY_CXT;
2539 RETVAL = my_cxt_getint_p(aMY_CXT);
2540 OUTPUT:
2541 RETVAL
2542
2543void
2544my_cxt_setint(i)
2545 int i;
2546 CODE:
2547 dMY_CXT;
2548 my_cxt_setint_p(aMY_CXT_ i);
2549
2550void
9568a123
NC
2551my_cxt_getsv(how)
2552 bool how;
85ce96a1 2553 PPCODE:
85ce96a1 2554 EXTEND(SP, 1);
9568a123 2555 ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
85ce96a1
DM
2556 XSRETURN(1);
2557
2558void
2559my_cxt_setsv(sv)
2560 SV *sv;
2561 CODE:
2562 dMY_CXT;
2563 SvREFCNT_dec(MY_CXT.sv);
2564 my_cxt_setsv_p(sv _aMY_CXT);
2565 SvREFCNT_inc(sv);
34482cd6
NC
2566
2567bool
2568sv_setsv_cow_hashkey_core()
2569
2570bool
2571sv_setsv_cow_hashkey_notcore()
84ac5fd7
NC
2572
2573void
74ee33f2
FC
2574sv_set_deref(SV *sv, SV *sv2, int which)
2575 CODE:
2576 {
2577 STRLEN len;
2578 const char *pv = SvPV(sv2,len);
2579 if (!SvROK(sv)) croak("Not a ref");
2580 sv = SvRV(sv);
2581 switch (which) {
2582 case 0: sv_setsv(sv,sv2); break;
2583 case 1: sv_setpv(sv,pv); break;
2584 case 2: sv_setpvn(sv,pv,len); break;
2585 }
2586 }
2587
2588void
218787bd
VP
2589rmagical_cast(sv, type)
2590 SV *sv;
2591 SV *type;
2592 PREINIT:
2593 struct ufuncs uf;
2594 PPCODE:
2595 if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
2596 sv = SvRV(sv);
2597 if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
2598 uf.uf_val = rmagical_a_dummy;
2599 uf.uf_set = NULL;
2600 uf.uf_index = 0;
2601 if (SvTRUE(type)) { /* b */
2602 sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
2603 } else { /* a */
2604 sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
2605 }
2606 XSRETURN_YES;
2607
2608void
2609rmagical_flags(sv)
2610 SV *sv;
2611 PPCODE:
2612 if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
2613 sv = SvRV(sv);
2614 EXTEND(SP, 3);
2615 mXPUSHu(SvFLAGS(sv) & SVs_GMG);
2616 mXPUSHu(SvFLAGS(sv) & SVs_SMG);
2617 mXPUSHu(SvFLAGS(sv) & SVs_RMG);
2618 XSRETURN(3);
2619
2620void
90d1f214
BM
2621my_caller(level)
2622 I32 level
2623 PREINIT:
2624 const PERL_CONTEXT *cx, *dbcx;
2625 const char *pv;
2626 const GV *gv;
2627 HV *hv;
2628 PPCODE:
2629 cx = caller_cx(level, &dbcx);
2630 EXTEND(SP, 8);
2631
2632 pv = CopSTASHPV(cx->blk_oldcop);
2633 ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
2634 gv = CvGV(cx->blk_sub.cv);
2635 ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
2636
2637 pv = CopSTASHPV(dbcx->blk_oldcop);
2638 ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
2639 gv = CvGV(dbcx->blk_sub.cv);
2640 ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
2641
20439bc7
Z
2642 ST(4) = cop_hints_fetch_pvs(cx->blk_oldcop, "foo", 0);
2643 ST(5) = cop_hints_fetch_pvn(cx->blk_oldcop, "foo", 3, 0, 0);
2644 ST(6) = cop_hints_fetch_sv(cx->blk_oldcop,
c2b90b61 2645 sv_2mortal(newSVpvs("foo")), 0, 0);
90d1f214 2646
20439bc7 2647 hv = cop_hints_2hv(cx->blk_oldcop, 0);
90d1f214
BM
2648 ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
2649
2650 XSRETURN(8);
2651
2652void
f9c17636
MB
2653DPeek (sv)
2654 SV *sv
2655
2656 PPCODE:
5b1f7359 2657 ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
f9c17636
MB
2658 XSRETURN (1);
2659
2660void
84ac5fd7
NC
2661BEGIN()
2662 CODE:
2663 sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
2664
2665void
2666CHECK()
2667 CODE:
2668 sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
2669
2670void
2671UNITCHECK()
2672 CODE:
0932863f 2673 sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
84ac5fd7
NC
2674
2675void
2676INIT()
2677 CODE:
2678 sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
2679
2680void
2681END()
2682 CODE:
2683 sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
30685b56
NC
2684
2685void
2686utf16_to_utf8 (sv, ...)
2687 SV* sv
2688 ALIAS:
2689 utf16_to_utf8_reversed = 1
2690 PREINIT:
2691 STRLEN len;
2692 U8 *source;
2693 SV *dest;
2694 I32 got; /* Gah, badly thought out APIs */
2695 CODE:
a4d7a71b 2696 if (ix) (void)SvPV_force_nolen(sv);
30685b56
NC
2697 source = (U8 *)SvPVbyte(sv, len);
2698 /* Optionally only convert part of the buffer. */
2699 if (items > 1) {
2700 len = SvUV(ST(1));
2701 }
2702 /* Mortalise this right now, as we'll be testing croak()s */
2703 dest = sv_2mortal(newSV(len * 3 / 2 + 1));
2704 if (ix) {
25f2e844 2705 utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
30685b56 2706 } else {
25f2e844 2707 utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
30685b56
NC
2708 }
2709 SvCUR_set(dest, got);
2710 SvPVX(dest)[got] = '\0';
2711 SvPOK_on(dest);
2712 ST(0) = dest;
2713 XSRETURN(1);
879d0c72 2714
6bd7445c
GG
2715void
2716my_exit(int exitcode)
2717 PPCODE:
2718 my_exit(exitcode);
d97c33b5 2719
209e41dc
NT
2720U8
2721first_byte(sv)
2722 SV *sv
2723 CODE:
2724 char *s;
2725 STRLEN len;
2726 s = SvPVbyte(sv, len);
2727 RETVAL = s[0];
2728 OUTPUT:
2729 RETVAL
2730
d97c33b5
DM
2731I32
2732sv_count()
2733 CODE:
2734 RETVAL = PL_sv_count;
2735 OUTPUT:
2736 RETVAL
13b6b3bc
BM
2737
2738void
2739bhk_record(bool on)
2740 CODE:
2741 dMY_CXT;
2742 MY_CXT.bhk_record = on;
2743 if (on)
2744 av_clear(MY_CXT.bhkav);
65bfe90c 2745
defdfed5 2746void
d9088386
Z
2747test_magic_chain()
2748 PREINIT:
2749 SV *sv;
2750 MAGIC *callmg, *uvarmg;
2751 CODE:
2752 sv = sv_2mortal(newSV(0));
11f9f0ed
NC
2753 if (SvTYPE(sv) >= SVt_PVMG) croak_fail();
2754 if (SvMAGICAL(sv)) croak_fail();
d9088386 2755 sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0);
11f9f0ed
NC
2756 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2757 if (!SvMAGICAL(sv)) croak_fail();
2758 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
d9088386 2759 callmg = mg_find(sv, PERL_MAGIC_checkcall);
11f9f0ed 2760 if (!callmg) croak_fail();
d9088386 2761 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 2762 croak_fail();
d9088386 2763 sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
11f9f0ed
NC
2764 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2765 if (!SvMAGICAL(sv)) croak_fail();
2766 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
d9088386 2767 uvarmg = mg_find(sv, PERL_MAGIC_uvar);
11f9f0ed 2768 if (!uvarmg) croak_fail();
d9088386 2769 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 2770 croak_fail();
d9088386 2771 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 2772 croak_fail();
d9088386 2773 mg_free_type(sv, PERL_MAGIC_vec);
11f9f0ed
NC
2774 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2775 if (!SvMAGICAL(sv)) croak_fail();
2776 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2777 if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
d9088386 2778 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 2779 croak_fail();
d9088386 2780 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 2781 croak_fail();
d9088386 2782 mg_free_type(sv, PERL_MAGIC_uvar);
11f9f0ed
NC
2783 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2784 if (!SvMAGICAL(sv)) croak_fail();
2785 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2786 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
d9088386 2787 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 2788 croak_fail();
d9088386 2789 sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
11f9f0ed
NC
2790 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2791 if (!SvMAGICAL(sv)) croak_fail();
2792 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
d9088386 2793 uvarmg = mg_find(sv, PERL_MAGIC_uvar);
11f9f0ed 2794 if (!uvarmg) croak_fail();
d9088386 2795 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
11f9f0ed 2796 croak_fail();
d9088386 2797 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 2798 croak_fail();
d9088386 2799 mg_free_type(sv, PERL_MAGIC_checkcall);
11f9f0ed
NC
2800 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2801 if (!SvMAGICAL(sv)) croak_fail();
2802 if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
2803 if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
d9088386 2804 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
11f9f0ed 2805 croak_fail();
d9088386 2806 mg_free_type(sv, PERL_MAGIC_uvar);
11f9f0ed
NC
2807 if (SvMAGICAL(sv)) croak_fail();
2808 if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
2809 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
d9088386
Z
2810
2811void
2812test_op_contextualize()
2813 PREINIT:
2814 OP *o;
2815 CODE:
2816 o = newSVOP(OP_CONST, 0, newSViv(0));
2817 o->op_flags &= ~OPf_WANT;
2818 o = op_contextualize(o, G_SCALAR);
2819 if (o->op_type != OP_CONST ||
2820 (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
11f9f0ed 2821 croak_fail();
d9088386
Z
2822 op_free(o);
2823 o = newSVOP(OP_CONST, 0, newSViv(0));
2824 o->op_flags &= ~OPf_WANT;
2825 o = op_contextualize(o, G_ARRAY);
2826 if (o->op_type != OP_CONST ||
2827 (o->op_flags & OPf_WANT) != OPf_WANT_LIST)
11f9f0ed 2828 croak_fail();
d9088386
Z
2829 op_free(o);
2830 o = newSVOP(OP_CONST, 0, newSViv(0));
2831 o->op_flags &= ~OPf_WANT;
2832 o = op_contextualize(o, G_VOID);
11f9f0ed 2833 if (o->op_type != OP_NULL) croak_fail();
d9088386
Z
2834 op_free(o);
2835
2836void
2837test_rv2cv_op_cv()
2838 PROTOTYPE:
2839 PREINIT:
7616a0c2 2840 GV *troc_gv;
d9088386
Z
2841 CV *troc_cv;
2842 OP *o;
2843 CODE:
2844 troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
2845 troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
d9088386 2846 o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
11f9f0ed 2847 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
d9088386 2848 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
11f9f0ed 2849 croak_fail();
d9088386 2850 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC
2851 if (rv2cv_op_cv(o, 0)) croak_fail();
2852 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 2853 o->op_private &= ~OPpENTERSUB_AMPER;
11f9f0ed
NC
2854 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2855 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
2856 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
d9088386
Z
2857 op_free(o);
2858 o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0));
2859 o->op_private = OPpCONST_BARE;
2860 o = newCVREF(0, o);
11f9f0ed 2861 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
d9088386 2862 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
11f9f0ed 2863 croak_fail();
d9088386 2864 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC
2865 if (rv2cv_op_cv(o, 0)) croak_fail();
2866 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386
Z
2867 op_free(o);
2868 o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv)));
11f9f0ed 2869 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
d9088386 2870 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
11f9f0ed 2871 croak_fail();
d9088386 2872 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC
2873 if (rv2cv_op_cv(o, 0)) croak_fail();
2874 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 2875 o->op_private &= ~OPpENTERSUB_AMPER;
11f9f0ed
NC
2876 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2877 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
2878 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
d9088386
Z
2879 op_free(o);
2880 o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))));
11f9f0ed
NC
2881 if (rv2cv_op_cv(o, 0)) croak_fail();
2882 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 2883 o->op_private |= OPpENTERSUB_AMPER;
11f9f0ed
NC
2884 if (rv2cv_op_cv(o, 0)) croak_fail();
2885 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386 2886 o->op_private &= ~OPpENTERSUB_AMPER;
11f9f0ed
NC
2887 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2888 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail();
2889 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
d9088386
Z
2890 op_free(o);
2891 o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)));
11f9f0ed
NC
2892 if (rv2cv_op_cv(o, 0)) croak_fail();
2893 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
d9088386
Z
2894 op_free(o);
2895
2896void
2897test_cv_getset_call_checker()
2898 PREINIT:
2899 CV *troc_cv, *tsh_cv;
2900 Perl_call_checker ckfun;
2901 SV *ckobj;
2902 CODE:
2903#define check_cc(cv, xckfun, xckobj) \
2904 do { \
2905 cv_get_call_checker((cv), &ckfun, &ckobj); \
779bc08a
NC
2906 if (ckfun != (xckfun)) croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); \
2907 if (ckobj != (xckobj)) croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); \
d9088386
Z
2908 } while(0)
2909 troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
2910 tsh_cv = get_cv("XS::APItest::test_savehints", 0);
2911 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
2912 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
2913 cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
2914 &PL_sv_yes);
2915 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
2916 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
2917 cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
2918 check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
2919 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
2920 cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
2921 (SV*)tsh_cv);
2922 check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
2923 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
2924 cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list,
2925 (SV*)troc_cv);
2926 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
2927 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
11f9f0ed
NC
2928 if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail();
2929 if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
d9088386
Z
2930#undef check_cc
2931
2932void
2933cv_set_call_checker_lists(CV *cv)
2934 CODE:
2935 cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
2936
2937void
2938cv_set_call_checker_scalars(CV *cv)
2939 CODE:
2940 cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
2941
2942void
2943cv_set_call_checker_proto(CV *cv, SV *proto)
2944 CODE:
2945 if (SvROK(proto))
2946 proto = SvRV(proto);
2947 cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
2948
2949void
2950cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
2951 CODE:
2952 if (SvROK(proto))
2953 proto = SvRV(proto);
2954 cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
2955
2956void
2957cv_set_call_checker_multi_sum(CV *cv)
2958 CODE:
2959 cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
2960
2961void
20439bc7
Z
2962test_cophh()
2963 PREINIT:
2964 COPHH *a, *b;
72900640
KW
2965#ifdef EBCDIC
2966 SV* key_sv;
2967 char * key_name;
2968 STRLEN key_len;
2969#endif
20439bc7
Z
2970 CODE:
2971#define check_ph(EXPR) \
2972 do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0)
2973#define check_iv(EXPR, EXPECT) \
2974 do { if(SvIV(EXPR) != (EXPECT)) croak("fail"); } while(0)
2975#define msvpvs(STR) sv_2mortal(newSVpvs(STR))
2976#define msviv(VALUE) sv_2mortal(newSViv(VALUE))
2977 a = cophh_new_empty();
2978 check_ph(cophh_fetch_pvn(a, "foo_1", 5, 0, 0));
2979 check_ph(cophh_fetch_pvs(a, "foo_1", 0));
2980 check_ph(cophh_fetch_pv(a, "foo_1", 0, 0));
2981 check_ph(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0));
2982 a = cophh_store_pvn(a, "foo_1abc", 5, 0, msviv(111), 0);
2983 a = cophh_store_pvs(a, "foo_2", msviv(222), 0);
2984 a = cophh_store_pv(a, "foo_3", 0, msviv(333), 0);
2985 a = cophh_store_sv(a, msvpvs("foo_4"), 0, msviv(444), 0);
2986 check_iv(cophh_fetch_pvn(a, "foo_1xyz", 5, 0, 0), 111);
2987 check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
2988 check_iv(cophh_fetch_pv(a, "foo_1", 0, 0), 111);
2989 check_iv(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0), 111);
2990 check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
2991 check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
2992 check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
2993 check_ph(cophh_fetch_pvs(a, "foo_5", 0));
2994 b = cophh_copy(a);
2995 b = cophh_store_pvs(b, "foo_1", msviv(1111), 0);
2996 check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
2997 check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
2998 check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
2999 check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3000 check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3001 check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3002 check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3003 check_iv(cophh_fetch_pvs(b, "foo_3", 0), 333);
3004 check_iv(cophh_fetch_pvs(b, "foo_4", 0), 444);
3005 check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3006 a = cophh_delete_pvn(a, "foo_1abc", 5, 0, 0);
3007 a = cophh_delete_pvs(a, "foo_2", 0);
3008 b = cophh_delete_pv(b, "foo_3", 0, 0);
3009 b = cophh_delete_sv(b, msvpvs("foo_4"), 0, 0);
3010 check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3011 check_ph(cophh_fetch_pvs(a, "foo_2", 0));
3012 check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3013 check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3014 check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3015 check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3016 check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3017 check_ph(cophh_fetch_pvs(b, "foo_3", 0));
3018 check_ph(cophh_fetch_pvs(b, "foo_4", 0));
3019 check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3020 b = cophh_delete_pvs(b, "foo_3", 0);
3021 b = cophh_delete_pvs(b, "foo_5", 0);
3022 check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3023 check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3024 check_ph(cophh_fetch_pvs(b, "foo_3", 0));
3025 check_ph(cophh_fetch_pvs(b, "foo_4", 0));
3026 check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3027 cophh_free(b);
3028 check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3029 check_ph(cophh_fetch_pvs(a, "foo_2", 0));
3030 check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3031 check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3032 check_ph(cophh_fetch_pvs(a, "foo_5", 0));
72900640 3033 a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8);
20439bc7 3034 a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
72900640 3035#ifndef EBCDIC
20439bc7 3036 a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
72900640
KW
3037#else
3038 /* On EBCDIC, we need to translate the UTF-8 in the ASCII test to the
3039 * equivalent UTF-EBCDIC for the code page. This is done at runtime
3040 * (with the helper function in this file). Therefore we can't use
3041 * cophhh_store_pvs(), as we don't have literal string */
3042 key_sv = sv_2mortal(newSVpvs("foo_"));
3043 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3044 key_name = SvPV(key_sv, key_len);
3045 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8);
3046#endif
3047#ifndef EBCDIC
20439bc7 3048 a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
72900640
KW
3049#else
3050 sv_setpvs(key_sv, "foo_");
3051 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3052 key_name = SvPV(key_sv, key_len);
3053 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8);
3054#endif
3055#ifndef EBCDIC
20439bc7 3056 a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
72900640
KW
3057#else
3058 sv_setpvs(key_sv, "foo_");
3059 cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3060 key_name = SvPV(key_sv, key_len);
3061 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8);
3062#endif
20439bc7
Z
3063 check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111);
3064 check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111);
3065 check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123);
72900640 3066#ifndef EBCDIC
20439bc7
Z
3067 check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123);
3068 check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0));
72900640
KW
3069#else
3070 sv_setpvs(key_sv, "foo_");
3071 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xaa"));
3072 key_name = SvPV(key_sv, key_len);
3073 check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 123);
3074 check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3075#endif
20439bc7 3076 check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456);
72900640 3077#ifndef EBCDIC
20439bc7
Z
3078 check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456);
3079 check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0));
72900640
KW
3080#else
3081 sv_setpvs(key_sv, "foo_");
3082 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3083 key_name = SvPV(key_sv, key_len);
3084 check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 456);
3085 check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3086#endif
20439bc7 3087 check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789);
72900640 3088#ifndef EBCDIC
20439bc7
Z
3089 check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789);
3090 check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0));
72900640
KW
3091#else
3092 sv_setpvs(key_sv, "foo_");
3093 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3094 key_name = SvPV(key_sv, key_len);
3095 check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 789);
3096 check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3097#endif
3098#ifndef EBCDIC
20439bc7
Z
3099 check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666);
3100 check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0));
72900640
KW
3101#else
3102 sv_setpvs(key_sv, "foo_");
3103 cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3104 key_name = SvPV(key_sv, key_len);
3105 check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 666);
3106 check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3107#endif
3987a177
Z
3108 ENTER;
3109 SAVEFREECOPHH(a);
3110 LEAVE;
20439bc7
Z
3111#undef check_ph
3112#undef check_iv
3113#undef msvpvs
3114#undef msviv
3115
8375c93e
RU
3116void
3117test_coplabel()
3118 PREINIT:
3119 COP *cop;
32708f0b
CB
3120 const char *label;
3121 STRLEN len;
3122 U32 utf8;
8375c93e
RU
3123 CODE:
3124 cop = &PL_compiling;
32708f0b
CB
3125 Perl_cop_store_label(aTHX_ cop, "foo", 3, 0);
3126 label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
3127 if (strcmp(label,"foo")) croak("fail # cop_fetch_label label");
3128 if (len != 3) croak("fail # cop_fetch_label len");
3129 if (utf8) croak("fail # cop_fetch_label utf8");
8375c93e 3130 /* SMALL GERMAN UMLAUT A */
a1cd495a 3131 Perl_cop_store_label(aTHX_ cop, "fo\xc3\xa4", 4, SVf_UTF8);
32708f0b 3132 label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
a1cd495a 3133 if (strcmp(label,"fo\xc3\xa4")) croak("fail # cop_fetch_label label");
72024711 3134 if (len != 4) croak("fail # cop_fetch_label len");
32708f0b 3135 if (!utf8) croak("fail # cop_fetch_label utf8");
8375c93e
RU
3136
3137
20439bc7
Z
3138HV *
3139example_cophh_2hv()
3140 PREINIT:
3141 COPHH *a;
72900640
KW
3142#ifdef EBCDIC
3143 SV* key_sv;
3144 char * key_name;
3145 STRLEN key_len;
3146#endif
20439bc7
Z
3147 CODE:
3148#define msviv(VALUE) sv_2mortal(newSViv(VALUE))
3149 a = cophh_new_empty();
3150 a = cophh_store_pvs(a, "foo_0", msviv(999), 0);
3151 a = cophh_store_pvs(a, "foo_1", msviv(111), 0);
3152 a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
72900640 3153#ifndef EBCDIC
20439bc7 3154 a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
72900640
KW
3155#else
3156 key_sv = sv_2mortal(newSVpvs("foo_"));
3157 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3158 key_name = SvPV(key_sv, key_len);
3159 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8);
3160#endif
3161#ifndef EBCDIC
20439bc7 3162 a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
72900640
KW
3163#else
3164 sv_setpvs(key_sv, "foo_");
3165 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3166 key_name = SvPV(key_sv, key_len);
3167 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8);
3168#endif
3169#ifndef EBCDIC
20439bc7 3170 a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
72900640
KW
3171#else
3172 sv_setpvs(key_sv, "foo_");
3173 cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3174 key_name = SvPV(key_sv, key_len);
3175 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8);
3176#endif
20439bc7
Z
3177 a = cophh_delete_pvs(a, "foo_0", 0);
3178 a = cophh_delete_pvs(a, "foo_2", 0);
3179 RETVAL = cophh_2hv(a, 0);
3180 cophh_free(a);
3181#undef msviv
3182 OUTPUT:
3183 RETVAL
3184
3185void
defdfed5
Z
3186test_savehints()
3187 PREINIT:
3188 SV **svp, *sv;
3189 CODE:
3190#define store_hint(KEY, VALUE) \
3191 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
3192#define hint_ok(KEY, EXPECT) \
3193 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
3194 (sv = *svp) && SvIV(sv) == (EXPECT) && \
20439bc7 3195 (sv = cop_hints_fetch_pvs(&PL_compiling, KEY, 0)) && \
defdfed5
Z
3196 SvIV(sv) == (EXPECT))
3197#define check_hint(KEY, EXPECT) \
11f9f0ed 3198 do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0)
defdfed5
Z
3199 PL_hints |= HINT_LOCALIZE_HH;
3200 ENTER;
3201 SAVEHINTS();
3202 PL_hints &= HINT_INTEGER;
3203 store_hint("t0", 123);
3204 store_hint("t1", 456);
11f9f0ed 3205 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
3206 check_hint("t0", 123); check_hint("t1", 456);
3207 ENTER;
3208 SAVEHINTS();
11f9f0ed 3209 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
3210 check_hint("t0", 123); check_hint("t1", 456);
3211 PL_hints |= HINT_INTEGER;
3212 store_hint("t0", 321);
11f9f0ed 3213 if (!(PL_hints & HINT_INTEGER)) croak_fail();
defdfed5
Z
3214 check_hint("t0", 321); check_hint("t1", 456);
3215 LEAVE;
11f9f0ed 3216 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
3217 check_hint("t0", 123); check_hint("t1", 456);
3218 ENTER;
3219 SAVEHINTS();
11f9f0ed 3220 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
3221 check_hint("t0", 123); check_hint("t1", 456);
3222 store_hint("t1", 654);
11f9f0ed 3223 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
3224 check_hint("t0", 123); check_hint("t1", 654);
3225 LEAVE;
11f9f0ed 3226 if (PL_hints & HINT_INTEGER) croak_fail();
defdfed5
Z
3227 check_hint("t0", 123); check_hint("t1", 456);
3228 LEAVE;
3229#undef store_hint
3230#undef hint_ok
3231#undef check_hint
3232
3233void
3234test_copyhints()
3235 PREINIT:
3236 HV *a, *b;
3237 CODE:
3238 PL_hints |= HINT_LOCALIZE_HH;
3239 ENTER;
3240 SAVEHINTS();
3241 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
20439bc7
Z
3242 if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
3243 croak_fail();
defdfed5
Z
3244 a = newHVhv(GvHV(PL_hintgv));
3245 sv_2mortal((SV*)a);
3246 sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
20439bc7
Z
3247 if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
3248 croak_fail();
defdfed5
Z
3249 b = hv_copy_hints_hv(a);
3250 sv_2mortal((SV*)b);
3251 sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
20439bc7
Z
3252 if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 789)
3253 croak_fail();
defdfed5
Z
3254 LEAVE;
3255
201c7e1f 3256void
2fcb4757
Z
3257test_op_list()
3258 PREINIT:
3259 OP *a;
3260 CODE:
3261#define iv_op(iv) newSVOP(OP_CONST, 0, newSViv(iv))
3262#define check_op(o, expect) \
3263 do { \
3264 if (strcmp(test_op_list_describe(o), (expect))) \
3265 croak("fail %s %s", test_op_list_describe(o), (expect)); \
3266 } while(0)
3267 a = op_append_elem(OP_LIST, NULL, NULL);
3268 check_op(a, "");
3269 a = op_append_elem(OP_LIST, iv_op(1), a);
3270 check_op(a, "const(1).");
3271 a = op_append_elem(OP_LIST, NULL, a);
3272 check_op(a, "const(1).");
3273 a = op_append_elem(OP_LIST, a, iv_op(2));
3274 check_op(a, "list[pushmark.const(1).const(2).]");
3275 a = op_append_elem(OP_LIST, a, iv_op(3));
3276 check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3277 a = op_append_elem(OP_LIST, a, NULL);
3278 check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3279 a = op_append_elem(OP_LIST, NULL, a);
3280 check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3281 a = op_append_elem(OP_LIST, iv_op(4), a);
3282 check_op(a, "list[pushmark.const(4)."
3283 "list[pushmark.const(1).const(2).const(3).]]");
3284 a = op_append_elem(OP_LIST, a, iv_op(5));
3285 check_op(a, "list[pushmark.const(4)."
3286 "list[pushmark.const(1).const(2).const(3).]const(5).]");
3287 a = op_append_elem(OP_LIST, a,
3288 op_append_elem(OP_LIST, iv_op(7), iv_op(6)));
3289 check_op(a, "list[pushmark.const(4)."
3290 "list[pushmark.const(1).const(2).const(3).]const(5)."
3291 "list[pushmark.const(7).const(6).]]");
3292 op_free(a);
3293 a = op_append_elem(OP_LINESEQ, iv_op(1), iv_op(2));
3294 check_op(a, "lineseq[const(1).const(2).]");
3295 a = op_append_elem(OP_LINESEQ, a, iv_op(3));
3296 check_op(a, "lineseq[const(1).const(2).const(3).]");
3297 op_free(a);
3298 a = op_append_elem(OP_LINESEQ,
3299 op_append_elem(OP_LIST, iv_op(1), iv_op(2)),
3300 iv_op(3));
3301 check_op(a, "lineseq[list[pushmark.const(1).const(2).]const(3).]");
3302 op_free(a);
3303 a = op_prepend_elem(OP_LIST, NULL, NULL);
3304 check_op(a, "");
3305 a = op_prepend_elem(OP_LIST, a, iv_op(1));
3306 check_op(a, "const(1).");
3307 a = op_prepend_elem(OP_LIST, a, NULL);
3308 check_op(a, "const(1).");
3309 a = op_prepend_elem(OP_LIST, iv_op(2), a);
3310 check_op(a, "list[pushmark.const(2).const(1).]");
3311 a = op_prepend_elem(OP_LIST, iv_op(3), a);
3312 check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3313 a = op_prepend_elem(OP_LIST, NULL, a);
3314 check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3315 a = op_prepend_elem(OP_LIST, a, NULL);
3316 check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3317 a = op_prepend_elem(OP_LIST, a, iv_op(4));
3318 check_op(a, "list[pushmark."
3319 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3320 a = op_prepend_elem(OP_LIST, iv_op(5), a);
3321 check_op(a, "list[pushmark.const(5)."
3322 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3323 a = op_prepend_elem(OP_LIST,
3324 op_prepend_elem(OP_LIST, iv_op(6), iv_op(7)), a);
3325 check_op(a, "list[pushmark.list[pushmark.const(6).const(7).]const(5)."
3326 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3327 op_free(a);
3328 a = op_prepend_elem(OP_LINESEQ, iv_op(2), iv_op(1));
3329 check_op(a, "lineseq[const(2).const(1).]");
3330 a = op_prepend_elem(OP_LINESEQ, iv_op(3), a);
3331 check_op(a, "lineseq[const(3).const(2).const(1).]");
3332 op_free(a);
3333 a = op_prepend_elem(OP_LINESEQ, iv_op(3),
3334 op_prepend_elem(OP_LIST, iv_op(2), iv_op(1)));
3335 check_op(a, "lineseq[const(3).list[pushmark.const(2).const(1).]]");
3336 op_free(a);
3337 a = op_append_list(OP_LINESEQ, NULL, NULL);
3338 check_op(a, "");
3339 a = op_append_list(OP_LINESEQ, iv_op(1), a);
3340 check_op(a, "const(1).");
3341 a = op_append_list(OP_LINESEQ, NULL, a);
3342 check_op(a, "const(1).");
3343 a = op_append_list(OP_LINESEQ, a, iv_op(2));
3344 check_op(a, "lineseq[const(1).const(2).]");
3345 a = op_append_list(OP_LINESEQ, a, iv_op(3));
3346 check_op(a, "lineseq[const(1).const(2).const(3).]");
3347 a = op_append_list(OP_LINESEQ, iv_op(4), a);
3348 check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3349 a = op_append_list(OP_LINESEQ, a, NULL);
3350 check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3351 a = op_append_list(OP_LINESEQ, NULL, a);
3352 check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3353 a = op_append_list(OP_LINESEQ, a,
3354 op_append_list(OP_LINESEQ, iv_op(5), iv_op(6)));
3355 check_op(a, "lineseq[const(4).const(1).const(2).const(3)."
3356 "const(5).const(6).]");
3357 op_free(a);
3358 a = op_append_list(OP_LINESEQ,
3359 op_append_list(OP_LINESEQ, iv_op(1), iv_op(2)),
3360 op_append_list(OP_LIST, iv_op(3), iv_op(4)));
3361 check_op(a, "lineseq[const(1).const(2)."
3362 "list[pushmark.const(3).const(4).]]");
3363 op_free(a);
3364 a = op_append_list(OP_LINESEQ,
3365 op_append_list(OP_LIST, iv_op(1), iv_op(2)),
3366 op_append_list(OP_LINESEQ, iv_op(3), iv_op(4)));
3367 check_op(a, "lineseq[list[pushmark.const(1).const(2).]"
3368 "const(3).const(4).]");
3369 op_free(a);
2fcb4757
Z
3370#undef check_op
3371
3372void
5983a79d
BM
3373test_op_linklist ()
3374 PREINIT:
3375 OP *o;
3376 CODE:
3377#define check_ll(o, expect) \
3378 STMT_START { \
3379 if (strNE(test_op_linklist_describe(o), (expect))) \
3380 croak("fail %s %s", test_op_linklist_describe(o), (expect)); \
3381 } STMT_END
3382 o = iv_op(1);
3383 check_ll(o, ".const1");
3384 op_free(o);
3385
3386 o = mkUNOP(OP_NOT, iv_op(1));
3387 check_ll(o, ".const1.not");
3388 op_free(o);
3389
3390 o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1)));
3391 check_ll(o, ".const1.negate.not");
3392 op_free(o);
3393
3394 o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
3395 check_ll(o, ".const1.const2.add");
3396 op_free(o);
3397
3398 o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2));
3399 check_ll(o, ".const1.not.const2.add");
3400 op_free(o);
3401
3402 o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2)));
3403 check_ll(o, ".const1.const2.add.not");
3404 op_free(o);
3405
3406 o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3));
3407 check_ll(o, ".const1.const2.const3.lineseq");
3408 op_free(o);
3409
3410 o = mkLISTOP(OP_LINESEQ,
3411 mkBINOP(OP_ADD, iv_op(1), iv_op(2)),
3412 mkUNOP(OP_NOT, iv_op(3)),
3413 mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6)));
3414 check_ll(o, ".const1.const2.add.const3.not"
3415 ".const4.const5.const6.substr.lineseq");
3416 op_free(o);
3417
3418 o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
3419 LINKLIST(o);
3420 o = mkBINOP(OP_SUBTRACT, o, iv_op(3));
3421 check_ll(o, ".const1.const2.add.const3.subtract");
3422 op_free(o);
3423#undef check_ll
3424#undef iv_op
3425
3426void
201c7e1f
FR
3427peep_enable ()
3428 PREINIT:
3429 dMY_CXT;
3430 CODE:
3431 av_clear(MY_CXT.peep_recorder);
3432 av_clear(MY_CXT.rpeep_recorder);
3433 MY_CXT.peep_recording = 1;
3434
3435void
3436peep_disable ()
3437 PREINIT:
3438 dMY_CXT;
3439 CODE:
3440 MY_CXT.peep_recording = 0;
3441
3442SV *
3443peep_record ()
3444 PREINIT:
3445 dMY_CXT;
3446 CODE:
95d2461a 3447 RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
201c7e1f
FR
3448 OUTPUT:
3449 RETVAL
3450
3451SV *
3452rpeep_record ()
3453 PREINIT:
3454 dMY_CXT;
3455 CODE:
95d2461a 3456 RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
201c7e1f
FR
3457 OUTPUT:
3458 RETVAL
3459
9c540340
DM
3460=pod
3461
3462multicall_each: call a sub for each item in the list. Used to test MULTICALL
3463
3464=cut
3465
3466void
3467multicall_each(block,...)
3468 SV * block
3469PROTOTYPE: &@
3470CODE:
3471{
3472 dMULTICALL;
3473 int index;
3474 GV *gv;
3475 HV *stash;
3476 I32 gimme = G_SCALAR;
3477 SV **args = &PL_stack_base[ax];
3478 CV *cv;
3479
3480 if(items <= 1) {
3481 XSRETURN_UNDEF;
3482 }
3483 cv = sv_2cv(block, &stash, &gv, 0);
3484 if (cv == Nullcv) {
3485 croak("multicall_each: not a subroutine reference");
3486 }
3487 PUSH_MULTICALL(cv);
3488 SAVESPTR(GvSV(PL_defgv));
3489
3490 for(index = 1 ; index < items ; index++) {
3491 GvSV(PL_defgv) = args[index];
3492 MULTICALL;
3493 }
3494 POP_MULTICALL;
5f74c55e 3495 PERL_UNUSED_VAR(newsp);
9c540340
DM
3496 XSRETURN_UNDEF;
3497}
3498
1f0ba93b
DM
3499=pod
3500
3501multicall_return(): call the passed sub once in the specificed context
3502and return whatever it returns
3503
3504=cut
3505
3506void
3507multicall_return(block, context)
3508 SV *block
3509 I32 context
3510PROTOTYPE: &$
3511CODE:
3512{
3513 dSP;
3514 dMULTICALL;
3515 GV *gv;
3516 HV *stash;
3517 I32 gimme = context;
3518 CV *cv;
3519 AV *av;
3520 SV **p;
3521 Size_t i, size;
3522
3523 cv = sv_2cv(block, &stash, &gv, 0);
3524 if (cv == Nullcv) {
3525 croak("multicall_return not a subroutine reference");
3526 }
3527 PUSH_MULTICALL(cv);
3528
3529 MULTICALL;
3530
3531 /* copy returned values into an array so they're not freed during
3532 * POP_MULTICALL */
3533
3534 av = newAV();
3535 SPAGAIN;
3536
3537 switch (context) {
3538 case G_VOID:
3539 break;
3540
3541 case G_SCALAR:
3542 av_push(av, SvREFCNT_inc(TOPs));
3543 break;
3544
3545 case G_ARRAY:
3546 for (p = PL_stack_base + 1; p <= SP; p++)
3547 av_push(av, SvREFCNT_inc(*p));
3548 break;
3549 }
3550
3551 POP_MULTICALL;
3552
3553 PERL_UNUSED_VAR(newsp);
3554
3555 size = AvFILLp(av) + 1;
3556 EXTEND(SP, size);
3557 for (i = 0; i < size; i++)
3558 ST(i) = *av_fetch(av, i, FALSE);
3559 sv_2mortal((SV*)av);
3560 XSRETURN(size);
3561}
3562
3563
7b81e549
GG
3564#ifdef USE_ITHREADS
3565
3566void
3567clone_with_stack()
3568CODE:
3569{
3570 PerlInterpreter *interp = aTHX; /* The original interpreter */
3571 PerlInterpreter *interp_dup; /* The duplicate interpreter */
3572 int oldscope = 1; /* We are responsible for all scopes */
3573
3574 interp_dup = perl_clone(interp, CLONEf_COPY_STACKS | CLONEf_CLONE_HOST );
3575
3576 /* destroy old perl */
3577 PERL_SET_CONTEXT(interp);
3578
3579 POPSTACK_TO(PL_mainstack);
3580 dounwind(-1);
3581 LEAVE_SCOPE(0);
3582
3583 while (interp->Iscopestack_ix > 1)
3584 LEAVE;
3585 FREETMPS;
3586
3587 perl_destruct(interp);
3588 perl_free(interp);
3589
3590 /* switch to new perl */
3591 PERL_SET_CONTEXT(interp_dup);
3592
3593 /* continue after 'clone_with_stack' */
4a808ed1
MS
3594 if (interp_dup->Iop)
3595 interp_dup->Iop = interp_dup->Iop->op_next;
7b81e549
GG
3596
3597 /* run with new perl */
3598 Perl_runops_standard(interp_dup);
3599
3600 /* We may have additional unclosed scopes if fork() was called
3601 * from within a BEGIN block. See perlfork.pod for more details.
3602 * We cannot clean up these other scopes because they belong to a
3603 * different interpreter, but we also cannot leave PL_scopestack_ix
3604 * dangling because that can trigger an assertion in perl_destruct().
3605 */
3606 if (PL_scopestack_ix > oldscope) {
3607 PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
3608 PL_scopestack_ix = oldscope;
3609 }
3610
3611 perl_destruct(interp_dup);
3612 perl_free(interp_dup);
3613
3614 /* call the real 'exit' not PerlProc_exit */
3615#undef exit
3616 exit(0);
3617}
3618
3619#endif /* USE_ITHREDS */
9c540340 3620
88b5a879 3621SV*
3622take_svref(SVREF sv)
3623CODE:
3624 RETVAL = newRV_inc(sv);
3625OUTPUT:
3626 RETVAL
3627
3628SV*
3629take_avref(AV* av)
3630CODE:
3631 RETVAL = newRV_inc((SV*)av);
3632OUTPUT:
3633 RETVAL
3634
3635SV*
3636take_hvref(HV* hv)
3637CODE:
3638 RETVAL = newRV_inc((SV*)hv);
3639OUTPUT:
3640 RETVAL
3641
3642
3643SV*
3644take_cvref(CV* cv)
3645CODE:
3646 RETVAL = newRV_inc((SV*)cv);
3647OUTPUT:
3648 RETVAL
3649
3650
e2fe06dd
EB
3651BOOT:
3652 {
3653 HV* stash;
3654 SV** meth = NULL;
3655 CV* cv;
3656 stash = gv_stashpv("XS::APItest::TempLv", 0);
3657 if (stash)
3658 meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
3659 if (!meth)
3660 croak("lost method 'make_temp_mg_lv'");
3661 cv = GvCV(*meth);
3662 CvLVALUE_on(cv);
3663 }
83f8bb56
Z
3664
3665BOOT:
3666{
3667 hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
3668 hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
3669 hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
3670 hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
07ffcb73 3671 hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
a7aaec61 3672 hintkey_scopelessblock_sv = newSVpvs_share("XS::APItest/scopelessblock");
9eb5c532
Z
3673 hintkey_stmtasexpr_sv = newSVpvs_share("XS::APItest/stmtasexpr");
3674 hintkey_stmtsasexpr_sv = newSVpvs_share("XS::APItest/stmtsasexpr");
e53d8f76
Z
3675 hintkey_loopblock_sv = newSVpvs_share("XS::APItest/loopblock");
3676 hintkey_blockasexpr_sv = newSVpvs_share("XS::APItest/blockasexpr");
361d9b55
Z
3677 hintkey_swaplabel_sv = newSVpvs_share("XS::APItest/swaplabel");
3678 hintkey_labelconst_sv = newSVpvs_share("XS::APItest/labelconst");
78cdf107
Z
3679 hintkey_arrayfullexpr_sv = newSVpvs_share("XS::APItest/arrayfullexpr");
3680 hintkey_arraylistexpr_sv = newSVpvs_share("XS::APItest/arraylistexpr");
3681 hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr");
3682 hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr");
3683 hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags");
ce409cc8 3684 hintkey_DEFSV_sv = newSVpvs_share("XS::APItest/DEFSV");
25f5d540 3685 hintkey_with_vars_sv = newSVpvs_share("XS::APItest/with_vars");
03d05f6e 3686 hintkey_join_with_space_sv = newSVpvs_share("XS::APItest/join_with_space");
83f8bb56
Z
3687 next_keyword_plugin = PL_keyword_plugin;
3688 PL_keyword_plugin = my_keyword_plugin;
3689}
8f89e5a9
Z
3690
3691void
3692establish_cleanup(...)
3693PROTOTYPE: $
3694CODE:
c33e8be1 3695 PERL_UNUSED_VAR(items);
8f89e5a9
Z
3696 croak("establish_cleanup called as a function");
3697
3698BOOT:
3699{
3700 CV *estcv = get_cv("XS::APItest::establish_cleanup", 0);
3701 cv_set_call_checker(estcv, THX_ck_entersub_establish_cleanup, (SV*)estcv);
3702}
3ad73efd
Z
3703
3704void
3705postinc(...)
3706PROTOTYPE: $
3707CODE:
c33e8be1 3708 PERL_UNUSED_VAR(items);
3ad73efd
Z
3709 croak("postinc called as a function");
3710
27fcb6ee
FC
3711void
3712filter()
3713CODE:
3714 filter_add(filter_call, NULL);
3715
3ad73efd
Z
3716BOOT:
3717{
3718 CV *asscv = get_cv("XS::APItest::postinc", 0);
3719 cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv);
3720}
26ab20ee 3721
fba8e77b
FC
3722SV *
3723lv_temp_object()
3724CODE:
3725 RETVAL =
3726 sv_bless(
3727 newRV_noinc(newSV(0)),
3728 gv_stashpvs("XS::APItest::TempObj",GV_ADD)
3729 ); /* Package defined in test script */
3730OUTPUT:
3731 RETVAL
3732
7d6175ef 3733void
65b22876 3734fill_hash_with_nulls(HV *hv)
a2bf5ab1 3735PREINIT:
7d6175ef 3736 UV i = 0;
a2bf5ab1 3737CODE:
7d6175ef
FC
3738 for(; i < 1000; ++i) {
3739 HE *entry = hv_fetch_ent(hv, sv_2mortal(newSVuv(i)), 1, 0);
3740 SvREFCNT_dec(HeVAL(entry));
3741 HeVAL(entry) = NULL;
3742 }
3743
3f4d1d78
FC
3744HV *
3745newHVhv(HV *hv)
3746CODE:
3747 RETVAL = newHVhv(hv);
3748OUTPUT:
3749 RETVAL
3750
dd82de44 3751U32
fa819c1c
FC
3752SvIsCOW(SV *sv)
3753CODE:
3754 RETVAL = SvIsCOW(sv);
3755OUTPUT:
3756 RETVAL
3757
15103811
Z
3758void
3759pad_scalar(...)
3760PROTOTYPE: $$
3761CODE:
3762 PERL_UNUSED_VAR(items);
3763 croak("pad_scalar called as a function");
3764
3765BOOT:
3766{
3767 CV *pscv = get_cv("XS::APItest::pad_scalar", 0);
3768 cv_set_call_checker(pscv, THX_ck_entersub_pad_scalar, (SV*)pscv);
3769}
3770
ab8f91e9
BF
3771SV*
3772fetch_pad_names( cv )
3773CV* cv
3774 PREINIT:
3775 I32 i;
35e035cc 3776 PADNAMELIST *pad_namelist;
ab8f91e9
BF
3777 AV *retav = newAV();
3778 CODE:
86d2498c 3779 pad_namelist = PadlistNAMES(CvPADLIST(cv));
ab8f91e9 3780
86d2498c
FC
3781 for ( i = PadnamelistMAX(pad_namelist); i >= 0; i-- ) {
3782 PADNAME* name = PadnamelistARRAY(pad_namelist)[i];
ab8f91e9 3783
325e1816 3784 if (PadnameLEN(name)) {
35e035cc 3785 av_push(retav, newSVpadname(name));
ab8f91e9
BF
3786 }
3787 }
3788 RETVAL = newRV_noinc((SV*)retav);
3789 OUTPUT:
3790 RETVAL
3791
c12735bb
Z
3792STRLEN
3793underscore_length()
3794PROTOTYPE:
3795PREINIT:
3796 SV *u;
3797 U8 *pv;
3798 STRLEN bytelen;
3799CODE:
3800 u = find_rundefsv();
3801 pv = (U8*)SvPV(u, bytelen);
3802 RETVAL = SvUTF8(u) ? utf8_length(pv, pv+bytelen) : bytelen;
3803OUTPUT:
3804 RETVAL
3805
e8ed61c5
FC
3806void
3807stringify(SV *sv)
e8ed61c5 3808CODE:
5f74c55e 3809 (void)SvPV_nolen(sv);
e8ed61c5 3810
c682ebef
FC
3811SV *
3812HvENAME(HV *hv)
3813CODE:
3814 RETVAL = hv && HvENAME(hv)
3815 ? newSVpvn_flags(
3816 HvENAME(hv),HvENAMELEN(hv),
3817 (HvENAMEUTF8(hv) ? SVf_UTF8 : 0)
3818 )
3819 : NULL;
3820OUTPUT:
3821 RETVAL
3822
2fc49ef1
FC
3823int
3824xs_cmp(int a, int b)
3825CODE:
3826 /* Odd sorting (odd numbers first), to make sure we are actually
3827 being called */
3828 RETVAL = a % 2 != b % 2
3829 ? a % 2 ? -1 : 1
3830 : a < b ? -1 : a == b ? 0 : 1;
3831OUTPUT:
3832 RETVAL
3833
c19fd8b4
FC
3834SV *
3835xs_cmp_undef(SV *a, SV *b)
3836CODE:
5f74c55e
DM
3837 PERL_UNUSED_ARG(a);
3838 PERL_UNUSED_ARG(b);
c19fd8b4
FC
3839 RETVAL = &PL_sv_undef;
3840OUTPUT:
3841 RETVAL
3842
fe46cbda
FC
3843char *
3844SvPVbyte(SV *sv)
3845CODE:
3846 RETVAL = SvPVbyte_nolen(sv);
3847OUTPUT:
3848 RETVAL
3849
3850char *
3851SvPVutf8(SV *sv)
3852CODE:
3853 RETVAL = SvPVutf8_nolen(sv);
3854OUTPUT:
3855 RETVAL
3856
e8570548
Z
3857void
3858setup_addissub()
3859CODE:
3860 wrap_op_checker(OP_ADD, addissub_myck_add, &addissub_nxck_add);
e8ed61c5 3861
39c012bc
FC
3862void
3863setup_rv2cv_addunderbar()
3864CODE:
3865 wrap_op_checker(OP_RV2CV, my_ck_rv2cv, &old_ck_rv2cv);
3866
c0b8aebd
FC
3867#ifdef USE_ITHREADS
3868
3869bool
3870test_alloccopstash()
3871CODE:
3872 RETVAL = PL_stashpad[alloccopstash(PL_defstash)] == PL_defstash;
3873OUTPUT:
3874 RETVAL
3875
3876#endif
3877
b448305b
FC
3878bool
3879test_newFOROP_without_slab()
3880CODE:
3881 {
3882 const I32 floor = start_subparse(0,0);
3f25e47a 3883 OP *o;
b448305b
FC
3884 /* The slab allocator does not like CvROOT being set. */
3885 CvROOT(PL_compcv) = (OP *)1;
3f25e47a
FC
3886 o = newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0);
3887#ifdef PERL_OP_PARENT
86cd3a13 3888 if (cLOOPx(cUNOPo->op_first)->op_last->op_sibparent
3f25e47a
FC
3889 != cUNOPo->op_first)
3890 {
3891 Perl_warn(aTHX_ "Op parent pointer is stale");
3892 RETVAL = FALSE;
3893 }
3894 else
3895#endif
3896 /* If we do not crash before returning, the test passes. */
3897 RETVAL = TRUE;
3898 op_free(o);
b448305b
FC
3899 Cv