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