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