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