1 #define PERL_IN_XS_APITEST
2
3 /* We want to be able to test things that aren't API yet. */
4 #define PERL_EXT
5
6 /* Do *not* define PERL_NO_GET_CONTEXT. This is the one place where we get
7 to test implicit Perl_get_context(). */
8
9 #include "EXTERN.h"
10 #include "perl.h"
11 #include "XSUB.h"
12
13 /* PERL_VERSION_xx sanity checks */
14 #if !PERL_VERSION_EQ(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, PERL_VERSION_PATCH)
15 # error PERL_VERSION_EQ(major, minor, patch) is false; expected true
16 #endif
17 #if !PERL_VERSION_EQ(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, '*')
18 # error PERL_VERSION_EQ(major, minor, '*') is false; expected true
19 #endif
20 #if PERL_VERSION_NE(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, PERL_VERSION_PATCH)
21 # error PERL_VERSION_NE(major, minor, patch) is true; expected false
22 #endif
23 #if PERL_VERSION_NE(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, '*')
24 # error PERL_VERSION_NE(major, minor, '*') is true; expected false
25 #endif
26 #if PERL_VERSION_LT(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, PERL_VERSION_PATCH)
27 # error PERL_VERSION_LT(major, minor, patch) is true; expected false
28 #endif
29 #if PERL_VERSION_LT(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, '*')
30 # error PERL_VERSION_LT(major, minor, '*') is true; expected false
31 #endif
32 #if !PERL_VERSION_LE(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, PERL_VERSION_PATCH)
33 # error PERL_VERSION_LE(major, minor, patch) is false; expected true
34 #endif
35 #if !PERL_VERSION_LE(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, '*')
36 # error PERL_VERSION_LE(major, minor, '*') is false; expected true
37 #endif
38 #if PERL_VERSION_GT(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, PERL_VERSION_PATCH)
39 # error PERL_VERSION_GT(major, minor, patch) is true; expected false
40 #endif
41 #if PERL_VERSION_GT(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, '*')
42 # error PERL_VERSION_GT(major, minor, '*') is true; expected false
43 #endif
44 #if !PERL_VERSION_GE(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, PERL_VERSION_PATCH)
45 # error PERL_VERSION_GE(major, minor, patch) is false; expected true
46 #endif
47 #if !PERL_VERSION_GE(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, '*')
48 # error PERL_VERSION_GE(major, minor, '*') is false; expected true
49 #endif
50
51 typedef FILE NativeFile;
52
53 #include "fakesdio.h" /* Causes us to use PerlIO below */
54
55 typedef SV *SVREF;
56 typedef PTR_TBL_t *XS__APItest__PtrTable;
57 typedef PerlIO * InputStream;
58 typedef PerlIO * OutputStream;
59
60 #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__)
61 #define croak_fail_nep(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__)
62 #define croak_fail_nei(h, w) croak("fail %d!=%d at " __FILE__ " line %d", (int)(h), (int)(w), __LINE__)
63
64 /* assumes that there is a 'failed' variable in scope */
65 #define TEST_EXPR(s) STMT_START { \
66 if (s) { \
67 printf("# ok: %s\n", #s); \
68 } else { \
69 printf("# not ok: %s\n", #s); \
70 failed++; \
71 } \
72 } STMT_END
73
74 #if IVSIZE == 8
75 # define TEST_64BIT 1
76 #else
77 # define TEST_64BIT 0
78 #endif
79
80 #ifdef EBCDIC
81
82 void
cat_utf8a2n(SV * sv,const char * const ascii_utf8,STRLEN len)83 cat_utf8a2n(SV* sv, const char * const ascii_utf8, STRLEN len)
84 {
85 /* Converts variant UTF-8 text pointed to by 'ascii_utf8' of length 'len',
86 * to UTF-EBCDIC, appending that text to the text already in 'sv'.
87 * Currently doesn't work on invariants, as that is unneeded here, and we
88 * could get double translations if we did.
89 *
90 * It has the algorithm for strict UTF-8 hard-coded in to find the code
91 * point it represents, then calls uvchr_to_utf8() to convert to
92 * UTF-EBCDIC).
93 *
94 * Note that this uses code points, not characters. Thus if the input is
95 * the UTF-8 for the code point 0xFF, the output will be the UTF-EBCDIC for
96 * 0xFF, even though that code point represents different characters on
97 * ASCII vs EBCDIC platforms. */
98
99 dTHX;
100 char * p = (char *) ascii_utf8;
101 const char * const e = p + len;
102
103 while (p < e) {
104 UV code_point;
105 U8 native_utf8[UTF8_MAXBYTES + 1];
106 U8 * char_end;
107 U8 start = (U8) *p;
108
109 /* Start bytes are the same in both UTF-8 and I8, therefore we can
110 * treat this ASCII UTF-8 byte as an I8 byte. But PL_utf8skip[] is
111 * indexed by NATIVE_UTF8 bytes, so transform to that */
112 STRLEN char_bytes_len = PL_utf8skip[I8_TO_NATIVE_UTF8(start)];
113
114 if (start < 0xc2) {
115 croak("fail: Expecting start byte, instead got 0x%X at %s line %d",
116 (U8) *p, __FILE__, __LINE__);
117 }
118 code_point = (start & (((char_bytes_len) >= 7)
119 ? 0x00
120 : (0x1F >> ((char_bytes_len)-2))));
121 p++;
122 while (p < e && ((( (U8) *p) & 0xC0) == 0x80)) {
123
124 code_point = (code_point << 6) | (( (U8) *p) & 0x3F);
125 p++;
126 }
127
128 char_end = uvchr_to_utf8(native_utf8, code_point);
129 sv_catpvn(sv, (char *) native_utf8, char_end - native_utf8);
130 }
131 }
132
133 #endif
134
135 /* for my_cxt tests */
136
137 #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
138
139 typedef struct {
140 int i;
141 SV *sv;
142 GV *cscgv;
143 AV *cscav;
144 AV *bhkav;
145 bool bhk_record;
146 peep_t orig_peep;
147 peep_t orig_rpeep;
148 int peep_recording;
149 AV *peep_recorder;
150 AV *rpeep_recorder;
151 AV *xop_record;
152 } my_cxt_t;
153
154 START_MY_CXT
155
156 static int
S_myset_set(pTHX_ SV * sv,MAGIC * mg)157 S_myset_set(pTHX_ SV* sv, MAGIC* mg)
158 {
159 SV *isv = (SV*)mg->mg_ptr;
160
161 PERL_UNUSED_ARG(sv);
162 SvIVX(isv)++;
163 return 0;
164 }
165
166 static int
S_myset_set_dies(pTHX_ SV * sv,MAGIC * mg)167 S_myset_set_dies(pTHX_ SV* sv, MAGIC* mg)
168 {
169 PERL_UNUSED_ARG(sv);
170 PERL_UNUSED_ARG(mg);
171 croak("in S_myset_set_dies");
172 return 0;
173 }
174
175
176 static MGVTBL vtbl_foo, vtbl_bar;
177 static MGVTBL vtbl_myset = { 0, S_myset_set, 0, 0, 0, 0, 0, 0 };
178 static MGVTBL vtbl_myset_dies = { 0, S_myset_set_dies, 0, 0, 0, 0, 0, 0 };
179
180 static int
S_mycopy_copy(pTHX_ SV * sv,MAGIC * mg,SV * nsv,const char * name,I32 namlen)181 S_mycopy_copy(pTHX_ SV *sv, MAGIC* mg, SV *nsv, const char *name, I32 namlen) {
182 PERL_UNUSED_ARG(sv);
183 PERL_UNUSED_ARG(nsv);
184 PERL_UNUSED_ARG(name);
185 PERL_UNUSED_ARG(namlen);
186
187 /* Count that we were called to "copy".
188 There's actually no point in copying *this* magic onto nsv, as it's a
189 SCALAR, whereas mg_copy is only triggered for ARRAYs and HASHes.
190 It's not *exactly* generic. :-( */
191 ++mg->mg_private;
192 return 0;
193 }
194
195 STATIC MGVTBL vtbl_mycopy = { 0, 0, 0, 0, 0, S_mycopy_copy, 0, 0 };
196
197 /* indirect functions to test the [pa]MY_CXT macros */
198
199 int
my_cxt_getint_p(pMY_CXT)200 my_cxt_getint_p(pMY_CXT)
201 {
202 return MY_CXT.i;
203 }
204
205 void
my_cxt_setint_p(pMY_CXT_ int i)206 my_cxt_setint_p(pMY_CXT_ int i)
207 {
208 MY_CXT.i = i;
209 }
210
211 SV*
my_cxt_getsv_interp_context(void)212 my_cxt_getsv_interp_context(void)
213 {
214 dTHX;
215 dMY_CXT_INTERP(my_perl);
216 return MY_CXT.sv;
217 }
218
219 SV*
my_cxt_getsv_interp(void)220 my_cxt_getsv_interp(void)
221 {
222 dMY_CXT;
223 return MY_CXT.sv;
224 }
225
226 void
my_cxt_setsv_p(SV * sv _pMY_CXT)227 my_cxt_setsv_p(SV* sv _pMY_CXT)
228 {
229 MY_CXT.sv = sv;
230 }
231
232
233 /* from exception.c */
234 int apitest_exception(int);
235
236 /* from core_or_not.inc */
237 bool sv_setsv_cow_hashkey_core(void);
238 bool sv_setsv_cow_hashkey_notcore(void);
239
240 /* A routine to test hv_delayfree_ent
241 (which itself is tested by testing on hv_free_ent */
242
243 typedef void (freeent_function)(pTHX_ HV *, HE *);
244
245 void
test_freeent(freeent_function * f)246 test_freeent(freeent_function *f) {
247 dSP;
248 HV *test_hash = newHV();
249 HE *victim;
250 SV *test_scalar;
251 U32 results[4];
252 int i;
253
254 #ifdef PURIFY
255 victim = (HE*)safemalloc(sizeof(HE));
256 #else
257 /* Storing then deleting something should ensure that a hash entry is
258 available. */
259 (void) hv_stores(test_hash, "", &PL_sv_yes);
260 (void) hv_deletes(test_hash, "", 0);
261
262 /* We need to "inline" new_he here as it's static, and the functions we
263 test expect to be able to call del_HE on the HE */
264 if (!PL_body_roots[HE_ARENA_ROOT_IX])
265 croak("PL_he_root is 0");
266 victim = (HE*) PL_body_roots[HE_ARENA_ROOT_IX];
267 PL_body_roots[HE_ARENA_ROOT_IX] = HeNEXT(victim);
268 #endif
269
270 #ifdef NODEFAULT_SHAREKEYS
271 HvSHAREKEYS_on(test_hash);
272 #endif
273
274 victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
275
276 test_scalar = newSV(0);
277 SvREFCNT_inc(test_scalar);
278 HeVAL(victim) = test_scalar;
279
280 /* Need this little game else we free the temps on the return stack. */
281 results[0] = SvREFCNT(test_scalar);
282 SAVETMPS;
283 results[1] = SvREFCNT(test_scalar);
284 f(aTHX_ test_hash, victim);
285 results[2] = SvREFCNT(test_scalar);
286 FREETMPS;
287 results[3] = SvREFCNT(test_scalar);
288
289 i = 0;
290 do {
291 mXPUSHu(results[i]);
292 } while (++i < (int)(sizeof(results)/sizeof(results[0])));
293
294 /* Goodbye to our extra reference. */
295 SvREFCNT_dec(test_scalar);
296 }
297
298 /* Not that it matters much, but it's handy for the flipped character to just
299 * be the opposite case (at least for ASCII-range and most Latin1 as well). */
300 #define FLIP_BIT ('A' ^ 'a')
301
302 static I32
bitflip_key(pTHX_ IV action,SV * field)303 bitflip_key(pTHX_ IV action, SV *field) {
304 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
305 SV *keysv;
306 PERL_UNUSED_ARG(action);
307 if (mg && (keysv = mg->mg_obj)) {
308 STRLEN len;
309 const char *p = SvPV(keysv, len);
310
311 if (len) {
312 /* Allow for the flipped val to be longer than the original. This
313 * is just for testing, so can afford to have some slop */
314 const STRLEN newlen = len * 2;
315
316 SV *newkey = newSV(newlen);
317 const char * const new_p_orig = SvPVX(newkey);
318 char *new_p = (char *) new_p_orig;
319
320 if (SvUTF8(keysv)) {
321 const char *const end = p + len;
322 while (p < end) {
323 STRLEN curlen;
324 UV chr = utf8_to_uvchr_buf((U8 *)p, (U8 *) end, &curlen);
325
326 /* Make sure don't exceed bounds */
327 assert(new_p - new_p_orig + curlen < newlen);
328
329 new_p = (char *)uvchr_to_utf8((U8 *)new_p, chr ^ FLIP_BIT);
330 p += curlen;
331 }
332 SvUTF8_on(newkey);
333 } else {
334 while (len--)
335 *new_p++ = *p++ ^ FLIP_BIT;
336 }
337 *new_p = '\0';
338 SvCUR_set(newkey, new_p - new_p_orig);
339 SvPOK_on(newkey);
340
341 mg->mg_obj = newkey;
342 }
343 }
344 return 0;
345 }
346
347 static I32
rot13_key(pTHX_ IV action,SV * field)348 rot13_key(pTHX_ IV action, SV *field) {
349 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
350 SV *keysv;
351 PERL_UNUSED_ARG(action);
352 if (mg && (keysv = mg->mg_obj)) {
353 STRLEN len;
354 const char *p = SvPV(keysv, len);
355
356 if (len) {
357 SV *newkey = newSV(len);
358 char *new_p = SvPVX(newkey);
359
360 /* There's a deliberate fencepost error here to loop len + 1 times
361 to copy the trailing \0 */
362 do {
363 char new_c = *p++;
364 /* Try doing this cleanly and clearly in EBCDIC another way: */
365 switch (new_c) {
366 case 'A': new_c = 'N'; break;
367 case 'B': new_c = 'O'; break;
368 case 'C': new_c = 'P'; break;
369 case 'D': new_c = 'Q'; break;
370 case 'E': new_c = 'R'; break;
371 case 'F': new_c = 'S'; break;
372 case 'G': new_c = 'T'; break;
373 case 'H': new_c = 'U'; break;
374 case 'I': new_c = 'V'; break;
375 case 'J': new_c = 'W'; break;
376 case 'K': new_c = 'X'; break;
377 case 'L': new_c = 'Y'; break;
378 case 'M': new_c = 'Z'; break;
379 case 'N': new_c = 'A'; break;
380 case 'O': new_c = 'B'; break;
381 case 'P': new_c = 'C'; break;
382 case 'Q': new_c = 'D'; break;
383 case 'R': new_c = 'E'; break;
384 case 'S': new_c = 'F'; break;
385 case 'T': new_c = 'G'; break;
386 case 'U': new_c = 'H'; break;
387 case 'V': new_c = 'I'; break;
388 case 'W': new_c = 'J'; break;
389 case 'X': new_c = 'K'; break;
390 case 'Y': new_c = 'L'; break;
391 case 'Z': new_c = 'M'; break;
392 case 'a': new_c = 'n'; break;
393 case 'b': new_c = 'o'; break;
394 case 'c': new_c = 'p'; break;
395 case 'd': new_c = 'q'; break;
396 case 'e': new_c = 'r'; break;
397 case 'f': new_c = 's'; break;
398 case 'g': new_c = 't'; break;
399 case 'h': new_c = 'u'; break;
400 case 'i': new_c = 'v'; break;
401 case 'j': new_c = 'w'; break;
402 case 'k': new_c = 'x'; break;
403 case 'l': new_c = 'y'; break;
404 case 'm': new_c = 'z'; break;
405 case 'n': new_c = 'a'; break;
406 case 'o': new_c = 'b'; break;
407 case 'p': new_c = 'c'; break;
408 case 'q': new_c = 'd'; break;
409 case 'r': new_c = 'e'; break;
410 case 's': new_c = 'f'; break;
411 case 't': new_c = 'g'; break;
412 case 'u': new_c = 'h'; break;
413 case 'v': new_c = 'i'; break;
414 case 'w': new_c = 'j'; break;
415 case 'x': new_c = 'k'; break;
416 case 'y': new_c = 'l'; break;
417 case 'z': new_c = 'm'; break;
418 }
419 *new_p++ = new_c;
420 } while (len--);
421 SvCUR_set(newkey, SvCUR(keysv));
422 SvPOK_on(newkey);
423 if (SvUTF8(keysv))
424 SvUTF8_on(newkey);
425
426 mg->mg_obj = newkey;
427 }
428 }
429 return 0;
430 }
431
432 STATIC I32
rmagical_a_dummy(pTHX_ IV idx,SV * sv)433 rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
434 PERL_UNUSED_ARG(idx);
435 PERL_UNUSED_ARG(sv);
436 return 0;
437 }
438
439 /* We could do "= { 0 };" but some versions of gcc do warn
440 * (with -Wextra) about missing initializer, this is probably gcc
441 * being a bit too paranoid. But since this is file-static, we can
442 * just have it without initializer, since it should get
443 * zero-initialized. */
444 STATIC MGVTBL rmagical_b;
445
446 STATIC void
blockhook_csc_start(pTHX_ int full)447 blockhook_csc_start(pTHX_ int full)
448 {
449 dMY_CXT;
450 AV *const cur = GvAV(MY_CXT.cscgv);
451
452 PERL_UNUSED_ARG(full);
453 SAVEGENERICSV(GvAV(MY_CXT.cscgv));
454
455 if (cur) {
456 Size_t i;
457 AV *const new_av = av_count(cur)
458 ? newAV_alloc_x(av_count(cur))
459 : newAV();
460
461 for (i = 0; i < av_count(cur); i++) {
462 av_store_simple(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
463 }
464
465 GvAV(MY_CXT.cscgv) = new_av;
466 }
467 }
468
469 STATIC void
blockhook_csc_pre_end(pTHX_ OP ** o)470 blockhook_csc_pre_end(pTHX_ OP **o)
471 {
472 dMY_CXT;
473
474 PERL_UNUSED_ARG(o);
475 /* if we hit the end of a scope we missed the start of, we need to
476 * unconditionally clear @CSC */
477 if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
478 av_clear(MY_CXT.cscav);
479 }
480
481 }
482
483 STATIC void
blockhook_test_start(pTHX_ int full)484 blockhook_test_start(pTHX_ int full)
485 {
486 dMY_CXT;
487 AV *av;
488
489 if (MY_CXT.bhk_record) {
490 av = newAV_alloc_x(3);
491 av_push_simple(av, newSVpvs("start"));
492 av_push_simple(av, newSViv(full));
493 av_push_simple(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
494 }
495 }
496
497 STATIC void
blockhook_test_pre_end(pTHX_ OP ** o)498 blockhook_test_pre_end(pTHX_ OP **o)
499 {
500 dMY_CXT;
501
502 PERL_UNUSED_ARG(o);
503 if (MY_CXT.bhk_record)
504 av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
505 }
506
507 STATIC void
blockhook_test_post_end(pTHX_ OP ** o)508 blockhook_test_post_end(pTHX_ OP **o)
509 {
510 dMY_CXT;
511
512 PERL_UNUSED_ARG(o);
513 if (MY_CXT.bhk_record)
514 av_push(MY_CXT.bhkav, newSVpvs("post_end"));
515 }
516
517 STATIC void
blockhook_test_eval(pTHX_ OP * const o)518 blockhook_test_eval(pTHX_ OP *const o)
519 {
520 dMY_CXT;
521 AV *av;
522
523 if (MY_CXT.bhk_record) {
524 av = newAV_alloc_x(3);
525 av_push_simple(av, newSVpvs("eval"));
526 av_push_simple(av, newSVpv(OP_NAME(o), 0));
527 av_push_simple(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
528 }
529 }
530
531 STATIC BHK bhk_csc, bhk_test;
532
533 STATIC void
my_peep(pTHX_ OP * o)534 my_peep (pTHX_ OP *o)
535 {
536 dMY_CXT;
537
538 if (!o)
539 return;
540
541 MY_CXT.orig_peep(aTHX_ o);
542
543 if (!MY_CXT.peep_recording)
544 return;
545
546 for (; o; o = o->op_next) {
547 if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
548 av_push(MY_CXT.peep_recorder, newSVsv(cSVOPx_sv(o)));
549 }
550 }
551 }
552
553 STATIC void
my_rpeep(pTHX_ OP * first)554 my_rpeep (pTHX_ OP *first)
555 {
556 dMY_CXT;
557 OP *o, *t;
558
559 if (!first)
560 return;
561
562 MY_CXT.orig_rpeep(aTHX_ first);
563
564 if (!MY_CXT.peep_recording)
565 return;
566
567 for (o = first, t = first; o; o = o->op_next, t = t->op_next) {
568 if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
569 av_push(MY_CXT.rpeep_recorder, newSVsv(cSVOPx_sv(o)));
570 }
571 o = o->op_next;
572 if (!o || o == t) break;
573 if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
574 av_push(MY_CXT.rpeep_recorder, newSVsv(cSVOPx_sv(o)));
575 }
576 }
577 }
578
579 STATIC OP *
THX_ck_entersub_args_lists(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)580 THX_ck_entersub_args_lists(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
581 {
582 PERL_UNUSED_ARG(namegv);
583 PERL_UNUSED_ARG(ckobj);
584 return ck_entersub_args_list(entersubop);
585 }
586
587 STATIC OP *
THX_ck_entersub_args_scalars(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)588 THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
589 {
590 OP *aop = cUNOPx(entersubop)->op_first;
591 PERL_UNUSED_ARG(namegv);
592 PERL_UNUSED_ARG(ckobj);
593 if (!OpHAS_SIBLING(aop))
594 aop = cUNOPx(aop)->op_first;
595 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
596 op_contextualize(aop, G_SCALAR);
597 }
598 return entersubop;
599 }
600
601 STATIC OP *
THX_ck_entersub_multi_sum(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)602 THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
603 {
604 OP *sumop = NULL;
605 OP *parent = entersubop;
606 OP *pushop = cUNOPx(entersubop)->op_first;
607 PERL_UNUSED_ARG(namegv);
608 PERL_UNUSED_ARG(ckobj);
609 if (!OpHAS_SIBLING(pushop)) {
610 parent = pushop;
611 pushop = cUNOPx(pushop)->op_first;
612 }
613 while (1) {
614 OP *aop = OpSIBLING(pushop);
615 if (!OpHAS_SIBLING(aop))
616 break;
617 /* cut out first arg */
618 op_sibling_splice(parent, pushop, 1, NULL);
619 op_contextualize(aop, G_SCALAR);
620 if (sumop) {
621 sumop = newBINOP(OP_ADD, 0, sumop, aop);
622 } else {
623 sumop = aop;
624 }
625 }
626 if (!sumop)
627 sumop = newSVOP(OP_CONST, 0, newSViv(0));
628 op_free(entersubop);
629 return sumop;
630 }
631
632 STATIC void test_op_list_describe_part(SV *res, OP *o);
633 STATIC void
test_op_list_describe_part(SV * res,OP * o)634 test_op_list_describe_part(SV *res, OP *o)
635 {
636 sv_catpv(res, PL_op_name[o->op_type]);
637 switch (o->op_type) {
638 case OP_CONST: {
639 sv_catpvf(res, "(%d)", (int)SvIV(cSVOPx(o)->op_sv));
640 } break;
641 }
642 if (o->op_flags & OPf_KIDS) {
643 OP *k;
644 sv_catpvs(res, "[");
645 for (k = cUNOPx(o)->op_first; k; k = OpSIBLING(k))
646 test_op_list_describe_part(res, k);
647 sv_catpvs(res, "]");
648 } else {
649 sv_catpvs(res, ".");
650 }
651 }
652
653 STATIC char *
test_op_list_describe(OP * o)654 test_op_list_describe(OP *o)
655 {
656 SV *res = sv_2mortal(newSVpvs(""));
657 if (o)
658 test_op_list_describe_part(res, o);
659 return SvPVX(res);
660 }
661
662 /* the real new*OP functions have a tendency to call fold_constants, and
663 * other such unhelpful things, so we need our own versions for testing */
664
665 #define mkUNOP(t, f) THX_mkUNOP(aTHX_ (t), (f))
666 static OP *
THX_mkUNOP(pTHX_ U32 type,OP * first)667 THX_mkUNOP(pTHX_ U32 type, OP *first)
668 {
669 UNOP *unop;
670 NewOp(1103, unop, 1, UNOP);
671 unop->op_type = (OPCODE)type;
672 op_sibling_splice((OP*)unop, NULL, 0, first);
673 return (OP *)unop;
674 }
675
676 #define mkBINOP(t, f, l) THX_mkBINOP(aTHX_ (t), (f), (l))
677 static OP *
THX_mkBINOP(pTHX_ U32 type,OP * first,OP * last)678 THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last)
679 {
680 BINOP *binop;
681 NewOp(1103, binop, 1, BINOP);
682 binop->op_type = (OPCODE)type;
683 op_sibling_splice((OP*)binop, NULL, 0, last);
684 op_sibling_splice((OP*)binop, NULL, 0, first);
685 return (OP *)binop;
686 }
687
688 #define mkLISTOP(t, f, s, l) THX_mkLISTOP(aTHX_ (t), (f), (s), (l))
689 static OP *
THX_mkLISTOP(pTHX_ U32 type,OP * first,OP * sib,OP * last)690 THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last)
691 {
692 LISTOP *listop;
693 NewOp(1103, listop, 1, LISTOP);
694 listop->op_type = (OPCODE)type;
695 op_sibling_splice((OP*)listop, NULL, 0, last);
696 op_sibling_splice((OP*)listop, NULL, 0, sib);
697 op_sibling_splice((OP*)listop, NULL, 0, first);
698 return (OP *)listop;
699 }
700
701 static char *
test_op_linklist_describe(OP * start)702 test_op_linklist_describe(OP *start)
703 {
704 SV *rv = sv_2mortal(newSVpvs(""));
705 OP *o;
706 o = start = LINKLIST(start);
707 do {
708 sv_catpvs(rv, ".");
709 sv_catpv(rv, OP_NAME(o));
710 if (o->op_type == OP_CONST)
711 sv_catsv(rv, cSVOPo->op_sv);
712 o = o->op_next;
713 } while (o && o != start);
714 return SvPVX(rv);
715 }
716
717 /** establish_cleanup operator, ripped off from Scope::Cleanup **/
718
719 STATIC void
THX_run_cleanup(pTHX_ void * cleanup_code_ref)720 THX_run_cleanup(pTHX_ void *cleanup_code_ref)
721 {
722 dSP;
723 PUSHSTACK;
724 ENTER;
725 SAVETMPS;
726 PUSHMARK(SP);
727 call_sv((SV*)cleanup_code_ref, G_VOID|G_DISCARD);
728 FREETMPS;
729 LEAVE;
730 POPSTACK;
731 }
732
733 /* Note that this is a pp function attached to an OP */
734
735 STATIC OP *
THX_pp_establish_cleanup(pTHX)736 THX_pp_establish_cleanup(pTHX)
737 {
738 SV *cleanup_code_ref;
739 cleanup_code_ref = newSVsv(*PL_stack_sp);
740 rpp_popfree_1();
741 SAVEFREESV(cleanup_code_ref);
742 SAVEDESTRUCTOR_X(THX_run_cleanup, cleanup_code_ref);
743 if(GIMME_V != G_VOID)
744 rpp_push_1(&PL_sv_undef);
745 return NORMAL;
746 ;
747 }
748
749 STATIC OP *
THX_ck_entersub_establish_cleanup(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)750 THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
751 {
752 OP *parent, *pushop, *argop, *estop;
753 ck_entersub_args_proto(entersubop, namegv, ckobj);
754 parent = entersubop;
755 pushop = cUNOPx(entersubop)->op_first;
756 if(!OpHAS_SIBLING(pushop)) {
757 parent = pushop;
758 pushop = cUNOPx(pushop)->op_first;
759 }
760 /* extract out first arg, then delete the rest of the tree */
761 argop = OpSIBLING(pushop);
762 op_sibling_splice(parent, pushop, 1, NULL);
763 op_free(entersubop);
764
765 estop = mkUNOP(OP_RAND, argop);
766 estop->op_ppaddr = THX_pp_establish_cleanup;
767 PL_hints |= HINT_BLOCK_SCOPE;
768 return estop;
769 }
770
771 STATIC OP *
THX_ck_entersub_postinc(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)772 THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
773 {
774 OP *parent, *pushop, *argop;
775 ck_entersub_args_proto(entersubop, namegv, ckobj);
776 parent = entersubop;
777 pushop = cUNOPx(entersubop)->op_first;
778 if(!OpHAS_SIBLING(pushop)) {
779 parent = pushop;
780 pushop = cUNOPx(pushop)->op_first;
781 }
782 argop = OpSIBLING(pushop);
783 op_sibling_splice(parent, pushop, 1, NULL);
784 op_free(entersubop);
785 return newUNOP(OP_POSTINC, 0,
786 op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC));
787 }
788
789 STATIC OP *
THX_ck_entersub_pad_scalar(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)790 THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
791 {
792 OP *pushop, *argop;
793 PADOFFSET padoff = NOT_IN_PAD;
794 SV *a0, *a1;
795 ck_entersub_args_proto(entersubop, namegv, ckobj);
796 pushop = cUNOPx(entersubop)->op_first;
797 if(!OpHAS_SIBLING(pushop))
798 pushop = cUNOPx(pushop)->op_first;
799 argop = OpSIBLING(pushop);
800 if(argop->op_type != OP_CONST || OpSIBLING(argop)->op_type != OP_CONST)
801 croak("bad argument expression type for pad_scalar()");
802 a0 = cSVOPx_sv(argop);
803 a1 = cSVOPx_sv(OpSIBLING(argop));
804 switch(SvIV(a0)) {
805 case 1: {
806 SV *namesv = sv_2mortal(newSVpvs("$"));
807 sv_catsv(namesv, a1);
808 padoff = pad_findmy_sv(namesv, 0);
809 } break;
810 case 2: {
811 char *namepv;
812 STRLEN namelen;
813 SV *namesv = sv_2mortal(newSVpvs("$"));
814 sv_catsv(namesv, a1);
815 namepv = SvPV(namesv, namelen);
816 padoff = pad_findmy_pvn(namepv, namelen, SvUTF8(namesv));
817 } break;
818 case 3: {
819 char *namepv;
820 SV *namesv = sv_2mortal(newSVpvs("$"));
821 sv_catsv(namesv, a1);
822 namepv = SvPV_nolen(namesv);
823 padoff = pad_findmy_pv(namepv, SvUTF8(namesv));
824 } break;
825 case 4: {
826 padoff = pad_findmy_pvs("$foo", 0);
827 } break;
828 default: croak("bad type value for pad_scalar()");
829 }
830 op_free(entersubop);
831 if(padoff == NOT_IN_PAD) {
832 return newSVOP(OP_CONST, 0, newSVpvs("NOT_IN_PAD"));
833 } else if(PAD_COMPNAME_FLAGS_isOUR(padoff)) {
834 return newSVOP(OP_CONST, 0, newSVpvs("NOT_MY"));
835 } else {
836 OP *padop = newOP(OP_PADSV, 0);
837 padop->op_targ = padoff;
838 return padop;
839 }
840 }
841
842 /** RPN keyword parser **/
843
844 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
845 #define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
846 #define sv_is_string(sv) \
847 (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
848 (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
849
850 static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
851 static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
852 static SV *hintkey_scopelessblock_sv;
853 static SV *hintkey_stmtasexpr_sv, *hintkey_stmtsasexpr_sv;
854 static SV *hintkey_loopblock_sv, *hintkey_blockasexpr_sv;
855 static SV *hintkey_swaplabel_sv, *hintkey_labelconst_sv;
856 static SV *hintkey_arrayfullexpr_sv, *hintkey_arraylistexpr_sv;
857 static SV *hintkey_arraytermexpr_sv, *hintkey_arrayarithexpr_sv;
858 static SV *hintkey_arrayexprflags_sv;
859 static SV *hintkey_subsignature_sv;
860 static SV *hintkey_DEFSV_sv;
861 static SV *hintkey_with_vars_sv;
862 static SV *hintkey_join_with_space_sv;
863 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
864
865 /* low-level parser helpers */
866
867 #define PL_bufptr (PL_parser->bufptr)
868 #define PL_bufend (PL_parser->bufend)
869
870 /* RPN parser */
871
872 #define parse_var() THX_parse_var(aTHX)
THX_parse_var(pTHX)873 static OP *THX_parse_var(pTHX)
874 {
875 char *s = PL_bufptr;
876 char *start = s;
877 PADOFFSET varpos;
878 OP *padop;
879 if(*s != '$') croak("RPN syntax error");
880 while(1) {
881 char c = *++s;
882 if(!isALNUM(c)) break;
883 }
884 if(s-start < 2) croak("RPN syntax error");
885 lex_read_to(s);
886 varpos = pad_findmy_pvn(start, s-start, 0);
887 if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
888 croak("RPN only supports \"my\" variables");
889 padop = newOP(OP_PADSV, 0);
890 padop->op_targ = varpos;
891 return padop;
892 }
893
894 #define push_rpn_item(o) \
895 op_sibling_splice(parent, NULL, 0, o);
896 #define pop_rpn_item() ( \
897 (tmpop = op_sibling_splice(parent, NULL, 1, NULL)) \
898 ? tmpop : (croak("RPN stack underflow"), (OP*)NULL))
899
900 #define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
THX_parse_rpn_expr(pTHX)901 static OP *THX_parse_rpn_expr(pTHX)
902 {
903 OP *tmpop;
904 /* fake parent for splice to mess with */
905 OP *parent = mkBINOP(OP_NULL, NULL, NULL);
906
907 while(1) {
908 I32 c;
909 lex_read_space(0);
910 c = lex_peek_unichar(0);
911 switch(c) {
912 case /*(*/')': case /*{*/'}': {
913 OP *result = pop_rpn_item();
914 if(cLISTOPx(parent)->op_first)
915 croak("RPN expression must return a single value");
916 op_free(parent);
917 return result;
918 } break;
919 case '0': case '1': case '2': case '3': case '4':
920 case '5': case '6': case '7': case '8': case '9': {
921 UV val = 0;
922 do {
923 lex_read_unichar(0);
924 val = 10*val + (c - '0');
925 c = lex_peek_unichar(0);
926 } while(c >= '0' && c <= '9');
927 push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val)));
928 } break;
929 case '$': {
930 push_rpn_item(parse_var());
931 } break;
932 case '+': {
933 OP *b = pop_rpn_item();
934 OP *a = pop_rpn_item();
935 lex_read_unichar(0);
936 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
937 } break;
938 case '-': {
939 OP *b = pop_rpn_item();
940 OP *a = pop_rpn_item();
941 lex_read_unichar(0);
942 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
943 } break;
944 case '*': {
945 OP *b = pop_rpn_item();
946 OP *a = pop_rpn_item();
947 lex_read_unichar(0);
948 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
949 } break;
950 case '/': {
951 OP *b = pop_rpn_item();
952 OP *a = pop_rpn_item();
953 lex_read_unichar(0);
954 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
955 } break;
956 case '%': {
957 OP *b = pop_rpn_item();
958 OP *a = pop_rpn_item();
959 lex_read_unichar(0);
960 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
961 } break;
962 default: {
963 croak("RPN syntax error");
964 } break;
965 }
966 }
967 }
968
969 #define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
THX_parse_keyword_rpn(pTHX)970 static OP *THX_parse_keyword_rpn(pTHX)
971 {
972 OP *op;
973 lex_read_space(0);
974 if(lex_peek_unichar(0) != '('/*)*/)
975 croak("RPN expression must be parenthesised");
976 lex_read_unichar(0);
977 op = parse_rpn_expr();
978 if(lex_peek_unichar(0) != /*(*/')')
979 croak("RPN expression must be parenthesised");
980 lex_read_unichar(0);
981 return op;
982 }
983
984 #define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
THX_parse_keyword_calcrpn(pTHX)985 static OP *THX_parse_keyword_calcrpn(pTHX)
986 {
987 OP *varop, *exprop;
988 lex_read_space(0);
989 varop = parse_var();
990 lex_read_space(0);
991 if(lex_peek_unichar(0) != '{'/*}*/)
992 croak("RPN expression must be braced");
993 lex_read_unichar(0);
994 exprop = parse_rpn_expr();
995 if(lex_peek_unichar(0) != /*{*/'}')
996 croak("RPN expression must be braced");
997 lex_read_unichar(0);
998 return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
999 }
1000
1001 #define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
THX_parse_keyword_stufftest(pTHX)1002 static OP *THX_parse_keyword_stufftest(pTHX)
1003 {
1004 I32 c;
1005 bool do_stuff;
1006 lex_read_space(0);
1007 do_stuff = lex_peek_unichar(0) == '+';
1008 if(do_stuff) {
1009 lex_read_unichar(0);
1010 lex_read_space(0);
1011 }
1012 c = lex_peek_unichar(0);
1013 if(c == ';') {
1014 lex_read_unichar(0);
1015 } else if(c != /*{*/'}') {
1016 croak("syntax error");
1017 }
1018 if(do_stuff) lex_stuff_pvs(" ", 0);
1019 return newOP(OP_NULL, 0);
1020 }
1021
1022 #define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
THX_parse_keyword_swaptwostmts(pTHX)1023 static OP *THX_parse_keyword_swaptwostmts(pTHX)
1024 {
1025 OP *a, *b;
1026 a = parse_fullstmt(0);
1027 b = parse_fullstmt(0);
1028 if(a && b)
1029 PL_hints |= HINT_BLOCK_SCOPE;
1030 return op_append_list(OP_LINESEQ, b, a);
1031 }
1032
1033 #define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
THX_parse_keyword_looprest(pTHX)1034 static OP *THX_parse_keyword_looprest(pTHX)
1035 {
1036 return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes),
1037 parse_stmtseq(0), NULL, 1);
1038 }
1039
1040 #define parse_keyword_scopelessblock() THX_parse_keyword_scopelessblock(aTHX)
THX_parse_keyword_scopelessblock(pTHX)1041 static OP *THX_parse_keyword_scopelessblock(pTHX)
1042 {
1043 I32 c;
1044 OP *body;
1045 lex_read_space(0);
1046 if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
1047 lex_read_unichar(0);
1048 body = parse_stmtseq(0);
1049 c = lex_peek_unichar(0);
1050 if(c != /*{*/'}' && c != /*[*/']' && c != /*(*/')') croak("syntax error");
1051 lex_read_unichar(0);
1052 return body;
1053 }
1054
1055 #define parse_keyword_stmtasexpr() THX_parse_keyword_stmtasexpr(aTHX)
THX_parse_keyword_stmtasexpr(pTHX)1056 static OP *THX_parse_keyword_stmtasexpr(pTHX)
1057 {
1058 OP *o = parse_barestmt(0);
1059 if (!o) o = newOP(OP_STUB, 0);
1060 if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
1061 return op_scope(o);
1062 }
1063
1064 #define parse_keyword_stmtsasexpr() THX_parse_keyword_stmtsasexpr(aTHX)
THX_parse_keyword_stmtsasexpr(pTHX)1065 static OP *THX_parse_keyword_stmtsasexpr(pTHX)
1066 {
1067 OP *o;
1068 lex_read_space(0);
1069 if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
1070 lex_read_unichar(0);
1071 o = parse_stmtseq(0);
1072 lex_read_space(0);
1073 if(lex_peek_unichar(0) != /*{*/'}') croak("syntax error");
1074 lex_read_unichar(0);
1075 if (!o) o = newOP(OP_STUB, 0);
1076 if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
1077 return op_scope(o);
1078 }
1079
1080 #define parse_keyword_loopblock() THX_parse_keyword_loopblock(aTHX)
THX_parse_keyword_loopblock(pTHX)1081 static OP *THX_parse_keyword_loopblock(pTHX)
1082 {
1083 return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes),
1084 parse_block(0), NULL, 1);
1085 }
1086
1087 #define parse_keyword_blockasexpr() THX_parse_keyword_blockasexpr(aTHX)
THX_parse_keyword_blockasexpr(pTHX)1088 static OP *THX_parse_keyword_blockasexpr(pTHX)
1089 {
1090 OP *o = parse_block(0);
1091 if (!o) o = newOP(OP_STUB, 0);
1092 if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
1093 return op_scope(o);
1094 }
1095
1096 #define parse_keyword_swaplabel() THX_parse_keyword_swaplabel(aTHX)
THX_parse_keyword_swaplabel(pTHX)1097 static OP *THX_parse_keyword_swaplabel(pTHX)
1098 {
1099 OP *sop = parse_barestmt(0);
1100 SV *label = parse_label(PARSE_OPTIONAL);
1101 if (label) sv_2mortal(label);
1102 return newSTATEOP(label ? SvUTF8(label) : 0,
1103 label ? savepv(SvPVX(label)) : NULL,
1104 sop);
1105 }
1106
1107 #define parse_keyword_labelconst() THX_parse_keyword_labelconst(aTHX)
THX_parse_keyword_labelconst(pTHX)1108 static OP *THX_parse_keyword_labelconst(pTHX)
1109 {
1110 return newSVOP(OP_CONST, 0, parse_label(0));
1111 }
1112
1113 #define parse_keyword_arrayfullexpr() THX_parse_keyword_arrayfullexpr(aTHX)
THX_parse_keyword_arrayfullexpr(pTHX)1114 static OP *THX_parse_keyword_arrayfullexpr(pTHX)
1115 {
1116 return newANONLIST(parse_fullexpr(0));
1117 }
1118
1119 #define parse_keyword_arraylistexpr() THX_parse_keyword_arraylistexpr(aTHX)
THX_parse_keyword_arraylistexpr(pTHX)1120 static OP *THX_parse_keyword_arraylistexpr(pTHX)
1121 {
1122 return newANONLIST(parse_listexpr(0));
1123 }
1124
1125 #define parse_keyword_arraytermexpr() THX_parse_keyword_arraytermexpr(aTHX)
THX_parse_keyword_arraytermexpr(pTHX)1126 static OP *THX_parse_keyword_arraytermexpr(pTHX)
1127 {
1128 return newANONLIST(parse_termexpr(0));
1129 }
1130
1131 #define parse_keyword_arrayarithexpr() THX_parse_keyword_arrayarithexpr(aTHX)
THX_parse_keyword_arrayarithexpr(pTHX)1132 static OP *THX_parse_keyword_arrayarithexpr(pTHX)
1133 {
1134 return newANONLIST(parse_arithexpr(0));
1135 }
1136
1137 #define parse_keyword_arrayexprflags() THX_parse_keyword_arrayexprflags(aTHX)
THX_parse_keyword_arrayexprflags(pTHX)1138 static OP *THX_parse_keyword_arrayexprflags(pTHX)
1139 {
1140 U32 flags = 0;
1141 I32 c;
1142 OP *o;
1143 lex_read_space(0);
1144 c = lex_peek_unichar(0);
1145 if (c != '!' && c != '?') croak("syntax error");
1146 lex_read_unichar(0);
1147 if (c == '?') flags |= PARSE_OPTIONAL;
1148 o = parse_listexpr(flags);
1149 return o ? newANONLIST(o) : newANONHASH(newOP(OP_STUB, 0));
1150 }
1151
1152 #define parse_keyword_subsignature() THX_parse_keyword_subsignature(aTHX)
THX_parse_keyword_subsignature(pTHX)1153 static OP *THX_parse_keyword_subsignature(pTHX)
1154 {
1155 OP *retop = NULL, *listop, *sigop = parse_subsignature(0);
1156 OP *kid;
1157 int seen_nextstate = 0;
1158
1159 /* We can't yield the optree as is to the caller because it won't be
1160 * executable outside of a called sub. We'll have to convert it into
1161 * something safe for them to invoke.
1162 * sigop should be an OP_NULL above a OP_LINESEQ containing
1163 * OP_NEXTSTATE-separated OP_ARGCHECK and OP_ARGELEMs
1164 */
1165 if(sigop->op_type != OP_NULL)
1166 croak("Expected parse_subsignature() to yield an OP_NULL");
1167
1168 if(!(sigop->op_flags & OPf_KIDS))
1169 croak("Expected parse_subsignature() to yield an OP_NULL with kids");
1170 listop = cUNOPx(sigop)->op_first;
1171
1172 if(listop->op_type != OP_LINESEQ)
1173 croak("Expected parse_subsignature() to yield an OP_LINESEQ");
1174
1175 for(kid = cLISTOPx(listop)->op_first; kid; kid = OpSIBLING(kid)) {
1176 switch(kid->op_type) {
1177 case OP_NEXTSTATE:
1178 /* Only emit the first one otherwise they get boring */
1179 if(seen_nextstate)
1180 break;
1181 seen_nextstate++;
1182 retop = op_append_list(OP_LIST, retop, newSVOP(OP_CONST, 0,
1183 /* newSVpvf("nextstate:%s:%d", CopFILE(cCOPx(kid)), cCOPx(kid)->cop_line))); */
1184 newSVpvf("nextstate:%u", (unsigned int)cCOPx(kid)->cop_line)));
1185 break;
1186 case OP_ARGCHECK: {
1187 struct op_argcheck_aux *p =
1188 (struct op_argcheck_aux*)(cUNOP_AUXx(kid)->op_aux);
1189 retop = op_append_list(OP_LIST, retop, newSVOP(OP_CONST, 0,
1190 newSVpvf("argcheck:%" UVuf ":%" UVuf ":%c",
1191 p->params, p->opt_params,
1192 p->slurpy ? p->slurpy : '-')));
1193 break;
1194 }
1195 case OP_ARGELEM: {
1196 PADOFFSET padix = kid->op_targ;
1197 PADNAMELIST *names = PadlistNAMES(CvPADLIST(find_runcv(0)));
1198 char *namepv = PadnamePV(padnamelist_fetch(names, padix));
1199 retop = op_append_list(OP_LIST, retop, newSVOP(OP_CONST, 0,
1200 newSVpvf(kid->op_flags & OPf_KIDS ? "argelem:%s:d" : "argelem:%s", namepv)));
1201 break;
1202 }
1203 default:
1204 fprintf(stderr, "TODO: examine kid %p (optype=%s)\n", kid, PL_op_name[kid->op_type]);
1205 break;
1206 }
1207 }
1208
1209 op_free(sigop);
1210 return newANONLIST(retop);
1211 }
1212
1213 #define parse_keyword_DEFSV() THX_parse_keyword_DEFSV(aTHX)
THX_parse_keyword_DEFSV(pTHX)1214 static OP *THX_parse_keyword_DEFSV(pTHX)
1215 {
1216 return newDEFSVOP();
1217 }
1218
1219 #define sv_cat_c(a,b) THX_sv_cat_c(aTHX_ a, b)
THX_sv_cat_c(pTHX_ SV * sv,U32 c)1220 static void THX_sv_cat_c(pTHX_ SV *sv, U32 c) {
1221 char ds[UTF8_MAXBYTES + 1], *d;
1222 d = (char *)uvchr_to_utf8((U8 *)ds, c);
1223 if (d - ds > 1) {
1224 sv_utf8_upgrade(sv);
1225 }
1226 sv_catpvn(sv, ds, d - ds);
1227 }
1228
1229 #define parse_keyword_with_vars() THX_parse_keyword_with_vars(aTHX)
THX_parse_keyword_with_vars(pTHX)1230 static OP *THX_parse_keyword_with_vars(pTHX)
1231 {
1232 I32 c;
1233 IV count;
1234 int save_ix;
1235 OP *vardeclseq, *body;
1236
1237 save_ix = block_start(TRUE);
1238 vardeclseq = NULL;
1239
1240 count = 0;
1241
1242 lex_read_space(0);
1243 c = lex_peek_unichar(0);
1244 while (c != '{') {
1245 SV *varname;
1246 PADOFFSET padoff;
1247
1248 if (c == -1) {
1249 croak("unexpected EOF; expecting '{'");
1250 }
1251
1252 if (!isIDFIRST_uni(c)) {
1253 croak("unexpected '%c'; expecting an identifier", (int)c);
1254 }
1255
1256 varname = newSVpvs("$");
1257 if (lex_bufutf8()) {
1258 SvUTF8_on(varname);
1259 }
1260
1261 sv_cat_c(varname, c);
1262 lex_read_unichar(0);
1263
1264 while (c = lex_peek_unichar(0), c != -1 && isIDCONT_uni(c)) {
1265 sv_cat_c(varname, c);
1266 lex_read_unichar(0);
1267 }
1268
1269 padoff = pad_add_name_sv(varname, padadd_NO_DUP_CHECK, NULL, NULL);
1270
1271 {
1272 OP *my_var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
1273 my_var->op_targ = padoff;
1274
1275 vardeclseq = op_append_list(
1276 OP_LINESEQ,
1277 vardeclseq,
1278 newSTATEOP(
1279 0, NULL,
1280 newASSIGNOP(
1281 OPf_STACKED,
1282 my_var, 0,
1283 newSVOP(
1284 OP_CONST, 0,
1285 newSViv(++count)
1286 )
1287 )
1288 )
1289 );
1290 }
1291
1292 lex_read_space(0);
1293 c = lex_peek_unichar(0);
1294 }
1295
1296 intro_my();
1297
1298 body = parse_block(0);
1299
1300 return block_end(save_ix, op_append_list(OP_LINESEQ, vardeclseq, body));
1301 }
1302
1303 #define parse_join_with_space() THX_parse_join_with_space(aTHX)
THX_parse_join_with_space(pTHX)1304 static OP *THX_parse_join_with_space(pTHX)
1305 {
1306 OP *delim, *args;
1307
1308 args = parse_listexpr(0);
1309 delim = newSVOP(OP_CONST, 0, newSVpvs(" "));
1310 return op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, delim, args));
1311 }
1312
1313 /* plugin glue */
1314
1315 #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
THX_keyword_active(pTHX_ SV * hintkey_sv)1316 static int THX_keyword_active(pTHX_ SV *hintkey_sv)
1317 {
1318 HE *he;
1319 if(!GvHV(PL_hintgv)) return 0;
1320 he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
1321 SvSHARED_HASH(hintkey_sv));
1322 return he && SvTRUE(HeVAL(he));
1323 }
1324
my_keyword_plugin(pTHX_ char * keyword_ptr,STRLEN keyword_len,OP ** op_ptr)1325 static int my_keyword_plugin(pTHX_
1326 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
1327 {
1328 if (memEQs(keyword_ptr, keyword_len, "rpn") &&
1329 keyword_active(hintkey_rpn_sv)) {
1330 *op_ptr = parse_keyword_rpn();
1331 return KEYWORD_PLUGIN_EXPR;
1332 } else if (memEQs(keyword_ptr, keyword_len, "calcrpn") &&
1333 keyword_active(hintkey_calcrpn_sv)) {
1334 *op_ptr = parse_keyword_calcrpn();
1335 return KEYWORD_PLUGIN_STMT;
1336 } else if (memEQs(keyword_ptr, keyword_len, "stufftest") &&
1337 keyword_active(hintkey_stufftest_sv)) {
1338 *op_ptr = parse_keyword_stufftest();
1339 return KEYWORD_PLUGIN_STMT;
1340 } else if (memEQs(keyword_ptr, keyword_len, "swaptwostmts") &&
1341 keyword_active(hintkey_swaptwostmts_sv)) {
1342 *op_ptr = parse_keyword_swaptwostmts();
1343 return KEYWORD_PLUGIN_STMT;
1344 } else if (memEQs(keyword_ptr, keyword_len, "looprest") &&
1345 keyword_active(hintkey_looprest_sv)) {
1346 *op_ptr = parse_keyword_looprest();
1347 return KEYWORD_PLUGIN_STMT;
1348 } else if (memEQs(keyword_ptr, keyword_len, "scopelessblock") &&
1349 keyword_active(hintkey_scopelessblock_sv)) {
1350 *op_ptr = parse_keyword_scopelessblock();
1351 return KEYWORD_PLUGIN_STMT;
1352 } else if (memEQs(keyword_ptr, keyword_len, "stmtasexpr") &&
1353 keyword_active(hintkey_stmtasexpr_sv)) {
1354 *op_ptr = parse_keyword_stmtasexpr();
1355 return KEYWORD_PLUGIN_EXPR;
1356 } else if (memEQs(keyword_ptr, keyword_len, "stmtsasexpr") &&
1357 keyword_active(hintkey_stmtsasexpr_sv)) {
1358 *op_ptr = parse_keyword_stmtsasexpr();
1359 return KEYWORD_PLUGIN_EXPR;
1360 } else if (memEQs(keyword_ptr, keyword_len, "loopblock") &&
1361 keyword_active(hintkey_loopblock_sv)) {
1362 *op_ptr = parse_keyword_loopblock();
1363 return KEYWORD_PLUGIN_STMT;
1364 } else if (memEQs(keyword_ptr, keyword_len, "blockasexpr") &&
1365 keyword_active(hintkey_blockasexpr_sv)) {
1366 *op_ptr = parse_keyword_blockasexpr();
1367 return KEYWORD_PLUGIN_EXPR;
1368 } else if (memEQs(keyword_ptr, keyword_len, "swaplabel") &&
1369 keyword_active(hintkey_swaplabel_sv)) {
1370 *op_ptr = parse_keyword_swaplabel();
1371 return KEYWORD_PLUGIN_STMT;
1372 } else if (memEQs(keyword_ptr, keyword_len, "labelconst") &&
1373 keyword_active(hintkey_labelconst_sv)) {
1374 *op_ptr = parse_keyword_labelconst();
1375 return KEYWORD_PLUGIN_EXPR;
1376 } else if (memEQs(keyword_ptr, keyword_len, "arrayfullexpr") &&
1377 keyword_active(hintkey_arrayfullexpr_sv)) {
1378 *op_ptr = parse_keyword_arrayfullexpr();
1379 return KEYWORD_PLUGIN_EXPR;
1380 } else if (memEQs(keyword_ptr, keyword_len, "arraylistexpr") &&
1381 keyword_active(hintkey_arraylistexpr_sv)) {
1382 *op_ptr = parse_keyword_arraylistexpr();
1383 return KEYWORD_PLUGIN_EXPR;
1384 } else if (memEQs(keyword_ptr, keyword_len, "arraytermexpr") &&
1385 keyword_active(hintkey_arraytermexpr_sv)) {
1386 *op_ptr = parse_keyword_arraytermexpr();
1387 return KEYWORD_PLUGIN_EXPR;
1388 } else if (memEQs(keyword_ptr, keyword_len, "arrayarithexpr") &&
1389 keyword_active(hintkey_arrayarithexpr_sv)) {
1390 *op_ptr = parse_keyword_arrayarithexpr();
1391 return KEYWORD_PLUGIN_EXPR;
1392 } else if (memEQs(keyword_ptr, keyword_len, "arrayexprflags") &&
1393 keyword_active(hintkey_arrayexprflags_sv)) {
1394 *op_ptr = parse_keyword_arrayexprflags();
1395 return KEYWORD_PLUGIN_EXPR;
1396 } else if (memEQs(keyword_ptr, keyword_len, "DEFSV") &&
1397 keyword_active(hintkey_DEFSV_sv)) {
1398 *op_ptr = parse_keyword_DEFSV();
1399 return KEYWORD_PLUGIN_EXPR;
1400 } else if (memEQs(keyword_ptr, keyword_len, "with_vars") &&
1401 keyword_active(hintkey_with_vars_sv)) {
1402 *op_ptr = parse_keyword_with_vars();
1403 return KEYWORD_PLUGIN_STMT;
1404 } else if (memEQs(keyword_ptr, keyword_len, "join_with_space") &&
1405 keyword_active(hintkey_join_with_space_sv)) {
1406 *op_ptr = parse_join_with_space();
1407 return KEYWORD_PLUGIN_EXPR;
1408 } else if (memEQs(keyword_ptr, keyword_len, "subsignature") &&
1409 keyword_active(hintkey_subsignature_sv)) {
1410 *op_ptr = parse_keyword_subsignature();
1411 return KEYWORD_PLUGIN_EXPR;
1412 } else {
1413 assert(next_keyword_plugin != my_keyword_plugin);
1414 return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
1415 }
1416 }
1417
1418 static XOP my_xop;
1419
1420 static OP *
pp_xop(pTHX)1421 pp_xop(pTHX)
1422 {
1423 return PL_op->op_next;
1424 }
1425
1426 static void
peep_xop(pTHX_ OP * o,OP * oldop)1427 peep_xop(pTHX_ OP *o, OP *oldop)
1428 {
1429 dMY_CXT;
1430 av_push(MY_CXT.xop_record, newSVpvf("peep:%" UVxf, PTR2UV(o)));
1431 av_push(MY_CXT.xop_record, newSVpvf("oldop:%" UVxf, PTR2UV(oldop)));
1432 }
1433
1434 static I32
filter_call(pTHX_ int idx,SV * buf_sv,int maxlen)1435 filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
1436 {
1437 char *p;
1438 char *end;
1439 int n = FILTER_READ(idx + 1, buf_sv, maxlen);
1440
1441 if (n<=0) return n;
1442
1443 p = SvPV_force_nolen(buf_sv);
1444 end = p + SvCUR(buf_sv);
1445 while (p < end) {
1446 if (*p == 'o') *p = 'e';
1447 p++;
1448 }
1449 return SvCUR(buf_sv);
1450 }
1451
1452 static AV *
myget_linear_isa(pTHX_ HV * stash,U32 level)1453 myget_linear_isa(pTHX_ HV *stash, U32 level) {
1454 GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0);
1455 PERL_UNUSED_ARG(level);
1456 return gvp && *gvp && GvAV(*gvp)
1457 ? GvAV(*gvp)
1458 : newAV_mortal();
1459 }
1460
1461
1462 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_undef);
1463 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_empty);
1464 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
1465
1466 static struct mro_alg mymro;
1467
1468 static Perl_check_t addissub_nxck_add;
1469
1470 static OP *
addissub_myck_add(pTHX_ OP * op)1471 addissub_myck_add(pTHX_ OP *op)
1472 {
1473 SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addissub", 0);
1474 OP *aop, *bop;
1475 U8 flags;
1476 if (!(flag_svp && SvTRUE(*flag_svp) && (op->op_flags & OPf_KIDS) &&
1477 (aop = cBINOPx(op)->op_first) && (bop = OpSIBLING(aop)) &&
1478 !OpHAS_SIBLING(bop)))
1479 return addissub_nxck_add(aTHX_ op);
1480 flags = op->op_flags;
1481 op_sibling_splice(op, NULL, 1, NULL); /* excise aop */
1482 op_sibling_splice(op, NULL, 1, NULL); /* excise bop */
1483 op_free(op); /* free the empty husk */
1484 flags &= ~OPf_KIDS;
1485 return newBINOP(OP_SUBTRACT, flags, aop, bop);
1486 }
1487
1488 static Perl_check_t old_ck_rv2cv;
1489
1490 static OP *
my_ck_rv2cv(pTHX_ OP * o)1491 my_ck_rv2cv(pTHX_ OP *o)
1492 {
1493 SV *ref;
1494 SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addunder", 0);
1495 OP *aop;
1496
1497 if (flag_svp && SvTRUE(*flag_svp) && (o->op_flags & OPf_KIDS)
1498 && (aop = cUNOPx(o)->op_first) && aop->op_type == OP_CONST
1499 && aop->op_private & (OPpCONST_ENTERED|OPpCONST_BARE)
1500 && (ref = cSVOPx(aop)->op_sv) && SvPOK(ref) && SvCUR(ref)
1501 && *(SvEND(ref)-1) == 'o')
1502 {
1503 SvGROW(ref, SvCUR(ref)+2);
1504 *SvEND(ref) = '_';
1505 SvCUR(ref)++; /* Not _set, so we don't accidentally break non-PERL_CORE */
1506 *SvEND(ref) = '\0';
1507 }
1508 return old_ck_rv2cv(aTHX_ o);
1509 }
1510
1511 #define test_bool_internals_macro(true_sv, false_sv) \
1512 test_bool_internals_func(true_sv, false_sv,\
1513 #true_sv " and " #false_sv)
1514
1515 U32
test_bool_internals_func(SV * true_sv,SV * false_sv,const char * msg)1516 test_bool_internals_func(SV *true_sv, SV *false_sv, const char *msg) {
1517 U32 failed = 0;
1518 printf("# Testing '%s'\n", msg);
1519 TEST_EXPR(SvCUR(true_sv) == 1);
1520 TEST_EXPR(SvCUR(false_sv) == 0);
1521 TEST_EXPR(SvLEN(true_sv) == 0);
1522 TEST_EXPR(SvLEN(false_sv) == 0);
1523 TEST_EXPR(SvIV(true_sv) == 1);
1524 TEST_EXPR(SvIV(false_sv) == 0);
1525 TEST_EXPR(SvIsCOW(true_sv));
1526 TEST_EXPR(SvIsCOW(false_sv));
1527 TEST_EXPR(strEQ(SvPV_nolen(true_sv),"1"));
1528 TEST_EXPR(strEQ(SvPV_nolen(false_sv),""));
1529 TEST_EXPR(SvIOK(true_sv));
1530 TEST_EXPR(SvIOK(false_sv));
1531 TEST_EXPR(SvPOK(true_sv));
1532 TEST_EXPR(SvPOK(false_sv));
1533 TEST_EXPR(SvBoolFlagsOK(true_sv));
1534 TEST_EXPR(SvBoolFlagsOK(false_sv));
1535 TEST_EXPR(SvTYPE(true_sv) >= SVt_PVNV);
1536 TEST_EXPR(SvTYPE(false_sv) >= SVt_PVNV);
1537 TEST_EXPR(SvBoolFlagsOK(true_sv) && BOOL_INTERNALS_sv_isbool(true_sv));
1538 TEST_EXPR(SvBoolFlagsOK(false_sv) && BOOL_INTERNALS_sv_isbool(false_sv));
1539 TEST_EXPR(SvBoolFlagsOK(true_sv) && BOOL_INTERNALS_sv_isbool_true(true_sv));
1540 TEST_EXPR(SvBoolFlagsOK(false_sv) && BOOL_INTERNALS_sv_isbool_false(false_sv));
1541 TEST_EXPR(SvBoolFlagsOK(true_sv) && !BOOL_INTERNALS_sv_isbool_false(true_sv));
1542 TEST_EXPR(SvBoolFlagsOK(false_sv) && !BOOL_INTERNALS_sv_isbool_true(false_sv));
1543 TEST_EXPR(SvTRUE(true_sv));
1544 TEST_EXPR(!SvTRUE(false_sv));
1545 if (failed) {
1546 PerlIO_printf(Perl_debug_log, "# '%s' the tested true_sv:\n", msg);
1547 sv_dump(true_sv);
1548 PerlIO_printf(Perl_debug_log, "# PL_sv_yes:\n");
1549 sv_dump(&PL_sv_yes);
1550 PerlIO_printf(Perl_debug_log, "# '%s' tested false_sv:\n",msg);
1551 sv_dump(false_sv);
1552 PerlIO_printf(Perl_debug_log, "# PL_sv_no:\n");
1553 sv_dump(&PL_sv_no);
1554 }
1555 fflush(stdout);
1556 SvREFCNT_dec(true_sv);
1557 SvREFCNT_dec(false_sv);
1558 return failed;
1559 }
1560
1561
1562 /* A simplified/fake replacement for pp_add, which tests the pp
1563 * function wrapping API, XSPP_wrapped() for a fixed number of args*/
1564
1565 XSPP_wrapped(my_pp_add, 2, 0)
1566 {
1567 SV *ret;
1568 dSP;
1569 SV *r = POPs;
1570 SV *l = TOPs;
1571 if (SvROK(l))
1572 l = SvRV(l);
1573 if (SvROK(r))
1574 r = SvRV(r);
1575 ret = newSViv( SvIV(l) + SvIV(r));
1576 sv_2mortal(ret);
1577 SETs(ret);
1578 RETURN;
1579 }
1580
1581
1582 /* A copy of pp_anonlist, which tests the pp
1583 * function wrapping API, XSPP_wrapped() for a list*/
1584
1585 XSPP_wrapped(my_pp_anonlist, 0, 1)
1586 {
1587 dSP; dMARK;
1588 const I32 items = SP - MARK;
1589 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
1590 SP = MARK;
1591 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
1592 ? newRV_noinc(av) : av);
1593 RETURN;
1594 }
1595
1596
1597 #include "const-c.inc"
1598
1599 void
destruct_test(pTHX_ void * p)1600 destruct_test(pTHX_ void *p) {
1601 warn("In destruct_test: %" SVf "\n", (SV*)p);
1602 }
1603
1604 #ifdef PERL_USE_HWM
1605 # define hwm_checks_enabled() true
1606 #else
1607 # define hwm_checks_enabled() false
1608 #endif
1609
1610 MODULE = XS::APItest PACKAGE = XS::APItest
1611
1612 INCLUDE: const-xs.inc
1613
1614 INCLUDE: numeric.xs
1615
1616 void
1617 assertx(int x)
1618 CODE:
1619 /* this only needs to compile and checks that assert() can be
1620 used this way syntactically */
1621 (void)(assert(x), 1);
1622 (void)(x);
1623
1624 MODULE = XS::APItest::utf8 PACKAGE = XS::APItest::utf8
1625
1626 int
1627 bytes_cmp_utf8(bytes, utf8)
1628 SV *bytes
1629 SV *utf8
1630 PREINIT:
1631 const U8 *b;
1632 STRLEN blen;
1633 const U8 *u;
1634 STRLEN ulen;
1635 CODE:
1636 b = (const U8 *)SvPVbyte(bytes, blen);
1637 u = (const U8 *)SvPVbyte(utf8, ulen);
1638 RETVAL = bytes_cmp_utf8(b, blen, u, ulen);
1639 OUTPUT:
1640 RETVAL
1641
1642 AV *
1643 test_utf8_to_bytes(bytes, len)
1644 U8 * bytes
1645 STRLEN len
1646 PREINIT:
1647 char * ret;
1648 CODE:
1649 RETVAL = newAV_mortal();
1650
1651 ret = (char *) utf8_to_bytes(bytes, &len);
1652 av_push_simple(RETVAL, newSVpv(ret, 0));
1653
1654 /* utf8_to_bytes uses (STRLEN)-1 to signal errors, and we want to
1655 * return that as -1 to perl, so cast to SSize_t in case
1656 * sizeof(IV) > sizeof(STRLEN) */
1657 av_push_simple(RETVAL, newSViv((SSize_t)len));
1658 av_push_simple(RETVAL, newSVpv((const char *) bytes, 0));
1659
1660 OUTPUT:
1661 RETVAL
1662
1663 AV *
1664 test_utf8n_to_uvchr_msgs(s, len, flags)
1665 char *s
1666 STRLEN len
1667 U32 flags
1668 PREINIT:
1669 STRLEN retlen;
1670 UV ret;
1671 U32 errors;
1672 AV *msgs = NULL;
1673
1674 CODE:
1675 RETVAL = newAV_mortal();
1676
1677 ret = utf8n_to_uvchr_msgs((U8*) s,
1678 len,
1679 &retlen,
1680 flags,
1681 &errors,
1682 &msgs);
1683
1684 /* Returns the return value in [0]; <retlen> in [1], <errors> in [2] */
1685 av_push_simple(RETVAL, newSVuv(ret));
1686 if (retlen == (STRLEN) -1) {
1687 av_push_simple(RETVAL, newSViv(-1));
1688 }
1689 else {
1690 av_push_simple(RETVAL, newSVuv(retlen));
1691 }
1692 av_push_simple(RETVAL, newSVuv(errors));
1693
1694 /* And any messages in [3] */
1695 if (msgs) {
1696 av_push_simple(RETVAL, newRV_noinc((SV*)msgs));
1697 }
1698
1699 OUTPUT:
1700 RETVAL
1701
1702 AV *
1703 test_utf8n_to_uvchr_error(s, len, flags)
1704
1705 char *s
1706 STRLEN len
1707 U32 flags
1708 PREINIT:
1709 STRLEN retlen;
1710 UV ret;
1711 U32 errors;
1712
1713 CODE:
1714 /* Now that utf8n_to_uvchr() is a trivial wrapper for
1715 * utf8n_to_uvchr_error(), call the latter with the inputs. It always
1716 * asks for the actual length to be returned and errors to be returned
1717 *
1718 * Length to assume <s> is; not checked, so could have buffer overflow
1719 */
1720 RETVAL = newAV_mortal();
1721
1722 ret = utf8n_to_uvchr_error((U8*) s,
1723 len,
1724 &retlen,
1725 flags,
1726 &errors);
1727
1728 /* Returns the return value in [0]; <retlen> in [1], <errors> in [2] */
1729 av_push_simple(RETVAL, newSVuv(ret));
1730 if (retlen == (STRLEN) -1) {
1731 av_push_simple(RETVAL, newSViv(-1));
1732 }
1733 else {
1734 av_push_simple(RETVAL, newSVuv(retlen));
1735 }
1736 av_push_simple(RETVAL, newSVuv(errors));
1737
1738 OUTPUT:
1739 RETVAL
1740
1741 AV *
1742 test_valid_utf8_to_uvchr(s)
1743
1744 SV *s
1745 PREINIT:
1746 STRLEN retlen;
1747 UV ret;
1748
1749 CODE:
1750 /* Call utf8n_to_uvchr() with the inputs. It always asks for the
1751 * actual length to be returned
1752 *
1753 * Length to assume <s> is; not checked, so could have buffer overflow
1754 */
1755 RETVAL = newAV_mortal();
1756
1757 ret = valid_utf8_to_uvchr((U8*) SvPV_nolen(s), &retlen);
1758
1759 /* Returns the return value in [0]; <retlen> in [1] */
1760 av_push_simple(RETVAL, newSVuv(ret));
1761 av_push_simple(RETVAL, newSVuv(retlen));
1762
1763 OUTPUT:
1764 RETVAL
1765
1766 SV *
1767 test_uvchr_to_utf8_flags(uv, flags)
1768
1769 SV *uv
1770 SV *flags
1771 PREINIT:
1772 U8 dest[UTF8_MAXBYTES + 1];
1773 U8 *ret;
1774
1775 CODE:
1776 /* Call uvchr_to_utf8_flags() with the inputs. */
1777 ret = uvchr_to_utf8_flags(dest, SvUV(uv), SvUV(flags));
1778 if (! ret) {
1779 XSRETURN_UNDEF;
1780 }
1781 RETVAL = newSVpvn((char *) dest, ret - dest);
1782
1783 OUTPUT:
1784 RETVAL
1785
1786 AV *
1787 test_uvchr_to_utf8_flags_msgs(uv, flags)
1788
1789 SV *uv
1790 SV *flags
1791 PREINIT:
1792 U8 dest[UTF8_MAXBYTES + 1];
1793 U8 *ret;
1794
1795 CODE:
1796 HV *msgs = NULL;
1797 RETVAL = newAV_mortal();
1798
1799 ret = uvchr_to_utf8_flags_msgs(dest, SvUV(uv), SvUV(flags), &msgs);
1800
1801 if (ret) {
1802 av_push_simple(RETVAL, newSVpvn((char *) dest, ret - dest));
1803 }
1804 else {
1805 av_push_simple(RETVAL, &PL_sv_undef);
1806 }
1807
1808 if (msgs) {
1809 av_push_simple(RETVAL, newRV_noinc((SV*)msgs));
1810 }
1811
1812 OUTPUT:
1813 RETVAL
1814
1815 MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload
1816
1817 void
1818 does_amagic_apply(sv, method, flags)
1819 SV *sv
1820 int method
1821 int flags
1822 PPCODE:
1823 if(Perl_amagic_applies(aTHX_ sv, method, flags))
1824 XSRETURN_YES;
1825 else
1826 XSRETURN_NO;
1827
1828
1829 void
1830 amagic_deref_call(sv, what)
1831 SV *sv
1832 int what
1833 PPCODE:
1834 /* The reference is owned by something else. */
1835 PUSHs(amagic_deref_call(sv, what));
1836
1837 # I'd certainly like to discourage the use of this macro, given that we now
1838 # have amagic_deref_call
1839
1840 void
tryAMAGICunDEREF_var(sv,what)1841 tryAMAGICunDEREF_var(sv, what)
1842 SV *sv
1843 int what
1844 PPCODE:
1845 {
1846 SV **sp = &sv;
1847 switch(what) {
1848 case to_av_amg:
1849 tryAMAGICunDEREF(to_av);
1850 break;
1851 case to_cv_amg:
1852 tryAMAGICunDEREF(to_cv);
1853 break;
1854 case to_gv_amg:
1855 tryAMAGICunDEREF(to_gv);
1856 break;
1857 case to_hv_amg:
1858 tryAMAGICunDEREF(to_hv);
1859 break;
1860 case to_sv_amg:
1861 tryAMAGICunDEREF(to_sv);
1862 break;
1863 default:
1864 croak("Invalid value %d passed to tryAMAGICunDEREF_var", what);
1865 }
1866 }
1867 /* The reference is owned by something else. */
1868 PUSHs(sv);
1869
1870 MODULE = XS::APItest PACKAGE = XS::APItest::XSUB
1871
1872 BOOT:
1873 newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
1874 newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
1875 newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
1876
1877 void
1878 XS_VERSION_defined(...)
1879 PPCODE:
1880 XS_VERSION_BOOTCHECK;
1881 XSRETURN_EMPTY;
1882
1883 void
1884 XS_APIVERSION_valid(...)
1885 PPCODE:
1886 XS_APIVERSION_BOOTCHECK;
1887 XSRETURN_EMPTY;
1888
1889 void
1890 xsreturn( int len )
1891 PPCODE:
1892 int i = 0;
1893 EXTEND( SP, len );
1894 for ( ; i < len; i++ ) {
1895 ST(i) = sv_2mortal( newSViv(i) );
1896 }
1897 XSRETURN( len );
1898
1899 void
1900 xsreturn_iv()
1901 PPCODE:
1902 XSRETURN_IV(I32_MIN + 1);
1903
1904 void
1905 xsreturn_uv()
1906 PPCODE:
1907 XSRETURN_UV( (U32)((1U<<31) + 1) );
1908
1909 void
1910 xsreturn_nv()
1911 PPCODE:
1912 XSRETURN_NV(0.25);
1913
1914 void
1915 xsreturn_pv()
1916 PPCODE:
1917 XSRETURN_PV("returned");
1918
1919 void
1920 xsreturn_pvn()
1921 PPCODE:
1922 XSRETURN_PVN("returned too much",8);
1923
1924 void
1925 xsreturn_no()
1926 PPCODE:
1927 XSRETURN_NO;
1928
1929 void
1930 xsreturn_yes()
1931 PPCODE:
1932 XSRETURN_YES;
1933
1934 void
1935 xsreturn_undef()
1936 PPCODE:
1937 XSRETURN_UNDEF;
1938
1939 void
1940 xsreturn_empty()
1941 PPCODE:
1942 XSRETURN_EMPTY;
1943
1944 MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
1945
1946 void
1947 rot13_hash(hash)
1948 HV *hash
1949 CODE:
1950 {
1951 struct ufuncs uf;
1952 uf.uf_val = rot13_key;
1953 uf.uf_set = 0;
1954 uf.uf_index = 0;
1955
1956 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
1957 }
1958
1959 void
1960 bitflip_hash(hash)
1961 HV *hash
1962 CODE:
1963 {
1964 struct ufuncs uf;
1965 uf.uf_val = bitflip_key;
1966 uf.uf_set = 0;
1967 uf.uf_index = 0;
1968
1969 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
1970 }
1971
1972 #define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
1973
1974 bool
1975 exists(hash, key_sv)
1976 PREINIT:
1977 STRLEN len;
1978 const char *key;
1979 INPUT:
1980 HV *hash
1981 SV *key_sv
1982 CODE:
1983 key = SvPV(key_sv, len);
1984 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
1985 OUTPUT:
1986 RETVAL
1987
1988 bool
1989 exists_ent(hash, key_sv)
1990 PREINIT:
1991 INPUT:
1992 HV *hash
1993 SV *key_sv
1994 CODE:
1995 RETVAL = hv_exists_ent(hash, key_sv, 0);
1996 OUTPUT:
1997 RETVAL
1998
1999 SV *
2000 delete(hash, key_sv, flags = 0)
2001 PREINIT:
2002 STRLEN len;
2003 const char *key;
2004 INPUT:
2005 HV *hash
2006 SV *key_sv
2007 I32 flags;
2008 CODE:
2009 key = SvPV(key_sv, len);
2010 /* It's already mortal, so need to increase reference count. */
2011 RETVAL
2012 = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
2013 OUTPUT:
2014 RETVAL
2015
2016 SV *
2017 delete_ent(hash, key_sv, flags = 0)
2018 INPUT:
2019 HV *hash
2020 SV *key_sv
2021 I32 flags;
2022 CODE:
2023 /* It's already mortal, so need to increase reference count. */
2024 RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
2025 OUTPUT:
2026 RETVAL
2027
2028 SV *
2029 store_ent(hash, key, value)
2030 PREINIT:
2031 SV *copy;
2032 HE *result;
2033 INPUT:
2034 HV *hash
2035 SV *key
2036 SV *value
2037 CODE:
2038 copy = newSV(0);
2039 result = hv_store_ent(hash, key, copy, 0);
2040 SvSetMagicSV(copy, value);
2041 if (!result) {
2042 SvREFCNT_dec(copy);
2043 XSRETURN_EMPTY;
2044 }
2045 /* It's about to become mortal, so need to increase reference count.
2046 */
2047 RETVAL = SvREFCNT_inc(HeVAL(result));
2048 OUTPUT:
2049 RETVAL
2050
2051 SV *
2052 store(hash, key_sv, value)
2053 PREINIT:
2054 STRLEN len;
2055 const char *key;
2056 SV *copy;
2057 SV **result;
2058 INPUT:
2059 HV *hash
2060 SV *key_sv
2061 SV *value
2062 CODE:
2063 key = SvPV(key_sv, len);
2064 copy = newSV(0);
2065 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
2066 SvSetMagicSV(copy, value);
2067 if (!result) {
2068 SvREFCNT_dec(copy);
2069 XSRETURN_EMPTY;
2070 }
2071 /* It's about to become mortal, so need to increase reference count.
2072 */
2073 RETVAL = SvREFCNT_inc(*result);
2074 OUTPUT:
2075 RETVAL
2076
2077 SV *
fetch_ent(hash,key_sv)2078 fetch_ent(hash, key_sv)
2079 PREINIT:
2080 HE *result;
2081 INPUT:
2082 HV *hash
2083 SV *key_sv
2084 CODE:
2085 result = hv_fetch_ent(hash, key_sv, 0, 0);
2086 if (!result) {
2087 XSRETURN_EMPTY;
2088 }
2089 /* Force mg_get */
2090 RETVAL = newSVsv(HeVAL(result));
2091 OUTPUT:
2092 RETVAL
2093
2094 SV *
2095 fetch(hash, key_sv)
2096 PREINIT:
2097 STRLEN len;
2098 const char *key;
2099 SV **result;
2100 INPUT:
2101 HV *hash
2102 SV *key_sv
2103 CODE:
2104 key = SvPV(key_sv, len);
2105 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
2106 if (!result) {
2107 XSRETURN_EMPTY;
2108 }
2109 /* Force mg_get */
2110 RETVAL = newSVsv(*result);
2111 OUTPUT:
2112 RETVAL
2113
2114 SV *
2115 common(params)
2116 INPUT:
2117 HV *params
2118 PREINIT:
2119 HE *result;
2120 HV *hv = NULL;
2121 SV *keysv = NULL;
2122 const char *key = NULL;
2123 STRLEN klen = 0;
2124 int flags = 0;
2125 int action = 0;
2126 SV *val = NULL;
2127 U32 hash = 0;
2128 SV **svp;
2129 CODE:
2130 if ((svp = hv_fetchs(params, "hv", 0))) {
2131 SV *const rv = *svp;
2132 if (!SvROK(rv))
2133 croak("common passed a non-reference for parameter hv");
2134 hv = (HV *)SvRV(rv);
2135 }
2136 if ((svp = hv_fetchs(params, "keysv", 0)))
2137 keysv = *svp;
2138 if ((svp = hv_fetchs(params, "keypv", 0))) {
2139 key = SvPV_const(*svp, klen);
2140 if (SvUTF8(*svp))
2141 flags = HVhek_UTF8;
2142 }
2143 if ((svp = hv_fetchs(params, "action", 0)))
2144 action = SvIV(*svp);
2145 if ((svp = hv_fetchs(params, "val", 0)))
2146 val = newSVsv(*svp);
2147 if ((svp = hv_fetchs(params, "hash", 0)))
2148 hash = SvUV(*svp);
2149
2150 if (hv_fetchs(params, "hash_pv", 0)) {
2151 assert(key);
2152 PERL_HASH(hash, key, klen);
2153 }
2154 if (hv_fetchs(params, "hash_sv", 0)) {
2155 assert(keysv);
2156 {
2157 STRLEN len;
2158 const char *const p = SvPV(keysv, len);
2159 PERL_HASH(hash, p, len);
2160 }
2161 }
2162
2163 result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
2164 if (!result) {
2165 XSRETURN_EMPTY;
2166 }
2167 /* Force mg_get */
2168 RETVAL = newSVsv(HeVAL(result));
2169 OUTPUT:
2170 RETVAL
2171
2172 void
2173 test_hv_free_ent()
2174 PPCODE:
2175 test_freeent(&Perl_hv_free_ent);
2176 XSRETURN(4);
2177
2178 void
2179 test_hv_delayfree_ent()
2180 PPCODE:
2181 test_freeent(&Perl_hv_delayfree_ent);
2182 XSRETURN(4);
2183
2184 SV *
2185 test_share_unshare_pvn(input)
2186 PREINIT:
2187 STRLEN len;
2188 U32 hash;
2189 char *pvx;
2190 char *p;
2191 INPUT:
2192 SV *input
2193 CODE:
2194 pvx = SvPV(input, len);
2195 PERL_HASH(hash, pvx, len);
2196 p = sharepvn(pvx, len, hash);
2197 RETVAL = newSVpvn(p, len);
2198 unsharepvn(p, len, hash);
2199 OUTPUT:
2200 RETVAL
2201
2202 bool
2203 refcounted_he_exists(key, level=0)
2204 SV *key
2205 IV level
2206 CODE:
2207 if (level) {
2208 croak("level must be zero, not %" IVdf, level);
2209 }
2210 RETVAL = (cop_hints_fetch_sv(PL_curcop, key, 0, 0) != &PL_sv_placeholder);
2211 OUTPUT:
2212 RETVAL
2213
2214 SV *
2215 refcounted_he_fetch(key, level=0)
2216 SV *key
2217 IV level
2218 CODE:
2219 if (level) {
2220 croak("level must be zero, not %" IVdf, level);
2221 }
2222 RETVAL = cop_hints_fetch_sv(PL_curcop, key, 0, 0);
2223 SvREFCNT_inc(RETVAL);
2224 OUTPUT:
2225 RETVAL
2226
2227 void
2228 test_force_keys(HV *hv)
2229 PREINIT:
2230 HE *he;
2231 SSize_t count = 0;
2232 PPCODE:
2233 hv_iterinit(hv);
2234 he = hv_iternext(hv);
2235 while (he) {
2236 SV *sv = HeSVKEY_force(he);
2237 ++count;
2238 EXTEND(SP, count);
2239 PUSHs(sv_mortalcopy(sv));
2240 he = hv_iternext(hv);
2241 }
2242
2243 =pod
2244
2245 sub TIEHASH { bless {}, $_[0] }
2246 sub STORE { $_[0]->{$_[1]} = $_[2] }
2247 sub FETCH { $_[0]->{$_[1]} }
2248 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
2249 sub NEXTKEY { each %{$_[0]} }
2250 sub EXISTS { exists $_[0]->{$_[1]} }
2251 sub DELETE { delete $_[0]->{$_[1]} }
2252 sub CLEAR { %{$_[0]} = () }
2253
2254 =cut
2255
2256 MODULE = XS::APItest:TempLv PACKAGE = XS::APItest::TempLv
2257
2258 void
2259 make_temp_mg_lv(sv)
2260 SV* sv
2261 PREINIT:
2262 SV * const lv = newSV_type(SVt_PVLV);
2263 STRLEN len;
2264 PPCODE:
2265 SvPV(sv, len);
2266
2267 sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
2268 LvTYPE(lv) = 'x';
2269 LvTARG(lv) = SvREFCNT_inc_simple(sv);
2270 LvTARGOFF(lv) = len == 0 ? 0 : 1;
2271 LvTARGLEN(lv) = len < 2 ? 0 : len-2;
2272
2273 EXTEND(SP, 1);
2274 ST(0) = sv_2mortal(lv);
2275 XSRETURN(1);
2276
2277
2278 MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
2279
2280 void
2281 ptr_table_new(classname)
2282 const char * classname
2283 PPCODE:
2284 PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
2285
2286 void
2287 DESTROY(table)
2288 XS::APItest::PtrTable table
2289 CODE:
2290 ptr_table_free(table);
2291
2292 void
2293 ptr_table_store(table, from, to)
2294 XS::APItest::PtrTable table
2295 SVREF from
2296 SVREF to
2297 CODE:
2298 ptr_table_store(table, from, to);
2299
2300 UV
2301 ptr_table_fetch(table, from)
2302 XS::APItest::PtrTable table
2303 SVREF from
2304 CODE:
2305 RETVAL = PTR2UV(ptr_table_fetch(table, from));
2306 OUTPUT:
2307 RETVAL
2308
2309 void
2310 ptr_table_split(table)
2311 XS::APItest::PtrTable table
2312
2313 MODULE = XS::APItest::AutoLoader PACKAGE = XS::APItest::AutoLoader
2314
2315 SV *
2316 AUTOLOAD()
2317 CODE:
2318 RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
2319 OUTPUT:
2320 RETVAL
2321
2322 SV *
2323 AUTOLOADp(...)
2324 PROTOTYPE: *$
2325 CODE:
2326 PERL_UNUSED_ARG(items);
2327 RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
2328 OUTPUT:
2329 RETVAL
2330
2331
2332 MODULE = XS::APItest PACKAGE = XS::APItest
2333
2334 PROTOTYPES: DISABLE
2335
2336 BOOT:
2337 mymro.resolve = myget_linear_isa;
2338 mymro.name = "justisa";
2339 mymro.length = 7;
2340 mymro.kflags = 0;
2341 mymro.hash = 0;
2342 Perl_mro_register(aTHX_ &mymro);
2343
2344 HV *
2345 xop_custom_ops ()
2346 CODE:
2347 RETVAL = PL_custom_ops;
2348 OUTPUT:
2349 RETVAL
2350
2351 HV *
2352 xop_custom_op_names ()
2353 CODE:
2354 PL_custom_op_names = newHV();
2355 RETVAL = PL_custom_op_names;
2356 OUTPUT:
2357 RETVAL
2358
2359 HV *
2360 xop_custom_op_descs ()
2361 CODE:
2362 PL_custom_op_descs = newHV();
2363 RETVAL = PL_custom_op_descs;
2364 OUTPUT:
2365 RETVAL
2366
2367 void
2368 xop_register ()
2369 CODE:
2370 XopENTRY_set(&my_xop, xop_name, "my_xop");
2371 XopENTRY_set(&my_xop, xop_desc, "XOP for testing");
2372 XopENTRY_set(&my_xop, xop_class, OA_UNOP);
2373 XopENTRY_set(&my_xop, xop_peep, peep_xop);
2374 Perl_custom_op_register(aTHX_ pp_xop, &my_xop);
2375
2376 void
2377 xop_clear ()
2378 CODE:
2379 XopDISABLE(&my_xop, xop_name);
2380 XopDISABLE(&my_xop, xop_desc);
2381 XopDISABLE(&my_xop, xop_class);
2382 XopDISABLE(&my_xop, xop_peep);
2383
2384 IV
2385 xop_my_xop ()
2386 CODE:
2387 RETVAL = PTR2IV(&my_xop);
2388 OUTPUT:
2389 RETVAL
2390
2391 IV
2392 xop_ppaddr ()
2393 CODE:
2394 RETVAL = PTR2IV(pp_xop);
2395 OUTPUT:
2396 RETVAL
2397
2398 IV
2399 xop_OA_UNOP ()
2400 CODE:
2401 RETVAL = OA_UNOP;
2402 OUTPUT:
2403 RETVAL
2404
2405 AV *
2406 xop_build_optree ()
2407 CODE:
2408 dMY_CXT;
2409 UNOP *unop;
2410 OP *kid;
2411
2412 MY_CXT.xop_record = newAV_alloc_x(5);
2413
2414 kid = newSVOP(OP_CONST, 0, newSViv(42));
2415
2416 unop = (UNOP*)mkUNOP(OP_CUSTOM, kid);
2417 unop->op_ppaddr = pp_xop;
2418 unop->op_private = 0;
2419 unop->op_next = NULL;
2420 kid->op_next = (OP*)unop;
2421
2422 av_push_simple(MY_CXT.xop_record, newSVpvf("unop:%" UVxf, PTR2UV(unop)));
2423 av_push_simple(MY_CXT.xop_record, newSVpvf("kid:%" UVxf, PTR2UV(kid)));
2424
2425 av_push_simple(MY_CXT.xop_record, newSVpvf("NAME:%s", OP_NAME((OP*)unop)));
2426 av_push_simple(MY_CXT.xop_record, newSVpvf("DESC:%s", OP_DESC((OP*)unop)));
2427 av_push_simple(MY_CXT.xop_record, newSVpvf("CLASS:%d", (int)OP_CLASS((OP*)unop)));
2428
2429 PL_rpeepp(aTHX_ kid);
2430
2431 FreeOp(kid);
2432 FreeOp(unop);
2433
2434 RETVAL = MY_CXT.xop_record;
2435 MY_CXT.xop_record = NULL;
2436 OUTPUT:
2437 RETVAL
2438
2439 IV
2440 xop_from_custom_op ()
2441 CODE:
2442 /* author note: this test doesn't imply Perl_custom_op_xop is or isn't public
2443 API or that Perl_custom_op_xop is known to be used outside the core */
2444 UNOP *unop;
2445 XOP *xop;
2446
2447 unop = (UNOP*)mkUNOP(OP_CUSTOM, NULL);
2448 unop->op_ppaddr = pp_xop;
2449 unop->op_private = 0;
2450 unop->op_next = NULL;
2451
2452 xop = Perl_custom_op_xop(aTHX_ (OP *)unop);
2453 FreeOp(unop);
2454 RETVAL = PTR2IV(xop);
2455 OUTPUT:
2456 RETVAL
2457
2458 BOOT:
2459 {
2460 MY_CXT_INIT;
2461
2462 MY_CXT.i = 99;
2463 MY_CXT.sv = newSVpv("initial",0);
2464
2465 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
2466 MY_CXT.bhk_record = 0;
2467
2468 BhkENTRY_set(&bhk_test, bhk_start, blockhook_test_start);
2469 BhkENTRY_set(&bhk_test, bhk_pre_end, blockhook_test_pre_end);
2470 BhkENTRY_set(&bhk_test, bhk_post_end, blockhook_test_post_end);
2471 BhkENTRY_set(&bhk_test, bhk_eval, blockhook_test_eval);
2472 Perl_blockhook_register(aTHX_ &bhk_test);
2473
2474 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
2475 GV_ADDMULTI, SVt_PVAV);
2476 MY_CXT.cscav = GvAV(MY_CXT.cscgv);
2477
2478 BhkENTRY_set(&bhk_csc, bhk_start, blockhook_csc_start);
2479 BhkENTRY_set(&bhk_csc, bhk_pre_end, blockhook_csc_pre_end);
2480 Perl_blockhook_register(aTHX_ &bhk_csc);
2481
2482 MY_CXT.peep_recorder = newAV();
2483 MY_CXT.rpeep_recorder = newAV();
2484
2485 MY_CXT.orig_peep = PL_peepp;
2486 MY_CXT.orig_rpeep = PL_rpeepp;
2487 PL_peepp = my_peep;
2488 PL_rpeepp = my_rpeep;
2489 }
2490
2491 void
2492 CLONE(...)
2493 CODE:
2494 MY_CXT_CLONE;
2495 PERL_UNUSED_VAR(items);
2496 MY_CXT.sv = newSVpv("initial_clone",0);
2497 MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
2498 GV_ADDMULTI, SVt_PVAV);
2499 MY_CXT.cscav = NULL;
2500 MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
2501 MY_CXT.bhk_record = 0;
2502 MY_CXT.peep_recorder = newAV();
2503 MY_CXT.rpeep_recorder = newAV();
2504
2505 void
2506 print_double(val)
2507 double val
2508 CODE:
2509 printf("%5.3f\n",val);
2510
2511 int
2512 have_long_double()
2513 CODE:
2514 #ifdef HAS_LONG_DOUBLE
2515 RETVAL = 1;
2516 #else
2517 RETVAL = 0;
2518 #endif
2519 OUTPUT:
2520 RETVAL
2521
2522 void
2523 print_long_double()
2524 CODE:
2525 #ifdef HAS_LONG_DOUBLE
2526 # if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
2527 long double val = 7.0;
2528 printf("%5.3" PERL_PRIfldbl "\n",val);
2529 # else
2530 double val = 7.0;
2531 printf("%5.3f\n",val);
2532 # endif
2533 #endif
2534
2535 void
2536 print_long_doubleL()
2537 CODE:
2538 #ifdef HAS_LONG_DOUBLE
2539 /* used to test we allow the length modifier required by the standard */
2540 long double val = 7.0;
2541 printf("%5.3Lf\n",val);
2542 #else
2543 double val = 7.0;
2544 printf("%5.3f\n",val);
2545 #endif
2546
2547 void
2548 print_int(val)
2549 int val
2550 CODE:
2551 printf("%d\n",val);
2552
2553 void
2554 print_long(val)
2555 long val
2556 CODE:
2557 printf("%ld\n",val);
2558
2559 void
2560 print_float(val)
2561 float val
2562 CODE:
2563 printf("%5.3f\n",val);
2564
2565 void
2566 print_flush()
2567 CODE:
2568 fflush(stdout);
2569
2570 void
2571 mpushp()
2572 PPCODE:
2573 EXTEND(SP, 3);
2574 mPUSHp("one", 3);
2575 mPUSHp("two", 3);
2576 mPUSHpvs("three");
2577 XSRETURN(3);
2578
2579 void
2580 mpushn()
2581 PPCODE:
2582 EXTEND(SP, 3);
2583 mPUSHn(0.5);
2584 mPUSHn(-0.25);
2585 mPUSHn(0.125);
2586 XSRETURN(3);
2587
2588 void
2589 mpushi()
2590 PPCODE:
2591 EXTEND(SP, 3);
2592 mPUSHi(-1);
2593 mPUSHi(2);
2594 mPUSHi(-3);
2595 XSRETURN(3);
2596
2597 void
2598 mpushu()
2599 PPCODE:
2600 EXTEND(SP, 3);
2601 mPUSHu(1);
2602 mPUSHu(2);
2603 mPUSHu(3);
2604 XSRETURN(3);
2605
2606 void
2607 mxpushp()
2608 PPCODE:
2609 mXPUSHp("one", 3);
2610 mXPUSHp("two", 3);
2611 mXPUSHpvs("three");
2612 XSRETURN(3);
2613
2614 void
2615 mxpushn()
2616 PPCODE:
2617 mXPUSHn(0.5);
2618 mXPUSHn(-0.25);
2619 mXPUSHn(0.125);
2620 XSRETURN(3);
2621
2622 void
2623 mxpushi()
2624 PPCODE:
2625 mXPUSHi(-1);
2626 mXPUSHi(2);
2627 mXPUSHi(-3);
2628 XSRETURN(3);
2629
2630 void
2631 mxpushu()
2632 PPCODE:
2633 mXPUSHu(1);
2634 mXPUSHu(2);
2635 mXPUSHu(3);
2636 XSRETURN(3);
2637
2638
2639 # test_EXTEND(): excerise the EXTEND() macro.
2640 # After calling EXTEND(), it also does *(p+n) = NULL and
2641 # *PL_stack_max = NULL to allow valgrind etc to spot if the stack hasn't
2642 # actually been extended properly.
2643 #
2644 # max_offset specifies the SP to use. It is treated as a signed offset
2645 # from PL_stack_max.
2646 # nsv is the SV holding the value of n indicating how many slots
2647 # to extend the stack by.
2648 # use_ss is a boolean indicating that n should be cast to a SSize_t
2649
2650 void
2651 test_EXTEND(max_offset, nsv, use_ss)
2652 IV max_offset;
2653 SV *nsv;
2654 bool use_ss;
2655 PREINIT:
2656 SV **new_sp = PL_stack_max + max_offset;
2657 SSize_t new_offset = new_sp - PL_stack_base;
2658 PPCODE:
2659 if (use_ss) {
2660 SSize_t n = (SSize_t)SvIV(nsv);
2661 EXTEND(new_sp, n);
2662 new_sp = PL_stack_base + new_offset;
2663 assert(new_sp + n <= PL_stack_max);
2664 if ((new_sp + n) > PL_stack_sp)
2665 *(new_sp + n) = NULL;
2666 }
2667 else {
2668 IV n = SvIV(nsv);
2669 EXTEND(new_sp, n);
2670 new_sp = PL_stack_base + new_offset;
2671 assert(new_sp + n <= PL_stack_max);
2672 if ((new_sp + n) > PL_stack_sp)
2673 *(new_sp + n) = NULL;
2674 }
2675 if (PL_stack_max > PL_stack_sp)
2676 *PL_stack_max = NULL;
2677
2678
2679 void
2680 bad_EXTEND()
2681 PPCODE:
2682 /* testing failure to extend the stack, do not extend the stack */
2683 PUSHs(&PL_sv_yes);
2684 PUSHs(&PL_sv_no);
2685 XSRETURN(2);
2686
2687 bool
2688 hwm_checks_enabled()
2689
2690 void
2691 call_sv_C()
2692 PREINIT:
2693 CV * i_sub;
2694 GV * i_gv;
2695 I32 retcnt;
2696 SV * errsv;
2697 char * errstr;
2698 STRLEN errlen;
2699 SV * miscsv = sv_newmortal();
2700 HV * hv = MUTABLE_HV(newSV_type_mortal(SVt_PVHV));
2701 CODE:
2702 i_sub = get_cv("i", 0);
2703 PUSHMARK(SP);
2704 /* PUTBACK not needed since this sub was called with 0 args, and is calling
2705 0 args, so global SP doesn't need to be moved before a call_* */
2706 retcnt = call_sv((SV*)i_sub, 0); /* try a CV* */
2707 SPAGAIN;
2708 SP -= retcnt; /* dont care about return count, wipe everything off */
2709 sv_setpvs(miscsv, "i");
2710 PUSHMARK(SP);
2711 retcnt = call_sv(miscsv, 0); /* try a PV */
2712 SPAGAIN;
2713 SP -= retcnt;
2714 /* no add and SVt_NULL are intentional, sub i should be defined already */
2715 i_gv = gv_fetchpvn_flags("i", sizeof("i")-1, 0, SVt_NULL);
2716 PUSHMARK(SP);
2717 retcnt = call_sv((SV*)i_gv, 0); /* try a GV* */
2718 SPAGAIN;
2719 SP -= retcnt;
2720 /* the tests below are not declaring this being public API behavior,
2721 only current internal behavior, these tests can be changed in the
2722 future if necessery */
2723 PUSHMARK(SP);
2724 retcnt = call_sv(&PL_sv_yes, G_EVAL);
2725 SPAGAIN;
2726 SP -= retcnt;
2727 errsv = ERRSV;
2728 errstr = SvPV(errsv, errlen);
2729 if(memBEGINs(errstr, errlen, "Undefined subroutine &main::1 called at")) {
2730 PUSHMARK(SP);
2731 retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2732 SPAGAIN;
2733 SP -= retcnt;
2734 }
2735 PUSHMARK(SP);
2736 retcnt = call_sv(&PL_sv_no, G_EVAL);
2737 SPAGAIN;
2738 SP -= retcnt;
2739 errsv = ERRSV;
2740 errstr = SvPV(errsv, errlen);
2741 if(memBEGINs(errstr, errlen, "Undefined subroutine &main:: called at")) {
2742 PUSHMARK(SP);
2743 retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2744 SPAGAIN;
2745 SP -= retcnt;
2746 }
2747 PUSHMARK(SP);
2748 retcnt = call_sv(&PL_sv_undef, G_EVAL);
2749 SPAGAIN;
2750 SP -= retcnt;
2751 errsv = ERRSV;
2752 errstr = SvPV(errsv, errlen);
2753 if(memBEGINs(errstr, errlen, "Can't use an undefined value as a subroutine reference at")) {
2754 PUSHMARK(SP);
2755 retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2756 SPAGAIN;
2757 SP -= retcnt;
2758 }
2759 PUSHMARK(SP);
2760 retcnt = call_sv((SV*)hv, G_EVAL);
2761 SPAGAIN;
2762 SP -= retcnt;
2763 errsv = ERRSV;
2764 errstr = SvPV(errsv, errlen);
2765 if(memBEGINs(errstr, errlen, "Not a CODE reference at")) {
2766 PUSHMARK(SP);
2767 retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2768 SPAGAIN;
2769 SP -= retcnt;
2770 }
2771
2772 void
2773 call_sv(sv, flags, ...)
2774 SV* sv
2775 I32 flags
2776 PREINIT:
2777 SSize_t i;
2778 PPCODE:
2779 for (i=0; i<items-2; i++)
2780 ST(i) = ST(i+2); /* pop first two args */
2781 PUSHMARK(SP);
2782 SP += items - 2;
2783 PUTBACK;
2784 i = call_sv(sv, flags);
2785 SPAGAIN;
2786 EXTEND(SP, 1);
2787 PUSHs(sv_2mortal(newSViv(i)));
2788
2789 void
2790 call_pv(subname, flags, ...)
2791 char* subname
2792 I32 flags
2793 PREINIT:
2794 I32 i;
2795 PPCODE:
2796 for (i=0; i<items-2; i++)
2797 ST(i) = ST(i+2); /* pop first two args */
2798 PUSHMARK(SP);
2799 SP += items - 2;
2800 PUTBACK;
2801 i = call_pv(subname, flags);
2802 SPAGAIN;
2803 EXTEND(SP, 1);
2804 PUSHs(sv_2mortal(newSViv(i)));
2805
2806 void
2807 call_argv(subname, flags, ...)
2808 char* subname
2809 I32 flags
2810 PREINIT:
2811 I32 i;
2812 char *tmpary[4];
2813 PPCODE:
2814 for (i=0; i<items-2; i++)
2815 tmpary[i] = SvPV_nolen(ST(i+2)); /* ignore first two args */
2816 tmpary[i] = NULL;
2817 PUTBACK;
2818 i = call_argv(subname, flags, tmpary);
2819 SPAGAIN;
2820 EXTEND(SP, 1);
2821 PUSHs(sv_2mortal(newSViv(i)));
2822
2823 void
2824 call_method(methname, flags, ...)
2825 char* methname
2826 I32 flags
2827 PREINIT:
2828 I32 i;
2829 PPCODE:
2830 for (i=0; i<items-2; i++)
2831 ST(i) = ST(i+2); /* pop first two args */
2832 PUSHMARK(SP);
2833 SP += items - 2;
2834 PUTBACK;
2835 i = call_method(methname, flags);
2836 SPAGAIN;
2837 EXTEND(SP, 1);
2838 PUSHs(sv_2mortal(newSViv(i)));
2839
2840 void
2841 newCONSTSUB(stash, name, flags, sv)
2842 HV* stash
2843 SV* name
2844 I32 flags
2845 SV* sv
2846 ALIAS:
2847 newCONSTSUB_flags = 1
2848 PREINIT:
2849 CV* mycv = NULL;
2850 STRLEN len;
2851 const char *pv = SvPV(name, len);
2852 PPCODE:
2853 switch (ix) {
2854 case 0:
2855 mycv = newCONSTSUB(stash, pv, SvOK(sv) ? SvREFCNT_inc(sv) : NULL);
2856 break;
2857 case 1:
2858 mycv = newCONSTSUB_flags(
2859 stash, pv, len, flags | SvUTF8(name), SvOK(sv) ? SvREFCNT_inc(sv) : NULL
2860 );
2861 break;
2862 }
2863 EXTEND(SP, 2);
2864 assert(mycv);
2865 PUSHs( CvCONST(mycv) ? &PL_sv_yes : &PL_sv_no );
2866 PUSHs((SV*)CvGV(mycv));
2867
2868 void
2869 gv_init_type(namesv, multi, flags, type)
2870 SV* namesv
2871 int multi
2872 I32 flags
2873 int type
2874 PREINIT:
2875 STRLEN len;
2876 const char * const name = SvPV_const(namesv, len);
2877 GV *gv = *(GV**)hv_fetch(PL_defstash, name, len, TRUE);
2878 PPCODE:
2879 if (SvTYPE(gv) == SVt_PVGV)
2880 Perl_croak(aTHX_ "GV is already a PVGV");
2881 if (multi) flags |= GV_ADDMULTI;
2882 switch (type) {
2883 case 0:
2884 gv_init(gv, PL_defstash, name, len, multi);
2885 break;
2886 case 1:
2887 gv_init_sv(gv, PL_defstash, namesv, flags);
2888 break;
2889 case 2:
2890 gv_init_pv(gv, PL_defstash, name, flags | SvUTF8(namesv));
2891 break;
2892 case 3:
2893 gv_init_pvn(gv, PL_defstash, name, len, flags | SvUTF8(namesv));
2894 break;
2895 }
2896 XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2897
2898 void
gv_fetchmeth_type(stash,methname,type,level,flags)2899 gv_fetchmeth_type(stash, methname, type, level, flags)
2900 HV* stash
2901 SV* methname
2902 int type
2903 I32 level
2904 I32 flags
2905 PREINIT:
2906 STRLEN len;
2907 const char * const name = SvPV_const(methname, len);
2908 GV* gv = NULL;
2909 PPCODE:
2910 switch (type) {
2911 case 0:
2912 gv = gv_fetchmeth(stash, name, len, level);
2913 break;
2914 case 1:
2915 gv = gv_fetchmeth_sv(stash, methname, level, flags);
2916 break;
2917 case 2:
2918 gv = gv_fetchmeth_pv(stash, name, level, flags | SvUTF8(methname));
2919 break;
2920 case 3:
2921 gv = gv_fetchmeth_pvn(stash, name, len, level, flags | SvUTF8(methname));
2922 break;
2923 }
2924 XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
2925
2926 void
gv_fetchmeth_autoload_type(stash,methname,type,level,flags)2927 gv_fetchmeth_autoload_type(stash, methname, type, level, flags)
2928 HV* stash
2929 SV* methname
2930 int type
2931 I32 level
2932 I32 flags
2933 PREINIT:
2934 STRLEN len;
2935 const char * const name = SvPV_const(methname, len);
2936 GV* gv = NULL;
2937 PPCODE:
2938 switch (type) {
2939 case 0:
2940 gv = gv_fetchmeth_autoload(stash, name, len, level);
2941 break;
2942 case 1:
2943 gv = gv_fetchmeth_sv_autoload(stash, methname, level, flags);
2944 break;
2945 case 2:
2946 gv = gv_fetchmeth_pv_autoload(stash, name, level, flags | SvUTF8(methname));
2947 break;
2948 case 3:
2949 gv = gv_fetchmeth_pvn_autoload(stash, name, len, level, flags | SvUTF8(methname));
2950 break;
2951 }
2952 XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
2953
2954 void
2955 gv_fetchmethod_flags_type(stash, methname, type, flags)
2956 HV* stash
2957 SV* methname
2958 int type
2959 I32 flags
2960 PREINIT:
2961 GV* gv = NULL;
2962 PPCODE:
2963 switch (type) {
2964 case 0:
2965 gv = gv_fetchmethod_flags(stash, SvPVX_const(methname), flags);
2966 break;
2967 case 1:
2968 gv = gv_fetchmethod_sv_flags(stash, methname, flags);
2969 break;
2970 case 2:
2971 gv = gv_fetchmethod_pv_flags(stash, SvPV_nolen(methname), flags | SvUTF8(methname));
2972 break;
2973 case 3: {
2974 STRLEN len;
2975 const char * const name = SvPV_const(methname, len);
2976 gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname));
2977 break;
2978 }
2979 case 4:
2980 gv = gv_fetchmethod_pvn_flags(stash, SvPV_nolen(methname),
2981 flags, SvUTF8(methname));
2982 }
2983 XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2984
2985 void
gv_autoload_type(stash,methname,type,method)2986 gv_autoload_type(stash, methname, type, method)
2987 HV* stash
2988 SV* methname
2989 int type
2990 I32 method
2991 PREINIT:
2992 STRLEN len;
2993 const char * const name = SvPV_const(methname, len);
2994 GV* gv = NULL;
2995 I32 flags = method ? GV_AUTOLOAD_ISMETHOD : 0;
2996 PPCODE:
2997 switch (type) {
2998 case 0:
2999 gv = gv_autoload4(stash, name, len, method);
3000 break;
3001 case 1:
3002 gv = gv_autoload_sv(stash, methname, flags);
3003 break;
3004 case 2:
3005 gv = gv_autoload_pv(stash, name, flags | SvUTF8(methname));
3006 break;
3007 case 3:
3008 gv = gv_autoload_pvn(stash, name, len, flags | SvUTF8(methname));
3009 break;
3010 }
3011 XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
3012
3013 SV *
3014 gv_const_sv(SV *name)
3015 PREINIT:
3016 GV *gv;
3017 CODE:
3018 if (SvPOK(name)) {
3019 HV *stash = gv_stashpv("main",0);
3020 HE *he = hv_fetch_ent(stash, name, 0, 0);
3021 gv = (GV *)HeVAL(he);
3022 }
3023 else {
3024 gv = (GV *)name;
3025 }
3026 RETVAL = gv_const_sv(gv);
3027 if (!RETVAL)
3028 XSRETURN_EMPTY;
3029 RETVAL = newSVsv(RETVAL);
3030 OUTPUT:
3031 RETVAL
3032
3033 void
3034 whichsig_type(namesv, type)
3035 SV* namesv
3036 int type
3037 PREINIT:
3038 STRLEN len;
3039 const char * const name = SvPV_const(namesv, len);
3040 I32 i = 0;
3041 PPCODE:
3042 switch (type) {
3043 case 0:
3044 i = whichsig(name);
3045 break;
3046 case 1:
3047 i = whichsig_sv(namesv);
3048 break;
3049 case 2:
3050 i = whichsig_pv(name);
3051 break;
3052 case 3:
3053 i = whichsig_pvn(name, len);
3054 break;
3055 }
3056 XPUSHs(sv_2mortal(newSViv(i)));
3057
3058 void
3059 eval_sv(sv, flags)
3060 SV* sv
3061 I32 flags
3062 PREINIT:
3063 SSize_t i;
3064 PPCODE:
3065 PUTBACK;
3066 i = eval_sv(sv, flags);
3067 SPAGAIN;
3068 EXTEND(SP, 1);
3069 PUSHs(sv_2mortal(newSViv(i)));
3070
3071 void
3072 eval_pv(p, croak_on_error)
3073 const char* p
3074 I32 croak_on_error
3075 PPCODE:
3076 PUTBACK;
3077 EXTEND(SP, 1);
3078 PUSHs(eval_pv(p, croak_on_error));
3079
3080 void
3081 require_pv(pv)
3082 const char* pv
3083 PPCODE:
3084 PUTBACK;
3085 require_pv(pv);
3086
3087 int
3088 apitest_exception(throw_e)
3089 int throw_e
3090 OUTPUT:
3091 RETVAL
3092
3093 void
3094 mycroak(sv)
3095 SV* sv
3096 CODE:
3097 if (SvOK(sv)) {
3098 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
3099 }
3100 else {
3101 Perl_croak(aTHX_ NULL);
3102 }
3103
3104 SV*
3105 strtab()
3106 CODE:
3107 RETVAL = newRV_inc((SV*)PL_strtab);
3108 OUTPUT:
3109 RETVAL
3110
3111 int
3112 my_cxt_getint()
3113 CODE:
3114 dMY_CXT;
3115 RETVAL = my_cxt_getint_p(aMY_CXT);
3116 OUTPUT:
3117 RETVAL
3118
3119 void
3120 my_cxt_setint(i)
3121 int i;
3122 CODE:
3123 dMY_CXT;
3124 my_cxt_setint_p(aMY_CXT_ i);
3125
3126 void
3127 my_cxt_getsv(how)
3128 bool how;
3129 PPCODE:
3130 EXTEND(SP, 1);
3131 ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
3132 XSRETURN(1);
3133
3134 void
3135 my_cxt_setsv(sv)
3136 SV *sv;
3137 CODE:
3138 dMY_CXT;
3139 SvREFCNT_dec(MY_CXT.sv);
3140 my_cxt_setsv_p(sv _aMY_CXT);
3141 SvREFCNT_inc(sv);
3142
3143 bool
sv_setsv_cow_hashkey_core()3144 sv_setsv_cow_hashkey_core()
3145
3146 bool
3147 sv_setsv_cow_hashkey_notcore()
3148
3149 void
3150 sv_set_deref(SV *sv, SV *sv2, int which)
3151 CODE:
3152 {
3153 STRLEN len;
3154 const char *pv = SvPV(sv2,len);
3155 if (!SvROK(sv)) croak("Not a ref");
3156 sv = SvRV(sv);
3157 switch (which) {
3158 case 0: sv_setsv(sv,sv2); break;
3159 case 1: sv_setpv(sv,pv); break;
3160 case 2: sv_setpvn(sv,pv,len); break;
3161 }
3162 }
3163
3164 void
3165 rmagical_cast(sv, type)
3166 SV *sv;
3167 SV *type;
3168 PREINIT:
3169 struct ufuncs uf;
3170 PPCODE:
3171 if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
3172 sv = SvRV(sv);
3173 if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
3174 uf.uf_val = rmagical_a_dummy;
3175 uf.uf_set = NULL;
3176 uf.uf_index = 0;
3177 if (SvTRUE(type)) { /* b */
3178 sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
3179 } else { /* a */
3180 sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
3181 }
3182 XSRETURN_YES;
3183
3184 void
rmagical_flags(sv)3185 rmagical_flags(sv)
3186 SV *sv;
3187 PPCODE:
3188 if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
3189 sv = SvRV(sv);
3190 EXTEND(SP, 3);
3191 mXPUSHu(SvFLAGS(sv) & SVs_GMG);
3192 mXPUSHu(SvFLAGS(sv) & SVs_SMG);
3193 mXPUSHu(SvFLAGS(sv) & SVs_RMG);
3194 XSRETURN(3);
3195
3196 void
3197 my_caller(level)
3198 I32 level
3199 PREINIT:
3200 const PERL_CONTEXT *cx, *dbcx;
3201 const char *pv;
3202 const GV *gv;
3203 HV *hv;
3204 PPCODE:
3205 cx = caller_cx(level, &dbcx);
3206 EXTEND(SP, 8);
3207
3208 pv = CopSTASHPV(cx->blk_oldcop);
3209 ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
3210 gv = CvGV(cx->blk_sub.cv);
3211 ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
3212
3213 pv = CopSTASHPV(dbcx->blk_oldcop);
3214 ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
3215 gv = CvGV(dbcx->blk_sub.cv);
3216 ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
3217
3218 ST(4) = cop_hints_fetch_pvs(cx->blk_oldcop, "foo", 0);
3219 ST(5) = cop_hints_fetch_pvn(cx->blk_oldcop, "foo", 3, 0, 0);
3220 ST(6) = cop_hints_fetch_sv(cx->blk_oldcop,
3221 sv_2mortal(newSVpvs("foo")), 0, 0);
3222
3223 hv = cop_hints_2hv(cx->blk_oldcop, 0);
3224 ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
3225
3226 XSRETURN(8);
3227
3228 void
3229 DPeek (sv)
3230 SV *sv
3231
3232 PPCODE:
3233 ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
3234 XSRETURN (1);
3235
3236 void
3237 BEGIN()
3238 CODE:
3239 sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
3240
3241 void
3242 CHECK()
3243 CODE:
3244 sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
3245
3246 void
3247 UNITCHECK()
3248 CODE:
3249 sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
3250
3251 void
3252 INIT()
3253 CODE:
3254 sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
3255
3256 void
3257 END()
3258 CODE:
3259 sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
3260
3261 void
3262 utf16_to_utf8 (sv, ...)
3263 SV* sv
3264 ALIAS:
3265 utf16_to_utf8_reversed = 1
3266 PREINIT:
3267 STRLEN len;
3268 U8 *source;
3269 SV *dest;
3270 Size_t got;
3271 CODE:
3272 source = (U8 *)SvPVbyte(sv, len);
3273 /* Optionally only convert part of the buffer. */
3274 if (items > 1) {
3275 len = SvUV(ST(1));
3276 }
3277 /* Mortalise this right now, as we'll be testing croak()s */
3278 dest = sv_2mortal(newSV(len * 2 + 1));
3279 if (ix) {
3280 utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
3281 } else {
3282 utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
3283 }
3284 SvCUR_set(dest, got);
3285 SvPVX(dest)[got] = '\0';
3286 SvPOK_on(dest);
3287 ST(0) = dest;
3288 XSRETURN(1);
3289
3290 void
3291 utf8_to_utf16 (sv, ...)
3292 SV* sv
3293 ALIAS:
3294 utf8_to_utf16_reversed = 1
3295 PREINIT:
3296 STRLEN len;
3297 U8 *source;
3298 SV *dest;
3299 Size_t got;
3300 CODE:
3301 source = (U8 *)SvPV(sv, len);
3302 /* Optionally only convert part of the buffer. */
3303 if (items > 1) {
3304 len = SvUV(ST(1));
3305 }
3306 /* Mortalise this right now, as we'll be testing croak()s */
3307 dest = sv_2mortal(newSV(len * 2 + 1));
3308 if (ix) {
3309 utf8_to_utf16_reversed(source, (U8 *)SvPVX(dest), len, &got);
3310 } else {
3311 utf8_to_utf16(source, (U8 *)SvPVX(dest), len, &got);
3312 }
3313 SvCUR_set(dest, got);
3314 SvPVX(dest)[got] = '\0';
3315 SvPOK_on(dest);
3316 ST(0) = dest;
3317 XSRETURN(1);
3318
3319 void
3320 my_exit(int exitcode)
3321 PPCODE:
3322 my_exit(exitcode);
3323
3324 U8
3325 first_byte(sv)
3326 SV *sv
3327 CODE:
3328 char *s;
3329 STRLEN len;
3330 s = SvPVbyte(sv, len);
3331 RETVAL = s[0];
3332 OUTPUT:
3333 RETVAL
3334
3335 I32
3336 sv_count()
3337 CODE:
3338 RETVAL = PL_sv_count;
3339 OUTPUT:
3340 RETVAL
3341
3342 IV
3343 xs_items(...)
3344 CODE:
3345 RETVAL = items;
3346 OUTPUT:
3347 RETVAL
3348
3349 void
3350 wide_marks(...)
3351 PPCODE:
3352 #ifdef PERL_STACK_OFFSET_SSIZET
3353 XSRETURN_YES;
3354 #else
3355 XSRETURN_NO;
3356 #endif
3357
3358 void
3359 bhk_record(bool on)
3360 CODE:
3361 dMY_CXT;
3362 MY_CXT.bhk_record = on;
3363 if (on)
3364 av_clear(MY_CXT.bhkav);
3365
3366 void
3367 test_magic_chain()
3368 PREINIT:
3369 SV *sv;
3370 MAGIC *callmg, *uvarmg;
3371 CODE:
3372 sv = newSV_type_mortal(SVt_NULL);
3373 if (SvTYPE(sv) >= SVt_PVMG) croak_fail();
3374 if (SvMAGICAL(sv)) croak_fail();
3375 sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0);
3376 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
3377 if (!SvMAGICAL(sv)) croak_fail();
3378 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
3379 callmg = mg_find(sv, PERL_MAGIC_checkcall);
3380 if (!callmg) croak_fail();
3381 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
3382 croak_fail();
3383 sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
3384 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
3385 if (!SvMAGICAL(sv)) croak_fail();
3386 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
3387 uvarmg = mg_find(sv, PERL_MAGIC_uvar);
3388 if (!uvarmg) croak_fail();
3389 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
3390 croak_fail();
3391 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
3392 croak_fail();
3393 mg_free_type(sv, PERL_MAGIC_vec);
3394 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
3395 if (!SvMAGICAL(sv)) croak_fail();
3396 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
3397 if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
3398 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
3399 croak_fail();
3400 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
3401 croak_fail();
3402 mg_free_type(sv, PERL_MAGIC_uvar);
3403 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
3404 if (!SvMAGICAL(sv)) croak_fail();
3405 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
3406 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
3407 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
3408 croak_fail();
3409 sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
3410 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
3411 if (!SvMAGICAL(sv)) croak_fail();
3412 if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
3413 uvarmg = mg_find(sv, PERL_MAGIC_uvar);
3414 if (!uvarmg) croak_fail();
3415 if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
3416 croak_fail();
3417 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
3418 croak_fail();
3419 mg_free_type(sv, PERL_MAGIC_checkcall);
3420 if (SvTYPE(sv) < SVt_PVMG) croak_fail();
3421 if (!SvMAGICAL(sv)) croak_fail();
3422 if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
3423 if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
3424 if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
3425 croak_fail();
3426 mg_free_type(sv, PERL_MAGIC_uvar);
3427 if (SvMAGICAL(sv)) croak_fail();
3428 if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
3429 if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
3430
3431 void
3432 test_op_contextualize()
3433 PREINIT:
3434 OP *o;
3435 CODE:
3436 o = newSVOP(OP_CONST, 0, newSViv(0));
3437 o->op_flags &= ~OPf_WANT;
3438 o = op_contextualize(o, G_SCALAR);
3439 if (o->op_type != OP_CONST ||
3440 (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
3441 croak_fail();
3442 op_free(o);
3443 o = newSVOP(OP_CONST, 0, newSViv(0));
3444 o->op_flags &= ~OPf_WANT;
3445 o = op_contextualize(o, G_LIST);
3446 if (o->op_type != OP_CONST ||
3447 (o->op_flags & OPf_WANT) != OPf_WANT_LIST)
3448 croak_fail();
3449 op_free(o);
3450 o = newSVOP(OP_CONST, 0, newSViv(0));
3451 o->op_flags &= ~OPf_WANT;
3452 o = op_contextualize(o, G_VOID);
3453 if (o->op_type != OP_NULL) croak_fail();
3454 op_free(o);
3455
3456 void
3457 test_rv2cv_op_cv()
3458 PROTOTYPE:
3459 PREINIT:
3460 GV *troc_gv;
3461 CV *troc_cv;
3462 OP *o;
3463 CODE:
3464 troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
3465 troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
3466 o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
3467 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
3468 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
3469 croak_fail();
3470 o->op_private |= OPpENTERSUB_AMPER;
3471 if (rv2cv_op_cv(o, 0)) croak_fail();
3472 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3473 o->op_private &= ~OPpENTERSUB_AMPER;
3474 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3475 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
3476 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3477 op_free(o);
3478 o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0));
3479 o->op_private = OPpCONST_BARE;
3480 o = newCVREF(0, o);
3481 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
3482 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
3483 croak_fail();
3484 o->op_private |= OPpENTERSUB_AMPER;
3485 if (rv2cv_op_cv(o, 0)) croak_fail();
3486 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3487 op_free(o);
3488 o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv)));
3489 if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
3490 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
3491 croak_fail();
3492 o->op_private |= OPpENTERSUB_AMPER;
3493 if (rv2cv_op_cv(o, 0)) croak_fail();
3494 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3495 o->op_private &= ~OPpENTERSUB_AMPER;
3496 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3497 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
3498 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3499 op_free(o);
3500 o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))));
3501 if (rv2cv_op_cv(o, 0)) croak_fail();
3502 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3503 o->op_private |= OPpENTERSUB_AMPER;
3504 if (rv2cv_op_cv(o, 0)) croak_fail();
3505 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3506 o->op_private &= ~OPpENTERSUB_AMPER;
3507 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3508 if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail();
3509 if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3510 op_free(o);
3511 o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)));
3512 if (rv2cv_op_cv(o, 0)) croak_fail();
3513 if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3514 op_free(o);
3515
3516 void
3517 test_cv_getset_call_checker()
3518 PREINIT:
3519 CV *troc_cv, *tsh_cv;
3520 Perl_call_checker ckfun;
3521 SV *ckobj;
3522 U32 ckflags;
3523 CODE:
3524 #define check_cc(cv, xckfun, xckobj, xckflags) \
3525 do { \
3526 cv_get_call_checker((cv), &ckfun, &ckobj); \
3527 if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), xckfun); \
3528 if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), xckobj); \
3529 cv_get_call_checker_flags((cv), CALL_CHECKER_REQUIRE_GV, &ckfun, &ckobj, &ckflags); \
3530 if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), xckfun); \
3531 if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), xckobj); \
3532 if (ckflags != CALL_CHECKER_REQUIRE_GV) croak_fail_nei(ckflags, CALL_CHECKER_REQUIRE_GV); \
3533 cv_get_call_checker_flags((cv), 0, &ckfun, &ckobj, &ckflags); \
3534 if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), xckfun); \
3535 if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), xckobj); \
3536 if (ckflags != (xckflags)) croak_fail_nei(ckflags, (xckflags)); \
3537 } while(0)
3538 troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
3539 tsh_cv = get_cv("XS::APItest::test_savehints", 0);
3540 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0);
3541 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
3542 cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3543 &PL_sv_yes);
3544 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0);
3545 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
3546 cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
3547 check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no, CALL_CHECKER_REQUIRE_GV);
3548 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
3549 cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3550 (SV*)tsh_cv);
3551 check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no, CALL_CHECKER_REQUIRE_GV);
3552 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
3553 cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list,
3554 (SV*)troc_cv);
3555 check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0);
3556 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
3557 if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail();
3558 if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
3559 cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3560 &PL_sv_yes, 0);
3561 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, 0);
3562 cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3563 &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
3564 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
3565 cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3566 (SV*)tsh_cv, 0);
3567 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
3568 if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
3569 cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3570 &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
3571 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
3572 cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3573 (SV*)tsh_cv, CALL_CHECKER_REQUIRE_GV);
3574 check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
3575 if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
3576 #undef check_cc
3577
3578 void
3579 cv_set_call_checker_lists(CV *cv)
3580 CODE:
3581 cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
3582
3583 void
3584 cv_set_call_checker_scalars(CV *cv)
3585 CODE:
3586 cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
3587
3588 void
3589 cv_set_call_checker_proto(CV *cv, SV *proto)
3590 CODE:
3591 if (SvROK(proto))
3592 proto = SvRV(proto);
3593 cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
3594
3595 void
3596 cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
3597 CODE:
3598 if (SvROK(proto))
3599 proto = SvRV(proto);
3600 cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
3601
3602 void
3603 cv_set_call_checker_multi_sum(CV *cv)
3604 CODE:
3605 cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
3606
3607 void
3608 test_cophh()
3609 PREINIT:
3610 COPHH *a, *b;
3611 #ifdef EBCDIC
3612 SV* key_sv;
3613 char * key_name;
3614 STRLEN key_len;
3615 #endif
3616 CODE:
3617 #define check_ph(EXPR) \
3618 do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0)
3619 #define check_iv(EXPR, EXPECT) \
3620 do { if(SvIV(EXPR) != (EXPECT)) croak("fail"); } while(0)
3621 #define msvpvs(STR) sv_2mortal(newSVpvs(STR))
3622 #define msviv(VALUE) sv_2mortal(newSViv(VALUE))
3623 a = cophh_new_empty();
3624 check_ph(cophh_fetch_pvn(a, "foo_1", 5, 0, 0));
3625 check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3626 check_ph(cophh_fetch_pv(a, "foo_1", 0, 0));
3627 check_ph(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0));
3628 a = cophh_store_pvn(a, "foo_1abc", 5, 0, msviv(111), 0);
3629 a = cophh_store_pvs(a, "foo_2", msviv(222), 0);
3630 a = cophh_store_pv(a, "foo_3", 0, msviv(333), 0);
3631 a = cophh_store_sv(a, msvpvs("foo_4"), 0, msviv(444), 0);
3632 check_iv(cophh_fetch_pvn(a, "foo_1xyz", 5, 0, 0), 111);
3633 check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
3634 check_iv(cophh_fetch_pv(a, "foo_1", 0, 0), 111);
3635 check_iv(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0), 111);
3636 check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
3637 check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3638 check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3639 check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3640 b = cophh_copy(a);
3641 b = cophh_store_pvs(b, "foo_1", msviv(1111), 0);
3642 check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
3643 check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
3644 check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3645 check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3646 check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3647 check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3648 check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3649 check_iv(cophh_fetch_pvs(b, "foo_3", 0), 333);
3650 check_iv(cophh_fetch_pvs(b, "foo_4", 0), 444);
3651 check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3652 a = cophh_delete_pvn(a, "foo_1abc", 5, 0, 0);
3653 a = cophh_delete_pvs(a, "foo_2", 0);
3654 b = cophh_delete_pv(b, "foo_3", 0, 0);
3655 b = cophh_delete_sv(b, msvpvs("foo_4"), 0, 0);
3656 check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3657 check_ph(cophh_fetch_pvs(a, "foo_2", 0));
3658 check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3659 check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3660 check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3661 check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3662 check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3663 check_ph(cophh_fetch_pvs(b, "foo_3", 0));
3664 check_ph(cophh_fetch_pvs(b, "foo_4", 0));
3665 check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3666 b = cophh_delete_pvs(b, "foo_3", 0);
3667 b = cophh_delete_pvs(b, "foo_5", 0);
3668 check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3669 check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3670 check_ph(cophh_fetch_pvs(b, "foo_3", 0));
3671 check_ph(cophh_fetch_pvs(b, "foo_4", 0));
3672 check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3673 cophh_free(b);
3674 check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3675 check_ph(cophh_fetch_pvs(a, "foo_2", 0));
3676 check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3677 check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3678 check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3679 a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8);
3680 a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
3681 #ifndef EBCDIC
3682 a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
3683 #else
3684 /* On EBCDIC, we need to translate the UTF-8 in the ASCII test to the
3685 * equivalent UTF-EBCDIC for the code page. This is done at runtime
3686 * (with the helper function in this file). Therefore we can't use
3687 * cophhh_store_pvs(), as we don't have literal string */
3688 key_sv = sv_2mortal(newSVpvs("foo_"));
3689 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3690 key_name = SvPV(key_sv, key_len);
3691 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8);
3692 #endif
3693 #ifndef EBCDIC
3694 a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
3695 #else
3696 sv_setpvs(key_sv, "foo_");
3697 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3698 key_name = SvPV(key_sv, key_len);
3699 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8);
3700 #endif
3701 #ifndef EBCDIC
3702 a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
3703 #else
3704 sv_setpvs(key_sv, "foo_");
3705 cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3706 key_name = SvPV(key_sv, key_len);
3707 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8);
3708 #endif
3709 check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111);
3710 check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111);
3711 check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123);
3712 #ifndef EBCDIC
3713 check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123);
3714 check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0));
3715 #else
3716 sv_setpvs(key_sv, "foo_");
3717 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xaa"));
3718 key_name = SvPV(key_sv, key_len);
3719 check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 123);
3720 check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3721 #endif
3722 check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456);
3723 #ifndef EBCDIC
3724 check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456);
3725 check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0));
3726 #else
3727 sv_setpvs(key_sv, "foo_");
3728 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3729 key_name = SvPV(key_sv, key_len);
3730 check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 456);
3731 check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3732 #endif
3733 check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789);
3734 #ifndef EBCDIC
3735 check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789);
3736 check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0));
3737 #else
3738 sv_setpvs(key_sv, "foo_");
3739 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3740 key_name = SvPV(key_sv, key_len);
3741 check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 789);
3742 check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3743 #endif
3744 #ifndef EBCDIC
3745 check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666);
3746 check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0));
3747 #else
3748 sv_setpvs(key_sv, "foo_");
3749 cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3750 key_name = SvPV(key_sv, key_len);
3751 check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 666);
3752 check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3753 #endif
3754 ENTER;
3755 SAVEFREECOPHH(a);
3756 LEAVE;
3757 #undef check_ph
3758 #undef check_iv
3759 #undef msvpvs
3760 #undef msviv
3761
3762 void
3763 test_coplabel()
3764 PREINIT:
3765 COP *cop;
3766 const char *label;
3767 STRLEN len;
3768 U32 utf8;
3769 CODE:
3770 cop = &PL_compiling;
3771 Perl_cop_store_label(aTHX_ cop, "foo", 3, 0);
3772 label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
3773 if (strNE(label,"foo")) croak("fail # cop_fetch_label label");
3774 if (len != 3) croak("fail # cop_fetch_label len");
3775 if (utf8) croak("fail # cop_fetch_label utf8");
3776 /* SMALL GERMAN UMLAUT A */
3777 Perl_cop_store_label(aTHX_ cop, "fo\xc3\xa4", 4, SVf_UTF8);
3778 label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
3779 if (strNE(label,"fo\xc3\xa4")) croak("fail # cop_fetch_label label");
3780 if (len != 4) croak("fail # cop_fetch_label len");
3781 if (!utf8) croak("fail # cop_fetch_label utf8");
3782
3783
3784 HV *
3785 example_cophh_2hv()
3786 PREINIT:
3787 COPHH *a;
3788 #ifdef EBCDIC
3789 SV* key_sv;
3790 char * key_name;
3791 STRLEN key_len;
3792 #endif
3793 CODE:
3794 #define msviv(VALUE) sv_2mortal(newSViv(VALUE))
3795 a = cophh_new_empty();
3796 a = cophh_store_pvs(a, "foo_0", msviv(999), 0);
3797 a = cophh_store_pvs(a, "foo_1", msviv(111), 0);
3798 a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
3799 #ifndef EBCDIC
3800 a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
3801 #else
3802 key_sv = sv_2mortal(newSVpvs("foo_"));
3803 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3804 key_name = SvPV(key_sv, key_len);
3805 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8);
3806 #endif
3807 #ifndef EBCDIC
3808 a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
3809 #else
3810 sv_setpvs(key_sv, "foo_");
3811 cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3812 key_name = SvPV(key_sv, key_len);
3813 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8);
3814 #endif
3815 #ifndef EBCDIC
3816 a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
3817 #else
3818 sv_setpvs(key_sv, "foo_");
3819 cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3820 key_name = SvPV(key_sv, key_len);
3821 a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8);
3822 #endif
3823 a = cophh_delete_pvs(a, "foo_0", 0);
3824 a = cophh_delete_pvs(a, "foo_2", 0);
3825 RETVAL = cophh_2hv(a, 0);
3826 cophh_free(a);
3827 #undef msviv
3828 OUTPUT:
3829 RETVAL
3830
3831 void
3832 test_savehints()
3833 PREINIT:
3834 SV **svp, *sv;
3835 CODE:
3836 #define store_hint(KEY, VALUE) \
3837 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
3838 #define hint_ok(KEY, EXPECT) \
3839 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
3840 (sv = *svp) && SvIV(sv) == (EXPECT) && \
3841 (sv = cop_hints_fetch_pvs(&PL_compiling, KEY, 0)) && \
3842 SvIV(sv) == (EXPECT))
3843 #define check_hint(KEY, EXPECT) \
3844 do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0)
3845 PL_hints |= HINT_LOCALIZE_HH;
3846 ENTER;
3847 SAVEHINTS();
3848 PL_hints &= HINT_INTEGER;
3849 store_hint("t0", 123);
3850 store_hint("t1", 456);
3851 if (PL_hints & HINT_INTEGER) croak_fail();
3852 check_hint("t0", 123); check_hint("t1", 456);
3853 ENTER;
3854 SAVEHINTS();
3855 if (PL_hints & HINT_INTEGER) croak_fail();
3856 check_hint("t0", 123); check_hint("t1", 456);
3857 PL_hints |= HINT_INTEGER;
3858 store_hint("t0", 321);
3859 if (!(PL_hints & HINT_INTEGER)) croak_fail();
3860 check_hint("t0", 321); check_hint("t1", 456);
3861 LEAVE;
3862 if (PL_hints & HINT_INTEGER) croak_fail();
3863 check_hint("t0", 123); check_hint("t1", 456);
3864 ENTER;
3865 SAVEHINTS();
3866 if (PL_hints & HINT_INTEGER) croak_fail();
3867 check_hint("t0", 123); check_hint("t1", 456);
3868 store_hint("t1", 654);
3869 if (PL_hints & HINT_INTEGER) croak_fail();
3870 check_hint("t0", 123); check_hint("t1", 654);
3871 LEAVE;
3872 if (PL_hints & HINT_INTEGER) croak_fail();
3873 check_hint("t0", 123); check_hint("t1", 456);
3874 LEAVE;
3875 #undef store_hint
3876 #undef hint_ok
3877 #undef check_hint
3878
3879 void
3880 test_copyhints()
3881 PREINIT:
3882 HV *a, *b;
3883 CODE:
3884 PL_hints |= HINT_LOCALIZE_HH;
3885 ENTER;
3886 SAVEHINTS();
3887 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
3888 if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
3889 croak_fail();
3890 a = newHVhv(GvHV(PL_hintgv));
3891 sv_2mortal((SV*)a);
3892 sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
3893 if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
3894 croak_fail();
3895 b = hv_copy_hints_hv(a);
3896 sv_2mortal((SV*)b);
3897 sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
3898 if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 789)
3899 croak_fail();
3900 LEAVE;
3901
3902 void
3903 test_op_list()
3904 PREINIT:
3905 OP *a;
3906 CODE:
3907 #define iv_op(iv) newSVOP(OP_CONST, 0, newSViv(iv))
3908 #define check_op(o, expect) \
3909 do { \
3910 if (strNE(test_op_list_describe(o), (expect))) \
3911 croak("fail %s %s", test_op_list_describe(o), (expect)); \
3912 } while(0)
3913 a = op_append_elem(OP_LIST, NULL, NULL);
3914 check_op(a, "");
3915 a = op_append_elem(OP_LIST, iv_op(1), a);
3916 check_op(a, "const(1).");
3917 a = op_append_elem(OP_LIST, NULL, a);
3918 check_op(a, "const(1).");
3919 a = op_append_elem(OP_LIST, a, iv_op(2));
3920 check_op(a, "list[pushmark.const(1).const(2).]");
3921 a = op_append_elem(OP_LIST, a, iv_op(3));
3922 check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3923 a = op_append_elem(OP_LIST, a, NULL);
3924 check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3925 a = op_append_elem(OP_LIST, NULL, a);
3926 check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3927 a = op_append_elem(OP_LIST, iv_op(4), a);
3928 check_op(a, "list[pushmark.const(4)."
3929 "list[pushmark.const(1).const(2).const(3).]]");
3930 a = op_append_elem(OP_LIST, a, iv_op(5));
3931 check_op(a, "list[pushmark.const(4)."
3932 "list[pushmark.const(1).const(2).const(3).]const(5).]");
3933 a = op_append_elem(OP_LIST, a,
3934 op_append_elem(OP_LIST, iv_op(7), iv_op(6)));
3935 check_op(a, "list[pushmark.const(4)."
3936 "list[pushmark.const(1).const(2).const(3).]const(5)."
3937 "list[pushmark.const(7).const(6).]]");
3938 op_free(a);
3939 a = op_append_elem(OP_LINESEQ, iv_op(1), iv_op(2));
3940 check_op(a, "lineseq[const(1).const(2).]");
3941 a = op_append_elem(OP_LINESEQ, a, iv_op(3));
3942 check_op(a, "lineseq[const(1).const(2).const(3).]");
3943 op_free(a);
3944 a = op_append_elem(OP_LINESEQ,
3945 op_append_elem(OP_LIST, iv_op(1), iv_op(2)),
3946 iv_op(3));
3947 check_op(a, "lineseq[list[pushmark.const(1).const(2).]const(3).]");
3948 op_free(a);
3949 a = op_prepend_elem(OP_LIST, NULL, NULL);
3950 check_op(a, "");
3951 a = op_prepend_elem(OP_LIST, a, iv_op(1));
3952 check_op(a, "const(1).");
3953 a = op_prepend_elem(OP_LIST, a, NULL);
3954 check_op(a, "const(1).");
3955 a = op_prepend_elem(OP_LIST, iv_op(2), a);
3956 check_op(a, "list[pushmark.const(2).const(1).]");
3957 a = op_prepend_elem(OP_LIST, iv_op(3), a);
3958 check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3959 a = op_prepend_elem(OP_LIST, NULL, a);
3960 check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3961 a = op_prepend_elem(OP_LIST, a, NULL);
3962 check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3963 a = op_prepend_elem(OP_LIST, a, iv_op(4));
3964 check_op(a, "list[pushmark."
3965 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3966 a = op_prepend_elem(OP_LIST, iv_op(5), a);
3967 check_op(a, "list[pushmark.const(5)."
3968 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3969 a = op_prepend_elem(OP_LIST,
3970 op_prepend_elem(OP_LIST, iv_op(6), iv_op(7)), a);
3971 check_op(a, "list[pushmark.list[pushmark.const(6).const(7).]const(5)."
3972 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3973 op_free(a);
3974 a = op_prepend_elem(OP_LINESEQ, iv_op(2), iv_op(1));
3975 check_op(a, "lineseq[const(2).const(1).]");
3976 a = op_prepend_elem(OP_LINESEQ, iv_op(3), a);
3977 check_op(a, "lineseq[const(3).const(2).const(1).]");
3978 op_free(a);
3979 a = op_prepend_elem(OP_LINESEQ, iv_op(3),
3980 op_prepend_elem(OP_LIST, iv_op(2), iv_op(1)));
3981 check_op(a, "lineseq[const(3).list[pushmark.const(2).const(1).]]");
3982 op_free(a);
3983 a = op_append_list(OP_LINESEQ, NULL, NULL);
3984 check_op(a, "");
3985 a = op_append_list(OP_LINESEQ, iv_op(1), a);
3986 check_op(a, "const(1).");
3987 a = op_append_list(OP_LINESEQ, NULL, a);
3988 check_op(a, "const(1).");
3989 a = op_append_list(OP_LINESEQ, a, iv_op(2));
3990 check_op(a, "lineseq[const(1).const(2).]");
3991 a = op_append_list(OP_LINESEQ, a, iv_op(3));
3992 check_op(a, "lineseq[const(1).const(2).const(3).]");
3993 a = op_append_list(OP_LINESEQ, iv_op(4), a);
3994 check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3995 a = op_append_list(OP_LINESEQ, a, NULL);
3996 check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3997 a = op_append_list(OP_LINESEQ, NULL, a);
3998 check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3999 a = op_append_list(OP_LINESEQ, a,
4000 op_append_list(OP_LINESEQ, iv_op(5), iv_op(6)));
4001 check_op(a, "lineseq[const(4).const(1).const(2).const(3)."
4002 "const(5).const(6).]");
4003 op_free(a);
4004 a = op_append_list(OP_LINESEQ,
4005 op_append_list(OP_LINESEQ, iv_op(1), iv_op(2)),
4006 op_append_list(OP_LIST, iv_op(3), iv_op(4)));
4007 check_op(a, "lineseq[const(1).const(2)."
4008 "list[pushmark.const(3).const(4).]]");
4009 op_free(a);
4010 a = op_append_list(OP_LINESEQ,
4011 op_append_list(OP_LIST, iv_op(1), iv_op(2)),
4012 op_append_list(OP_LINESEQ, iv_op(3), iv_op(4)));
4013 check_op(a, "lineseq[list[pushmark.const(1).const(2).]"
4014 "const(3).const(4).]");
4015 op_free(a);
4016 #undef check_op
4017
4018 void
4019 test_op_linklist ()
4020 PREINIT:
4021 OP *o;
4022 CODE:
4023 #define check_ll(o, expect) \
4024 STMT_START { \
4025 if (strNE(test_op_linklist_describe(o), (expect))) \
4026 croak("fail %s %s", test_op_linklist_describe(o), (expect)); \
4027 } STMT_END
4028 o = iv_op(1);
4029 check_ll(o, ".const1");
4030 op_free(o);
4031
4032 o = mkUNOP(OP_NOT, iv_op(1));
4033 check_ll(o, ".const1.not");
4034 op_free(o);
4035
4036 o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1)));
4037 check_ll(o, ".const1.negate.not");
4038 op_free(o);
4039
4040 o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
4041 check_ll(o, ".const1.const2.add");
4042 op_free(o);
4043
4044 o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2));
4045 check_ll(o, ".const1.not.const2.add");
4046 op_free(o);
4047
4048 o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2)));
4049 check_ll(o, ".const1.const2.add.not");
4050 op_free(o);
4051
4052 o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3));
4053 check_ll(o, ".const1.const2.const3.lineseq");
4054 op_free(o);
4055
4056 o = mkLISTOP(OP_LINESEQ,
4057 mkBINOP(OP_ADD, iv_op(1), iv_op(2)),
4058 mkUNOP(OP_NOT, iv_op(3)),
4059 mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6)));
4060 check_ll(o, ".const1.const2.add.const3.not"
4061 ".const4.const5.const6.substr.lineseq");
4062 op_free(o);
4063
4064 o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
4065 LINKLIST(o);
4066 o = mkBINOP(OP_SUBTRACT, o, iv_op(3));
4067 check_ll(o, ".const1.const2.add.const3.subtract");
4068 op_free(o);
4069 #undef check_ll
4070 #undef iv_op
4071
4072 void
4073 peep_enable ()
4074 PREINIT:
4075 dMY_CXT;
4076 CODE:
4077 av_clear(MY_CXT.peep_recorder);
4078 av_clear(MY_CXT.rpeep_recorder);
4079 MY_CXT.peep_recording = 1;
4080
4081 void
4082 peep_disable ()
4083 PREINIT:
4084 dMY_CXT;
4085 CODE:
4086 MY_CXT.peep_recording = 0;
4087
4088 SV *
4089 peep_record ()
4090 PREINIT:
4091 dMY_CXT;
4092 CODE:
4093 RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
4094 OUTPUT:
4095 RETVAL
4096
4097 SV *
4098 rpeep_record ()
4099 PREINIT:
4100 dMY_CXT;
4101 CODE:
4102 RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
4103 OUTPUT:
4104 RETVAL
4105
4106 =pod
4107
4108 multicall_each: call a sub for each item in the list. Used to test MULTICALL
4109
4110 =cut
4111
4112 void
4113 multicall_each(block,...)
4114 SV * block
4115 PROTOTYPE: &@
4116 CODE:
4117 {
4118 dMULTICALL;
4119 int index;
4120 GV *gv;
4121 HV *stash;
4122 I32 gimme = G_SCALAR;
4123 SV **args = &PL_stack_base[ax];
4124 CV *cv;
4125
4126 if(items <= 1) {
4127 XSRETURN_UNDEF;
4128 }
4129 cv = sv_2cv(block, &stash, &gv, 0);
4130 if (cv == Nullcv) {
4131 croak("multicall_each: not a subroutine reference");
4132 }
4133 PUSH_MULTICALL(cv);
4134 SAVESPTR(GvSV(PL_defgv));
4135
4136 for(index = 1 ; index < items ; index++) {
4137 GvSV(PL_defgv) = args[index];
4138 MULTICALL;
4139 }
4140 POP_MULTICALL;
4141 XSRETURN_UNDEF;
4142 }
4143
4144 =pod
4145
4146 multicall_return(): call the passed sub once in the specificed context
4147 and return whatever it returns
4148
4149 =cut
4150
4151 void
4152 multicall_return(block, context)
4153 SV *block
4154 I32 context
4155 PROTOTYPE: &$
4156 CODE:
4157 {
4158 dSP;
4159 dMULTICALL;
4160 GV *gv;
4161 HV *stash;
4162 I32 gimme = context;
4163 CV *cv;
4164 AV *av = NULL;
4165 SV **p;
4166 SSize_t i, size;
4167
4168 cv = sv_2cv(block, &stash, &gv, 0);
4169 if (cv == Nullcv) {
4170 croak("multicall_return not a subroutine reference");
4171 }
4172 PUSH_MULTICALL(cv);
4173
4174 MULTICALL;
4175
4176 /* copy returned values into an array so they're not freed during
4177 * POP_MULTICALL */
4178
4179 SPAGAIN;
4180
4181 switch (context) {
4182 case G_VOID:
4183 av = newAV();
4184 break;
4185
4186 case G_SCALAR:
4187 av = newAV_alloc_x(1);
4188 av_push_simple(av, SvREFCNT_inc(TOPs));
4189 break;
4190
4191 case G_LIST:
4192 av = (SP - PL_stack_base)
4193 ? newAV_alloc_xz(SP - PL_stack_base)
4194 : newAV();
4195 for (p = PL_stack_base + 1; p <= SP; p++)
4196 av_push_simple(av, SvREFCNT_inc(*p));
4197 break;
4198
4199 default:
4200 croak("multicall_return: invalid context %" I32df, context);
4201 }
4202
4203 POP_MULTICALL;
4204
4205 size = AvFILLp(av) + 1;
4206 EXTEND(SP, size);
4207 for (i = 0; i < size; i++)
4208 ST(i) = *av_fetch_simple(av, i, FALSE);
4209 sv_2mortal((SV*)av);
4210 XSRETURN(size);
4211 }
4212
4213
4214 #ifdef USE_ITHREADS
4215
4216 void
4217 clone_with_stack()
4218 CODE:
4219 {
4220 PerlInterpreter *interp = aTHX; /* The original interpreter */
4221 PerlInterpreter *interp_dup; /* The duplicate interpreter */
4222 int oldscope = 1; /* We are responsible for all scopes */
4223
4224 /* push a ref-counted and non-RC stackinfo to see how they get cloned */
4225 push_stackinfo(PERLSI_UNKNOWN, 1);
4226 push_stackinfo(PERLSI_UNKNOWN, 0);
4227
4228 interp_dup = perl_clone(interp, CLONEf_COPY_STACKS | CLONEf_CLONE_HOST );
4229
4230 /* destroy old perl */
4231 PERL_SET_CONTEXT(interp);
4232
4233 POPSTACK_TO(PL_mainstack);
4234 if (cxstack_ix >= 0) {
4235 dounwind(-1);
4236 cx_popblock(cxstack);
4237 }
4238 LEAVE_SCOPE(0);
4239 PL_scopestack_ix = oldscope;
4240 FREETMPS;
4241
4242 perl_destruct(interp);
4243 perl_free(interp);
4244
4245 /* switch to new perl */
4246 PERL_SET_CONTEXT(interp_dup);
4247
4248 /* check and pop the stackinfo's pushed above */
4249 #ifdef PERL_RC_STACK
4250 assert(!AvREAL(PL_curstack));
4251 #endif
4252 pop_stackinfo();
4253 #ifdef PERL_RC_STACK
4254 assert(AvREAL(PL_curstack));
4255 #endif
4256 pop_stackinfo();
4257
4258 /* continue after 'clone_with_stack' */
4259 if (interp_dup->Iop)
4260 interp_dup->Iop = interp_dup->Iop->op_next;
4261
4262 /* run with new perl */
4263 CALLRUNOPS(interp_dup);
4264
4265 /* We may have additional unclosed scopes if fork() was called
4266 * from within a BEGIN block. See perlfork.pod for more details.
4267 * We cannot clean up these other scopes because they belong to a
4268 * different interpreter, but we also cannot leave PL_scopestack_ix
4269 * dangling because that can trigger an assertion in perl_destruct().
4270 */
4271 if (PL_scopestack_ix > oldscope) {
4272 PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
4273 PL_scopestack_ix = oldscope;
4274 }
4275
4276 /* the COP which PL_curcop points to is about to be freed, but might
4277 * still be accessed when destructors, END() blocks etc are called.
4278 * So point it somewhere safe.
4279 */
4280 PL_curcop = &PL_compiling;
4281 perl_destruct(interp_dup);
4282 perl_free(interp_dup);
4283
4284 /* call the real 'exit' not PerlProc_exit */
4285 #undef exit
4286 exit(0);
4287 }
4288
4289 #endif /* USE_ITHREADS */
4290
4291 SV*
4292 take_svref(SVREF sv)
4293 CODE:
4294 RETVAL = newRV_inc(sv);
4295 OUTPUT:
4296 RETVAL
4297
4298 SV*
4299 take_avref(AV* av)
4300 CODE:
4301 RETVAL = newRV_inc((SV*)av);
4302 OUTPUT:
4303 RETVAL
4304
4305 SV*
4306 take_hvref(HV* hv)
4307 CODE:
4308 RETVAL = newRV_inc((SV*)hv);
4309 OUTPUT:
4310 RETVAL
4311
4312
4313 SV*
4314 take_cvref(CV* cv)
4315 CODE:
4316 RETVAL = newRV_inc((SV*)cv);
4317 OUTPUT:
4318 RETVAL
4319
4320
4321 BOOT:
4322 {
4323 HV* stash;
4324 SV** meth = NULL;
4325 CV* cv;
4326 stash = gv_stashpv("XS::APItest::TempLv", 0);
4327 if (stash)
4328 meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
4329 if (!meth)
4330 croak("lost method 'make_temp_mg_lv'");
4331 cv = GvCV(*meth);
4332 CvLVALUE_on(cv);
4333 }
4334
4335 BOOT:
4336 {
4337 hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
4338 hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
4339 hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
4340 hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
4341 hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
4342 hintkey_scopelessblock_sv = newSVpvs_share("XS::APItest/scopelessblock");
4343 hintkey_stmtasexpr_sv = newSVpvs_share("XS::APItest/stmtasexpr");
4344 hintkey_stmtsasexpr_sv = newSVpvs_share("XS::APItest/stmtsasexpr");
4345 hintkey_loopblock_sv = newSVpvs_share("XS::APItest/loopblock");
4346 hintkey_blockasexpr_sv = newSVpvs_share("XS::APItest/blockasexpr");
4347 hintkey_swaplabel_sv = newSVpvs_share("XS::APItest/swaplabel");
4348 hintkey_labelconst_sv = newSVpvs_share("XS::APItest/labelconst");
4349 hintkey_arrayfullexpr_sv = newSVpvs_share("XS::APItest/arrayfullexpr");
4350 hintkey_arraylistexpr_sv = newSVpvs_share("XS::APItest/arraylistexpr");
4351 hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr");
4352 hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr");
4353 hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags");
4354 hintkey_subsignature_sv = newSVpvs_share("XS::APItest/subsignature");
4355 hintkey_DEFSV_sv = newSVpvs_share("XS::APItest/DEFSV");
4356 hintkey_with_vars_sv = newSVpvs_share("XS::APItest/with_vars");
4357 hintkey_join_with_space_sv = newSVpvs_share("XS::APItest/join_with_space");
4358 wrap_keyword_plugin(my_keyword_plugin, &next_keyword_plugin);
4359 }
4360
4361 void
4362 establish_cleanup(...)
4363 PROTOTYPE: $
4364 CODE:
4365 PERL_UNUSED_VAR(items);
4366 croak("establish_cleanup called as a function");
4367
4368 BOOT:
4369 {
4370 CV *estcv = get_cv("XS::APItest::establish_cleanup", 0);
4371 cv_set_call_checker(estcv, THX_ck_entersub_establish_cleanup, (SV*)estcv);
4372 }
4373
4374 void
4375 postinc(...)
4376 PROTOTYPE: $
4377 CODE:
4378 PERL_UNUSED_VAR(items);
4379 croak("postinc called as a function");
4380
4381 void
4382 filter()
4383 CODE:
4384 filter_add(filter_call, NULL);
4385
4386 BOOT:
4387 {
4388 CV *asscv = get_cv("XS::APItest::postinc", 0);
4389 cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv);
4390 }
4391
4392 SV *
4393 lv_temp_object()
4394 CODE:
4395 RETVAL =
4396 sv_bless(
4397 newRV_noinc(newSV(0)),
4398 gv_stashpvs("XS::APItest::TempObj",GV_ADD)
4399 ); /* Package defined in test script */
4400 OUTPUT:
4401 RETVAL
4402
4403 void
4404 fill_hash_with_nulls(HV *hv)
4405 PREINIT:
4406 UV i = 0;
4407 CODE:
4408 for(; i < 1000; ++i) {
4409 HE *entry = hv_fetch_ent(hv, sv_2mortal(newSVuv(i)), 1, 0);
4410 SvREFCNT_dec(HeVAL(entry));
4411 HeVAL(entry) = NULL;
4412 }
4413
4414 HV *
4415 newHVhv(HV *hv)
4416 CODE:
4417 RETVAL = newHVhv(hv);
4418 OUTPUT:
4419 RETVAL
4420
4421 U32
4422 SvIsCOW(SV *sv)
4423 CODE:
4424 RETVAL = SvIsCOW(sv);
4425 OUTPUT:
4426 RETVAL
4427
4428 void
4429 pad_scalar(...)
4430 PROTOTYPE: $$
4431 CODE:
4432 PERL_UNUSED_VAR(items);
4433 croak("pad_scalar called as a function");
4434
4435 BOOT:
4436 {
4437 CV *pscv = get_cv("XS::APItest::pad_scalar", 0);
4438 cv_set_call_checker(pscv, THX_ck_entersub_pad_scalar, (SV*)pscv);
4439 }
4440
4441 SV*
4442 fetch_pad_names( cv )
4443 CV* cv
4444 PREINIT:
4445 I32 i;
4446 PADNAMELIST *pad_namelist;
4447 AV *retav = newAV();
4448 CODE:
4449 pad_namelist = PadlistNAMES(CvPADLIST(cv));
4450
4451 for ( i = PadnamelistMAX(pad_namelist); i >= 0; i-- ) {
4452 PADNAME* name = PadnamelistARRAY(pad_namelist)[i];
4453
4454 if (PadnameLEN(name)) {
4455 av_push_simple(retav, newSVpadname(name));
4456 }
4457 }
4458 RETVAL = newRV_noinc((SV*)retav);
4459 OUTPUT:
4460 RETVAL
4461
4462 STRLEN
4463 underscore_length()
4464 PROTOTYPE:
4465 PREINIT:
4466 SV *u;
4467 U8 *pv;
4468 STRLEN bytelen;
4469 CODE:
4470 u = find_rundefsv();
4471 pv = (U8*)SvPV(u, bytelen);
4472 RETVAL = SvUTF8(u) ? utf8_length(pv, pv+bytelen) : bytelen;
4473 OUTPUT:
4474 RETVAL
4475
4476 void
4477 stringify(SV *sv)
4478 CODE:
4479 (void)SvPV_nolen(sv);
4480
4481 SV *
4482 HvENAME(HV *hv)
4483 CODE:
4484 RETVAL = hv && HvHasENAME(hv)
4485 ? newSVpvn_flags(
4486 HvENAME(hv),HvENAMELEN(hv),
4487 (HvENAMEUTF8(hv) ? SVf_UTF8 : 0)
4488 )
4489 : NULL;
4490 OUTPUT:
4491 RETVAL
4492
4493 int
4494 xs_cmp(int a, int b)
4495 CODE:
4496 /* Odd sorting (odd numbers first), to make sure we are actually
4497 being called */
4498 RETVAL = a % 2 != b % 2
4499 ? a % 2 ? -1 : 1
4500 : a < b ? -1 : a == b ? 0 : 1;
4501 OUTPUT:
4502 RETVAL
4503
4504 SV *
4505 xs_cmp_undef(SV *a, SV *b)
4506 CODE:
4507 PERL_UNUSED_ARG(a);
4508 PERL_UNUSED_ARG(b);
4509 RETVAL = &PL_sv_undef;
4510 OUTPUT:
4511 RETVAL
4512
4513 char *
4514 SvPVbyte(SV *sv, OUT STRLEN len)
4515 CODE:
4516 RETVAL = SvPVbyte(sv, len);
4517 OUTPUT:
4518 RETVAL
4519
4520 char *
4521 SvPVbyte_nolen(SV *sv)
4522 CODE:
4523 RETVAL = SvPVbyte_nolen(sv);
4524 OUTPUT:
4525 RETVAL
4526
4527 char *
4528 SvPVbyte_nomg(SV *sv, OUT STRLEN len)
4529 CODE:
4530 RETVAL = SvPVbyte_nomg(sv, len);
4531 OUTPUT:
4532 RETVAL
4533
4534 char *
4535 SvPVutf8(SV *sv, OUT STRLEN len)
4536 CODE:
4537 RETVAL = SvPVutf8(sv, len);
4538 OUTPUT:
4539 RETVAL
4540
4541 char *
4542 SvPVutf8_nolen(SV *sv)
4543 CODE:
4544 RETVAL = SvPVutf8_nolen(sv);
4545 OUTPUT:
4546 RETVAL
4547
4548 char *
4549 SvPVutf8_nomg(SV *sv, OUT STRLEN len)
4550 CODE:
4551 RETVAL = SvPVutf8_nomg(sv, len);
4552 OUTPUT:
4553 RETVAL
4554
4555 bool
4556 SvIsBOOL(SV *sv)
4557 CODE:
4558 RETVAL = SvIsBOOL(sv);
4559 OUTPUT:
4560 RETVAL
4561
4562 void
4563 setup_addissub()
4564 CODE:
4565 wrap_op_checker(OP_ADD, addissub_myck_add, &addissub_nxck_add);
4566
4567 void
4568 setup_rv2cv_addunderbar()
4569 CODE:
4570 wrap_op_checker(OP_RV2CV, my_ck_rv2cv, &old_ck_rv2cv);
4571
4572 #ifdef USE_ITHREADS
4573
4574 bool
4575 test_alloccopstash()
4576 CODE:
4577 RETVAL = PL_stashpad[alloccopstash(PL_defstash)] == PL_defstash;
4578 OUTPUT:
4579 RETVAL
4580
4581 #endif
4582
4583 bool
test_newFOROP_without_slab()4584 test_newFOROP_without_slab()
4585 CODE:
4586 {
4587 const I32 floor = start_subparse(0,0);
4588 OP *o;
4589 /* The slab allocator does not like CvROOT being set. */
4590 CvROOT(PL_compcv) = (OP *)1;
4591 o = newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0);
4592 if (cLOOPx(cUNOPo->op_first)->op_last->op_sibparent
4593 != cUNOPo->op_first)
4594 {
4595 Perl_warn(aTHX_ "Op parent pointer is stale");
4596 RETVAL = FALSE;
4597 }
4598 else
4599 /* If we do not crash before returning, the test passes. */
4600 RETVAL = TRUE;
4601 op_free(o);
4602 CvROOT(PL_compcv) = NULL;
4603 SvREFCNT_dec(PL_compcv);
4604 LEAVE_SCOPE(floor);
4605 }
4606 OUTPUT:
4607 RETVAL
4608
4609 # provide access to CALLREGEXEC, except replace pointers within the
4610 # string with offsets from the start of the string
4611
4612 I32
callregexec(SV * prog,STRLEN stringarg,STRLEN strend,I32 minend,SV * sv,U32 nosave)4613 callregexec(SV *prog, STRLEN stringarg, STRLEN strend, I32 minend, SV *sv, U32 nosave)
4614 CODE:
4615 {
4616 STRLEN len;
4617 char *strbeg;
4618 if (SvROK(prog))
4619 prog = SvRV(prog);
4620 strbeg = SvPV_force(sv, len);
4621 RETVAL = CALLREGEXEC((REGEXP *)prog,
4622 strbeg + stringarg,
4623 strbeg + strend,
4624 strbeg,
4625 minend,
4626 sv,
4627 NULL, /* data */
4628 nosave);
4629 }
4630 OUTPUT:
4631 RETVAL
4632
4633 void
lexical_import(SV * name,CV * cv)4634 lexical_import(SV *name, CV *cv)
4635 CODE:
4636 {
4637 PADLIST *pl;
4638 PADOFFSET off;
4639 if (!PL_compcv)
4640 Perl_croak(aTHX_
4641 "lexical_import can only be called at compile time");
4642 pl = CvPADLIST(PL_compcv);
4643 ENTER;
4644 SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(pl);
4645 SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(pl)[1];
4646 SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad);
4647 off = pad_add_name_sv(sv_2mortal(newSVpvf("&%" SVf,name)),
4648 padadd_STATE, 0, 0);
4649 SvREFCNT_dec(PL_curpad[off]);
4650 PL_curpad[off] = SvREFCNT_inc(cv);
4651 intro_my();
4652 LEAVE;
4653 }
4654
4655 SV *
4656 sv_mortalcopy(SV *sv)
4657 CODE:
4658 RETVAL = SvREFCNT_inc(sv_mortalcopy(sv));
4659 OUTPUT:
4660 RETVAL
4661
4662 SV *
4663 newRV(SV *sv)
4664
4665 SV *
4666 newAVav(AV *av)
4667 CODE:
4668 RETVAL = newRV_noinc((SV *)newAVav(av));
4669 OUTPUT:
4670 RETVAL
4671
4672 SV *
4673 newAVhv(HV *hv)
4674 CODE:
4675 RETVAL = newRV_noinc((SV *)newAVhv(hv));
4676 OUTPUT:
4677 RETVAL
4678
4679 void
4680 alias_av(AV *av, IV ix, SV *sv)
4681 CODE:
4682 av_store(av, ix, SvREFCNT_inc(sv));
4683
4684 SV *
4685 cv_name(SVREF ref, ...)
4686 CODE:
4687 RETVAL = SvREFCNT_inc(cv_name((CV *)ref,
4688 items>1 && ST(1) != &PL_sv_undef
4689 ? ST(1)
4690 : NULL,
4691 items>2 ? SvUV(ST(2)) : 0));
4692 OUTPUT:
4693 RETVAL
4694
4695 void
sv_catpvn(SV * sv,SV * sv2)4696 sv_catpvn(SV *sv, SV *sv2)
4697 CODE:
4698 {
4699 STRLEN len;
4700 const char *s = SvPV(sv2,len);
4701 sv_catpvn_flags(sv,s,len, SvUTF8(sv2) ? SV_CATUTF8 : SV_CATBYTES);
4702 }
4703
4704 bool
test_newOP_CUSTOM()4705 test_newOP_CUSTOM()
4706 CODE:
4707 {
4708 OP *o = newLISTOP(OP_CUSTOM, 0, NULL, NULL);
4709 op_free(o);
4710 o = newOP(OP_CUSTOM, 0);
4711 op_free(o);
4712 o = newUNOP(OP_CUSTOM, 0, NULL);
4713 op_free(o);
4714 o = newUNOP_AUX(OP_CUSTOM, 0, NULL, NULL);
4715 op_free(o);
4716 o = newMETHOP(OP_CUSTOM, 0, newOP(OP_NULL,0));
4717 op_free(o);
4718 o = newMETHOP_named(OP_CUSTOM, 0, newSV(0));
4719 op_free(o);
4720 o = newBINOP(OP_CUSTOM, 0, NULL, NULL);
4721 op_free(o);
4722 o = newPMOP(OP_CUSTOM, 0);
4723 op_free(o);
4724 o = newSVOP(OP_CUSTOM, 0, newSV(0));
4725 op_free(o);
4726 #ifdef USE_ITHREADS
4727 ENTER;
4728 lex_start(NULL, NULL, 0);
4729 {
4730 I32 ix = start_subparse(FALSE,0);
4731 o = newPADOP(OP_CUSTOM, 0, newSV(0));
4732 op_free(o);
4733 LEAVE_SCOPE(ix);
4734 }
4735 LEAVE;
4736 #endif
4737 o = newPVOP(OP_CUSTOM, 0, NULL);
4738 op_free(o);
4739 o = newLOGOP(OP_CUSTOM, 0, newOP(OP_NULL,0), newOP(OP_NULL,0));
4740 op_free(o);
4741 o = newLOOPEX(OP_CUSTOM, newOP(OP_NULL,0));
4742 op_free(o);
4743 RETVAL = TRUE;
4744 }
4745 OUTPUT:
4746 RETVAL
4747
4748 void
4749 test_sv_catpvf(SV *fmtsv)
4750 PREINIT:
4751 SV *sv;
4752 char *fmt;
4753 CODE:
4754 fmt = SvPV_nolen(fmtsv);
4755 sv = sv_2mortal(newSVpvn("", 0));
4756 sv_catpvf(sv, fmt, 5, 6, 7, 8);
4757
4758 void
4759 load_module(flags, name, ...)
4760 U32 flags
4761 SV *name
4762 CODE:
4763 if (items == 2) {
4764 Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), NULL);
4765 } else if (items == 3) {
4766 Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), SvREFCNT_inc(ST(2)));
4767 } else
4768 Perl_croak(aTHX_ "load_module can't yet support %" IVdf " items",
4769 (IV)items);
4770
4771 SV *
string_without_null(SV * sv)4772 string_without_null(SV *sv)
4773 CODE:
4774 {
4775 STRLEN len;
4776 const char *s = SvPV(sv, len);
4777 RETVAL = newSVpvn_flags(s, len, SvUTF8(sv));
4778 *SvEND(RETVAL) = 0xff;
4779 }
4780 OUTPUT:
4781 RETVAL
4782
4783 CV *
get_cv(SV * sv)4784 get_cv(SV *sv)
4785 CODE:
4786 {
4787 STRLEN len;
4788 const char *s = SvPV(sv, len);
4789 RETVAL = get_cvn_flags(s, len, 0);
4790 }
4791 OUTPUT:
4792 RETVAL
4793
4794 CV *
get_cv_flags(SV * sv,UV flags)4795 get_cv_flags(SV *sv, UV flags)
4796 CODE:
4797 {
4798 STRLEN len;
4799 const char *s = SvPV(sv, len);
4800 RETVAL = get_cvn_flags(s, len, flags);
4801 }
4802 OUTPUT:
4803 RETVAL
4804
4805 void
4806 unshift_and_set_defav(SV *sv,...)
4807 CODE:
4808 av_unshift(GvAVn(PL_defgv), 1);
4809 av_store(GvAV(PL_defgv), 0, newSVuv(42));
4810 sv_setuv(sv, 43);
4811
4812 PerlIO *
4813 PerlIO_stderr()
4814
4815 OutputStream
4816 PerlIO_stdout()
4817
4818 InputStream
4819 PerlIO_stdin()
4820
4821 #undef FILE
4822 #define FILE NativeFile
4823
4824 FILE *
4825 PerlIO_exportFILE(PerlIO *f, const char *mode)
4826
4827 SV *
4828 test_MAX_types()
4829 CODE:
4830 /* tests that IV_MAX and UV_MAX have types suitable
4831 for the IVdf and UVdf formats.
4832 If this warns then don't add casts here.
4833 */
4834 RETVAL = newSVpvf("iv %" IVdf " uv %" UVuf, IV_MAX, UV_MAX);
4835 OUTPUT:
4836 RETVAL
4837
4838 SV *
4839 test_HvNAMEf(sv)
4840 SV *sv
4841 CODE:
4842 if (!sv_isobject(sv)) XSRETURN_UNDEF;
4843 HV *pkg = SvSTASH(SvRV(sv));
4844 RETVAL = newSVpvf("class='%" HvNAMEf "'", pkg);
4845 OUTPUT:
4846 RETVAL
4847
4848 SV *
4849 test_HvNAMEf_QUOTEDPREFIX(sv)
4850 SV *sv
4851 CODE:
4852 if (!sv_isobject(sv)) XSRETURN_UNDEF;
4853 HV *pkg = SvSTASH(SvRV(sv));
4854 RETVAL = newSVpvf("class=%" HvNAMEf_QUOTEDPREFIX, pkg);
4855 OUTPUT:
4856 RETVAL
4857
4858
4859 bool
4860 sv_numeq(SV *sv1, SV *sv2)
4861 CODE:
4862 RETVAL = sv_numeq(sv1, sv2);
4863 OUTPUT:
4864 RETVAL
4865
4866 bool
4867 sv_numeq_flags(SV *sv1, SV *sv2, U32 flags)
4868 CODE:
4869 RETVAL = sv_numeq_flags(sv1, sv2, flags);
4870 OUTPUT:
4871 RETVAL
4872
4873 bool
4874 sv_streq(SV *sv1, SV *sv2)
4875 CODE:
4876 RETVAL = sv_streq(sv1, sv2);
4877 OUTPUT:
4878 RETVAL
4879
4880 bool
4881 sv_streq_flags(SV *sv1, SV *sv2, U32 flags)
4882 CODE:
4883 RETVAL = sv_streq_flags(sv1, sv2, flags);
4884 OUTPUT:
4885 RETVAL
4886
4887 void
4888 set_custom_pp_func(sv)
4889 SV *sv;
4890 PPCODE:
4891 /* replace the pp func of the next op */
4892 OP* o = PL_op->op_next;
4893 if (o->op_type == OP_ADD)
4894 o->op_ppaddr = my_pp_add;
4895 else if (o->op_type == OP_ANONLIST)
4896 o->op_ppaddr = my_pp_anonlist;
4897 else
4898 croak("set_custom_pp_func: op_next is not an OP_ADD\n");
4899
4900 /* the single SV arg is passed through */
4901 PERL_UNUSED_ARG(sv);
4902 XSRETURN(1);
4903
4904 void
4905 set_xs_rc_stack(cv, sv)
4906 CV *cv;
4907 SV *sv;
4908 PPCODE:
4909 /* set or undet the CVf_XS_RCSTACK flag on the CV */
4910 assert(SvTYPE(cv) == SVt_PVCV);
4911 if (SvTRUE(sv))
4912 CvXS_RCSTACK_on(cv);
4913 else
4914 CvXS_RCSTACK_off(cv);
4915 XSRETURN(0);
4916
4917 void
4918 rc_add(sv1, sv2)
4919 SV *sv1;
4920 SV *sv2;
4921 PPCODE:
4922 /* Do the XS equivalent of pp_add(), while expecting a
4923 * reference-counted stack */
4924
4925 /* manipulate the stack directly */
4926 PERL_UNUSED_ARG(sv1);
4927 PERL_UNUSED_ARG(sv2);
4928 SV *r = newSViv(SvIV(PL_stack_sp[-1]) + SvIV(PL_stack_sp[0]));
4929 rpp_replace_2_1(r);
4930 return;
4931
4932
4933
4934 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
4935
4936 int
4937 AUTOLOAD(...)
4938 INIT:
4939 SV* comms;
4940 SV* class_and_method;
4941 CODE:
4942 PERL_UNUSED_ARG(items);
4943 class_and_method = GvSV(CvGV(cv));
4944 comms = get_sv("main::the_method", 1);
4945 if (class_and_method == NULL) {
4946 RETVAL = 1;
4947 } else if (!SvOK(class_and_method)) {
4948 RETVAL = 2;
4949 } else if (!SvPOK(class_and_method)) {
4950 RETVAL = 3;
4951 } else {
4952 sv_setsv(comms, class_and_method);
4953 RETVAL = 0;
4954 }
4955 OUTPUT: RETVAL
4956
4957
4958 MODULE = XS::APItest PACKAGE = XS::APItest::Magic
4959
4960 PROTOTYPES: DISABLE
4961
4962 void
4963 sv_magic_foo(SV *sv, SV *thingy)
4964 ALIAS:
4965 sv_magic_bar = 1
4966 sv_magic_baz = 2
4967 CODE:
4968 sv_magicext(sv, NULL, ix == 2 ? PERL_MAGIC_extvalue : PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo, (const char *)thingy, 0);
4969
4970 SV *
4971 mg_find_foo(SV *sv)
4972 ALIAS:
4973 mg_find_bar = 1
4974 mg_find_baz = 2
4975 CODE:
4976 RETVAL = &PL_sv_undef;
4977 if (SvTYPE(sv) >= SVt_PVMG) {
4978 MAGIC *mg = mg_findext(sv, ix == 2 ? PERL_MAGIC_extvalue : PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
4979 if (mg)
4980 RETVAL = SvREFCNT_inc((SV *)mg->mg_ptr);
4981 }
4982 OUTPUT:
4983 RETVAL
4984
4985 void
4986 sv_unmagic_foo(SV *sv)
4987 ALIAS:
4988 sv_unmagic_bar = 1
4989 sv_unmagic_baz = 2
4990 CODE:
4991 sv_unmagicext(sv, ix == 2 ? PERL_MAGIC_extvalue : PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
4992
4993 void
4994 sv_magic(SV *sv, SV *thingy)
4995 CODE:
4996 sv_magic(sv, NULL, PERL_MAGIC_ext, (const char *)thingy, 0);
4997
4998 UV
4999 test_get_vtbl()
5000 PREINIT:
5001 MGVTBL *have;
5002 MGVTBL *want;
5003 CODE:
5004 #define test_get_this_vtable(name) \
5005 want = (MGVTBL*)CAT2(&PL_vtbl_, name); \
5006 have = get_vtbl(CAT2(want_vtbl_, name)); \
5007 if (have != want) \
5008 croak("fail %p!=%p for get_vtbl(want_vtbl_" STRINGIFY(name) ") at " __FILE__ " line %d", have, want, __LINE__)
5009
5010 test_get_this_vtable(sv);
5011 test_get_this_vtable(env);
5012 test_get_this_vtable(envelem);
5013 test_get_this_vtable(sigelem);
5014 test_get_this_vtable(pack);
5015 test_get_this_vtable(packelem);
5016 test_get_this_vtable(dbline);
5017 test_get_this_vtable(isa);
5018 test_get_this_vtable(isaelem);
5019 test_get_this_vtable(arylen);
5020 test_get_this_vtable(mglob);
5021 test_get_this_vtable(nkeys);
5022 test_get_this_vtable(taint);
5023 test_get_this_vtable(substr);
5024 test_get_this_vtable(vec);
5025 test_get_this_vtable(pos);
5026 test_get_this_vtable(bm);
5027 test_get_this_vtable(fm);
5028 test_get_this_vtable(uvar);
5029 test_get_this_vtable(defelem);
5030 test_get_this_vtable(regexp);
5031 test_get_this_vtable(regdata);
5032 test_get_this_vtable(regdatum);
5033 #ifdef USE_LOCALE_COLLATE
5034 test_get_this_vtable(collxfrm);
5035 #endif
5036 test_get_this_vtable(backref);
5037 test_get_this_vtable(utf8);
5038
5039 RETVAL = PTR2UV(get_vtbl(-1));
5040 OUTPUT:
5041 RETVAL
5042
5043
5044 # attach ext magic to the SV pointed to by rsv that only has set magic,
5045 # where that magic's job is to increment thingy
5046
5047 void
5048 sv_magic_myset_dies(SV *rsv, SV *thingy)
5049 CODE:
5050 sv_magicext(SvRV(rsv), NULL, PERL_MAGIC_ext, &vtbl_myset_dies,
5051 (const char *)thingy, 0);
5052
5053
5054 void
5055 sv_magic_myset(SV *rsv, SV *thingy)
5056 CODE:
5057 sv_magicext(SvRV(rsv), NULL, PERL_MAGIC_ext, &vtbl_myset,
5058 (const char *)thingy, 0);
5059
5060 void
5061 sv_magic_mycopy(SV *rsv)
5062 PREINIT:
5063 MAGIC *mg;
5064 CODE:
5065 /* It's only actually useful to attach this to arrays and hashes. */
5066 mg = sv_magicext(SvRV(rsv), NULL, PERL_MAGIC_ext, &vtbl_mycopy, NULL, 0);
5067 mg->mg_flags = MGf_COPY;
5068
5069 SV *
5070 sv_magic_mycopy_count(SV *rsv)
5071 PREINIT:
5072 MAGIC *mg;
5073 CODE:
5074 mg = mg_findext(SvRV(rsv), PERL_MAGIC_ext, &vtbl_mycopy);
5075 RETVAL = mg ? newSViv(mg->mg_private) : &PL_sv_undef;
5076 OUTPUT:
5077 RETVAL
5078
5079 int
5080 my_av_store(SV *rsv, IV i, SV *sv)
5081 CODE:
5082 if (av_store((AV*)SvRV(rsv), i, sv)) {
5083 SvREFCNT_inc(sv);
5084 RETVAL = 1;
5085 } else {
5086 RETVAL = 0;
5087 }
5088 OUTPUT:
5089 RETVAL
5090
5091 STRLEN
5092 sv_refcnt(SV *sv)
5093 CODE:
5094 RETVAL = SvREFCNT(sv);
5095 OUTPUT:
5096 RETVAL
5097
5098 void
5099 test_mortal_destructor_sv(SV *coderef, SV *args)
5100 CODE:
5101 MORTALDESTRUCTOR_SV(coderef,args);
5102
5103 void
5104 test_mortal_destructor_av(SV *coderef, AV *args)
5105 CODE:
5106 /* passing in an AV cast to SV is different from a SV ref to an AV */
5107 MORTALDESTRUCTOR_SV(coderef, (SV *)args);
5108
5109 void
5110 test_mortal_svfunc_x(SV *args)
5111 CODE:
5112 MORTALSVFUNC_X(&destruct_test,args);
5113
5114
5115
5116
5117 MODULE = XS::APItest PACKAGE = XS::APItest
5118
5119 bool
5120 test_isBLANK_uni(UV ord)
5121 CODE:
5122 RETVAL = isBLANK_uni(ord);
5123 OUTPUT:
5124 RETVAL
5125
5126 bool
5127 test_isBLANK_uvchr(UV ord)
5128 CODE:
5129 RETVAL = isBLANK_uvchr(ord);
5130 OUTPUT:
5131 RETVAL
5132
5133 bool
5134 test_isBLANK_LC_uvchr(UV ord)
5135 CODE:
5136 RETVAL = isBLANK_LC_uvchr(ord);
5137 OUTPUT:
5138 RETVAL
5139
5140 bool
5141 test_isBLANK(UV ord)
5142 CODE:
5143 RETVAL = isBLANK(ord);
5144 OUTPUT:
5145 RETVAL
5146
5147 bool
5148 test_isBLANK_A(UV ord)
5149 CODE:
5150 RETVAL = isBLANK_A(ord);
5151 OUTPUT:
5152 RETVAL
5153
5154 bool
5155 test_isBLANK_L1(UV ord)
5156 CODE:
5157 RETVAL = isBLANK_L1(ord);
5158 OUTPUT:
5159 RETVAL
5160
5161 bool
5162 test_isBLANK_LC(UV ord)
5163 CODE:
5164 RETVAL = isBLANK_LC(ord);
5165 OUTPUT:
5166 RETVAL
5167
5168 bool
5169 test_isBLANK_utf8(U8 * p, int type)
5170 PREINIT:
5171 const U8 * e;
5172 CODE:
5173
5174 /* In this function and those that follow, the boolean 'type'
5175 * indicates if to pass a malformed UTF-8 string to the tested macro
5176 * (malformed by making it too short) */
5177 if (type >= 0) {
5178 e = p + UTF8SKIP(p) - type;
5179 RETVAL = isBLANK_utf8_safe(p, e);
5180 }
5181 else {
5182 RETVAL = 0;
5183 }
5184 OUTPUT:
5185 RETVAL
5186
5187 bool
5188 test_isBLANK_LC_utf8(U8 * p, int type)
5189 PREINIT:
5190 const U8 * e;
5191 CODE:
5192 if (type >= 0) {
5193 e = p + UTF8SKIP(p) - type;
5194 RETVAL = isBLANK_LC_utf8_safe(p, e);
5195 }
5196 else {
5197 RETVAL = 0;
5198 }
5199 OUTPUT:
5200 RETVAL
5201
5202 bool
5203 test_isVERTWS_uni(UV ord)
5204 CODE:
5205 RETVAL = isVERTWS_uni(ord);
5206 OUTPUT:
5207 RETVAL
5208
5209 bool
5210 test_isVERTWS_uvchr(UV ord)
5211 CODE:
5212 RETVAL = isVERTWS_uvchr(ord);
5213 OUTPUT:
5214 RETVAL
5215
5216 bool
5217 test_isVERTWS_utf8(U8 * p, int type)
5218 PREINIT:
5219 const U8 * e;
5220 CODE:
5221 if (type >= 0) {
5222 e = p + UTF8SKIP(p) - type;
5223 RETVAL = isVERTWS_utf8_safe(p, e);
5224 }
5225 else {
5226 RETVAL = 0;
5227 }
5228 OUTPUT:
5229 RETVAL
5230
5231 bool
5232 test_isUPPER_uni(UV ord)
5233 CODE:
5234 RETVAL = isUPPER_uni(ord);
5235 OUTPUT:
5236 RETVAL
5237
5238 bool
5239 test_isUPPER_uvchr(UV ord)
5240 CODE:
5241 RETVAL = isUPPER_uvchr(ord);
5242 OUTPUT:
5243 RETVAL
5244
5245 bool
5246 test_isUPPER_LC_uvchr(UV ord)
5247 CODE:
5248 RETVAL = isUPPER_LC_uvchr(ord);
5249 OUTPUT:
5250 RETVAL
5251
5252 bool
5253 test_isUPPER(UV ord)
5254 CODE:
5255 RETVAL = isUPPER(ord);
5256 OUTPUT:
5257 RETVAL
5258
5259 bool
5260 test_isUPPER_A(UV ord)
5261 CODE:
5262 RETVAL = isUPPER_A(ord);
5263 OUTPUT:
5264 RETVAL
5265
5266 bool
5267 test_isUPPER_L1(UV ord)
5268 CODE:
5269 RETVAL = isUPPER_L1(ord);
5270 OUTPUT:
5271 RETVAL
5272
5273 bool
5274 test_isUPPER_LC(UV ord)
5275 CODE:
5276 RETVAL = isUPPER_LC(ord);
5277 OUTPUT:
5278 RETVAL
5279
5280 bool
5281 test_isUPPER_utf8(U8 * p, int type)
5282 PREINIT:
5283 const U8 * e;
5284 CODE:
5285 if (type >= 0) {
5286 e = p + UTF8SKIP(p) - type;
5287 RETVAL = isUPPER_utf8_safe(p, e);
5288 }
5289 else {
5290 RETVAL = 0;
5291 }
5292 OUTPUT:
5293 RETVAL
5294
5295 bool
5296 test_isUPPER_LC_utf8(U8 * p, int type)
5297 PREINIT:
5298 const U8 * e;
5299 CODE:
5300 if (type >= 0) {
5301 e = p + UTF8SKIP(p) - type;
5302 RETVAL = isUPPER_LC_utf8_safe(p, e);
5303 }
5304 else {
5305 RETVAL = 0;
5306 }
5307 OUTPUT:
5308 RETVAL
5309
5310 bool
5311 test_isLOWER_uni(UV ord)
5312 CODE:
5313 RETVAL = isLOWER_uni(ord);
5314 OUTPUT:
5315 RETVAL
5316
5317 bool
5318 test_isLOWER_uvchr(UV ord)
5319 CODE:
5320 RETVAL = isLOWER_uvchr(ord);
5321 OUTPUT:
5322 RETVAL
5323
5324 bool
5325 test_isLOWER_LC_uvchr(UV ord)
5326 CODE:
5327 RETVAL = isLOWER_LC_uvchr(ord);
5328 OUTPUT:
5329 RETVAL
5330
5331 bool
5332 test_isLOWER(UV ord)
5333 CODE:
5334 RETVAL = isLOWER(ord);
5335 OUTPUT:
5336 RETVAL
5337
5338 bool
5339 test_isLOWER_A(UV ord)
5340 CODE:
5341 RETVAL = isLOWER_A(ord);
5342 OUTPUT:
5343 RETVAL
5344
5345 bool
5346 test_isLOWER_L1(UV ord)
5347 CODE:
5348 RETVAL = isLOWER_L1(ord);
5349 OUTPUT:
5350 RETVAL
5351
5352 bool
5353 test_isLOWER_LC(UV ord)
5354 CODE:
5355 RETVAL = isLOWER_LC(ord);
5356 OUTPUT:
5357 RETVAL
5358
5359 bool
5360 test_isLOWER_utf8(U8 * p, int type)
5361 PREINIT:
5362 const U8 * e;
5363 CODE:
5364 if (type >= 0) {
5365 e = p + UTF8SKIP(p) - type;
5366 RETVAL = isLOWER_utf8_safe(p, e);
5367 }
5368 else {
5369 RETVAL = 0;
5370 }
5371 OUTPUT:
5372 RETVAL
5373
5374 bool
5375 test_isLOWER_LC_utf8(U8 * p, int type)
5376 PREINIT:
5377 const U8 * e;
5378 CODE:
5379 if (type >= 0) {
5380 e = p + UTF8SKIP(p) - type;
5381 RETVAL = isLOWER_LC_utf8_safe(p, e);
5382 }
5383 else {
5384 RETVAL = 0;
5385 }
5386 OUTPUT:
5387 RETVAL
5388
5389 bool
5390 test_isALPHA_uni(UV ord)
5391 CODE:
5392 RETVAL = isALPHA_uni(ord);
5393 OUTPUT:
5394 RETVAL
5395
5396 bool
5397 test_isALPHA_uvchr(UV ord)
5398 CODE:
5399 RETVAL = isALPHA_uvchr(ord);
5400 OUTPUT:
5401 RETVAL
5402
5403 bool
5404 test_isALPHA_LC_uvchr(UV ord)
5405 CODE:
5406 RETVAL = isALPHA_LC_uvchr(ord);
5407 OUTPUT:
5408 RETVAL
5409
5410 bool
5411 test_isALPHA(UV ord)
5412 CODE:
5413 RETVAL = isALPHA(ord);
5414 OUTPUT:
5415 RETVAL
5416
5417 bool
5418 test_isALPHA_A(UV ord)
5419 CODE:
5420 RETVAL = isALPHA_A(ord);
5421 OUTPUT:
5422 RETVAL
5423
5424 bool
5425 test_isALPHA_L1(UV ord)
5426 CODE:
5427 RETVAL = isALPHA_L1(ord);
5428 OUTPUT:
5429 RETVAL
5430
5431 bool
5432 test_isALPHA_LC(UV ord)
5433 CODE:
5434 RETVAL = isALPHA_LC(ord);
5435 OUTPUT:
5436 RETVAL
5437
5438 bool
5439 test_isALPHA_utf8(U8 * p, int type)
5440 PREINIT:
5441 const U8 * e;
5442 CODE:
5443 if (type >= 0) {
5444 e = p + UTF8SKIP(p) - type;
5445 RETVAL = isALPHA_utf8_safe(p, e);
5446 }
5447 else {
5448 RETVAL = 0;
5449 }
5450 OUTPUT:
5451 RETVAL
5452
5453 bool
5454 test_isALPHA_LC_utf8(U8 * p, int type)
5455 PREINIT:
5456 const U8 * e;
5457 CODE:
5458 if (type >= 0) {
5459 e = p + UTF8SKIP(p) - type;
5460 RETVAL = isALPHA_LC_utf8_safe(p, e);
5461 }
5462 else {
5463 RETVAL = 0;
5464 }
5465 OUTPUT:
5466 RETVAL
5467
5468 bool
5469 test_isWORDCHAR_uni(UV ord)
5470 CODE:
5471 RETVAL = isWORDCHAR_uni(ord);
5472 OUTPUT:
5473 RETVAL
5474
5475 bool
5476 test_isWORDCHAR_uvchr(UV ord)
5477 CODE:
5478 RETVAL = isWORDCHAR_uvchr(ord);
5479 OUTPUT:
5480 RETVAL
5481
5482 bool
5483 test_isWORDCHAR_LC_uvchr(UV ord)
5484 CODE:
5485 RETVAL = isWORDCHAR_LC_uvchr(ord);
5486 OUTPUT:
5487 RETVAL
5488
5489 bool
5490 test_isWORDCHAR(UV ord)
5491 CODE:
5492 RETVAL = isWORDCHAR(ord);
5493 OUTPUT:
5494 RETVAL
5495
5496 bool
5497 test_isWORDCHAR_A(UV ord)
5498 CODE:
5499 RETVAL = isWORDCHAR_A(ord);
5500 OUTPUT:
5501 RETVAL
5502
5503 bool
5504 test_isWORDCHAR_L1(UV ord)
5505 CODE:
5506 RETVAL = isWORDCHAR_L1(ord);
5507 OUTPUT:
5508 RETVAL
5509
5510 bool
5511 test_isWORDCHAR_LC(UV ord)
5512 CODE:
5513 RETVAL = isWORDCHAR_LC(ord);
5514 OUTPUT:
5515 RETVAL
5516
5517 bool
5518 test_isWORDCHAR_utf8(U8 * p, int type)
5519 PREINIT:
5520 const U8 * e;
5521 CODE:
5522 if (type >= 0) {
5523 e = p + UTF8SKIP(p) - type;
5524 RETVAL = isWORDCHAR_utf8_safe(p, e);
5525 }
5526 else {
5527 RETVAL = 0;
5528 }
5529 OUTPUT:
5530 RETVAL
5531
5532 bool
5533 test_isWORDCHAR_LC_utf8(U8 * p, int type)
5534 PREINIT:
5535 const U8 * e;
5536 CODE:
5537 if (type >= 0) {
5538 e = p + UTF8SKIP(p) - type;
5539 RETVAL = isWORDCHAR_LC_utf8_safe(p, e);
5540 }
5541 else {
5542 RETVAL = 0;
5543 }
5544 OUTPUT:
5545 RETVAL
5546
5547 bool
5548 test_isALPHANUMERIC_uni(UV ord)
5549 CODE:
5550 RETVAL = isALPHANUMERIC_uni(ord);
5551 OUTPUT:
5552 RETVAL
5553
5554 bool
5555 test_isALPHANUMERIC_uvchr(UV ord)
5556 CODE:
5557 RETVAL = isALPHANUMERIC_uvchr(ord);
5558 OUTPUT:
5559 RETVAL
5560
5561 bool
5562 test_isALPHANUMERIC_LC_uvchr(UV ord)
5563 CODE:
5564 RETVAL = isALPHANUMERIC_LC_uvchr(ord);
5565 OUTPUT:
5566 RETVAL
5567
5568 bool
5569 test_isALPHANUMERIC(UV ord)
5570 CODE:
5571 RETVAL = isALPHANUMERIC(ord);
5572 OUTPUT:
5573 RETVAL
5574
5575 bool
5576 test_isALPHANUMERIC_A(UV ord)
5577 CODE:
5578 RETVAL = isALPHANUMERIC_A(ord);
5579 OUTPUT:
5580 RETVAL
5581
5582 bool
5583 test_isALPHANUMERIC_L1(UV ord)
5584 CODE:
5585 RETVAL = isALPHANUMERIC_L1(ord);
5586 OUTPUT:
5587 RETVAL
5588
5589 bool
5590 test_isALPHANUMERIC_LC(UV ord)
5591 CODE:
5592 RETVAL = isALPHANUMERIC_LC(ord);
5593 OUTPUT:
5594 RETVAL
5595
5596 bool
5597 test_isALPHANUMERIC_utf8(U8 * p, int type)
5598 PREINIT:
5599 const U8 * e;
5600 CODE:
5601 if (type >= 0) {
5602 e = p + UTF8SKIP(p) - type;
5603 RETVAL = isALPHANUMERIC_utf8_safe(p, e);
5604 }
5605 else {
5606 RETVAL = 0;
5607 }
5608 OUTPUT:
5609 RETVAL
5610
5611 bool
5612 test_isALPHANUMERIC_LC_utf8(U8 * p, int type)
5613 PREINIT:
5614 const U8 * e;
5615 CODE:
5616 if (type >= 0) {
5617 e = p + UTF8SKIP(p) - type;
5618 RETVAL = isALPHANUMERIC_LC_utf8_safe(p, e);
5619 }
5620 else {
5621 RETVAL = 0;
5622 }
5623 OUTPUT:
5624 RETVAL
5625
5626 bool
5627 test_isALNUM(UV ord)
5628 CODE:
5629 RETVAL = isALNUM(ord);
5630 OUTPUT:
5631 RETVAL
5632
5633 bool
5634 test_isALNUM_uni(UV ord)
5635 CODE:
5636 RETVAL = isALNUM_uni(ord);
5637 OUTPUT:
5638 RETVAL
5639
5640 bool
5641 test_isALNUM_LC_uvchr(UV ord)
5642 CODE:
5643 RETVAL = isALNUM_LC_uvchr(ord);
5644 OUTPUT:
5645 RETVAL
5646
5647 bool
5648 test_isALNUM_LC(UV ord)
5649 CODE:
5650 RETVAL = isALNUM_LC(ord);
5651 OUTPUT:
5652 RETVAL
5653
5654 bool
5655 test_isALNUM_utf8(U8 * p, int type)
5656 PREINIT:
5657 const U8 * e;
5658 CODE:
5659 if (type >= 0) {
5660 e = p + UTF8SKIP(p) - type;
5661 RETVAL = isWORDCHAR_utf8_safe(p, e);
5662 }
5663 else {
5664 RETVAL = 0;
5665 }
5666 OUTPUT:
5667 RETVAL
5668
5669 bool
5670 test_isALNUM_LC_utf8(U8 * p, int type)
5671 PREINIT:
5672 const U8 * e;
5673 CODE:
5674 if (type >= 0) {
5675 e = p + UTF8SKIP(p) - type;
5676 RETVAL = isWORDCHAR_LC_utf8_safe(p, e);
5677 }
5678 else {
5679 RETVAL = 0;
5680 }
5681 OUTPUT:
5682 RETVAL
5683
5684 bool
5685 test_isDIGIT_uni(UV ord)
5686 CODE:
5687 RETVAL = isDIGIT_uni(ord);
5688 OUTPUT:
5689 RETVAL
5690
5691 bool
5692 test_isDIGIT_uvchr(UV ord)
5693 CODE:
5694 RETVAL = isDIGIT_uvchr(ord);
5695 OUTPUT:
5696 RETVAL
5697
5698 bool
5699 test_isDIGIT_LC_uvchr(UV ord)
5700 CODE:
5701 RETVAL = isDIGIT_LC_uvchr(ord);
5702 OUTPUT:
5703 RETVAL
5704
5705 bool
5706 test_isDIGIT_utf8(U8 * p, int type)
5707 PREINIT:
5708 const U8 * e;
5709 CODE:
5710 if (type >= 0) {
5711 e = p + UTF8SKIP(p) - type;
5712 RETVAL = isDIGIT_utf8_safe(p, e);
5713 }
5714 else {
5715 RETVAL = 0;
5716 }
5717 OUTPUT:
5718 RETVAL
5719
5720 bool
5721 test_isDIGIT_LC_utf8(U8 * p, int type)
5722 PREINIT:
5723 const U8 * e;
5724 CODE:
5725 if (type >= 0) {
5726 e = p + UTF8SKIP(p) - type;
5727 RETVAL = isDIGIT_LC_utf8_safe(p, e);
5728 }
5729 else {
5730 RETVAL = 0;
5731 }
5732 OUTPUT:
5733 RETVAL
5734
5735 bool
5736 test_isDIGIT(UV ord)
5737 CODE:
5738 RETVAL = isDIGIT(ord);
5739 OUTPUT:
5740 RETVAL
5741
5742 bool
5743 test_isDIGIT_A(UV ord)
5744 CODE:
5745 RETVAL = isDIGIT_A(ord);
5746 OUTPUT:
5747 RETVAL
5748
5749 bool
5750 test_isDIGIT_L1(UV ord)
5751 CODE:
5752 RETVAL = isDIGIT_L1(ord);
5753 OUTPUT:
5754 RETVAL
5755
5756 bool
5757 test_isDIGIT_LC(UV ord)
5758 CODE:
5759 RETVAL = isDIGIT_LC(ord);
5760 OUTPUT:
5761 RETVAL
5762
5763 bool
5764 test_isOCTAL(UV ord)
5765 CODE:
5766 RETVAL = isOCTAL(ord);
5767 OUTPUT:
5768 RETVAL
5769
5770 bool
5771 test_isOCTAL_A(UV ord)
5772 CODE:
5773 RETVAL = isOCTAL_A(ord);
5774 OUTPUT:
5775 RETVAL
5776
5777 bool
5778 test_isOCTAL_L1(UV ord)
5779 CODE:
5780 RETVAL = isOCTAL_L1(ord);
5781 OUTPUT:
5782 RETVAL
5783
5784 bool
5785 test_isIDFIRST_uni(UV ord)
5786 CODE:
5787 RETVAL = isIDFIRST_uni(ord);
5788 OUTPUT:
5789 RETVAL
5790
5791 bool
5792 test_isIDFIRST_uvchr(UV ord)
5793 CODE:
5794 RETVAL = isIDFIRST_uvchr(ord);
5795 OUTPUT:
5796 RETVAL
5797
5798 bool
5799 test_isIDFIRST_LC_uvchr(UV ord)
5800 CODE:
5801 RETVAL = isIDFIRST_LC_uvchr(ord);
5802 OUTPUT:
5803 RETVAL
5804
5805 bool
5806 test_isIDFIRST(UV ord)
5807 CODE:
5808 RETVAL = isIDFIRST(ord);
5809 OUTPUT:
5810 RETVAL
5811
5812 bool
5813 test_isIDFIRST_A(UV ord)
5814 CODE:
5815 RETVAL = isIDFIRST_A(ord);
5816 OUTPUT:
5817 RETVAL
5818
5819 bool
5820 test_isIDFIRST_L1(UV ord)
5821 CODE:
5822 RETVAL = isIDFIRST_L1(ord);
5823 OUTPUT:
5824 RETVAL
5825
5826 bool
5827 test_isIDFIRST_LC(UV ord)
5828 CODE:
5829 RETVAL = isIDFIRST_LC(ord);
5830 OUTPUT:
5831 RETVAL
5832
5833 bool
5834 test_isIDFIRST_utf8(U8 * p, int type)
5835 PREINIT:
5836 const U8 * e;
5837 CODE:
5838 if (type >= 0) {
5839 e = p + UTF8SKIP(p) - type;
5840 RETVAL = isIDFIRST_utf8_safe(p, e);
5841 }
5842 else {
5843 RETVAL = 0;
5844 }
5845 OUTPUT:
5846 RETVAL
5847
5848 bool
5849 test_isIDFIRST_LC_utf8(U8 * p, int type)
5850 PREINIT:
5851 const U8 * e;
5852 CODE:
5853 if (type >= 0) {
5854 e = p + UTF8SKIP(p) - type;
5855 RETVAL = isIDFIRST_LC_utf8_safe(p, e);
5856 }
5857 else {
5858 RETVAL = 0;
5859 }
5860 OUTPUT:
5861 RETVAL
5862
5863 bool
5864 test_isIDCONT_uni(UV ord)
5865 CODE:
5866 RETVAL = isIDCONT_uni(ord);
5867 OUTPUT:
5868 RETVAL
5869
5870 bool
5871 test_isIDCONT_uvchr(UV ord)
5872 CODE:
5873 RETVAL = isIDCONT_uvchr(ord);
5874 OUTPUT:
5875 RETVAL
5876
5877 bool
5878 test_isIDCONT_LC_uvchr(UV ord)
5879 CODE:
5880 RETVAL = isIDCONT_LC_uvchr(ord);
5881 OUTPUT:
5882 RETVAL
5883
5884 bool
5885 test_isIDCONT(UV ord)
5886 CODE:
5887 RETVAL = isIDCONT(ord);
5888 OUTPUT:
5889 RETVAL
5890
5891 bool
5892 test_isIDCONT_A(UV ord)
5893 CODE:
5894 RETVAL = isIDCONT_A(ord);
5895 OUTPUT:
5896 RETVAL
5897
5898 bool
5899 test_isIDCONT_L1(UV ord)
5900 CODE:
5901 RETVAL = isIDCONT_L1(ord);
5902 OUTPUT:
5903 RETVAL
5904
5905 bool
5906 test_isIDCONT_LC(UV ord)
5907 CODE:
5908 RETVAL = isIDCONT_LC(ord);
5909 OUTPUT:
5910 RETVAL
5911
5912 bool
5913 test_isIDCONT_utf8(U8 * p, int type)
5914 PREINIT:
5915 const U8 * e;
5916 CODE:
5917 if (type >= 0) {
5918 e = p + UTF8SKIP(p) - type;
5919 RETVAL = isIDCONT_utf8_safe(p, e);
5920 }
5921 else {
5922 RETVAL = 0;
5923 }
5924 OUTPUT:
5925 RETVAL
5926
5927 bool
5928 test_isIDCONT_LC_utf8(U8 * p, int type)
5929 PREINIT:
5930 const U8 * e;
5931 CODE:
5932 if (type >= 0) {
5933 e = p + UTF8SKIP(p) - type;
5934 RETVAL = isIDCONT_LC_utf8_safe(p, e);
5935 }
5936 else {
5937 RETVAL = 0;
5938 }
5939 OUTPUT:
5940 RETVAL
5941
5942 bool
5943 test_isSPACE_uni(UV ord)
5944 CODE:
5945 RETVAL = isSPACE_uni(ord);
5946 OUTPUT:
5947 RETVAL
5948
5949 bool
5950 test_isSPACE_uvchr(UV ord)
5951 CODE:
5952 RETVAL = isSPACE_uvchr(ord);
5953 OUTPUT:
5954 RETVAL
5955
5956 bool
5957 test_isSPACE_LC_uvchr(UV ord)
5958 CODE:
5959 RETVAL = isSPACE_LC_uvchr(ord);
5960 OUTPUT:
5961 RETVAL
5962
5963 bool
5964 test_isSPACE(UV ord)
5965 CODE:
5966 RETVAL = isSPACE(ord);
5967 OUTPUT:
5968 RETVAL
5969
5970 bool
5971 test_isSPACE_A(UV ord)
5972 CODE:
5973 RETVAL = isSPACE_A(ord);
5974 OUTPUT:
5975 RETVAL
5976
5977 bool
5978 test_isSPACE_L1(UV ord)
5979 CODE:
5980 RETVAL = isSPACE_L1(ord);
5981 OUTPUT:
5982 RETVAL
5983
5984 bool
5985 test_isSPACE_LC(UV ord)
5986 CODE:
5987 RETVAL = isSPACE_LC(ord);
5988 OUTPUT:
5989 RETVAL
5990
5991 bool
5992 test_isSPACE_utf8(U8 * p, int type)
5993 PREINIT:
5994 const U8 * e;
5995 CODE:
5996 if (type >= 0) {
5997 e = p + UTF8SKIP(p) - type;
5998 RETVAL = isSPACE_utf8_safe(p, e);
5999 }
6000 else {
6001 RETVAL = 0;
6002 }
6003 OUTPUT:
6004 RETVAL
6005
6006 bool
6007 test_isSPACE_LC_utf8(U8 * p, int type)
6008 PREINIT:
6009 const U8 * e;
6010 CODE:
6011 if (type >= 0) {
6012 e = p + UTF8SKIP(p) - type;
6013 RETVAL = isSPACE_LC_utf8_safe(p, e);
6014 }
6015 else {
6016 RETVAL = 0;
6017 }
6018 OUTPUT:
6019 RETVAL
6020
6021 bool
6022 test_isASCII_uni(UV ord)
6023 CODE:
6024 RETVAL = isASCII_uni(ord);
6025 OUTPUT:
6026 RETVAL
6027
6028 bool
6029 test_isASCII_uvchr(UV ord)
6030 CODE:
6031 RETVAL = isASCII_uvchr(ord);
6032 OUTPUT:
6033 RETVAL
6034
6035 bool
6036 test_isASCII_LC_uvchr(UV ord)
6037 CODE:
6038 RETVAL = isASCII_LC_uvchr(ord);
6039 OUTPUT:
6040 RETVAL
6041
6042 bool
6043 test_isASCII(UV ord)
6044 CODE:
6045 RETVAL = isASCII(ord);
6046 OUTPUT:
6047 RETVAL
6048
6049 bool
6050 test_isASCII_A(UV ord)
6051 CODE:
6052 RETVAL = isASCII_A(ord);
6053 OUTPUT:
6054 RETVAL
6055
6056 bool
6057 test_isASCII_L1(UV ord)
6058 CODE:
6059 RETVAL = isASCII_L1(ord);
6060 OUTPUT:
6061 RETVAL
6062
6063 bool
6064 test_isASCII_LC(UV ord)
6065 CODE:
6066 RETVAL = isASCII_LC(ord);
6067 OUTPUT:
6068 RETVAL
6069
6070 bool
6071 test_isASCII_utf8(U8 * p, int type)
6072 PREINIT:
6073 const U8 * e;
6074 CODE:
6075 #ifndef DEBUGGING
6076 PERL_UNUSED_VAR(e);
6077 #endif
6078 if (type >= 0) {
6079 e = p + UTF8SKIP(p) - type;
6080 RETVAL = isASCII_utf8_safe(p, e);
6081 }
6082 else {
6083 RETVAL = 0;
6084 }
6085 OUTPUT:
6086 RETVAL
6087
6088 bool
6089 test_isASCII_LC_utf8(U8 * p, int type)
6090 PREINIT:
6091 const U8 * e;
6092 CODE:
6093 #ifndef DEBUGGING
6094 PERL_UNUSED_VAR(e);
6095 #endif
6096 if (type >= 0) {
6097 e = p + UTF8SKIP(p) - type;
6098 RETVAL = isASCII_LC_utf8_safe(p, e);
6099 }
6100 else {
6101 RETVAL = 0;
6102 }
6103 OUTPUT:
6104 RETVAL
6105
6106 bool
6107 test_isCNTRL_uni(UV ord)
6108 CODE:
6109 RETVAL = isCNTRL_uni(ord);
6110 OUTPUT:
6111 RETVAL
6112
6113 bool
6114 test_isCNTRL_uvchr(UV ord)
6115 CODE:
6116 RETVAL = isCNTRL_uvchr(ord);
6117 OUTPUT:
6118 RETVAL
6119
6120 bool
6121 test_isCNTRL_LC_uvchr(UV ord)
6122 CODE:
6123 RETVAL = isCNTRL_LC_uvchr(ord);
6124 OUTPUT:
6125 RETVAL
6126
6127 bool
6128 test_isCNTRL(UV ord)
6129 CODE:
6130 RETVAL = isCNTRL(ord);
6131 OUTPUT:
6132 RETVAL
6133
6134 bool
6135 test_isCNTRL_A(UV ord)
6136 CODE:
6137 RETVAL = isCNTRL_A(ord);
6138 OUTPUT:
6139 RETVAL
6140
6141 bool
6142 test_isCNTRL_L1(UV ord)
6143 CODE:
6144 RETVAL = isCNTRL_L1(ord);
6145 OUTPUT:
6146 RETVAL
6147
6148 bool
6149 test_isCNTRL_LC(UV ord)
6150 CODE:
6151 RETVAL = isCNTRL_LC(ord);
6152 OUTPUT:
6153 RETVAL
6154
6155 bool
6156 test_isCNTRL_utf8(U8 * p, int type)
6157 PREINIT:
6158 const U8 * e;
6159 CODE:
6160 if (type >= 0) {
6161 e = p + UTF8SKIP(p) - type;
6162 RETVAL = isCNTRL_utf8_safe(p, e);
6163 }
6164 else {
6165 RETVAL = 0;
6166 }
6167 OUTPUT:
6168 RETVAL
6169
6170 bool
6171 test_isCNTRL_LC_utf8(U8 * p, int type)
6172 PREINIT:
6173 const U8 * e;
6174 CODE:
6175 if (type >= 0) {
6176 e = p + UTF8SKIP(p) - type;
6177 RETVAL = isCNTRL_LC_utf8_safe(p, e);
6178 }
6179 else {
6180 RETVAL = 0;
6181 }
6182 OUTPUT:
6183 RETVAL
6184
6185 bool
6186 test_isPRINT_uni(UV ord)
6187 CODE:
6188 RETVAL = isPRINT_uni(ord);
6189 OUTPUT:
6190 RETVAL
6191
6192 bool
6193 test_isPRINT_uvchr(UV ord)
6194 CODE:
6195 RETVAL = isPRINT_uvchr(ord);
6196 OUTPUT:
6197 RETVAL
6198
6199 bool
6200 test_isPRINT_LC_uvchr(UV ord)
6201 CODE:
6202 RETVAL = isPRINT_LC_uvchr(ord);
6203 OUTPUT:
6204 RETVAL
6205
6206 bool
6207 test_isPRINT(UV ord)
6208 CODE:
6209 RETVAL = isPRINT(ord);
6210 OUTPUT:
6211 RETVAL
6212
6213 bool
6214 test_isPRINT_A(UV ord)
6215 CODE:
6216 RETVAL = isPRINT_A(ord);
6217 OUTPUT:
6218 RETVAL
6219
6220 bool
6221 test_isPRINT_L1(UV ord)
6222 CODE:
6223 RETVAL = isPRINT_L1(ord);
6224 OUTPUT:
6225 RETVAL
6226
6227 bool
6228 test_isPRINT_LC(UV ord)
6229 CODE:
6230 RETVAL = isPRINT_LC(ord);
6231 OUTPUT:
6232 RETVAL
6233
6234 bool
6235 test_isPRINT_utf8(U8 * p, int type)
6236 PREINIT:
6237 const U8 * e;
6238 CODE:
6239 if (type >= 0) {
6240 e = p + UTF8SKIP(p) - type;
6241 RETVAL = isPRINT_utf8_safe(p, e);
6242 }
6243 else {
6244 RETVAL = 0;
6245 }
6246 OUTPUT:
6247 RETVAL
6248
6249 bool
6250 test_isPRINT_LC_utf8(U8 * p, int type)
6251 PREINIT:
6252 const U8 * e;
6253 CODE:
6254 if (type >= 0) {
6255 e = p + UTF8SKIP(p) - type;
6256 RETVAL = isPRINT_LC_utf8_safe(p, e);
6257 }
6258 else {
6259 RETVAL = 0;
6260 }
6261 OUTPUT:
6262 RETVAL
6263
6264 bool
6265 test_isGRAPH_uni(UV ord)
6266 CODE:
6267 RETVAL = isGRAPH_uni(ord);
6268 OUTPUT:
6269 RETVAL
6270
6271 bool
6272 test_isGRAPH_uvchr(UV ord)
6273 CODE:
6274 RETVAL = isGRAPH_uvchr(ord);
6275 OUTPUT:
6276 RETVAL
6277
6278 bool
6279 test_isGRAPH_LC_uvchr(UV ord)
6280 CODE:
6281 RETVAL = isGRAPH_LC_uvchr(ord);
6282 OUTPUT:
6283 RETVAL
6284
6285 bool
6286 test_isGRAPH(UV ord)
6287 CODE:
6288 RETVAL = isGRAPH(ord);
6289 OUTPUT:
6290 RETVAL
6291
6292 bool
6293 test_isGRAPH_A(UV ord)
6294 CODE:
6295 RETVAL = isGRAPH_A(ord);
6296 OUTPUT:
6297 RETVAL
6298
6299 bool
6300 test_isGRAPH_L1(UV ord)
6301 CODE:
6302 RETVAL = isGRAPH_L1(ord);
6303 OUTPUT:
6304 RETVAL
6305
6306 bool
6307 test_isGRAPH_LC(UV ord)
6308 CODE:
6309 RETVAL = isGRAPH_LC(ord);
6310 OUTPUT:
6311 RETVAL
6312
6313 bool
6314 test_isGRAPH_utf8(U8 * p, int type)
6315 PREINIT:
6316 const U8 * e;
6317 CODE:
6318 if (type >= 0) {
6319 e = p + UTF8SKIP(p) - type;
6320 RETVAL = isGRAPH_utf8_safe(p, e);
6321 }
6322 else {
6323 RETVAL = 0;
6324 }
6325 OUTPUT:
6326 RETVAL
6327
6328 bool
6329 test_isGRAPH_LC_utf8(U8 * p, int type)
6330 PREINIT:
6331 const U8 * e;
6332 CODE:
6333 if (type >= 0) {
6334 e = p + UTF8SKIP(p) - type;
6335 RETVAL = isGRAPH_LC_utf8_safe(p, e);
6336 }
6337 else {
6338 RETVAL = 0;
6339 }
6340 OUTPUT:
6341 RETVAL
6342
6343 bool
6344 test_isPUNCT_uni(UV ord)
6345 CODE:
6346 RETVAL = isPUNCT_uni(ord);
6347 OUTPUT:
6348 RETVAL
6349
6350 bool
6351 test_isPUNCT_uvchr(UV ord)
6352 CODE:
6353 RETVAL = isPUNCT_uvchr(ord);
6354 OUTPUT:
6355 RETVAL
6356
6357 bool
6358 test_isPUNCT_LC_uvchr(UV ord)
6359 CODE:
6360 RETVAL = isPUNCT_LC_uvchr(ord);
6361 OUTPUT:
6362 RETVAL
6363
6364 bool
6365 test_isPUNCT(UV ord)
6366 CODE:
6367 RETVAL = isPUNCT(ord);
6368 OUTPUT:
6369 RETVAL
6370
6371 bool
6372 test_isPUNCT_A(UV ord)
6373 CODE:
6374 RETVAL = isPUNCT_A(ord);
6375 OUTPUT:
6376 RETVAL
6377
6378 bool
6379 test_isPUNCT_L1(UV ord)
6380 CODE:
6381 RETVAL = isPUNCT_L1(ord);
6382 OUTPUT:
6383 RETVAL
6384
6385 bool
6386 test_isPUNCT_LC(UV ord)
6387 CODE:
6388 RETVAL = isPUNCT_LC(ord);
6389 OUTPUT:
6390 RETVAL
6391
6392 bool
6393 test_isPUNCT_utf8(U8 * p, int type)
6394 PREINIT:
6395 const U8 * e;
6396 CODE:
6397 if (type >= 0) {
6398 e = p + UTF8SKIP(p) - type;
6399 RETVAL = isPUNCT_utf8_safe(p, e);
6400 }
6401 else {
6402 RETVAL = 0;
6403 }
6404 OUTPUT:
6405 RETVAL
6406
6407 bool
6408 test_isPUNCT_LC_utf8(U8 * p, int type)
6409 PREINIT:
6410 const U8 * e;
6411 CODE:
6412 if (type >= 0) {
6413 e = p + UTF8SKIP(p) - type;
6414 RETVAL = isPUNCT_LC_utf8_safe(p, e);
6415 }
6416 else {
6417 RETVAL = 0;
6418 }
6419 OUTPUT:
6420 RETVAL
6421
6422 bool
6423 test_isXDIGIT_uni(UV ord)
6424 CODE:
6425 RETVAL = isXDIGIT_uni(ord);
6426 OUTPUT:
6427 RETVAL
6428
6429 bool
6430 test_isXDIGIT_uvchr(UV ord)
6431 CODE:
6432 RETVAL = isXDIGIT_uvchr(ord);
6433 OUTPUT:
6434 RETVAL
6435
6436 bool
6437 test_isXDIGIT_LC_uvchr(UV ord)
6438 CODE:
6439 RETVAL = isXDIGIT_LC_uvchr(ord);
6440 OUTPUT:
6441 RETVAL
6442
6443 bool
6444 test_isXDIGIT(UV ord)
6445 CODE:
6446 RETVAL = isXDIGIT(ord);
6447 OUTPUT:
6448 RETVAL
6449
6450 bool
6451 test_isXDIGIT_A(UV ord)
6452 CODE:
6453 RETVAL = isXDIGIT_A(ord);
6454 OUTPUT:
6455 RETVAL
6456
6457 bool
6458 test_isXDIGIT_L1(UV ord)
6459 CODE:
6460 RETVAL = isXDIGIT_L1(ord);
6461 OUTPUT:
6462 RETVAL
6463
6464 bool
6465 test_isXDIGIT_LC(UV ord)
6466 CODE:
6467 RETVAL = isXDIGIT_LC(ord);
6468 OUTPUT:
6469 RETVAL
6470
6471 bool
6472 test_isXDIGIT_utf8(U8 * p, int type)
6473 PREINIT:
6474 const U8 * e;
6475 CODE:
6476 if (type >= 0) {
6477 e = p + UTF8SKIP(p) - type;
6478 RETVAL = isXDIGIT_utf8_safe(p, e);
6479 }
6480 else {
6481 RETVAL = 0;
6482 }
6483 OUTPUT:
6484 RETVAL
6485
6486 bool
6487 test_isXDIGIT_LC_utf8(U8 * p, int type)
6488 PREINIT:
6489 const U8 * e;
6490 CODE:
6491 if (type >= 0) {
6492 e = p + UTF8SKIP(p) - type;
6493 RETVAL = isXDIGIT_LC_utf8_safe(p, e);
6494 }
6495 else {
6496 RETVAL = 0;
6497 }
6498 OUTPUT:
6499 RETVAL
6500
6501 bool
6502 test_isPSXSPC_uni(UV ord)
6503 CODE:
6504 RETVAL = isPSXSPC_uni(ord);
6505 OUTPUT:
6506 RETVAL
6507
6508 bool
6509 test_isPSXSPC_uvchr(UV ord)
6510 CODE:
6511 RETVAL = isPSXSPC_uvchr(ord);
6512 OUTPUT:
6513 RETVAL
6514
6515 bool
6516 test_isPSXSPC_LC_uvchr(UV ord)
6517 CODE:
6518 RETVAL = isPSXSPC_LC_uvchr(ord);
6519 OUTPUT:
6520 RETVAL
6521
6522 bool
6523 test_isPSXSPC(UV ord)
6524 CODE:
6525 RETVAL = isPSXSPC(ord);
6526 OUTPUT:
6527 RETVAL
6528
6529 bool
6530 test_isPSXSPC_A(UV ord)
6531 CODE:
6532 RETVAL = isPSXSPC_A(ord);
6533 OUTPUT:
6534 RETVAL
6535
6536 bool
6537 test_isPSXSPC_L1(UV ord)
6538 CODE:
6539 RETVAL = isPSXSPC_L1(ord);
6540 OUTPUT:
6541 RETVAL
6542
6543 bool
6544 test_isPSXSPC_LC(UV ord)
6545 CODE:
6546 RETVAL = isPSXSPC_LC(ord);
6547 OUTPUT:
6548 RETVAL
6549
6550 bool
6551 test_isPSXSPC_utf8(U8 * p, int type)
6552 PREINIT:
6553 const U8 * e;
6554 CODE:
6555 if (type >= 0) {
6556 e = p + UTF8SKIP(p) - type;
6557 RETVAL = isPSXSPC_utf8_safe(p, e);
6558 }
6559 else {
6560 RETVAL = 0;
6561 }
6562 OUTPUT:
6563 RETVAL
6564
6565 bool
6566 test_isPSXSPC_LC_utf8(U8 * p, int type)
6567 PREINIT:
6568 const U8 * e;
6569 CODE:
6570 if (type >= 0) {
6571 e = p + UTF8SKIP(p) - type;
6572 RETVAL = isPSXSPC_LC_utf8_safe(p, e);
6573 }
6574 else {
6575 RETVAL = 0;
6576 }
6577 OUTPUT:
6578 RETVAL
6579
6580 STRLEN
6581 test_UTF8_IS_REPLACEMENT(char *s, STRLEN len)
6582 CODE:
6583 RETVAL = UTF8_IS_REPLACEMENT(s, s + len);
6584 OUTPUT:
6585 RETVAL
6586
6587 bool
6588 test_isQUOTEMETA(UV ord)
6589 CODE:
6590 RETVAL = _isQUOTEMETA(ord);
6591 OUTPUT:
6592 RETVAL
6593
6594 UV
6595 test_OFFUNISKIP(UV ord)
6596 CODE:
6597 RETVAL = OFFUNISKIP(ord);
6598 OUTPUT:
6599 RETVAL
6600
6601 bool
6602 test_OFFUNI_IS_INVARIANT(UV ord)
6603 CODE:
6604 RETVAL = OFFUNI_IS_INVARIANT(ord);
6605 OUTPUT:
6606 RETVAL
6607
6608 bool
6609 test_UVCHR_IS_INVARIANT(UV ord)
6610 CODE:
6611 RETVAL = UVCHR_IS_INVARIANT(ord);
6612 OUTPUT:
6613 RETVAL
6614
6615 bool
6616 test_UTF8_IS_INVARIANT(char ch)
6617 CODE:
6618 RETVAL = UTF8_IS_INVARIANT(ch);
6619 OUTPUT:
6620 RETVAL
6621
6622 UV
6623 test_UVCHR_SKIP(UV ord)
6624 CODE:
6625 RETVAL = UVCHR_SKIP(ord);
6626 OUTPUT:
6627 RETVAL
6628
6629 UV
6630 test_UTF8_SKIP(char * ch)
6631 CODE:
6632 RETVAL = UTF8_SKIP(ch);
6633 OUTPUT:
6634 RETVAL
6635
6636 bool
6637 test_UTF8_IS_START(char ch)
6638 CODE:
6639 RETVAL = UTF8_IS_START(ch);
6640 OUTPUT:
6641 RETVAL
6642
6643 bool
6644 test_UTF8_IS_CONTINUATION(char ch)
6645 CODE:
6646 RETVAL = UTF8_IS_CONTINUATION(ch);
6647 OUTPUT:
6648 RETVAL
6649
6650 bool
6651 test_UTF8_IS_CONTINUED(char ch)
6652 CODE:
6653 RETVAL = UTF8_IS_CONTINUED(ch);
6654 OUTPUT:
6655 RETVAL
6656
6657 bool
6658 test_UTF8_IS_DOWNGRADEABLE_START(char ch)
6659 CODE:
6660 RETVAL = UTF8_IS_DOWNGRADEABLE_START(ch);
6661 OUTPUT:
6662 RETVAL
6663
6664 bool
6665 test_UTF8_IS_ABOVE_LATIN1(char ch)
6666 CODE:
6667 RETVAL = UTF8_IS_ABOVE_LATIN1(ch);
6668 OUTPUT:
6669 RETVAL
6670
6671 bool
6672 test_isUTF8_POSSIBLY_PROBLEMATIC(char ch)
6673 CODE:
6674 RETVAL = isUTF8_POSSIBLY_PROBLEMATIC(ch);
6675 OUTPUT:
6676 RETVAL
6677
6678 STRLEN
6679 test_isUTF8_CHAR(char *s, STRLEN len)
6680 CODE:
6681 RETVAL = isUTF8_CHAR((U8 *) s, (U8 *) s + len);
6682 OUTPUT:
6683 RETVAL
6684
6685 STRLEN
6686 test_isUTF8_CHAR_flags(char *s, STRLEN len, U32 flags)
6687 CODE:
6688 RETVAL = isUTF8_CHAR_flags((U8 *) s, (U8 *) s + len, flags);
6689 OUTPUT:
6690 RETVAL
6691
6692 STRLEN
6693 test_isSTRICT_UTF8_CHAR(char *s, STRLEN len)
6694 CODE:
6695 RETVAL = isSTRICT_UTF8_CHAR((U8 *) s, (U8 *) s + len);
6696 OUTPUT:
6697 RETVAL
6698
6699 STRLEN
6700 test_isC9_STRICT_UTF8_CHAR(char *s, STRLEN len)
6701 CODE:
6702 RETVAL = isC9_STRICT_UTF8_CHAR((U8 *) s, (U8 *) s + len);
6703 OUTPUT:
6704 RETVAL
6705
6706 IV
6707 test_is_utf8_valid_partial_char_flags(char *s, STRLEN len, U32 flags)
6708 CODE:
6709 /* RETVAL should be bool (here and in tests below), but making it IV
6710 * allows us to test it returning 0 or 1 */
6711 RETVAL = is_utf8_valid_partial_char_flags((U8 *) s, (U8 *) s + len, flags);
6712 OUTPUT:
6713 RETVAL
6714
6715 IV
6716 test_is_utf8_string(char *s, STRLEN len)
6717 CODE:
6718 RETVAL = is_utf8_string((U8 *) s, len);
6719 OUTPUT:
6720 RETVAL
6721
6722 #define WORDSIZE sizeof(PERL_UINTMAX_T)
6723
6724 AV *
6725 test_is_utf8_invariant_string_loc(U8 *s, STRLEN offset, STRLEN len)
6726 PREINIT:
6727 AV *av;
6728 const U8 * ep = NULL;
6729 PERL_UINTMAX_T* copy;
6730 CODE:
6731 /* 'offset' is number of bytes past a word boundary the testing of 's'
6732 * is to start at. Allocate space that does start at the word
6733 * boundary, and copy 's' to the correct offset past it. Then call the
6734 * tested function with that position */
6735 Newx(copy, 1 + ((len + WORDSIZE - 1) / WORDSIZE), PERL_UINTMAX_T);
6736 Copy(s, (U8 *) copy + offset, len, U8);
6737 av = newAV_alloc_x(2);
6738 av_push_simple(av, newSViv(is_utf8_invariant_string_loc((U8 *) copy + offset, len, &ep)));
6739 av_push_simple(av, newSViv(ep - ((U8 *) copy + offset)));
6740 RETVAL = av;
6741 Safefree(copy);
6742 OUTPUT:
6743 RETVAL
6744
6745 STRLEN
6746 test_variant_under_utf8_count(U8 *s, STRLEN offset, STRLEN len)
6747 PREINIT:
6748 PERL_UINTMAX_T * copy;
6749 CODE:
6750 Newx(copy, 1 + ((len + WORDSIZE - 1) / WORDSIZE), PERL_UINTMAX_T);
6751 Copy(s, (U8 *) copy + offset, len, U8);
6752 RETVAL = variant_under_utf8_count((U8 *) copy + offset, (U8 *) copy + offset + len);
6753 Safefree(copy);
6754 OUTPUT:
6755 RETVAL
6756
6757 STRLEN
6758 test_utf8_length(U8 *s, STRLEN offset, STRLEN len)
6759 CODE:
6760 RETVAL = utf8_length(s + offset, s + len);
6761 OUTPUT:
6762 RETVAL
6763
6764 AV *
6765 test_is_utf8_string_loc(char *s, STRLEN len)
6766 PREINIT:
6767 AV *av;
6768 const U8 * ep;
6769 CODE:
6770 av = newAV_alloc_x(2);
6771 av_push_simple(av, newSViv(is_utf8_string_loc((U8 *) s, len, &ep)));
6772 av_push_simple(av, newSViv(ep - (U8 *) s));
6773 RETVAL = av;
6774 OUTPUT:
6775 RETVAL
6776
6777 AV *
6778 test_is_utf8_string_loclen(char *s, STRLEN len)
6779 PREINIT:
6780 AV *av;
6781 STRLEN ret_len;
6782 const U8 * ep;
6783 CODE:
6784 av = newAV_alloc_x(3);
6785 av_push_simple(av, newSViv(is_utf8_string_loclen((U8 *) s, len, &ep, &ret_len)));
6786 av_push_simple(av, newSViv(ep - (U8 *) s));
6787 av_push_simple(av, newSVuv(ret_len));
6788 RETVAL = av;
6789 OUTPUT:
6790 RETVAL
6791
6792 IV
6793 test_is_utf8_string_flags(char *s, STRLEN len, U32 flags)
6794 CODE:
6795 RETVAL = is_utf8_string_flags((U8 *) s, len, flags);
6796 OUTPUT:
6797 RETVAL
6798
6799 AV *
6800 test_is_utf8_string_loc_flags(char *s, STRLEN len, U32 flags)
6801 PREINIT:
6802 AV *av;
6803 const U8 * ep;
6804 CODE:
6805 av = newAV_alloc_x(2);
6806 av_push_simple(av, newSViv(is_utf8_string_loc_flags((U8 *) s, len, &ep, flags)));
6807 av_push_simple(av, newSViv(ep - (U8 *) s));
6808 RETVAL = av;
6809 OUTPUT:
6810 RETVAL
6811
6812 AV *
6813 test_is_utf8_string_loclen_flags(char *s, STRLEN len, U32 flags)
6814 PREINIT:
6815 AV *av;
6816 STRLEN ret_len;
6817 const U8 * ep;
6818 CODE:
6819 av = newAV_alloc_x(3);
6820 av_push_simple(av, newSViv(is_utf8_string_loclen_flags((U8 *) s, len, &ep, &ret_len, flags)));
6821 av_push_simple(av, newSViv(ep - (U8 *) s));
6822 av_push_simple(av, newSVuv(ret_len));
6823 RETVAL = av;
6824 OUTPUT:
6825 RETVAL
6826
6827 IV
6828 test_is_strict_utf8_string(char *s, STRLEN len)
6829 CODE:
6830 RETVAL = is_strict_utf8_string((U8 *) s, len);
6831 OUTPUT:
6832 RETVAL
6833
6834 AV *
6835 test_is_strict_utf8_string_loc(char *s, STRLEN len)
6836 PREINIT:
6837 AV *av;
6838 const U8 * ep;
6839 CODE:
6840 av = newAV_alloc_x(2);
6841 av_push_simple(av, newSViv(is_strict_utf8_string_loc((U8 *) s, len, &ep)));
6842 av_push_simple(av, newSViv(ep - (U8 *) s));
6843 RETVAL = av;
6844 OUTPUT:
6845 RETVAL
6846
6847 AV *
6848 test_is_strict_utf8_string_loclen(char *s, STRLEN len)
6849 PREINIT:
6850 AV *av;
6851 STRLEN ret_len;
6852 const U8 * ep;
6853 CODE:
6854 av = newAV_alloc_x(3);
6855 av_push_simple(av, newSViv(is_strict_utf8_string_loclen((U8 *) s, len, &ep, &ret_len)));
6856 av_push_simple(av, newSViv(ep - (U8 *) s));
6857 av_push_simple(av, newSVuv(ret_len));
6858 RETVAL = av;
6859 OUTPUT:
6860 RETVAL
6861
6862 IV
6863 test_is_c9strict_utf8_string(char *s, STRLEN len)
6864 CODE:
6865 RETVAL = is_c9strict_utf8_string((U8 *) s, len);
6866 OUTPUT:
6867 RETVAL
6868
6869 AV *
6870 test_is_c9strict_utf8_string_loc(char *s, STRLEN len)
6871 PREINIT:
6872 AV *av;
6873 const U8 * ep;
6874 CODE:
6875 av = newAV_alloc_x(2);
6876 av_push_simple(av, newSViv(is_c9strict_utf8_string_loc((U8 *) s, len, &ep)));
6877 av_push_simple(av, newSViv(ep - (U8 *) s));
6878 RETVAL = av;
6879 OUTPUT:
6880 RETVAL
6881
6882 AV *
6883 test_is_c9strict_utf8_string_loclen(char *s, STRLEN len)
6884 PREINIT:
6885 AV *av;
6886 STRLEN ret_len;
6887 const U8 * ep;
6888 CODE:
6889 av = newAV_alloc_x(3);
6890 av_push_simple(av, newSViv(is_c9strict_utf8_string_loclen((U8 *) s, len, &ep, &ret_len)));
6891 av_push_simple(av, newSViv(ep - (U8 *) s));
6892 av_push_simple(av, newSVuv(ret_len));
6893 RETVAL = av;
6894 OUTPUT:
6895 RETVAL
6896
6897 IV
6898 test_is_utf8_fixed_width_buf_flags(char *s, STRLEN len, U32 flags)
6899 CODE:
6900 RETVAL = is_utf8_fixed_width_buf_flags((U8 *) s, len, flags);
6901 OUTPUT:
6902 RETVAL
6903
6904 AV *
6905 test_is_utf8_fixed_width_buf_loc_flags(char *s, STRLEN len, U32 flags)
6906 PREINIT:
6907 AV *av;
6908 const U8 * ep;
6909 CODE:
6910 av = newAV_alloc_x(2);
6911 av_push_simple(av, newSViv(is_utf8_fixed_width_buf_loc_flags((U8 *) s, len, &ep, flags)));
6912 av_push_simple(av, newSViv(ep - (U8 *) s));
6913 RETVAL = av;
6914 OUTPUT:
6915 RETVAL
6916
6917 AV *
6918 test_is_utf8_fixed_width_buf_loclen_flags(char *s, STRLEN len, U32 flags)
6919 PREINIT:
6920 AV *av;
6921 STRLEN ret_len;
6922 const U8 * ep;
6923 CODE:
6924 av = newAV_alloc_x(3);
6925 av_push_simple(av, newSViv(is_utf8_fixed_width_buf_loclen_flags((U8 *) s, len, &ep, &ret_len, flags)));
6926 av_push_simple(av, newSViv(ep - (U8 *) s));
6927 av_push_simple(av, newSVuv(ret_len));
6928 RETVAL = av;
6929 OUTPUT:
6930 RETVAL
6931
6932 IV
6933 test_utf8_hop_safe(SV *s_sv, STRLEN s_off, IV hop)
6934 PREINIT:
6935 STRLEN len;
6936 U8 *p;
6937 U8 *r;
6938 CODE:
6939 p = (U8 *)SvPV(s_sv, len);
6940 r = utf8_hop_safe(p + s_off, hop, p, p + len);
6941 RETVAL = r - p;
6942 OUTPUT:
6943 RETVAL
6944
6945 UV
6946 test_toLOWER(UV ord)
6947 CODE:
6948 RETVAL = toLOWER(ord);
6949 OUTPUT:
6950 RETVAL
6951
6952 UV
6953 test_toLOWER_L1(UV ord)
6954 CODE:
6955 RETVAL = toLOWER_L1(ord);
6956 OUTPUT:
6957 RETVAL
6958
6959 UV
6960 test_toLOWER_LC(UV ord)
6961 CODE:
6962 RETVAL = toLOWER_LC(ord);
6963 OUTPUT:
6964 RETVAL
6965
6966 AV *
6967 test_toLOWER_uni(UV ord)
6968 PREINIT:
6969 U8 s[UTF8_MAXBYTES_CASE + 1];
6970 STRLEN len;
6971 AV *av;
6972 SV *utf8;
6973 CODE:
6974 av = newAV_alloc_x(3);
6975 av_push_simple(av, newSVuv(toLOWER_uni(ord, s, &len)));
6976
6977 utf8 = newSVpvn((char *) s, len);
6978 SvUTF8_on(utf8);
6979 av_push_simple(av, utf8);
6980
6981 av_push_simple(av, newSVuv(len));
6982 RETVAL = av;
6983 OUTPUT:
6984 RETVAL
6985
6986 AV *
6987 test_toLOWER_uvchr(UV ord)
6988 PREINIT:
6989 U8 s[UTF8_MAXBYTES_CASE + 1];
6990 STRLEN len;
6991 AV *av;
6992 SV *utf8;
6993 CODE:
6994 av = newAV_alloc_x(3);
6995 av_push_simple(av, newSVuv(toLOWER_uvchr(ord, s, &len)));
6996
6997 utf8 = newSVpvn((char *) s, len);
6998 SvUTF8_on(utf8);
6999 av_push_simple(av, utf8);
7000
7001 av_push_simple(av, newSVuv(len));
7002 RETVAL = av;
7003 OUTPUT:
7004 RETVAL
7005
7006 AV *
7007 test_toLOWER_utf8(SV * p, int type)
7008 PREINIT:
7009 U8 *input;
7010 U8 s[UTF8_MAXBYTES_CASE + 1];
7011 STRLEN len;
7012 AV *av;
7013 SV *utf8;
7014 const U8 * e;
7015 UV resultant_cp = UV_MAX; /* Initialized because of dumb compilers */
7016 CODE:
7017 input = (U8 *) SvPV(p, len);
7018 if (type >= 0) {
7019 av = newAV_alloc_x(3);
7020 e = input + UTF8SKIP(input) - type;
7021 resultant_cp = toLOWER_utf8_safe(input, e, s, &len);
7022 av_push_simple(av, newSVuv(resultant_cp));
7023
7024 utf8 = newSVpvn((char *) s, len);
7025 SvUTF8_on(utf8);
7026 av_push_simple(av, utf8);
7027
7028 av_push_simple(av, newSVuv(len));
7029 RETVAL = av;
7030 }
7031 else {
7032 RETVAL = 0;
7033 }
7034 OUTPUT:
7035 RETVAL
7036
7037 UV
7038 test_toFOLD(UV ord)
7039 CODE:
7040 RETVAL = toFOLD(ord);
7041 OUTPUT:
7042 RETVAL
7043
7044 UV
7045 test_toFOLD_LC(UV ord)
7046 CODE:
7047 RETVAL = toFOLD_LC(ord);
7048 OUTPUT:
7049 RETVAL
7050
7051 AV *
7052 test_toFOLD_uni(UV ord)
7053 PREINIT:
7054 U8 s[UTF8_MAXBYTES_CASE + 1];
7055 STRLEN len;
7056 AV *av;
7057 SV *utf8;
7058 CODE:
7059 av = newAV_alloc_x(3);
7060 av_push_simple(av, newSVuv(toFOLD_uni(ord, s, &len)));
7061
7062 utf8 = newSVpvn((char *) s, len);
7063 SvUTF8_on(utf8);
7064 av_push_simple(av, utf8);
7065
7066 av_push_simple(av, newSVuv(len));
7067 RETVAL = av;
7068 OUTPUT:
7069 RETVAL
7070
7071 AV *
7072 test_toFOLD_uvchr(UV ord)
7073 PREINIT:
7074 U8 s[UTF8_MAXBYTES_CASE + 1];
7075 STRLEN len;
7076 AV *av;
7077 SV *utf8;
7078 CODE:
7079 av = newAV_alloc_x(3);
7080 av_push_simple(av, newSVuv(toFOLD_uvchr(ord, s, &len)));
7081
7082 utf8 = newSVpvn((char *) s, len);
7083 SvUTF8_on(utf8);
7084 av_push_simple(av, utf8);
7085
7086 av_push_simple(av, newSVuv(len));
7087 RETVAL = av;
7088 OUTPUT:
7089 RETVAL
7090
7091 AV *
7092 test_toFOLD_utf8(SV * p, int type)
7093 PREINIT:
7094 U8 *input;
7095 U8 s[UTF8_MAXBYTES_CASE + 1];
7096 STRLEN len;
7097 AV *av;
7098 SV *utf8;
7099 const U8 * e;
7100 UV resultant_cp = UV_MAX;
7101 CODE:
7102 input = (U8 *) SvPV(p, len);
7103 if (type >= 0) {
7104 av = newAV_alloc_x(3);
7105 e = input + UTF8SKIP(input) - type;
7106 resultant_cp = toFOLD_utf8_safe(input, e, s, &len);
7107 av_push_simple(av, newSVuv(resultant_cp));
7108
7109 utf8 = newSVpvn((char *) s, len);
7110 SvUTF8_on(utf8);
7111 av_push_simple(av, utf8);
7112
7113 av_push_simple(av, newSVuv(len));
7114 RETVAL = av;
7115 }
7116 else {
7117 RETVAL = 0;
7118 }
7119 OUTPUT:
7120 RETVAL
7121
7122 UV
7123 test_toUPPER(UV ord)
7124 CODE:
7125 RETVAL = toUPPER(ord);
7126 OUTPUT:
7127 RETVAL
7128
7129 UV
7130 test_toUPPER_LC(UV ord)
7131 CODE:
7132 RETVAL = toUPPER_LC(ord);
7133 OUTPUT:
7134 RETVAL
7135
7136 AV *
7137 test_toUPPER_uni(UV ord)
7138 PREINIT:
7139 U8 s[UTF8_MAXBYTES_CASE + 1];
7140 STRLEN len;
7141 AV *av;
7142 SV *utf8;
7143 CODE:
7144 av = newAV_alloc_x(3);
7145 av_push_simple(av, newSVuv(toUPPER_uni(ord, s, &len)));
7146
7147 utf8 = newSVpvn((char *) s, len);
7148 SvUTF8_on(utf8);
7149 av_push_simple(av, utf8);
7150
7151 av_push_simple(av, newSVuv(len));
7152 RETVAL = av;
7153 OUTPUT:
7154 RETVAL
7155
7156 AV *
7157 test_toUPPER_uvchr(UV ord)
7158 PREINIT:
7159 U8 s[UTF8_MAXBYTES_CASE + 1];
7160 STRLEN len;
7161 AV *av;
7162 SV *utf8;
7163 CODE:
7164 av = newAV_alloc_x(3);
7165 av_push_simple(av, newSVuv(toUPPER_uvchr(ord, s, &len)));
7166
7167 utf8 = newSVpvn((char *) s, len);
7168 SvUTF8_on(utf8);
7169 av_push_simple(av, utf8);
7170
7171 av_push_simple(av, newSVuv(len));
7172 RETVAL = av;
7173 OUTPUT:
7174 RETVAL
7175
7176 AV *
7177 test_toUPPER_utf8(SV * p, int type)
7178 PREINIT:
7179 U8 *input;
7180 U8 s[UTF8_MAXBYTES_CASE + 1];
7181 STRLEN len;
7182 AV *av;
7183 SV *utf8;
7184 const U8 * e;
7185 UV resultant_cp = UV_MAX;
7186 CODE:
7187 input = (U8 *) SvPV(p, len);
7188 if (type >= 0) {
7189 av = newAV_alloc_x(3);
7190 e = input + UTF8SKIP(input) - type;
7191 resultant_cp = toUPPER_utf8_safe(input, e, s, &len);
7192 av_push_simple(av, newSVuv(resultant_cp));
7193
7194 utf8 = newSVpvn((char *) s, len);
7195 SvUTF8_on(utf8);
7196 av_push_simple(av, utf8);
7197
7198 av_push_simple(av, newSVuv(len));
7199 RETVAL = av;
7200 }
7201 else {
7202 RETVAL = 0;
7203 }
7204 OUTPUT:
7205 RETVAL
7206
7207 UV
7208 test_toTITLE(UV ord)
7209 CODE:
7210 RETVAL = toTITLE(ord);
7211 OUTPUT:
7212 RETVAL
7213
7214 AV *
7215 test_toTITLE_uni(UV ord)
7216 PREINIT:
7217 U8 s[UTF8_MAXBYTES_CASE + 1];
7218 STRLEN len;
7219 AV *av;
7220 SV *utf8;
7221 CODE:
7222 av = newAV_alloc_x(3);
7223 av_push_simple(av, newSVuv(toTITLE_uni(ord, s, &len)));
7224
7225 utf8 = newSVpvn((char *) s, len);
7226 SvUTF8_on(utf8);
7227 av_push_simple(av, utf8);
7228
7229 av_push_simple(av, newSVuv(len));
7230 RETVAL = av;
7231 OUTPUT:
7232 RETVAL
7233
7234 AV *
7235 test_toTITLE_uvchr(UV ord)
7236 PREINIT:
7237 U8 s[UTF8_MAXBYTES_CASE + 1];
7238 STRLEN len;
7239 AV *av;
7240 SV *utf8;
7241 CODE:
7242 av = newAV_alloc_x(3);
7243 av_push_simple(av, newSVuv(toTITLE_uvchr(ord, s, &len)));
7244
7245 utf8 = newSVpvn((char *) s, len);
7246 SvUTF8_on(utf8);
7247 av_push_simple(av, utf8);
7248
7249 av_push_simple(av, newSVuv(len));
7250 RETVAL = av;
7251 OUTPUT:
7252 RETVAL
7253
7254 AV *
7255 test_toTITLE_utf8(SV * p, int type)
7256 PREINIT:
7257 U8 *input;
7258 U8 s[UTF8_MAXBYTES_CASE + 1];
7259 STRLEN len;
7260 AV *av;
7261 SV *utf8;
7262 const U8 * e;
7263 UV resultant_cp = UV_MAX;
7264 CODE:
7265 input = (U8 *) SvPV(p, len);
7266 if (type >= 0) {
7267 av = newAV_alloc_x(3);
7268 e = input + UTF8SKIP(input) - type;
7269 resultant_cp = toTITLE_utf8_safe(input, e, s, &len);
7270 av_push_simple(av, newSVuv(resultant_cp));
7271
7272 utf8 = newSVpvn((char *) s, len);
7273 SvUTF8_on(utf8);
7274 av_push_simple(av, utf8);
7275
7276 av_push_simple(av, newSVuv(len));
7277 RETVAL = av;
7278 }
7279 else {
7280 RETVAL = 0;
7281 }
7282 OUTPUT:
7283 RETVAL
7284
7285 AV *
7286 test_delimcpy(SV * from_sv, STRLEN trunc_from, char delim, STRLEN to_len, STRLEN trunc_to, char poison = '?')
7287 PREINIT:
7288 char * from;
7289 I32 retlen;
7290 char * from_pos_after_copy;
7291 char * to;
7292 CODE:
7293 from = SvPV_nolen(from_sv);
7294 Newx(to, to_len, char);
7295 PoisonWith(to, to_len, char, poison);
7296 assert(trunc_from <= SvCUR(from_sv));
7297 /* trunc_to allows us to throttle the output size available */
7298 assert(trunc_to <= to_len);
7299 from_pos_after_copy = delimcpy(to, to + trunc_to,
7300 from, from + trunc_from,
7301 delim, &retlen);
7302 RETVAL = newAV_mortal();
7303 av_push_simple(RETVAL, newSVpvn(to, to_len));
7304 av_push_simple(RETVAL, newSVuv(retlen));
7305 av_push_simple(RETVAL, newSVuv(from_pos_after_copy - from));
7306 Safefree(to);
7307 OUTPUT:
7308 RETVAL
7309
7310 AV *
7311 test_delimcpy_no_escape(SV * from_sv, STRLEN trunc_from, char delim, STRLEN to_len, STRLEN trunc_to, char poison = '?')
7312 PREINIT:
7313 char * from;
7314 AV *av;
7315 I32 retlen;
7316 char * from_pos_after_copy;
7317 char * to;
7318 CODE:
7319 from = SvPV_nolen(from_sv);
7320 Newx(to, to_len, char);
7321 PoisonWith(to, to_len, char, poison);
7322 assert(trunc_from <= SvCUR(from_sv));
7323 /* trunc_to allows us to throttle the output size available */
7324 assert(trunc_to <= to_len);
7325 from_pos_after_copy = delimcpy_no_escape(to, to + trunc_to,
7326 from, from + trunc_from,
7327 delim, &retlen);
7328 av = newAV_alloc_x(3);
7329 av_push_simple(av, newSVpvn(to, to_len));
7330 av_push_simple(av, newSVuv(retlen));
7331 av_push_simple(av, newSVuv(from_pos_after_copy - from));
7332 Safefree(to);
7333 RETVAL = av;
7334 OUTPUT:
7335 RETVAL
7336
7337 SV *
7338 test_Gconvert(SV * number, SV * num_digits)
7339 PREINIT:
7340 char buffer[100];
7341 int len;
7342 int extras;
7343 CODE:
7344 len = (int) SvIV(num_digits);
7345 /* To silence a -Wformat-overflow compiler warning we *
7346 * make allowance for the following characters that may *
7347 * appear, in addition to the digits of the significand: *
7348 * a leading "-", a single byte radix point, "e-", the *
7349 * terminating NULL, and a 3 or 4 digit exponent. *
7350 * Ie, allow 8 bytes if nvtype is "double", otherwise 9 *
7351 * bytes (as the exponent could then contain 4 digits ). */
7352 extras = sizeof(NV) == 8 ? 8 : 9;
7353 if(len > 100 - extras)
7354 croak("Too long a number for test_Gconvert");
7355 if (len < 0)
7356 croak("Too short a number for test_Gconvert");
7357 PERL_UNUSED_RESULT(Gconvert(SvNV(number), len,
7358 0, /* No trailing zeroes */
7359 buffer));
7360 RETVAL = newSVpv(buffer, 0);
7361 OUTPUT:
7362 RETVAL
7363
7364 SV *
7365 test_Perl_langinfo(SV * item)
7366 CODE:
7367 RETVAL = newSVpv(Perl_langinfo(SvIV(item)), 0);
7368 OUTPUT:
7369 RETVAL
7370
7371 SV *
7372 gimme()
7373 CODE:
7374 /* facilitate tests that GIMME_V gives the right result
7375 * in XS calls */
7376 int gimme = GIMME_V;
7377 SV* sv = get_sv("XS::APItest::GIMME_V", GV_ADD);
7378 sv_setiv_mg(sv, (IV)gimme);
7379 RETVAL = &PL_sv_undef;
7380 OUTPUT:
7381 RETVAL
7382
7383
7384 MODULE = XS::APItest PACKAGE = XS::APItest::Backrefs
7385
7386 void
7387 apitest_weaken(SV *sv)
7388 PROTOTYPE: $
7389 CODE:
7390 sv_rvweaken(sv);
7391
7392 SV *
7393 has_backrefs(SV *sv)
7394 CODE:
7395 if (SvROK(sv) && sv_get_backrefs(SvRV(sv)))
7396 RETVAL = &PL_sv_yes;
7397 else
7398 RETVAL = &PL_sv_no;
7399 OUTPUT:
7400 RETVAL
7401
7402 #ifdef WIN32
7403 #ifdef PERL_IMPLICIT_SYS
7404
7405 const char *
7406 PerlDir_mapA(const char *path)
7407
7408 const WCHAR *
7409 PerlDir_mapW(const WCHAR *wpath)
7410
7411 #endif
7412
7413 void
7414 Comctl32Version()
7415 PREINIT:
7416 HMODULE dll;
7417 VS_FIXEDFILEINFO *info;
7418 UINT len;
7419 HRSRC hrsc;
7420 HGLOBAL ver;
7421 void * vercopy;
7422 PPCODE:
7423 dll = GetModuleHandle("comctl32.dll"); /* must already be in proc */
7424 if(!dll)
7425 croak("Comctl32Version: comctl32.dll not in process???");
7426 hrsc = FindResource(dll, MAKEINTRESOURCE(VS_VERSION_INFO),
7427 MAKEINTRESOURCE((Size_t)VS_FILE_INFO));
7428 if(!hrsc)
7429 croak("Comctl32Version: comctl32.dll no version???");
7430 ver = LoadResource(dll, hrsc);
7431 len = SizeofResource(dll, hrsc);
7432 vercopy = (void *)sv_grow(sv_newmortal(),len);
7433 memcpy(vercopy, ver, len);
7434 if (VerQueryValue(vercopy, "\\", (void**)&info, &len)) {
7435 int dwValueMS1 = (info->dwFileVersionMS>>16);
7436 int dwValueMS2 = (info->dwFileVersionMS&0xffff);
7437 int dwValueLS1 = (info->dwFileVersionLS>>16);
7438 int dwValueLS2 = (info->dwFileVersionLS&0xffff);
7439 EXTEND(SP, 4);
7440 mPUSHi(dwValueMS1);
7441 mPUSHi(dwValueMS2);
7442 mPUSHi(dwValueLS1);
7443 mPUSHi(dwValueLS2);
7444 }
7445
7446 #endif
7447
7448
7449 MODULE = XS::APItest PACKAGE = XS::APItest::RWMacro
7450
7451 #if defined(USE_ITHREADS)
7452
7453 void
7454 compile_macros()
7455 PREINIT:
7456 perl_RnW1_mutex_t m;
7457 perl_RnW1_mutex_t *pm = &m;
7458 CODE:
7459 PERL_RW_MUTEX_INIT(&m);
7460 PERL_WRITE_LOCK(&m);
7461 PERL_WRITE_UNLOCK(&m);
7462 PERL_READ_LOCK(&m);
7463 PERL_READ_UNLOCK(&m);
7464 PERL_RW_MUTEX_DESTROY(&m);
7465 PERL_RW_MUTEX_INIT(pm);
7466 PERL_WRITE_LOCK(pm);
7467 PERL_WRITE_UNLOCK(pm);
7468 PERL_READ_LOCK(pm);
7469 PERL_READ_UNLOCK(pm);
7470 PERL_RW_MUTEX_DESTROY(pm);
7471
7472 #endif
7473
7474 MODULE = XS::APItest PACKAGE = XS::APItest::HvMacro
7475
7476
7477 UV
u8_to_u16_le(SV * sv,STRLEN ofs)7478 u8_to_u16_le(SV *sv, STRLEN ofs)
7479 ALIAS:
7480 u8_to_u32_le = 1
7481 u8_to_u64_le = 2
7482 CODE:
7483 {
7484 STRLEN len;
7485 char *pv= SvPV(sv,len);
7486 STRLEN minlen= 2<<ix;
7487 U16 u16;
7488 U32 u32;
7489 U64 u64;
7490 RETVAL= 0; /* silence warnings about uninitialized RETVAL */
7491 switch (ix) {
7492 case 0:
7493 if (ofs+minlen>len) croak("cowardly refusing to read past end of string in u8_to_u16_le");
7494 u16= U8TO16_LE(pv+ofs);
7495 RETVAL= (UV)u16;
7496 break;
7497 case 1:
7498 if (ofs+minlen>len) croak("cowardly refusing to read past end of string in u8_to_u32_le");
7499 u32= U8TO32_LE(pv+ofs);
7500 RETVAL= (UV)u32;
7501 break;
7502 case 2:
7503 #if TEST_64BIT
7504 if (ofs+minlen>len) croak("cowardly refusing to read past end of string in u8_to_u64_le");
7505 u64= U8TO64_LE(pv+ofs);
7506 RETVAL= (UV)u64;
7507 #else
7508 PERL_UNUSED_VAR(u64);
7509 croak("not a 64 bit perl IVSIZE=%d",IVSIZE);
7510 #endif
7511 break;
7512 }
7513 }
7514 OUTPUT:
7515 RETVAL
7516
7517 U32
rotl32(U32 n,U8 r)7518 rotl32(U32 n, U8 r)
7519 CODE:
7520 {
7521 RETVAL= ROTL32(n,r);
7522 }
7523 OUTPUT:
7524 RETVAL
7525
7526 U32
rotr32(U32 n,U8 r)7527 rotr32(U32 n, U8 r)
7528 CODE:
7529 {
7530 RETVAL= ROTR32(n,r);
7531 }
7532 OUTPUT:
7533 RETVAL
7534
7535 #if TEST_64BIT
7536
7537 UV
rotl64(UV n,U8 r)7538 rotl64(UV n, U8 r)
7539 CODE:
7540 {
7541 RETVAL= ROTL64(n,r);
7542 }
7543 OUTPUT:
7544 RETVAL
7545
7546 UV
rotr64(UV n,U8 r)7547 rotr64(UV n, U8 r)
7548 CODE:
7549 {
7550 RETVAL= ROTR64(n,r);
7551 }
7552 OUTPUT:
7553 RETVAL
7554
7555 SV *
siphash_seed_state(SV * seed_sv)7556 siphash_seed_state(SV *seed_sv)
7557 CODE:
7558 {
7559 U8 state_buf[sizeof(U64)*4];
7560 STRLEN seed_len;
7561 U8 *seed_pv= (U8*)SvPV(seed_sv,seed_len);
7562 if (seed_len<16) croak("seed should be 16 bytes long");
7563 else if (seed_len>16) warn("only using the first 16 bytes of seed");
7564 RETVAL= newSV(sizeof(U64)*4+3);
7565 S_perl_siphash_seed_state(seed_pv,state_buf);
7566 sv_setpvn(RETVAL,(char*)state_buf,sizeof(U64)*4);
7567 }
7568 OUTPUT:
7569 RETVAL
7570
7571
7572 UV
siphash24(SV * state_sv,SV * str_sv)7573 siphash24(SV *state_sv, SV *str_sv)
7574 ALIAS:
7575 siphash13 = 1
7576 CODE:
7577 {
7578 STRLEN state_len;
7579 STRLEN str_len;
7580 U8 *str_pv= (U8*)SvPV(str_sv,str_len);
7581 /* (U8*)SvPV(state_sv, state_len) return differs between little-endian *
7582 * and big-endian. It's the same values, but in a different order. *
7583 * On big-endian architecture, we transpose the values into the same *
7584 * order as for little-endian, so that we can test against the same *
7585 * test vectors. *
7586 * We could alternatively alter the code that produced state_sv to *
7587 * output identical arrangements for big-endian and little-endian. */
7588 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
7589 U8 *state_pv= (U8*)SvPV(state_sv,state_len);
7590 if (state_len!=32) croak("siphash state should be exactly 32 bytes");
7591 #else
7592 U8 *temp_pv = (U8*)SvPV(state_sv, state_len);
7593 U8 state_pv[32];
7594 int i;
7595 if (state_len!=32) croak("siphash state should be exactly 32 bytes");
7596 for( i = 0; i < 32; i++ ) {
7597 if (i < 8) state_pv[ 7 - i] = temp_pv[i];
7598 else if(i < 16) state_pv[23 - i] = temp_pv[i];
7599 else if(i < 24) state_pv[39 - i] = temp_pv[i];
7600 else state_pv[55 - i] = temp_pv[i];
7601 }
7602 #endif
7603 if (ix) {
7604 RETVAL= S_perl_hash_siphash_1_3_with_state_64(state_pv,str_pv,str_len);
7605 } else {
7606 RETVAL= S_perl_hash_siphash_2_4_with_state_64(state_pv,str_pv,str_len);
7607 }
7608 }
7609 OUTPUT:
7610 RETVAL
7611
7612
7613 UV
test_siphash24()7614 test_siphash24()
7615 CODE:
7616 {
7617 U8 vectors[64][8] = {
7618 { 0x31, 0x0e, 0x0e, 0xdd, 0x47, 0xdb, 0x6f, 0x72, },
7619 { 0xfd, 0x67, 0xdc, 0x93, 0xc5, 0x39, 0xf8, 0x74, },
7620 { 0x5a, 0x4f, 0xa9, 0xd9, 0x09, 0x80, 0x6c, 0x0d, },
7621 { 0x2d, 0x7e, 0xfb, 0xd7, 0x96, 0x66, 0x67, 0x85, },
7622 { 0xb7, 0x87, 0x71, 0x27, 0xe0, 0x94, 0x27, 0xcf, },
7623 { 0x8d, 0xa6, 0x99, 0xcd, 0x64, 0x55, 0x76, 0x18, },
7624 { 0xce, 0xe3, 0xfe, 0x58, 0x6e, 0x46, 0xc9, 0xcb, },
7625 { 0x37, 0xd1, 0x01, 0x8b, 0xf5, 0x00, 0x02, 0xab, },
7626 { 0x62, 0x24, 0x93, 0x9a, 0x79, 0xf5, 0xf5, 0x93, },
7627 { 0xb0, 0xe4, 0xa9, 0x0b, 0xdf, 0x82, 0x00, 0x9e, },
7628 { 0xf3, 0xb9, 0xdd, 0x94, 0xc5, 0xbb, 0x5d, 0x7a, },
7629 { 0xa7, 0xad, 0x6b, 0x22, 0x46, 0x2f, 0xb3, 0xf4, },
7630 { 0xfb, 0xe5, 0x0e, 0x86, 0xbc, 0x8f, 0x1e, 0x75, },
7631 { 0x90, 0x3d, 0x84, 0xc0, 0x27, 0x56, 0xea, 0x14, },
7632 { 0xee, 0xf2, 0x7a, 0x8e, 0x90, 0xca, 0x23, 0xf7, },
7633 { 0xe5, 0x45, 0xbe, 0x49, 0x61, 0xca, 0x29, 0xa1, },
7634 { 0xdb, 0x9b, 0xc2, 0x57, 0x7f, 0xcc, 0x2a, 0x3f, },
7635 { 0x94, 0x47, 0xbe, 0x2c, 0xf5, 0xe9, 0x9a, 0x69, },
7636 { 0x9c, 0xd3, 0x8d, 0x96, 0xf0, 0xb3, 0xc1, 0x4b, },
7637 { 0xbd, 0x61, 0x79, 0xa7, 0x1d, 0xc9, 0x6d, 0xbb, },
7638 { 0x98, 0xee, 0xa2, 0x1a, 0xf2, 0x5c, 0xd6, 0xbe, },
7639 { 0xc7, 0x67, 0x3b, 0x2e, 0xb0, 0xcb, 0xf2, 0xd0, },
7640 { 0x88, 0x3e, 0xa3, 0xe3, 0x95, 0x67, 0x53, 0x93, },
7641 { 0xc8, 0xce, 0x5c, 0xcd, 0x8c, 0x03, 0x0c, 0xa8, },
7642 { 0x94, 0xaf, 0x49, 0xf6, 0xc6, 0x50, 0xad, 0xb8, },
7643 { 0xea, 0xb8, 0x85, 0x8a, 0xde, 0x92, 0xe1, 0xbc, },
7644 { 0xf3, 0x15, 0xbb, 0x5b, 0xb8, 0x35, 0xd8, 0x17, },
7645 { 0xad, 0xcf, 0x6b, 0x07, 0x63, 0x61, 0x2e, 0x2f, },
7646 { 0xa5, 0xc9, 0x1d, 0xa7, 0xac, 0xaa, 0x4d, 0xde, },
7647 { 0x71, 0x65, 0x95, 0x87, 0x66, 0x50, 0xa2, 0xa6, },
7648 { 0x28, 0xef, 0x49, 0x5c, 0x53, 0xa3, 0x87, 0xad, },
7649 { 0x42, 0xc3, 0x41, 0xd8, 0xfa, 0x92, 0xd8, 0x32, },
7650 { 0xce, 0x7c, 0xf2, 0x72, 0x2f, 0x51, 0x27, 0x71, },
7651 { 0xe3, 0x78, 0x59, 0xf9, 0x46, 0x23, 0xf3, 0xa7, },
7652 { 0x38, 0x12, 0x05, 0xbb, 0x1a, 0xb0, 0xe0, 0x12, },
7653 { 0xae, 0x97, 0xa1, 0x0f, 0xd4, 0x34, 0xe0, 0x15, },
7654 { 0xb4, 0xa3, 0x15, 0x08, 0xbe, 0xff, 0x4d, 0x31, },
7655 { 0x81, 0x39, 0x62, 0x29, 0xf0, 0x90, 0x79, 0x02, },
7656 { 0x4d, 0x0c, 0xf4, 0x9e, 0xe5, 0xd4, 0xdc, 0xca, },
7657 { 0x5c, 0x73, 0x33, 0x6a, 0x76, 0xd8, 0xbf, 0x9a, },
7658 { 0xd0, 0xa7, 0x04, 0x53, 0x6b, 0xa9, 0x3e, 0x0e, },
7659 { 0x92, 0x59, 0x58, 0xfc, 0xd6, 0x42, 0x0c, 0xad, },
7660 { 0xa9, 0x15, 0xc2, 0x9b, 0xc8, 0x06, 0x73, 0x18, },
7661 { 0x95, 0x2b, 0x79, 0xf3, 0xbc, 0x0a, 0xa6, 0xd4, },
7662 { 0xf2, 0x1d, 0xf2, 0xe4, 0x1d, 0x45, 0x35, 0xf9, },
7663 { 0x87, 0x57, 0x75, 0x19, 0x04, 0x8f, 0x53, 0xa9, },
7664 { 0x10, 0xa5, 0x6c, 0xf5, 0xdf, 0xcd, 0x9a, 0xdb, },
7665 { 0xeb, 0x75, 0x09, 0x5c, 0xcd, 0x98, 0x6c, 0xd0, },
7666 { 0x51, 0xa9, 0xcb, 0x9e, 0xcb, 0xa3, 0x12, 0xe6, },
7667 { 0x96, 0xaf, 0xad, 0xfc, 0x2c, 0xe6, 0x66, 0xc7, },
7668 { 0x72, 0xfe, 0x52, 0x97, 0x5a, 0x43, 0x64, 0xee, },
7669 { 0x5a, 0x16, 0x45, 0xb2, 0x76, 0xd5, 0x92, 0xa1, },
7670 { 0xb2, 0x74, 0xcb, 0x8e, 0xbf, 0x87, 0x87, 0x0a, },
7671 { 0x6f, 0x9b, 0xb4, 0x20, 0x3d, 0xe7, 0xb3, 0x81, },
7672 { 0xea, 0xec, 0xb2, 0xa3, 0x0b, 0x22, 0xa8, 0x7f, },
7673 { 0x99, 0x24, 0xa4, 0x3c, 0xc1, 0x31, 0x57, 0x24, },
7674 { 0xbd, 0x83, 0x8d, 0x3a, 0xaf, 0xbf, 0x8d, 0xb7, },
7675 { 0x0b, 0x1a, 0x2a, 0x32, 0x65, 0xd5, 0x1a, 0xea, },
7676 { 0x13, 0x50, 0x79, 0xa3, 0x23, 0x1c, 0xe6, 0x60, },
7677 { 0x93, 0x2b, 0x28, 0x46, 0xe4, 0xd7, 0x06, 0x66, },
7678 { 0xe1, 0x91, 0x5f, 0x5c, 0xb1, 0xec, 0xa4, 0x6c, },
7679 { 0xf3, 0x25, 0x96, 0x5c, 0xa1, 0x6d, 0x62, 0x9f, },
7680 { 0x57, 0x5f, 0xf2, 0x8e, 0x60, 0x38, 0x1b, 0xe5, },
7681 { 0x72, 0x45, 0x06, 0xeb, 0x4c, 0x32, 0x8a, 0x95, }
7682 };
7683 U32 vectors_32[64] = {
7684 0xaf61d576,
7685 0xe7245e38,
7686 0xd4c5cf53,
7687 0x529c18bb,
7688 0xe8561357,
7689 0xd5eff3e9,
7690 0x9337a5a0,
7691 0x2003d1c2,
7692 0x0966d11b,
7693 0x95a9666f,
7694 0xee800236,
7695 0xd6d882e1,
7696 0xf3106a47,
7697 0xd46e6bb7,
7698 0x7959387e,
7699 0xe8978f84,
7700 0x68e857a4,
7701 0x4524ae61,
7702 0xdd4c606c,
7703 0x1c14a8a0,
7704 0xa474b26a,
7705 0xfec9ac77,
7706 0x70f0591d,
7707 0x6550cd44,
7708 0x4ee4ff52,
7709 0x36642a34,
7710 0x4c63204b,
7711 0x2845aece,
7712 0x79506309,
7713 0x21373517,
7714 0xf1ce4c7b,
7715 0xea9951b8,
7716 0x03d52de1,
7717 0x5eaa5ba5,
7718 0xa9e5a222,
7719 0x1a41a37a,
7720 0x39585c0a,
7721 0x2b1ba971,
7722 0x5428d8a8,
7723 0xf08cab2a,
7724 0x5d3a0ebb,
7725 0x51541b44,
7726 0x83b11361,
7727 0x27df2129,
7728 0x1dc758ef,
7729 0xb026d883,
7730 0x2ef668cf,
7731 0x8c65ed26,
7732 0x78d90a9a,
7733 0x3bcb49ba,
7734 0x7936bd28,
7735 0x13d7c32c,
7736 0x844cf30d,
7737 0xa1077c52,
7738 0xdc1acee1,
7739 0x18f31558,
7740 0x8d003c12,
7741 0xd830cf6e,
7742 0xc39f4c30,
7743 0x202efc77,
7744 0x30fb7d50,
7745 0xc3f44852,
7746 0x6be96737,
7747 0x7e8c773e
7748 };
7749
7750 const U8 MAXLEN= 64;
7751 U8 in[64], seed_pv[16], state_pv[32];
7752 union {
7753 U64 hash;
7754 U32 h32[2];
7755 U8 bytes[8];
7756 } out;
7757 int i,j;
7758 int failed = 0;
7759 U32 hash32;
7760 /* S_perl_siphash_seed_state(seed_pv, state_pv) sets state_pv *
7761 * differently between little-endian and big-endian. It's the same *
7762 * values, but in a different order. *
7763 * On big-endian architecture, we transpose the values into the same *
7764 * order as for little-endian, so that we can test against the same *
7765 * test vectors. *
7766 * We could alternatively alter the code that produces state_pv to *
7767 * output identical arrangements for big-endian and little-endian. */
7768 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
7769 for( i = 0; i < 16; ++i ) seed_pv[i] = i;
7770 S_perl_siphash_seed_state(seed_pv, state_pv);
7771 #else
7772 U8 temp_pv[32];
7773 for( i = 0; i < 16; ++i ) seed_pv[i] = i;
7774 S_perl_siphash_seed_state(seed_pv, temp_pv);
7775 for( i = 0; i < 32; ++i ) {
7776 if (i < 8) state_pv[ 7 - i] = temp_pv[i];
7777 else if(i < 16) state_pv[23 - i] = temp_pv[i];
7778 else if(i < 24) state_pv[39 - i] = temp_pv[i];
7779 else state_pv[55 - i] = temp_pv[i];
7780 }
7781 #endif
7782 for( i = 0; i < MAXLEN; ++i )
7783 {
7784 in[i] = i;
7785
7786 out.hash= S_perl_hash_siphash_2_4_with_state_64( state_pv, in, i );
7787
7788 hash32= S_perl_hash_siphash_2_4_with_state( state_pv, in, i);
7789 /* The test vectors need to reversed here for big-endian architecture *
7790 * Alternatively we could rewrite S_perl_hash_siphash_2_4_with_state_64 *
7791 * to produce reversed vectors when run on big-endian architecture */
7792 #if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* reverse order of vectors[i] */
7793 temp_pv [0] = vectors[i][0]; /* temp_pv is temporary holder of vectors[i][0] */
7794 vectors[i][0] = vectors[i][7];
7795 vectors[i][7] = temp_pv[0];
7796
7797 temp_pv [0] = vectors[i][1]; /* temp_pv is temporary holder of vectors[i][1] */
7798 vectors[i][1] = vectors[i][6];
7799 vectors[i][6] = temp_pv[0];
7800
7801 temp_pv [0] = vectors[i][2]; /* temp_pv is temporary holder of vectors[i][2] */
7802 vectors[i][2] = vectors[i][5];
7803 vectors[i][5] = temp_pv[0];
7804
7805 temp_pv [0] = vectors[i][3]; /* temp_pv is temporary holder of vectors[i][3] */
7806 vectors[i][3] = vectors[i][4];
7807 vectors[i][4] = temp_pv[0];
7808 #endif
7809 if ( memcmp( out.bytes, vectors[i], 8 ) )
7810 {
7811 failed++;
7812 printf( "Error in 64 bit result on test vector of length %d for siphash24\n have: {", i );
7813 for (j=0;j<7;j++)
7814 printf( "0x%02x, ", out.bytes[j]);
7815 printf( "0x%02x },\n", out.bytes[7]);
7816 printf( " want: {" );
7817 for (j=0;j<7;j++)
7818 printf( "0x%02x, ", vectors[i][j]);
7819 printf( "0x%02x },\n", vectors[i][7]);
7820 }
7821 if (hash32 != vectors_32[i]) {
7822 failed++;
7823 printf( "Error in 32 bit result on test vector of length %d for siphash24\n"
7824 " have: 0x%08" UVxf "\n"
7825 " want: 0x%08" UVxf "\n",
7826 i, (UV)hash32, (UV)vectors_32[i]);
7827 }
7828 }
7829 RETVAL= failed;
7830 }
7831 OUTPUT:
7832 RETVAL
7833
7834 UV
test_siphash13()7835 test_siphash13()
7836 CODE:
7837 {
7838 U8 vectors[64][8] = {
7839 {0xdc, 0xc4, 0x0f, 0x05, 0x58, 0x01, 0xac, 0xab },
7840 {0x93, 0xca, 0x57, 0x7d, 0xf3, 0x9b, 0xf4, 0xc9 },
7841 {0x4d, 0xd4, 0xc7, 0x4d, 0x02, 0x9b, 0xcb, 0x82 },
7842 {0xfb, 0xf7, 0xdd, 0xe7, 0xb8, 0x0a, 0xf8, 0x8b },
7843 {0x28, 0x83, 0xd3, 0x88, 0x60, 0x57, 0x75, 0xcf },
7844 {0x67, 0x3b, 0x53, 0x49, 0x2f, 0xd5, 0xf9, 0xde },
7845 {0xa7, 0x22, 0x9f, 0xc5, 0x50, 0x2b, 0x0d, 0xc5 },
7846 {0x40, 0x11, 0xb1, 0x9b, 0x98, 0x7d, 0x92, 0xd3 },
7847 {0x8e, 0x9a, 0x29, 0x8d, 0x11, 0x95, 0x90, 0x36 },
7848 {0xe4, 0x3d, 0x06, 0x6c, 0xb3, 0x8e, 0xa4, 0x25 },
7849 {0x7f, 0x09, 0xff, 0x92, 0xee, 0x85, 0xde, 0x79 },
7850 {0x52, 0xc3, 0x4d, 0xf9, 0xc1, 0x18, 0xc1, 0x70 },
7851 {0xa2, 0xd9, 0xb4, 0x57, 0xb1, 0x84, 0xa3, 0x78 },
7852 {0xa7, 0xff, 0x29, 0x12, 0x0c, 0x76, 0x6f, 0x30 },
7853 {0x34, 0x5d, 0xf9, 0xc0, 0x11, 0xa1, 0x5a, 0x60 },
7854 {0x56, 0x99, 0x51, 0x2a, 0x6d, 0xd8, 0x20, 0xd3 },
7855 {0x66, 0x8b, 0x90, 0x7d, 0x1a, 0xdd, 0x4f, 0xcc },
7856 {0x0c, 0xd8, 0xdb, 0x63, 0x90, 0x68, 0xf2, 0x9c },
7857 {0x3e, 0xe6, 0x73, 0xb4, 0x9c, 0x38, 0xfc, 0x8f },
7858 {0x1c, 0x7d, 0x29, 0x8d, 0xe5, 0x9d, 0x1f, 0xf2 },
7859 {0x40, 0xe0, 0xcc, 0xa6, 0x46, 0x2f, 0xdc, 0xc0 },
7860 {0x44, 0xf8, 0x45, 0x2b, 0xfe, 0xab, 0x92, 0xb9 },
7861 {0x2e, 0x87, 0x20, 0xa3, 0x9b, 0x7b, 0xfe, 0x7f },
7862 {0x23, 0xc1, 0xe6, 0xda, 0x7f, 0x0e, 0x5a, 0x52 },
7863 {0x8c, 0x9c, 0x34, 0x67, 0xb2, 0xae, 0x64, 0xf4 },
7864 {0x79, 0x09, 0x5b, 0x70, 0x28, 0x59, 0xcd, 0x45 },
7865 {0xa5, 0x13, 0x99, 0xca, 0xe3, 0x35, 0x3e, 0x3a },
7866 {0x35, 0x3b, 0xde, 0x4a, 0x4e, 0xc7, 0x1d, 0xa9 },
7867 {0x0d, 0xd0, 0x6c, 0xef, 0x02, 0xed, 0x0b, 0xfb },
7868 {0xf4, 0xe1, 0xb1, 0x4a, 0xb4, 0x3c, 0xd9, 0x88 },
7869 {0x63, 0xe6, 0xc5, 0x43, 0xd6, 0x11, 0x0f, 0x54 },
7870 {0xbc, 0xd1, 0x21, 0x8c, 0x1f, 0xdd, 0x70, 0x23 },
7871 {0x0d, 0xb6, 0xa7, 0x16, 0x6c, 0x7b, 0x15, 0x81 },
7872 {0xbf, 0xf9, 0x8f, 0x7a, 0xe5, 0xb9, 0x54, 0x4d },
7873 {0x3e, 0x75, 0x2a, 0x1f, 0x78, 0x12, 0x9f, 0x75 },
7874 {0x91, 0x6b, 0x18, 0xbf, 0xbe, 0xa3, 0xa1, 0xce },
7875 {0x06, 0x62, 0xa2, 0xad, 0xd3, 0x08, 0xf5, 0x2c },
7876 {0x57, 0x30, 0xc3, 0xa3, 0x2d, 0x1c, 0x10, 0xb6 },
7877 {0xa1, 0x36, 0x3a, 0xae, 0x96, 0x74, 0xf4, 0xb3 },
7878 {0x92, 0x83, 0x10, 0x7b, 0x54, 0x57, 0x6b, 0x62 },
7879 {0x31, 0x15, 0xe4, 0x99, 0x32, 0x36, 0xd2, 0xc1 },
7880 {0x44, 0xd9, 0x1a, 0x3f, 0x92, 0xc1, 0x7c, 0x66 },
7881 {0x25, 0x88, 0x13, 0xc8, 0xfe, 0x4f, 0x70, 0x65 },
7882 {0xa6, 0x49, 0x89, 0xc2, 0xd1, 0x80, 0xf2, 0x24 },
7883 {0x6b, 0x87, 0xf8, 0xfa, 0xed, 0x1c, 0xca, 0xc2 },
7884 {0x96, 0x21, 0x04, 0x9f, 0xfc, 0x4b, 0x16, 0xc2 },
7885 {0x23, 0xd6, 0xb1, 0x68, 0x93, 0x9c, 0x6e, 0xa1 },
7886 {0xfd, 0x14, 0x51, 0x8b, 0x9c, 0x16, 0xfb, 0x49 },
7887 {0x46, 0x4c, 0x07, 0xdf, 0xf8, 0x43, 0x31, 0x9f },
7888 {0xb3, 0x86, 0xcc, 0x12, 0x24, 0xaf, 0xfd, 0xc6 },
7889 {0x8f, 0x09, 0x52, 0x0a, 0xd1, 0x49, 0xaf, 0x7e },
7890 {0x9a, 0x2f, 0x29, 0x9d, 0x55, 0x13, 0xf3, 0x1c },
7891 {0x12, 0x1f, 0xf4, 0xa2, 0xdd, 0x30, 0x4a, 0xc4 },
7892 {0xd0, 0x1e, 0xa7, 0x43, 0x89, 0xe9, 0xfa, 0x36 },
7893 {0xe6, 0xbc, 0xf0, 0x73, 0x4c, 0xb3, 0x8f, 0x31 },
7894 {0x80, 0xe9, 0xa7, 0x70, 0x36, 0xbf, 0x7a, 0xa2 },
7895 {0x75, 0x6d, 0x3c, 0x24, 0xdb, 0xc0, 0xbc, 0xb4 },
7896 {0x13, 0x15, 0xb7, 0xfd, 0x52, 0xd8, 0xf8, 0x23 },
7897 {0x08, 0x8a, 0x7d, 0xa6, 0x4d, 0x5f, 0x03, 0x8f },
7898 {0x48, 0xf1, 0xe8, 0xb7, 0xe5, 0xd0, 0x9c, 0xd8 },
7899 {0xee, 0x44, 0xa6, 0xf7, 0xbc, 0xe6, 0xf4, 0xf6 },
7900 {0xf2, 0x37, 0x18, 0x0f, 0xd8, 0x9a, 0xc5, 0xae },
7901 {0xe0, 0x94, 0x66, 0x4b, 0x15, 0xf6, 0xb2, 0xc3 },
7902 {0xa8, 0xb3, 0xbb, 0xb7, 0x62, 0x90, 0x19, 0x9d }
7903 };
7904 U32 vectors_32[64] = {
7905 0xaea3c584,
7906 0xb4a35160,
7907 0xcf0c4f4f,
7908 0x6c25fd43,
7909 0x47a6d448,
7910 0x97aaee48,
7911 0x009209f7,
7912 0x48236cd8,
7913 0xbbb90f9f,
7914 0x49a2b357,
7915 0xeb218c91,
7916 0x898cdb93,
7917 0x2f175d13,
7918 0x224689ab,
7919 0xa0a3fc25,
7920 0xf971413b,
7921 0xb1df567c,
7922 0xff29b09c,
7923 0x3b8fdea2,
7924 0x7f36e0f9,
7925 0x6610cf06,
7926 0x92d753ba,
7927 0xdcdefcb5,
7928 0x88bccf5c,
7929 0x9350323e,
7930 0x35965051,
7931 0xf0a72646,
7932 0xe3c3fc7b,
7933 0x14673d0f,
7934 0xc268dd40,
7935 0x17caf7b5,
7936 0xaf510ca3,
7937 0x97b2cd61,
7938 0x37db405a,
7939 0x6ab56746,
7940 0x71b9c82f,
7941 0x81576ad5,
7942 0x15d32c7a,
7943 0x1dce4237,
7944 0x197bd4c6,
7945 0x58362303,
7946 0x596618d6,
7947 0xad63c7db,
7948 0xe67bc977,
7949 0x38329b86,
7950 0x5d126a6a,
7951 0xc9df4ab0,
7952 0xc2aa0261,
7953 0x40360fbe,
7954 0xd4312997,
7955 0x74fd405e,
7956 0x81da3ccf,
7957 0x66be2fcf,
7958 0x755df759,
7959 0x427f0faa,
7960 0xd2dd56b6,
7961 0x9080adae,
7962 0xde4fcd41,
7963 0x297ed545,
7964 0x6f7421ad,
7965 0x0152a252,
7966 0xa1ddad2a,
7967 0x88d462f5,
7968 0x2aa223ca,
7969 };
7970
7971 const U8 MAXLEN= 64;
7972 U8 in[64], seed_pv[16], state_pv[32];
7973 union {
7974 U64 hash;
7975 U32 h32[2];
7976 U8 bytes[8];
7977 } out;
7978 int i,j;
7979 int failed = 0;
7980 U32 hash32;
7981 /* S_perl_siphash_seed_state(seed_pv, state_pv) sets state_pv *
7982 * differently between little-endian and big-endian. It's the same *
7983 * values, but in a different order. *
7984 * On big-endian architecture, we transpose the values into the same *
7985 * order as for little-endian, so that we can test against the same *
7986 * test vectors. *
7987 * We could alternatively alter the code that produces state_pv to *
7988 * output identical arrangements for big-endian and little-endian. */
7989 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
7990 for( i = 0; i < 16; ++i ) seed_pv[i] = i;
7991 S_perl_siphash_seed_state(seed_pv, state_pv);
7992 #else
7993 U8 temp_pv[32];
7994 for( i = 0; i < 16; ++i ) seed_pv[i] = i;
7995 S_perl_siphash_seed_state(seed_pv, temp_pv);
7996 for( i = 0; i < 32; ++i ) {
7997 if (i < 8) state_pv[ 7 - i] = temp_pv[i];
7998 else if(i < 16) state_pv[23 - i] = temp_pv[i];
7999 else if(i < 24) state_pv[39 - i] = temp_pv[i];
8000 else state_pv[55 - i] = temp_pv[i];
8001 }
8002 #endif
8003 for( i = 0; i < MAXLEN; ++i )
8004 {
8005 in[i] = i;
8006
8007 out.hash= S_perl_hash_siphash_1_3_with_state_64( state_pv, in, i );
8008
8009 hash32= S_perl_hash_siphash_1_3_with_state( state_pv, in, i);
8010 /* The test vectors need to reversed here for big-endian architecture *
8011 * Alternatively we could rewrite S_perl_hash_siphash_1_3_with_state_64 *
8012 * to produce reversed vectors when run on big-endian architecture */
8013 #if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
8014 temp_pv [0] = vectors[i][0]; /* temp_pv is temporary holder of vectors[i][0] */
8015 vectors[i][0] = vectors[i][7];
8016 vectors[i][7] = temp_pv[0];
8017
8018 temp_pv [0] = vectors[i][1]; /* temp_pv is temporary holder of vectors[i][1] */
8019 vectors[i][1] = vectors[i][6];
8020 vectors[i][6] = temp_pv[0];
8021
8022 temp_pv [0] = vectors[i][2]; /* temp_pv is temporary holder of vectors[i][2] */
8023 vectors[i][2] = vectors[i][5];
8024 vectors[i][5] = temp_pv[0];
8025
8026 temp_pv [0] = vectors[i][3]; /* temp_pv is temporary holder of vectors[i][3] */
8027 vectors[i][3] = vectors[i][4];
8028 vectors[i][4] = temp_pv[0];
8029 #endif
8030 if ( memcmp( out.bytes, vectors[i], 8 ) )
8031 {
8032 failed++;
8033 printf( "Error in 64 bit result on test vector of length %d for siphash13\n have: {", i );
8034 for (j=0;j<7;j++)
8035 printf( "0x%02x, ", out.bytes[j]);
8036 printf( "0x%02x },\n", out.bytes[7]);
8037 printf( " want: {" );
8038 for (j=0;j<7;j++)
8039 printf( "0x%02x, ", vectors[i][j]);
8040 printf( "0x%02x },\n", vectors[i][7]);
8041 }
8042 if (hash32 != vectors_32[i]) {
8043 failed++;
8044 printf( "Error in 32 bit result on test vector of length %d for siphash13\n"
8045 " have: 0x%08" UVxf"\n"
8046 " want: 0x%08" UVxf"\n",
8047 i, (UV)hash32, (UV)vectors_32[i]);
8048 }
8049 }
8050 RETVAL= failed;
8051 }
8052 OUTPUT:
8053 RETVAL
8054
8055 #endif /* END 64 BIT SIPHASH TESTS */
8056
8057 MODULE = XS::APItest PACKAGE = XS::APItest::BoolInternals
8058
8059 UV
test_bool_internals()8060 test_bool_internals()
8061 CODE:
8062 {
8063 U32 failed = 0;
8064 SV *true_sv_setsv = newSV(0);
8065 SV *false_sv_setsv = newSV(0);
8066 SV *true_sv_set_true = newSV(0);
8067 SV *false_sv_set_false = newSV(0);
8068 SV *true_sv_set_bool = newSV(0);
8069 SV *false_sv_set_bool = newSV(0);
8070 SV *sviv = newSViv(1);
8071 SV *svpv = newSVpvs("whatever");
8072 TEST_EXPR(SvIOK(sviv) && !SvIandPOK(sviv));
8073 TEST_EXPR(SvPOK(svpv) && !SvIandPOK(svpv));
8074 TEST_EXPR(SvIOK(sviv) && !SvBoolFlagsOK(sviv));
8075 TEST_EXPR(SvPOK(svpv) && !SvBoolFlagsOK(svpv));
8076 sv_setsv(true_sv_setsv, &PL_sv_yes);
8077 sv_setsv(false_sv_setsv, &PL_sv_no);
8078 sv_set_true(true_sv_set_true);
8079 sv_set_false(false_sv_set_false);
8080 sv_set_bool(true_sv_set_bool, true);
8081 sv_set_bool(false_sv_set_bool, false);
8082 /* note that test_bool_internals_macro() SvREFCNT_dec's its arguments
8083 * after the tests */
8084 failed += test_bool_internals_macro(newSVsv(&PL_sv_yes), newSVsv(&PL_sv_no));
8085 failed += test_bool_internals_macro(newSV_true(), newSV_false());
8086 failed += test_bool_internals_macro(newSVbool(1), newSVbool(0));
8087 failed += test_bool_internals_macro(true_sv_setsv, false_sv_setsv);
8088 failed += test_bool_internals_macro(true_sv_set_true, false_sv_set_false);
8089 failed += test_bool_internals_macro(true_sv_set_bool, false_sv_set_bool);
8090 SvREFCNT_dec(sviv);
8091 SvREFCNT_dec(svpv);
8092 RETVAL = failed;
8093 }
8094 OUTPUT:
8095 RETVAL
8096
8097 MODULE = XS::APItest PACKAGE = XS::APItest::CvREFCOUNTED_ANYSV
8098
8099 UV
test_CvREFCOUNTED_ANYSV()8100 test_CvREFCOUNTED_ANYSV()
8101 CODE:
8102 {
8103 U32 failed = 0;
8104
8105 /* Doesn't matter what actual function we wrap because we're never
8106 * actually going to call it. */
8107 CV *cv = newXS("XS::APItest::(test-cv-1)", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
8108 SV *sv = newSV(0);
8109 CvXSUBANY(cv).any_sv = SvREFCNT_inc(sv);
8110 CvREFCOUNTED_ANYSV_on(cv);
8111 TEST_EXPR(SvREFCNT(sv) == 2);
8112
8113 SvREFCNT_dec((SV *)cv);
8114 TEST_EXPR(SvREFCNT(sv) == 1);
8115
8116 SvREFCNT_dec(sv);
8117
8118 RETVAL = failed;
8119 }
8120 OUTPUT:
8121 RETVAL
8122
8123 MODULE = XS::APItest PACKAGE = XS::APItest::global_locale
8124
8125 char *
8126 switch_to_global_and_setlocale(int category, const char * locale)
8127 CODE:
8128 switch_to_global_locale();
8129 RETVAL = setlocale(category, locale);
8130 OUTPUT:
8131 RETVAL
8132
8133 bool
8134 sync_locale()
8135 CODE:
8136 RETVAL = sync_locale();
8137 OUTPUT:
8138 RETVAL
8139
8140 NV
8141 newSvNV(const char * string)
8142 CODE:
8143 RETVAL = SvNV(newSVpv(string, 0));
8144 OUTPUT:
8145 RETVAL
8146
8147 MODULE = XS::APItest PACKAGE = XS::APItest::savestack
8148
8149 IV
8150 get_savestack_ix()
8151 CODE:
8152 RETVAL = PL_savestack_ix;
8153 OUTPUT:
8154 RETVAL
8155