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