1 /* B.xs 2 * 3 * Copyright (c) 1996 Malcolm Beattie 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 */ 9 10 #define PERL_NO_GET_CONTEXT 11 #include "EXTERN.h" 12 #include "perl.h" 13 #include "XSUB.h" 14 15 #ifdef PerlIO 16 typedef PerlIO * InputStream; 17 #else 18 typedef FILE * InputStream; 19 #endif 20 21 22 static char *svclassnames[] = { 23 "B::NULL", 24 "B::IV", 25 "B::NV", 26 "B::RV", 27 "B::PV", 28 "B::PVIV", 29 "B::PVNV", 30 "B::PVMG", 31 "B::BM", 32 "B::PVLV", 33 "B::AV", 34 "B::HV", 35 "B::CV", 36 "B::GV", 37 "B::FM", 38 "B::IO", 39 }; 40 41 typedef enum { 42 OPc_NULL, /* 0 */ 43 OPc_BASEOP, /* 1 */ 44 OPc_UNOP, /* 2 */ 45 OPc_BINOP, /* 3 */ 46 OPc_LOGOP, /* 4 */ 47 OPc_LISTOP, /* 5 */ 48 OPc_PMOP, /* 6 */ 49 OPc_SVOP, /* 7 */ 50 OPc_PADOP, /* 8 */ 51 OPc_PVOP, /* 9 */ 52 OPc_CVOP, /* 10 */ 53 OPc_LOOP, /* 11 */ 54 OPc_COP /* 12 */ 55 } opclass; 56 57 static char *opclassnames[] = { 58 "B::NULL", 59 "B::OP", 60 "B::UNOP", 61 "B::BINOP", 62 "B::LOGOP", 63 "B::LISTOP", 64 "B::PMOP", 65 "B::SVOP", 66 "B::PADOP", 67 "B::PVOP", 68 "B::CVOP", 69 "B::LOOP", 70 "B::COP" 71 }; 72 73 #define MY_CXT_KEY "B::_guts" XS_VERSION 74 75 typedef struct { 76 int x_walkoptree_debug; /* Flag for walkoptree debug hook */ 77 SV * x_specialsv_list[7]; 78 } my_cxt_t; 79 80 START_MY_CXT 81 82 #define walkoptree_debug (MY_CXT.x_walkoptree_debug) 83 #define specialsv_list (MY_CXT.x_specialsv_list) 84 85 static opclass 86 cc_opclass(pTHX_ OP *o) 87 { 88 if (!o) 89 return OPc_NULL; 90 91 if (o->op_type == 0) 92 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; 93 94 if (o->op_type == OP_SASSIGN) 95 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); 96 97 #ifdef USE_ITHREADS 98 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST) 99 return OPc_PADOP; 100 #endif 101 102 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { 103 case OA_BASEOP: 104 return OPc_BASEOP; 105 106 case OA_UNOP: 107 return OPc_UNOP; 108 109 case OA_BINOP: 110 return OPc_BINOP; 111 112 case OA_LOGOP: 113 return OPc_LOGOP; 114 115 case OA_LISTOP: 116 return OPc_LISTOP; 117 118 case OA_PMOP: 119 return OPc_PMOP; 120 121 case OA_SVOP: 122 return OPc_SVOP; 123 124 case OA_PADOP: 125 return OPc_PADOP; 126 127 case OA_PVOP_OR_SVOP: 128 /* 129 * Character translations (tr///) are usually a PVOP, keeping a 130 * pointer to a table of shorts used to look up translations. 131 * Under utf8, however, a simple table isn't practical; instead, 132 * the OP is an SVOP, and the SV is a reference to a swash 133 * (i.e., an RV pointing to an HV). 134 */ 135 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) 136 ? OPc_SVOP : OPc_PVOP; 137 138 case OA_LOOP: 139 return OPc_LOOP; 140 141 case OA_COP: 142 return OPc_COP; 143 144 case OA_BASEOP_OR_UNOP: 145 /* 146 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on 147 * whether parens were seen. perly.y uses OPf_SPECIAL to 148 * signal whether a BASEOP had empty parens or none. 149 * Some other UNOPs are created later, though, so the best 150 * test is OPf_KIDS, which is set in newUNOP. 151 */ 152 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; 153 154 case OA_FILESTATOP: 155 /* 156 * The file stat OPs are created via UNI(OP_foo) in toke.c but use 157 * the OPf_REF flag to distinguish between OP types instead of the 158 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we 159 * return OPc_UNOP so that walkoptree can find our children. If 160 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set 161 * (no argument to the operator) it's an OP; with OPf_REF set it's 162 * an SVOP (and op_sv is the GV for the filehandle argument). 163 */ 164 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : 165 #ifdef USE_ITHREADS 166 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP); 167 #else 168 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP); 169 #endif 170 case OA_LOOPEXOP: 171 /* 172 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a 173 * label was omitted (in which case it's a BASEOP) or else a term was 174 * seen. In this last case, all except goto are definitely PVOP but 175 * goto is either a PVOP (with an ordinary constant label), an UNOP 176 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for 177 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to 178 * get set. 179 */ 180 if (o->op_flags & OPf_STACKED) 181 return OPc_UNOP; 182 else if (o->op_flags & OPf_SPECIAL) 183 return OPc_BASEOP; 184 else 185 return OPc_PVOP; 186 } 187 warn("can't determine class of operator %s, assuming BASEOP\n", 188 PL_op_name[o->op_type]); 189 return OPc_BASEOP; 190 } 191 192 static char * 193 cc_opclassname(pTHX_ OP *o) 194 { 195 return opclassnames[cc_opclass(aTHX_ o)]; 196 } 197 198 static SV * 199 make_sv_object(pTHX_ SV *arg, SV *sv) 200 { 201 char *type = 0; 202 IV iv; 203 dMY_CXT; 204 205 for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) { 206 if (sv == specialsv_list[iv]) { 207 type = "B::SPECIAL"; 208 break; 209 } 210 } 211 if (!type) { 212 type = svclassnames[SvTYPE(sv)]; 213 iv = PTR2IV(sv); 214 } 215 sv_setiv(newSVrv(arg, type), iv); 216 return arg; 217 } 218 219 static SV * 220 make_mg_object(pTHX_ SV *arg, MAGIC *mg) 221 { 222 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg)); 223 return arg; 224 } 225 226 static SV * 227 cstring(pTHX_ SV *sv, bool perlstyle) 228 { 229 SV *sstr = newSVpvn("", 0); 230 STRLEN len; 231 char *s; 232 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ 233 234 if (!SvOK(sv)) 235 sv_setpvn(sstr, "0", 1); 236 else if (perlstyle && SvUTF8(sv)) 237 { 238 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */ 239 len = SvCUR(sv); 240 s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ); 241 sv_setpv(sstr,"\""); 242 while (*s) 243 { 244 if (*s == '"') 245 sv_catpv(sstr, "\\\""); 246 else if (*s == '$') 247 sv_catpv(sstr, "\\$"); 248 else if (*s == '@') 249 sv_catpv(sstr, "\\@"); 250 else if (*s == '\\') 251 { 252 if (strchr("nrftax\\",*(s+1))) 253 sv_catpvn(sstr, s++, 2); 254 else 255 sv_catpv(sstr, "\\\\"); 256 } 257 else /* should always be printable */ 258 sv_catpvn(sstr, s, 1); 259 ++s; 260 } 261 sv_catpv(sstr, "\""); 262 return sstr; 263 } 264 else 265 { 266 /* XXX Optimise? */ 267 s = SvPV(sv, len); 268 sv_catpv(sstr, "\""); 269 for (; len; len--, s++) 270 { 271 /* At least try a little for readability */ 272 if (*s == '"') 273 sv_catpv(sstr, "\\\""); 274 else if (*s == '\\') 275 sv_catpv(sstr, "\\\\"); 276 /* trigraphs - bleagh */ 277 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') 278 { 279 sprintf(escbuff, "\\%03o", '?'); 280 sv_catpv(sstr, escbuff); 281 } 282 else if (perlstyle && *s == '$') 283 sv_catpv(sstr, "\\$"); 284 else if (perlstyle && *s == '@') 285 sv_catpv(sstr, "\\@"); 286 #ifdef EBCDIC 287 else if (isPRINT(*s)) 288 #else 289 else if (*s >= ' ' && *s < 127) 290 #endif /* EBCDIC */ 291 sv_catpvn(sstr, s, 1); 292 else if (*s == '\n') 293 sv_catpv(sstr, "\\n"); 294 else if (*s == '\r') 295 sv_catpv(sstr, "\\r"); 296 else if (*s == '\t') 297 sv_catpv(sstr, "\\t"); 298 else if (*s == '\a') 299 sv_catpv(sstr, "\\a"); 300 else if (*s == '\b') 301 sv_catpv(sstr, "\\b"); 302 else if (*s == '\f') 303 sv_catpv(sstr, "\\f"); 304 else if (!perlstyle && *s == '\v') 305 sv_catpv(sstr, "\\v"); 306 else 307 { 308 /* Don't want promotion of a signed -1 char in sprintf args */ 309 unsigned char c = (unsigned char) *s; 310 sprintf(escbuff, "\\%03o", c); 311 sv_catpv(sstr, escbuff); 312 } 313 /* XXX Add line breaks if string is long */ 314 } 315 sv_catpv(sstr, "\""); 316 } 317 return sstr; 318 } 319 320 static SV * 321 cchar(pTHX_ SV *sv) 322 { 323 SV *sstr = newSVpvn("'", 1); 324 STRLEN n_a; 325 char *s = SvPV(sv, n_a); 326 327 if (*s == '\'') 328 sv_catpv(sstr, "\\'"); 329 else if (*s == '\\') 330 sv_catpv(sstr, "\\\\"); 331 #ifdef EBCDIC 332 else if (isPRINT(*s)) 333 #else 334 else if (*s >= ' ' && *s < 127) 335 #endif /* EBCDIC */ 336 sv_catpvn(sstr, s, 1); 337 else if (*s == '\n') 338 sv_catpv(sstr, "\\n"); 339 else if (*s == '\r') 340 sv_catpv(sstr, "\\r"); 341 else if (*s == '\t') 342 sv_catpv(sstr, "\\t"); 343 else if (*s == '\a') 344 sv_catpv(sstr, "\\a"); 345 else if (*s == '\b') 346 sv_catpv(sstr, "\\b"); 347 else if (*s == '\f') 348 sv_catpv(sstr, "\\f"); 349 else if (*s == '\v') 350 sv_catpv(sstr, "\\v"); 351 else 352 { 353 /* no trigraph support */ 354 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ 355 /* Don't want promotion of a signed -1 char in sprintf args */ 356 unsigned char c = (unsigned char) *s; 357 sprintf(escbuff, "\\%03o", c); 358 sv_catpv(sstr, escbuff); 359 } 360 sv_catpv(sstr, "'"); 361 return sstr; 362 } 363 364 void 365 walkoptree(pTHX_ SV *opsv, char *method) 366 { 367 dSP; 368 OP *o, *kid; 369 dMY_CXT; 370 371 if (!SvROK(opsv)) 372 croak("opsv is not a reference"); 373 opsv = sv_mortalcopy(opsv); 374 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv))); 375 if (walkoptree_debug) { 376 PUSHMARK(sp); 377 XPUSHs(opsv); 378 PUTBACK; 379 perl_call_method("walkoptree_debug", G_DISCARD); 380 } 381 PUSHMARK(sp); 382 XPUSHs(opsv); 383 PUTBACK; 384 perl_call_method(method, G_DISCARD); 385 if (o && (o->op_flags & OPf_KIDS)) { 386 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) { 387 /* Use the same opsv. Rely on methods not to mess it up. */ 388 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid)); 389 walkoptree(aTHX_ opsv, method); 390 } 391 } 392 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) 393 && (kid = cPMOPo->op_pmreplroot)) 394 { 395 sv_setiv(newSVrv(opsv, opclassnames[OPc_PMOP]), PTR2IV(kid)); 396 walkoptree(aTHX_ opsv, method); 397 } 398 } 399 400 typedef OP *B__OP; 401 typedef UNOP *B__UNOP; 402 typedef BINOP *B__BINOP; 403 typedef LOGOP *B__LOGOP; 404 typedef LISTOP *B__LISTOP; 405 typedef PMOP *B__PMOP; 406 typedef SVOP *B__SVOP; 407 typedef PADOP *B__PADOP; 408 typedef PVOP *B__PVOP; 409 typedef LOOP *B__LOOP; 410 typedef COP *B__COP; 411 412 typedef SV *B__SV; 413 typedef SV *B__IV; 414 typedef SV *B__PV; 415 typedef SV *B__NV; 416 typedef SV *B__PVMG; 417 typedef SV *B__PVLV; 418 typedef SV *B__BM; 419 typedef SV *B__RV; 420 typedef AV *B__AV; 421 typedef HV *B__HV; 422 typedef CV *B__CV; 423 typedef GV *B__GV; 424 typedef IO *B__IO; 425 426 typedef MAGIC *B__MAGIC; 427 428 MODULE = B PACKAGE = B PREFIX = B_ 429 430 PROTOTYPES: DISABLE 431 432 BOOT: 433 { 434 HV *stash = gv_stashpvn("B", 1, TRUE); 435 AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE); 436 MY_CXT_INIT; 437 specialsv_list[0] = Nullsv; 438 specialsv_list[1] = &PL_sv_undef; 439 specialsv_list[2] = &PL_sv_yes; 440 specialsv_list[3] = &PL_sv_no; 441 specialsv_list[4] = pWARN_ALL; 442 specialsv_list[5] = pWARN_NONE; 443 specialsv_list[6] = pWARN_STD; 444 #include "defsubs.h" 445 } 446 447 #define B_main_cv() PL_main_cv 448 #define B_init_av() PL_initav 449 #define B_begin_av() PL_beginav_save 450 #define B_end_av() PL_endav 451 #define B_main_root() PL_main_root 452 #define B_main_start() PL_main_start 453 #define B_amagic_generation() PL_amagic_generation 454 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv)) 455 #define B_sv_undef() &PL_sv_undef 456 #define B_sv_yes() &PL_sv_yes 457 #define B_sv_no() &PL_sv_no 458 #ifdef USE_ITHREADS 459 #define B_regex_padav() PL_regex_padav 460 #endif 461 462 B::AV 463 B_init_av() 464 465 B::AV 466 B_begin_av() 467 468 B::AV 469 B_end_av() 470 471 #ifdef USE_ITHREADS 472 473 B::AV 474 B_regex_padav() 475 476 #endif 477 478 B::CV 479 B_main_cv() 480 481 B::OP 482 B_main_root() 483 484 B::OP 485 B_main_start() 486 487 long 488 B_amagic_generation() 489 490 B::AV 491 B_comppadlist() 492 493 B::SV 494 B_sv_undef() 495 496 B::SV 497 B_sv_yes() 498 499 B::SV 500 B_sv_no() 501 502 MODULE = B PACKAGE = B 503 504 505 void 506 walkoptree(opsv, method) 507 SV * opsv 508 char * method 509 CODE: 510 walkoptree(aTHX_ opsv, method); 511 512 int 513 walkoptree_debug(...) 514 CODE: 515 dMY_CXT; 516 RETVAL = walkoptree_debug; 517 if (items > 0 && SvTRUE(ST(1))) 518 walkoptree_debug = 1; 519 OUTPUT: 520 RETVAL 521 522 #define address(sv) PTR2IV(sv) 523 524 IV 525 address(sv) 526 SV * sv 527 528 B::SV 529 svref_2object(sv) 530 SV * sv 531 CODE: 532 if (!SvROK(sv)) 533 croak("argument is not a reference"); 534 RETVAL = (SV*)SvRV(sv); 535 OUTPUT: 536 RETVAL 537 538 void 539 opnumber(name) 540 char * name 541 CODE: 542 { 543 int i; 544 IV result = -1; 545 ST(0) = sv_newmortal(); 546 if (strncmp(name,"pp_",3) == 0) 547 name += 3; 548 for (i = 0; i < PL_maxo; i++) 549 { 550 if (strcmp(name, PL_op_name[i]) == 0) 551 { 552 result = i; 553 break; 554 } 555 } 556 sv_setiv(ST(0),result); 557 } 558 559 void 560 ppname(opnum) 561 int opnum 562 CODE: 563 ST(0) = sv_newmortal(); 564 if (opnum >= 0 && opnum < PL_maxo) { 565 sv_setpvn(ST(0), "pp_", 3); 566 sv_catpv(ST(0), PL_op_name[opnum]); 567 } 568 569 void 570 hash(sv) 571 SV * sv 572 CODE: 573 char *s; 574 STRLEN len; 575 U32 hash = 0; 576 char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */ 577 s = SvPV(sv, len); 578 PERL_HASH(hash, s, len); 579 sprintf(hexhash, "0x%"UVxf, (UV)hash); 580 ST(0) = sv_2mortal(newSVpv(hexhash, 0)); 581 582 #define cast_I32(foo) (I32)foo 583 IV 584 cast_I32(i) 585 IV i 586 587 void 588 minus_c() 589 CODE: 590 PL_minus_c = TRUE; 591 592 void 593 save_BEGINs() 594 CODE: 595 PL_savebegin = TRUE; 596 597 SV * 598 cstring(sv) 599 SV * sv 600 CODE: 601 RETVAL = cstring(aTHX_ sv, 0); 602 OUTPUT: 603 RETVAL 604 605 SV * 606 perlstring(sv) 607 SV * sv 608 CODE: 609 RETVAL = cstring(aTHX_ sv, 1); 610 OUTPUT: 611 RETVAL 612 613 SV * 614 cchar(sv) 615 SV * sv 616 CODE: 617 RETVAL = cchar(aTHX_ sv); 618 OUTPUT: 619 RETVAL 620 621 void 622 threadsv_names() 623 PPCODE: 624 #ifdef USE_5005THREADS 625 int i; 626 STRLEN len = strlen(PL_threadsv_names); 627 628 EXTEND(sp, len); 629 for (i = 0; i < len; i++) 630 PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1))); 631 #endif 632 633 634 #define OP_next(o) o->op_next 635 #define OP_sibling(o) o->op_sibling 636 #define OP_desc(o) PL_op_desc[o->op_type] 637 #define OP_targ(o) o->op_targ 638 #define OP_type(o) o->op_type 639 #define OP_seq(o) o->op_seq 640 #define OP_flags(o) o->op_flags 641 #define OP_private(o) o->op_private 642 643 MODULE = B PACKAGE = B::OP PREFIX = OP_ 644 645 B::OP 646 OP_next(o) 647 B::OP o 648 649 B::OP 650 OP_sibling(o) 651 B::OP o 652 653 char * 654 OP_name(o) 655 B::OP o 656 CODE: 657 RETVAL = PL_op_name[o->op_type]; 658 OUTPUT: 659 RETVAL 660 661 662 void 663 OP_ppaddr(o) 664 B::OP o 665 PREINIT: 666 int i; 667 SV *sv = sv_newmortal(); 668 CODE: 669 sv_setpvn(sv, "PL_ppaddr[OP_", 13); 670 sv_catpv(sv, PL_op_name[o->op_type]); 671 for (i=13; (STRLEN)i < SvCUR(sv); ++i) 672 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]); 673 sv_catpv(sv, "]"); 674 ST(0) = sv; 675 676 char * 677 OP_desc(o) 678 B::OP o 679 680 PADOFFSET 681 OP_targ(o) 682 B::OP o 683 684 U16 685 OP_type(o) 686 B::OP o 687 688 U16 689 OP_seq(o) 690 B::OP o 691 692 U8 693 OP_flags(o) 694 B::OP o 695 696 U8 697 OP_private(o) 698 B::OP o 699 700 #define UNOP_first(o) o->op_first 701 702 MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_ 703 704 B::OP 705 UNOP_first(o) 706 B::UNOP o 707 708 #define BINOP_last(o) o->op_last 709 710 MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_ 711 712 B::OP 713 BINOP_last(o) 714 B::BINOP o 715 716 #define LOGOP_other(o) o->op_other 717 718 MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_ 719 720 B::OP 721 LOGOP_other(o) 722 B::LOGOP o 723 724 MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_ 725 726 U32 727 LISTOP_children(o) 728 B::LISTOP o 729 OP * kid = NO_INIT 730 int i = NO_INIT 731 CODE: 732 i = 0; 733 for (kid = o->op_first; kid; kid = kid->op_sibling) 734 i++; 735 RETVAL = i; 736 OUTPUT: 737 RETVAL 738 739 #define PMOP_pmreplroot(o) o->op_pmreplroot 740 #define PMOP_pmreplstart(o) o->op_pmreplstart 741 #define PMOP_pmnext(o) o->op_pmnext 742 #define PMOP_pmregexp(o) PM_GETRE(o) 743 #ifdef USE_ITHREADS 744 #define PMOP_pmoffset(o) o->op_pmoffset 745 #endif 746 #define PMOP_pmflags(o) o->op_pmflags 747 #define PMOP_pmpermflags(o) o->op_pmpermflags 748 #define PMOP_pmdynflags(o) o->op_pmdynflags 749 750 MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_ 751 752 void 753 PMOP_pmreplroot(o) 754 B::PMOP o 755 OP * root = NO_INIT 756 CODE: 757 ST(0) = sv_newmortal(); 758 root = o->op_pmreplroot; 759 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */ 760 if (o->op_type == OP_PUSHRE) { 761 #ifdef USE_ITHREADS 762 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) ); 763 #else 764 sv_setiv(newSVrv(ST(0), root ? 765 svclassnames[SvTYPE((SV*)root)] : "B::SV"), 766 PTR2IV(root)); 767 #endif 768 } 769 else { 770 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root)); 771 } 772 773 B::OP 774 PMOP_pmreplstart(o) 775 B::PMOP o 776 777 B::PMOP 778 PMOP_pmnext(o) 779 B::PMOP o 780 781 #ifdef USE_ITHREADS 782 783 IV 784 PMOP_pmoffset(o) 785 B::PMOP o 786 787 #endif 788 789 U32 790 PMOP_pmflags(o) 791 B::PMOP o 792 793 U32 794 PMOP_pmpermflags(o) 795 B::PMOP o 796 797 U8 798 PMOP_pmdynflags(o) 799 B::PMOP o 800 801 void 802 PMOP_precomp(o) 803 B::PMOP o 804 REGEXP * rx = NO_INIT 805 CODE: 806 ST(0) = sv_newmortal(); 807 rx = PM_GETRE(o); 808 if (rx) 809 sv_setpvn(ST(0), rx->precomp, rx->prelen); 810 811 #define SVOP_sv(o) cSVOPo->op_sv 812 #define SVOP_gv(o) ((GV*)cSVOPo->op_sv) 813 814 MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ 815 816 B::SV 817 SVOP_sv(o) 818 B::SVOP o 819 820 B::GV 821 SVOP_gv(o) 822 B::SVOP o 823 824 #define PADOP_padix(o) o->op_padix 825 #define PADOP_sv(o) (o->op_padix ? PL_curpad[o->op_padix] : Nullsv) 826 #define PADOP_gv(o) ((o->op_padix \ 827 && SvTYPE(PL_curpad[o->op_padix]) == SVt_PVGV) \ 828 ? (GV*)PL_curpad[o->op_padix] : Nullgv) 829 830 MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_ 831 832 PADOFFSET 833 PADOP_padix(o) 834 B::PADOP o 835 836 B::SV 837 PADOP_sv(o) 838 B::PADOP o 839 840 B::GV 841 PADOP_gv(o) 842 B::PADOP o 843 844 MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_ 845 846 void 847 PVOP_pv(o) 848 B::PVOP o 849 CODE: 850 /* 851 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts 852 * whereas other PVOPs point to a null terminated string. 853 */ 854 if (o->op_type == OP_TRANS && 855 (o->op_private & OPpTRANS_COMPLEMENT) && 856 !(o->op_private & OPpTRANS_DELETE)) 857 { 858 short* tbl = (short*)o->op_pv; 859 short entries = 257 + tbl[256]; 860 ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short))); 861 } 862 else if (o->op_type == OP_TRANS) { 863 ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short))); 864 } 865 else 866 ST(0) = sv_2mortal(newSVpv(o->op_pv, 0)); 867 868 #define LOOP_redoop(o) o->op_redoop 869 #define LOOP_nextop(o) o->op_nextop 870 #define LOOP_lastop(o) o->op_lastop 871 872 MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_ 873 874 875 B::OP 876 LOOP_redoop(o) 877 B::LOOP o 878 879 B::OP 880 LOOP_nextop(o) 881 B::LOOP o 882 883 B::OP 884 LOOP_lastop(o) 885 B::LOOP o 886 887 #define COP_label(o) o->cop_label 888 #define COP_stashpv(o) CopSTASHPV(o) 889 #define COP_stash(o) CopSTASH(o) 890 #define COP_file(o) CopFILE(o) 891 #define COP_cop_seq(o) o->cop_seq 892 #define COP_arybase(o) o->cop_arybase 893 #define COP_line(o) CopLINE(o) 894 #define COP_warnings(o) o->cop_warnings 895 896 MODULE = B PACKAGE = B::COP PREFIX = COP_ 897 898 char * 899 COP_label(o) 900 B::COP o 901 902 char * 903 COP_stashpv(o) 904 B::COP o 905 906 B::HV 907 COP_stash(o) 908 B::COP o 909 910 char * 911 COP_file(o) 912 B::COP o 913 914 U32 915 COP_cop_seq(o) 916 B::COP o 917 918 I32 919 COP_arybase(o) 920 B::COP o 921 922 U16 923 COP_line(o) 924 B::COP o 925 926 B::SV 927 COP_warnings(o) 928 B::COP o 929 930 MODULE = B PACKAGE = B::SV PREFIX = Sv 931 932 U32 933 SvREFCNT(sv) 934 B::SV sv 935 936 U32 937 SvFLAGS(sv) 938 B::SV sv 939 940 MODULE = B PACKAGE = B::IV PREFIX = Sv 941 942 IV 943 SvIV(sv) 944 B::IV sv 945 946 IV 947 SvIVX(sv) 948 B::IV sv 949 950 UV 951 SvUVX(sv) 952 B::IV sv 953 954 955 MODULE = B PACKAGE = B::IV 956 957 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv)) 958 959 int 960 needs64bits(sv) 961 B::IV sv 962 963 void 964 packiv(sv) 965 B::IV sv 966 CODE: 967 if (sizeof(IV) == 8) { 968 U32 wp[2]; 969 IV iv = SvIVX(sv); 970 /* 971 * The following way of spelling 32 is to stop compilers on 972 * 32-bit architectures from moaning about the shift count 973 * being >= the width of the type. Such architectures don't 974 * reach this code anyway (unless sizeof(IV) > 8 but then 975 * everything else breaks too so I'm not fussed at the moment). 976 */ 977 #ifdef UV_IS_QUAD 978 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4)); 979 #else 980 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4)); 981 #endif 982 wp[1] = htonl(iv & 0xffffffff); 983 ST(0) = sv_2mortal(newSVpvn((char *)wp, 8)); 984 } else { 985 U32 w = htonl((U32)SvIVX(sv)); 986 ST(0) = sv_2mortal(newSVpvn((char *)&w, 4)); 987 } 988 989 MODULE = B PACKAGE = B::NV PREFIX = Sv 990 991 NV 992 SvNV(sv) 993 B::NV sv 994 995 NV 996 SvNVX(sv) 997 B::NV sv 998 999 MODULE = B PACKAGE = B::RV PREFIX = Sv 1000 1001 B::SV 1002 SvRV(sv) 1003 B::RV sv 1004 1005 MODULE = B PACKAGE = B::PV PREFIX = Sv 1006 1007 char* 1008 SvPVX(sv) 1009 B::PV sv 1010 1011 B::SV 1012 SvRV(sv) 1013 B::PV sv 1014 CODE: 1015 if( SvROK(sv) ) { 1016 RETVAL = SvRV(sv); 1017 } 1018 else { 1019 croak( "argument is not SvROK" ); 1020 } 1021 OUTPUT: 1022 RETVAL 1023 1024 void 1025 SvPV(sv) 1026 B::PV sv 1027 CODE: 1028 ST(0) = sv_newmortal(); 1029 if( SvPOK(sv) ) { 1030 sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv)); 1031 SvFLAGS(ST(0)) |= SvUTF8(sv); 1032 } 1033 else { 1034 /* XXX for backward compatibility, but should fail */ 1035 /* croak( "argument is not SvPOK" ); */ 1036 sv_setpvn(ST(0), NULL, 0); 1037 } 1038 1039 STRLEN 1040 SvLEN(sv) 1041 B::PV sv 1042 1043 STRLEN 1044 SvCUR(sv) 1045 B::PV sv 1046 1047 MODULE = B PACKAGE = B::PVMG PREFIX = Sv 1048 1049 void 1050 SvMAGIC(sv) 1051 B::PVMG sv 1052 MAGIC * mg = NO_INIT 1053 PPCODE: 1054 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) 1055 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg)); 1056 1057 MODULE = B PACKAGE = B::PVMG 1058 1059 B::HV 1060 SvSTASH(sv) 1061 B::PVMG sv 1062 1063 #define MgMOREMAGIC(mg) mg->mg_moremagic 1064 #define MgPRIVATE(mg) mg->mg_private 1065 #define MgTYPE(mg) mg->mg_type 1066 #define MgFLAGS(mg) mg->mg_flags 1067 #define MgOBJ(mg) mg->mg_obj 1068 #define MgLENGTH(mg) mg->mg_len 1069 #define MgREGEX(mg) PTR2IV(mg->mg_obj) 1070 1071 MODULE = B PACKAGE = B::MAGIC PREFIX = Mg 1072 1073 B::MAGIC 1074 MgMOREMAGIC(mg) 1075 B::MAGIC mg 1076 1077 U16 1078 MgPRIVATE(mg) 1079 B::MAGIC mg 1080 1081 char 1082 MgTYPE(mg) 1083 B::MAGIC mg 1084 1085 U8 1086 MgFLAGS(mg) 1087 B::MAGIC mg 1088 1089 B::SV 1090 MgOBJ(mg) 1091 B::MAGIC mg 1092 CODE: 1093 if( mg->mg_type != 'r' ) { 1094 RETVAL = MgOBJ(mg); 1095 } 1096 else { 1097 croak( "OBJ is not meaningful on r-magic" ); 1098 } 1099 OUTPUT: 1100 RETVAL 1101 1102 IV 1103 MgREGEX(mg) 1104 B::MAGIC mg 1105 CODE: 1106 if( mg->mg_type == 'r' ) { 1107 RETVAL = MgREGEX(mg); 1108 } 1109 else { 1110 croak( "REGEX is only meaningful on r-magic" ); 1111 } 1112 OUTPUT: 1113 RETVAL 1114 1115 SV* 1116 precomp(mg) 1117 B::MAGIC mg 1118 CODE: 1119 if (mg->mg_type == 'r') { 1120 REGEXP* rx = (REGEXP*)mg->mg_obj; 1121 if( rx ) 1122 RETVAL = newSVpvn( rx->precomp, rx->prelen ); 1123 } 1124 else { 1125 croak( "precomp is only meaningful on r-magic" ); 1126 } 1127 OUTPUT: 1128 RETVAL 1129 1130 I32 1131 MgLENGTH(mg) 1132 B::MAGIC mg 1133 1134 void 1135 MgPTR(mg) 1136 B::MAGIC mg 1137 CODE: 1138 ST(0) = sv_newmortal(); 1139 if (mg->mg_ptr){ 1140 if (mg->mg_len >= 0){ 1141 sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len); 1142 } else { 1143 if (mg->mg_len == HEf_SVKEY) 1144 sv_setsv(ST(0),newRV((SV*)mg->mg_ptr)); 1145 } 1146 } 1147 1148 MODULE = B PACKAGE = B::PVLV PREFIX = Lv 1149 1150 U32 1151 LvTARGOFF(sv) 1152 B::PVLV sv 1153 1154 U32 1155 LvTARGLEN(sv) 1156 B::PVLV sv 1157 1158 char 1159 LvTYPE(sv) 1160 B::PVLV sv 1161 1162 B::SV 1163 LvTARG(sv) 1164 B::PVLV sv 1165 1166 MODULE = B PACKAGE = B::BM PREFIX = Bm 1167 1168 I32 1169 BmUSEFUL(sv) 1170 B::BM sv 1171 1172 U16 1173 BmPREVIOUS(sv) 1174 B::BM sv 1175 1176 U8 1177 BmRARE(sv) 1178 B::BM sv 1179 1180 void 1181 BmTABLE(sv) 1182 B::BM sv 1183 STRLEN len = NO_INIT 1184 char * str = NO_INIT 1185 CODE: 1186 str = SvPV(sv, len); 1187 /* Boyer-Moore table is just after string and its safety-margin \0 */ 1188 ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256)); 1189 1190 MODULE = B PACKAGE = B::GV PREFIX = Gv 1191 1192 void 1193 GvNAME(gv) 1194 B::GV gv 1195 CODE: 1196 ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv))); 1197 1198 bool 1199 is_empty(gv) 1200 B::GV gv 1201 CODE: 1202 RETVAL = GvGP(gv) == Null(GP*); 1203 OUTPUT: 1204 RETVAL 1205 1206 B::HV 1207 GvSTASH(gv) 1208 B::GV gv 1209 1210 B::SV 1211 GvSV(gv) 1212 B::GV gv 1213 1214 B::IO 1215 GvIO(gv) 1216 B::GV gv 1217 1218 B::CV 1219 GvFORM(gv) 1220 B::GV gv 1221 1222 B::AV 1223 GvAV(gv) 1224 B::GV gv 1225 1226 B::HV 1227 GvHV(gv) 1228 B::GV gv 1229 1230 B::GV 1231 GvEGV(gv) 1232 B::GV gv 1233 1234 B::CV 1235 GvCV(gv) 1236 B::GV gv 1237 1238 U32 1239 GvCVGEN(gv) 1240 B::GV gv 1241 1242 U16 1243 GvLINE(gv) 1244 B::GV gv 1245 1246 char * 1247 GvFILE(gv) 1248 B::GV gv 1249 1250 B::GV 1251 GvFILEGV(gv) 1252 B::GV gv 1253 1254 MODULE = B PACKAGE = B::GV 1255 1256 U32 1257 GvREFCNT(gv) 1258 B::GV gv 1259 1260 U8 1261 GvFLAGS(gv) 1262 B::GV gv 1263 1264 MODULE = B PACKAGE = B::IO PREFIX = Io 1265 1266 long 1267 IoLINES(io) 1268 B::IO io 1269 1270 long 1271 IoPAGE(io) 1272 B::IO io 1273 1274 long 1275 IoPAGE_LEN(io) 1276 B::IO io 1277 1278 long 1279 IoLINES_LEFT(io) 1280 B::IO io 1281 1282 char * 1283 IoTOP_NAME(io) 1284 B::IO io 1285 1286 B::GV 1287 IoTOP_GV(io) 1288 B::IO io 1289 1290 char * 1291 IoFMT_NAME(io) 1292 B::IO io 1293 1294 B::GV 1295 IoFMT_GV(io) 1296 B::IO io 1297 1298 char * 1299 IoBOTTOM_NAME(io) 1300 B::IO io 1301 1302 B::GV 1303 IoBOTTOM_GV(io) 1304 B::IO io 1305 1306 short 1307 IoSUBPROCESS(io) 1308 B::IO io 1309 1310 bool 1311 IsSTD(io,name) 1312 B::IO io 1313 char* name 1314 PREINIT: 1315 PerlIO* handle = 0; 1316 CODE: 1317 if( strEQ( name, "stdin" ) ) { 1318 handle = PerlIO_stdin(); 1319 } 1320 else if( strEQ( name, "stdout" ) ) { 1321 handle = PerlIO_stdout(); 1322 } 1323 else if( strEQ( name, "stderr" ) ) { 1324 handle = PerlIO_stderr(); 1325 } 1326 else { 1327 croak( "Invalid value '%s'", name ); 1328 } 1329 RETVAL = handle == IoIFP(io); 1330 OUTPUT: 1331 RETVAL 1332 1333 MODULE = B PACKAGE = B::IO 1334 1335 char 1336 IoTYPE(io) 1337 B::IO io 1338 1339 U8 1340 IoFLAGS(io) 1341 B::IO io 1342 1343 MODULE = B PACKAGE = B::AV PREFIX = Av 1344 1345 SSize_t 1346 AvFILL(av) 1347 B::AV av 1348 1349 SSize_t 1350 AvMAX(av) 1351 B::AV av 1352 1353 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off 1354 1355 IV 1356 AvOFF(av) 1357 B::AV av 1358 1359 void 1360 AvARRAY(av) 1361 B::AV av 1362 PPCODE: 1363 if (AvFILL(av) >= 0) { 1364 SV **svp = AvARRAY(av); 1365 I32 i; 1366 for (i = 0; i <= AvFILL(av); i++) 1367 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i])); 1368 } 1369 1370 MODULE = B PACKAGE = B::AV 1371 1372 U8 1373 AvFLAGS(av) 1374 B::AV av 1375 1376 MODULE = B PACKAGE = B::CV PREFIX = Cv 1377 1378 B::HV 1379 CvSTASH(cv) 1380 B::CV cv 1381 1382 B::OP 1383 CvSTART(cv) 1384 B::CV cv 1385 1386 B::OP 1387 CvROOT(cv) 1388 B::CV cv 1389 1390 B::GV 1391 CvGV(cv) 1392 B::CV cv 1393 1394 char * 1395 CvFILE(cv) 1396 B::CV cv 1397 1398 long 1399 CvDEPTH(cv) 1400 B::CV cv 1401 1402 B::AV 1403 CvPADLIST(cv) 1404 B::CV cv 1405 1406 B::CV 1407 CvOUTSIDE(cv) 1408 B::CV cv 1409 1410 void 1411 CvXSUB(cv) 1412 B::CV cv 1413 CODE: 1414 ST(0) = sv_2mortal(newSViv(PTR2IV(CvXSUB(cv)))); 1415 1416 1417 void 1418 CvXSUBANY(cv) 1419 B::CV cv 1420 CODE: 1421 ST(0) = CvCONST(cv) ? 1422 make_sv_object(aTHX_ sv_newmortal(),CvXSUBANY(cv).any_ptr) : 1423 sv_2mortal(newSViv(CvXSUBANY(cv).any_iv)); 1424 1425 MODULE = B PACKAGE = B::CV 1426 1427 U16 1428 CvFLAGS(cv) 1429 B::CV cv 1430 1431 MODULE = B PACKAGE = B::CV PREFIX = cv_ 1432 1433 B::SV 1434 cv_const_sv(cv) 1435 B::CV cv 1436 1437 1438 MODULE = B PACKAGE = B::HV PREFIX = Hv 1439 1440 STRLEN 1441 HvFILL(hv) 1442 B::HV hv 1443 1444 STRLEN 1445 HvMAX(hv) 1446 B::HV hv 1447 1448 I32 1449 HvKEYS(hv) 1450 B::HV hv 1451 1452 I32 1453 HvRITER(hv) 1454 B::HV hv 1455 1456 char * 1457 HvNAME(hv) 1458 B::HV hv 1459 1460 B::PMOP 1461 HvPMROOT(hv) 1462 B::HV hv 1463 1464 void 1465 HvARRAY(hv) 1466 B::HV hv 1467 PPCODE: 1468 if (HvKEYS(hv) > 0) { 1469 SV *sv; 1470 char *key; 1471 I32 len; 1472 (void)hv_iterinit(hv); 1473 EXTEND(sp, HvKEYS(hv) * 2); 1474 while ((sv = hv_iternextsv(hv, &key, &len))) { 1475 PUSHs(newSVpvn(key, len)); 1476 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv)); 1477 } 1478 } 1479