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