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