File Coverage

ext/XS-APItest/APItest.xs
Criterion Covered Total %
statement 1488 1746 85.2
branch n/a
condition n/a
subroutine n/a
total 1488 1746 85.2


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