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