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