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 const char* const svclassnames[] = { 23 "B::NULL", 24 #if PERL_VERSION >= 9 25 "B::BIND", 26 #endif 27 "B::IV", 28 "B::NV", 29 #if PERL_VERSION <= 10 30 "B::RV", 31 #endif 32 "B::PV", 33 "B::PVIV", 34 "B::PVNV", 35 "B::PVMG", 36 #if PERL_VERSION <= 8 37 "B::BM", 38 #endif 39 #if PERL_VERSION >= 11 40 "B::REGEXP", 41 #endif 42 #if PERL_VERSION >= 9 43 "B::GV", 44 #endif 45 "B::PVLV", 46 "B::AV", 47 "B::HV", 48 "B::CV", 49 #if PERL_VERSION <= 8 50 "B::GV", 51 #endif 52 "B::FM", 53 "B::IO", 54 }; 55 56 typedef enum { 57 OPc_NULL, /* 0 */ 58 OPc_BASEOP, /* 1 */ 59 OPc_UNOP, /* 2 */ 60 OPc_BINOP, /* 3 */ 61 OPc_LOGOP, /* 4 */ 62 OPc_LISTOP, /* 5 */ 63 OPc_PMOP, /* 6 */ 64 OPc_SVOP, /* 7 */ 65 OPc_PADOP, /* 8 */ 66 OPc_PVOP, /* 9 */ 67 OPc_LOOP, /* 10 */ 68 OPc_COP /* 11 */ 69 } opclass; 70 71 static const char* const opclassnames[] = { 72 "B::NULL", 73 "B::OP", 74 "B::UNOP", 75 "B::BINOP", 76 "B::LOGOP", 77 "B::LISTOP", 78 "B::PMOP", 79 "B::SVOP", 80 "B::PADOP", 81 "B::PVOP", 82 "B::LOOP", 83 "B::COP" 84 }; 85 86 static const size_t opsizes[] = { 87 0, 88 sizeof(OP), 89 sizeof(UNOP), 90 sizeof(BINOP), 91 sizeof(LOGOP), 92 sizeof(LISTOP), 93 sizeof(PMOP), 94 sizeof(SVOP), 95 sizeof(PADOP), 96 sizeof(PVOP), 97 sizeof(LOOP), 98 sizeof(COP) 99 }; 100 101 #define MY_CXT_KEY "B::_guts" XS_VERSION 102 103 typedef struct { 104 int x_walkoptree_debug; /* Flag for walkoptree debug hook */ 105 SV * x_specialsv_list[7]; 106 } my_cxt_t; 107 108 START_MY_CXT 109 110 #define walkoptree_debug (MY_CXT.x_walkoptree_debug) 111 #define specialsv_list (MY_CXT.x_specialsv_list) 112 113 static opclass 114 cc_opclass(pTHX_ const OP *o) 115 { 116 if (!o) 117 return OPc_NULL; 118 119 if (o->op_type == 0) 120 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; 121 122 if (o->op_type == OP_SASSIGN) 123 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); 124 125 if (o->op_type == OP_AELEMFAST) { 126 if (o->op_flags & OPf_SPECIAL) 127 return OPc_BASEOP; 128 else 129 #ifdef USE_ITHREADS 130 return OPc_PADOP; 131 #else 132 return OPc_SVOP; 133 #endif 134 } 135 136 #ifdef USE_ITHREADS 137 if (o->op_type == OP_GV || o->op_type == OP_GVSV || 138 o->op_type == OP_RCATLINE) 139 return OPc_PADOP; 140 #endif 141 142 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { 143 case OA_BASEOP: 144 return OPc_BASEOP; 145 146 case OA_UNOP: 147 return OPc_UNOP; 148 149 case OA_BINOP: 150 return OPc_BINOP; 151 152 case OA_LOGOP: 153 return OPc_LOGOP; 154 155 case OA_LISTOP: 156 return OPc_LISTOP; 157 158 case OA_PMOP: 159 return OPc_PMOP; 160 161 case OA_SVOP: 162 return OPc_SVOP; 163 164 case OA_PADOP: 165 return OPc_PADOP; 166 167 case OA_PVOP_OR_SVOP: 168 /* 169 * Character translations (tr///) are usually a PVOP, keeping a 170 * pointer to a table of shorts used to look up translations. 171 * Under utf8, however, a simple table isn't practical; instead, 172 * the OP is an SVOP, and the SV is a reference to a swash 173 * (i.e., an RV pointing to an HV). 174 */ 175 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) 176 ? OPc_SVOP : OPc_PVOP; 177 178 case OA_LOOP: 179 return OPc_LOOP; 180 181 case OA_COP: 182 return OPc_COP; 183 184 case OA_BASEOP_OR_UNOP: 185 /* 186 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on 187 * whether parens were seen. perly.y uses OPf_SPECIAL to 188 * signal whether a BASEOP had empty parens or none. 189 * Some other UNOPs are created later, though, so the best 190 * test is OPf_KIDS, which is set in newUNOP. 191 */ 192 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; 193 194 case OA_FILESTATOP: 195 /* 196 * The file stat OPs are created via UNI(OP_foo) in toke.c but use 197 * the OPf_REF flag to distinguish between OP types instead of the 198 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we 199 * return OPc_UNOP so that walkoptree can find our children. If 200 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set 201 * (no argument to the operator) it's an OP; with OPf_REF set it's 202 * an SVOP (and op_sv is the GV for the filehandle argument). 203 */ 204 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : 205 #ifdef USE_ITHREADS 206 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP); 207 #else 208 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP); 209 #endif 210 case OA_LOOPEXOP: 211 /* 212 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a 213 * label was omitted (in which case it's a BASEOP) or else a term was 214 * seen. In this last case, all except goto are definitely PVOP but 215 * goto is either a PVOP (with an ordinary constant label), an UNOP 216 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for 217 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to 218 * get set. 219 */ 220 if (o->op_flags & OPf_STACKED) 221 return OPc_UNOP; 222 else if (o->op_flags & OPf_SPECIAL) 223 return OPc_BASEOP; 224 else 225 return OPc_PVOP; 226 } 227 warn("can't determine class of operator %s, assuming BASEOP\n", 228 PL_op_name[o->op_type]); 229 return OPc_BASEOP; 230 } 231 232 static char * 233 cc_opclassname(pTHX_ const OP *o) 234 { 235 return (char *)opclassnames[cc_opclass(aTHX_ o)]; 236 } 237 238 static SV * 239 make_sv_object(pTHX_ SV *arg, SV *sv) 240 { 241 const char *type = 0; 242 IV iv; 243 dMY_CXT; 244 245 for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) { 246 if (sv == specialsv_list[iv]) { 247 type = "B::SPECIAL"; 248 break; 249 } 250 } 251 if (!type) { 252 type = svclassnames[SvTYPE(sv)]; 253 iv = PTR2IV(sv); 254 } 255 sv_setiv(newSVrv(arg, type), iv); 256 return arg; 257 } 258 259 #if PERL_VERSION >= 9 260 static SV * 261 make_temp_object(pTHX_ SV *arg, SV *temp) 262 { 263 SV *target; 264 const char *const type = svclassnames[SvTYPE(temp)]; 265 const IV iv = PTR2IV(temp); 266 267 target = newSVrv(arg, type); 268 sv_setiv(target, iv); 269 270 /* Need to keep our "temp" around as long as the target exists. 271 Simplest way seems to be to hang it from magic, and let that clear 272 it up. No vtable, so won't actually get in the way of anything. */ 273 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0); 274 /* magic object has had its reference count increased, so we must drop 275 our reference. */ 276 SvREFCNT_dec(temp); 277 return arg; 278 } 279 280 static SV * 281 make_warnings_object(pTHX_ SV *arg, STRLEN *warnings) 282 { 283 const char *type = 0; 284 dMY_CXT; 285 IV iv = sizeof(specialsv_list)/sizeof(SV*); 286 287 /* Counting down is deliberate. Before the split between make_sv_object 288 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD 289 were both 0, so you could never get a B::SPECIAL for pWARN_STD */ 290 291 while (iv--) { 292 if ((SV*)warnings == specialsv_list[iv]) { 293 type = "B::SPECIAL"; 294 break; 295 } 296 } 297 if (type) { 298 sv_setiv(newSVrv(arg, type), iv); 299 return arg; 300 } else { 301 /* B assumes that warnings are a regular SV. Seems easier to keep it 302 happy by making them into a regular SV. */ 303 return make_temp_object(aTHX_ arg, 304 newSVpvn((char *)(warnings + 1), *warnings)); 305 } 306 } 307 308 static SV * 309 make_cop_io_object(pTHX_ SV *arg, COP *cop) 310 { 311 SV *const value = newSV(0); 312 313 Perl_emulate_cop_io(aTHX_ cop, value); 314 315 if(SvOK(value)) { 316 return make_temp_object(aTHX_ arg, newSVsv(value)); 317 } else { 318 SvREFCNT_dec(value); 319 return make_sv_object(aTHX_ arg, NULL); 320 } 321 } 322 #endif 323 324 static SV * 325 make_mg_object(pTHX_ SV *arg, MAGIC *mg) 326 { 327 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg)); 328 return arg; 329 } 330 331 static SV * 332 cstring(pTHX_ SV *sv, bool perlstyle) 333 { 334 SV *sstr = newSVpvs(""); 335 336 if (!SvOK(sv)) 337 sv_setpvs(sstr, "0"); 338 else if (perlstyle && SvUTF8(sv)) { 339 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */ 340 const STRLEN len = SvCUR(sv); 341 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ); 342 sv_setpvs(sstr,"\""); 343 while (*s) 344 { 345 if (*s == '"') 346 sv_catpvs(sstr, "\\\""); 347 else if (*s == '$') 348 sv_catpvs(sstr, "\\$"); 349 else if (*s == '@') 350 sv_catpvs(sstr, "\\@"); 351 else if (*s == '\\') 352 { 353 if (strchr("nrftax\\",*(s+1))) 354 sv_catpvn(sstr, s++, 2); 355 else 356 sv_catpvs(sstr, "\\\\"); 357 } 358 else /* should always be printable */ 359 sv_catpvn(sstr, s, 1); 360 ++s; 361 } 362 sv_catpvs(sstr, "\""); 363 return sstr; 364 } 365 else 366 { 367 /* XXX Optimise? */ 368 STRLEN len; 369 const char *s = SvPV(sv, len); 370 sv_catpvs(sstr, "\""); 371 for (; len; len--, s++) 372 { 373 /* At least try a little for readability */ 374 if (*s == '"') 375 sv_catpvs(sstr, "\\\""); 376 else if (*s == '\\') 377 sv_catpvs(sstr, "\\\\"); 378 /* trigraphs - bleagh */ 379 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') { 380 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ 381 const STRLEN oct_len = my_sprintf(escbuff, "\\%03o", '?'); 382 sv_catpvn(sstr, escbuff, oct_len); 383 } 384 else if (perlstyle && *s == '$') 385 sv_catpvs(sstr, "\\$"); 386 else if (perlstyle && *s == '@') 387 sv_catpvs(sstr, "\\@"); 388 #ifdef EBCDIC 389 else if (isPRINT(*s)) 390 #else 391 else if (*s >= ' ' && *s < 127) 392 #endif /* EBCDIC */ 393 sv_catpvn(sstr, s, 1); 394 else if (*s == '\n') 395 sv_catpvs(sstr, "\\n"); 396 else if (*s == '\r') 397 sv_catpvs(sstr, "\\r"); 398 else if (*s == '\t') 399 sv_catpvs(sstr, "\\t"); 400 else if (*s == '\a') 401 sv_catpvs(sstr, "\\a"); 402 else if (*s == '\b') 403 sv_catpvs(sstr, "\\b"); 404 else if (*s == '\f') 405 sv_catpvs(sstr, "\\f"); 406 else if (!perlstyle && *s == '\v') 407 sv_catpvs(sstr, "\\v"); 408 else 409 { 410 /* Don't want promotion of a signed -1 char in sprintf args */ 411 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ 412 const unsigned char c = (unsigned char) *s; 413 const STRLEN oct_len = my_sprintf(escbuff, "\\%03o", c); 414 sv_catpvn(sstr, escbuff, oct_len); 415 } 416 /* XXX Add line breaks if string is long */ 417 } 418 sv_catpvs(sstr, "\""); 419 } 420 return sstr; 421 } 422 423 static SV * 424 cchar(pTHX_ SV *sv) 425 { 426 SV *sstr = newSVpvs("'"); 427 const char *s = SvPV_nolen(sv); 428 429 if (*s == '\'') 430 sv_catpvs(sstr, "\\'"); 431 else if (*s == '\\') 432 sv_catpvs(sstr, "\\\\"); 433 #ifdef EBCDIC 434 else if (isPRINT(*s)) 435 #else 436 else if (*s >= ' ' && *s < 127) 437 #endif /* EBCDIC */ 438 sv_catpvn(sstr, s, 1); 439 else if (*s == '\n') 440 sv_catpvs(sstr, "\\n"); 441 else if (*s == '\r') 442 sv_catpvs(sstr, "\\r"); 443 else if (*s == '\t') 444 sv_catpvs(sstr, "\\t"); 445 else if (*s == '\a') 446 sv_catpvs(sstr, "\\a"); 447 else if (*s == '\b') 448 sv_catpvs(sstr, "\\b"); 449 else if (*s == '\f') 450 sv_catpvs(sstr, "\\f"); 451 else if (*s == '\v') 452 sv_catpvs(sstr, "\\v"); 453 else 454 { 455 /* no trigraph support */ 456 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ 457 /* Don't want promotion of a signed -1 char in sprintf args */ 458 unsigned char c = (unsigned char) *s; 459 const STRLEN oct_len = my_sprintf(escbuff, "\\%03o", c); 460 sv_catpvn(sstr, escbuff, oct_len); 461 } 462 sv_catpvs(sstr, "'"); 463 return sstr; 464 } 465 466 #if PERL_VERSION >= 9 467 # define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart 468 # define PMOP_pmreplroot(o) o->op_pmreplrootu.op_pmreplroot 469 #else 470 # define PMOP_pmreplstart(o) o->op_pmreplstart 471 # define PMOP_pmreplroot(o) o->op_pmreplroot 472 # define PMOP_pmpermflags(o) o->op_pmpermflags 473 # define PMOP_pmdynflags(o) o->op_pmdynflags 474 #endif 475 476 static void 477 walkoptree(pTHX_ SV *opsv, const char *method) 478 { 479 dSP; 480 OP *o, *kid; 481 dMY_CXT; 482 483 if (!SvROK(opsv)) 484 croak("opsv is not a reference"); 485 opsv = sv_mortalcopy(opsv); 486 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv))); 487 if (walkoptree_debug) { 488 PUSHMARK(sp); 489 XPUSHs(opsv); 490 PUTBACK; 491 perl_call_method("walkoptree_debug", G_DISCARD); 492 } 493 PUSHMARK(sp); 494 XPUSHs(opsv); 495 PUTBACK; 496 perl_call_method(method, G_DISCARD); 497 if (o && (o->op_flags & OPf_KIDS)) { 498 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) { 499 /* Use the same opsv. Rely on methods not to mess it up. */ 500 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid)); 501 walkoptree(aTHX_ opsv, method); 502 } 503 } 504 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE 505 && (kid = PMOP_pmreplroot(cPMOPo))) 506 { 507 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid)); 508 walkoptree(aTHX_ opsv, method); 509 } 510 } 511 512 static SV ** 513 oplist(pTHX_ OP *o, SV **SP) 514 { 515 for(; o; o = o->op_next) { 516 SV *opsv; 517 #if PERL_VERSION >= 9 518 if (o->op_opt == 0) 519 break; 520 o->op_opt = 0; 521 #else 522 if (o->op_seq == 0) 523 break; 524 o->op_seq = 0; 525 #endif 526 opsv = sv_newmortal(); 527 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o)); 528 XPUSHs(opsv); 529 switch (o->op_type) { 530 case OP_SUBST: 531 SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP); 532 continue; 533 case OP_SORT: 534 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) { 535 OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */ 536 kid = kUNOP->op_first; /* pass rv2gv */ 537 kid = kUNOP->op_first; /* pass leave */ 538 SP = oplist(aTHX_ kid->op_next, SP); 539 } 540 continue; 541 } 542 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { 543 case OA_LOGOP: 544 SP = oplist(aTHX_ cLOGOPo->op_other, SP); 545 break; 546 case OA_LOOP: 547 SP = oplist(aTHX_ cLOOPo->op_lastop, SP); 548 SP = oplist(aTHX_ cLOOPo->op_nextop, SP); 549 SP = oplist(aTHX_ cLOOPo->op_redoop, SP); 550 break; 551 } 552 } 553 return SP; 554 } 555 556 typedef OP *B__OP; 557 typedef UNOP *B__UNOP; 558 typedef BINOP *B__BINOP; 559 typedef LOGOP *B__LOGOP; 560 typedef LISTOP *B__LISTOP; 561 typedef PMOP *B__PMOP; 562 typedef SVOP *B__SVOP; 563 typedef PADOP *B__PADOP; 564 typedef PVOP *B__PVOP; 565 typedef LOOP *B__LOOP; 566 typedef COP *B__COP; 567 568 typedef SV *B__SV; 569 typedef SV *B__IV; 570 typedef SV *B__PV; 571 typedef SV *B__NV; 572 typedef SV *B__PVMG; 573 #if PERL_VERSION >= 11 574 typedef SV *B__REGEXP; 575 #endif 576 typedef SV *B__PVLV; 577 typedef SV *B__BM; 578 typedef SV *B__RV; 579 typedef SV *B__FM; 580 typedef AV *B__AV; 581 typedef HV *B__HV; 582 typedef CV *B__CV; 583 typedef GV *B__GV; 584 typedef IO *B__IO; 585 586 typedef MAGIC *B__MAGIC; 587 typedef HE *B__HE; 588 #if PERL_VERSION >= 9 589 typedef struct refcounted_he *B__RHE; 590 #endif 591 592 MODULE = B PACKAGE = B PREFIX = B_ 593 594 PROTOTYPES: DISABLE 595 596 BOOT: 597 { 598 HV *stash = gv_stashpvs("B", GV_ADD); 599 AV *export_ok = perl_get_av("B::EXPORT_OK", GV_ADD); 600 MY_CXT_INIT; 601 specialsv_list[0] = Nullsv; 602 specialsv_list[1] = &PL_sv_undef; 603 specialsv_list[2] = &PL_sv_yes; 604 specialsv_list[3] = &PL_sv_no; 605 specialsv_list[4] = (SV *) pWARN_ALL; 606 specialsv_list[5] = (SV *) pWARN_NONE; 607 specialsv_list[6] = (SV *) pWARN_STD; 608 #if PERL_VERSION <= 8 609 # define OPpPAD_STATE 0 610 #endif 611 #include "defsubs.h" 612 } 613 614 #define B_main_cv() PL_main_cv 615 #define B_init_av() PL_initav 616 #define B_inc_gv() PL_incgv 617 #define B_check_av() PL_checkav_save 618 #if PERL_VERSION > 8 619 # define B_unitcheck_av() PL_unitcheckav_save 620 #else 621 # define B_unitcheck_av() NULL 622 #endif 623 #define B_begin_av() PL_beginav_save 624 #define B_end_av() PL_endav 625 #define B_main_root() PL_main_root 626 #define B_main_start() PL_main_start 627 #define B_amagic_generation() PL_amagic_generation 628 #define B_sub_generation() PL_sub_generation 629 #define B_defstash() PL_defstash 630 #define B_curstash() PL_curstash 631 #define B_dowarn() PL_dowarn 632 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv)) 633 #define B_sv_undef() &PL_sv_undef 634 #define B_sv_yes() &PL_sv_yes 635 #define B_sv_no() &PL_sv_no 636 #define B_formfeed() PL_formfeed 637 #ifdef USE_ITHREADS 638 #define B_regex_padav() PL_regex_padav 639 #endif 640 641 B::AV 642 B_init_av() 643 644 B::AV 645 B_check_av() 646 647 #if PERL_VERSION >= 9 648 649 B::AV 650 B_unitcheck_av() 651 652 #endif 653 654 B::AV 655 B_begin_av() 656 657 B::AV 658 B_end_av() 659 660 B::GV 661 B_inc_gv() 662 663 #ifdef USE_ITHREADS 664 665 B::AV 666 B_regex_padav() 667 668 #endif 669 670 B::CV 671 B_main_cv() 672 673 B::OP 674 B_main_root() 675 676 B::OP 677 B_main_start() 678 679 long 680 B_amagic_generation() 681 682 long 683 B_sub_generation() 684 685 B::AV 686 B_comppadlist() 687 688 B::SV 689 B_sv_undef() 690 691 B::SV 692 B_sv_yes() 693 694 B::SV 695 B_sv_no() 696 697 B::HV 698 B_curstash() 699 700 B::HV 701 B_defstash() 702 703 U8 704 B_dowarn() 705 706 B::SV 707 B_formfeed() 708 709 void 710 B_warnhook() 711 CODE: 712 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook); 713 714 void 715 B_diehook() 716 CODE: 717 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook); 718 719 MODULE = B PACKAGE = B 720 721 void 722 walkoptree(opsv, method) 723 SV * opsv 724 const char * method 725 CODE: 726 walkoptree(aTHX_ opsv, method); 727 728 int 729 walkoptree_debug(...) 730 CODE: 731 dMY_CXT; 732 RETVAL = walkoptree_debug; 733 if (items > 0 && SvTRUE(ST(1))) 734 walkoptree_debug = 1; 735 OUTPUT: 736 RETVAL 737 738 #define address(sv) PTR2IV(sv) 739 740 IV 741 address(sv) 742 SV * sv 743 744 B::SV 745 svref_2object(sv) 746 SV * sv 747 CODE: 748 if (!SvROK(sv)) 749 croak("argument is not a reference"); 750 RETVAL = (SV*)SvRV(sv); 751 OUTPUT: 752 RETVAL 753 754 void 755 opnumber(name) 756 const char * name 757 CODE: 758 { 759 int i; 760 IV result = -1; 761 ST(0) = sv_newmortal(); 762 if (strncmp(name,"pp_",3) == 0) 763 name += 3; 764 for (i = 0; i < PL_maxo; i++) 765 { 766 if (strcmp(name, PL_op_name[i]) == 0) 767 { 768 result = i; 769 break; 770 } 771 } 772 sv_setiv(ST(0),result); 773 } 774 775 void 776 ppname(opnum) 777 int opnum 778 CODE: 779 ST(0) = sv_newmortal(); 780 if (opnum >= 0 && opnum < PL_maxo) { 781 sv_setpvs(ST(0), "pp_"); 782 sv_catpv(ST(0), PL_op_name[opnum]); 783 } 784 785 void 786 hash(sv) 787 SV * sv 788 CODE: 789 STRLEN len; 790 U32 hash = 0; 791 char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */ 792 const char *s = SvPV(sv, len); 793 PERL_HASH(hash, s, len); 794 len = my_sprintf(hexhash, "0x%"UVxf, (UV)hash); 795 ST(0) = newSVpvn_flags(hexhash, len, SVs_TEMP); 796 797 #define cast_I32(foo) (I32)foo 798 IV 799 cast_I32(i) 800 IV i 801 802 void 803 minus_c() 804 CODE: 805 PL_minus_c = TRUE; 806 807 void 808 save_BEGINs() 809 CODE: 810 PL_savebegin = TRUE; 811 812 SV * 813 cstring(sv) 814 SV * sv 815 CODE: 816 RETVAL = cstring(aTHX_ sv, 0); 817 OUTPUT: 818 RETVAL 819 820 SV * 821 perlstring(sv) 822 SV * sv 823 CODE: 824 RETVAL = cstring(aTHX_ sv, 1); 825 OUTPUT: 826 RETVAL 827 828 SV * 829 cchar(sv) 830 SV * sv 831 CODE: 832 RETVAL = cchar(aTHX_ sv); 833 OUTPUT: 834 RETVAL 835 836 void 837 threadsv_names() 838 PPCODE: 839 #if PERL_VERSION <= 8 840 # ifdef USE_5005THREADS 841 int i; 842 const STRLEN len = strlen(PL_threadsv_names); 843 844 EXTEND(sp, len); 845 for (i = 0; i < len; i++) 846 PUSHs(newSVpvn_flags(&PL_threadsv_names[i], 1, SVs_TEMP)); 847 # endif 848 #endif 849 850 #define OP_next(o) o->op_next 851 #define OP_sibling(o) o->op_sibling 852 #define OP_desc(o) (char *)PL_op_desc[o->op_type] 853 #define OP_targ(o) o->op_targ 854 #define OP_type(o) o->op_type 855 #if PERL_VERSION >= 9 856 # define OP_opt(o) o->op_opt 857 #else 858 # define OP_seq(o) o->op_seq 859 #endif 860 #define OP_flags(o) o->op_flags 861 #define OP_private(o) o->op_private 862 #define OP_spare(o) o->op_spare 863 864 MODULE = B PACKAGE = B::OP PREFIX = OP_ 865 866 size_t 867 OP_size(o) 868 B::OP o 869 CODE: 870 RETVAL = opsizes[cc_opclass(aTHX_ o)]; 871 OUTPUT: 872 RETVAL 873 874 B::OP 875 OP_next(o) 876 B::OP o 877 878 B::OP 879 OP_sibling(o) 880 B::OP o 881 882 char * 883 OP_name(o) 884 B::OP o 885 CODE: 886 RETVAL = (char *)PL_op_name[o->op_type]; 887 OUTPUT: 888 RETVAL 889 890 891 void 892 OP_ppaddr(o) 893 B::OP o 894 PREINIT: 895 int i; 896 SV *sv = sv_newmortal(); 897 CODE: 898 sv_setpvs(sv, "PL_ppaddr[OP_"); 899 sv_catpv(sv, PL_op_name[o->op_type]); 900 for (i=13; (STRLEN)i < SvCUR(sv); ++i) 901 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]); 902 sv_catpvs(sv, "]"); 903 ST(0) = sv; 904 905 char * 906 OP_desc(o) 907 B::OP o 908 909 PADOFFSET 910 OP_targ(o) 911 B::OP o 912 913 U16 914 OP_type(o) 915 B::OP o 916 917 #if PERL_VERSION >= 9 918 919 U16 920 OP_opt(o) 921 B::OP o 922 923 #else 924 925 U16 926 OP_seq(o) 927 B::OP o 928 929 #endif 930 931 U8 932 OP_flags(o) 933 B::OP o 934 935 U8 936 OP_private(o) 937 B::OP o 938 939 #if PERL_VERSION >= 9 940 941 U16 942 OP_spare(o) 943 B::OP o 944 945 #endif 946 947 void 948 OP_oplist(o) 949 B::OP o 950 PPCODE: 951 SP = oplist(aTHX_ o, SP); 952 953 #define UNOP_first(o) o->op_first 954 955 MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_ 956 957 B::OP 958 UNOP_first(o) 959 B::UNOP o 960 961 #define BINOP_last(o) o->op_last 962 963 MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_ 964 965 B::OP 966 BINOP_last(o) 967 B::BINOP o 968 969 #define LOGOP_other(o) o->op_other 970 971 MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_ 972 973 B::OP 974 LOGOP_other(o) 975 B::LOGOP o 976 977 MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_ 978 979 U32 980 LISTOP_children(o) 981 B::LISTOP o 982 OP * kid = NO_INIT 983 int i = NO_INIT 984 CODE: 985 i = 0; 986 for (kid = o->op_first; kid; kid = kid->op_sibling) 987 i++; 988 RETVAL = i; 989 OUTPUT: 990 RETVAL 991 992 #define PMOP_pmnext(o) o->op_pmnext 993 #define PMOP_pmregexp(o) PM_GETRE(o) 994 #ifdef USE_ITHREADS 995 #define PMOP_pmoffset(o) o->op_pmoffset 996 #define PMOP_pmstashpv(o) PmopSTASHPV(o); 997 #else 998 #define PMOP_pmstash(o) PmopSTASH(o); 999 #endif 1000 #define PMOP_pmflags(o) o->op_pmflags 1001 1002 MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_ 1003 1004 #if PERL_VERSION <= 8 1005 1006 void 1007 PMOP_pmreplroot(o) 1008 B::PMOP o 1009 OP * root = NO_INIT 1010 CODE: 1011 ST(0) = sv_newmortal(); 1012 root = o->op_pmreplroot; 1013 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */ 1014 if (o->op_type == OP_PUSHRE) { 1015 # ifdef USE_ITHREADS 1016 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) ); 1017 # else 1018 sv_setiv(newSVrv(ST(0), root ? 1019 svclassnames[SvTYPE((SV*)root)] : "B::SV"), 1020 PTR2IV(root)); 1021 # endif 1022 } 1023 else { 1024 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root)); 1025 } 1026 1027 #else 1028 1029 void 1030 PMOP_pmreplroot(o) 1031 B::PMOP o 1032 CODE: 1033 ST(0) = sv_newmortal(); 1034 if (o->op_type == OP_PUSHRE) { 1035 # ifdef USE_ITHREADS 1036 sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff); 1037 # else 1038 GV *const target = o->op_pmreplrootu.op_pmtargetgv; 1039 sv_setiv(newSVrv(ST(0), target ? 1040 svclassnames[SvTYPE((SV*)target)] : "B::SV"), 1041 PTR2IV(target)); 1042 # endif 1043 } 1044 else { 1045 OP *const root = o->op_pmreplrootu.op_pmreplroot; 1046 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), 1047 PTR2IV(root)); 1048 } 1049 1050 #endif 1051 1052 B::OP 1053 PMOP_pmreplstart(o) 1054 B::PMOP o 1055 1056 #if PERL_VERSION < 9 1057 1058 B::PMOP 1059 PMOP_pmnext(o) 1060 B::PMOP o 1061 1062 #endif 1063 1064 #ifdef USE_ITHREADS 1065 1066 IV 1067 PMOP_pmoffset(o) 1068 B::PMOP o 1069 1070 char* 1071 PMOP_pmstashpv(o) 1072 B::PMOP o 1073 1074 #else 1075 1076 B::HV 1077 PMOP_pmstash(o) 1078 B::PMOP o 1079 1080 #endif 1081 1082 U32 1083 PMOP_pmflags(o) 1084 B::PMOP o 1085 1086 #if PERL_VERSION < 9 1087 1088 U32 1089 PMOP_pmpermflags(o) 1090 B::PMOP o 1091 1092 U8 1093 PMOP_pmdynflags(o) 1094 B::PMOP o 1095 1096 #endif 1097 1098 void 1099 PMOP_precomp(o) 1100 B::PMOP o 1101 REGEXP * rx = NO_INIT 1102 CODE: 1103 ST(0) = sv_newmortal(); 1104 rx = PM_GETRE(o); 1105 if (rx) 1106 sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx)); 1107 1108 #if PERL_VERSION >= 9 1109 1110 void 1111 PMOP_reflags(o) 1112 B::PMOP o 1113 REGEXP * rx = NO_INIT 1114 CODE: 1115 ST(0) = sv_newmortal(); 1116 rx = PM_GETRE(o); 1117 if (rx) 1118 sv_setuv(ST(0), RX_EXTFLAGS(rx)); 1119 1120 #endif 1121 1122 #define SVOP_sv(o) cSVOPo->op_sv 1123 #define SVOP_gv(o) ((GV*)cSVOPo->op_sv) 1124 1125 MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ 1126 1127 B::SV 1128 SVOP_sv(o) 1129 B::SVOP o 1130 1131 B::GV 1132 SVOP_gv(o) 1133 B::SVOP o 1134 1135 #define PADOP_padix(o) o->op_padix 1136 #define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv) 1137 #define PADOP_gv(o) ((o->op_padix \ 1138 && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \ 1139 ? (GV*)PAD_SVl(o->op_padix) : (GV *)NULL) 1140 1141 MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_ 1142 1143 PADOFFSET 1144 PADOP_padix(o) 1145 B::PADOP o 1146 1147 B::SV 1148 PADOP_sv(o) 1149 B::PADOP o 1150 1151 B::GV 1152 PADOP_gv(o) 1153 B::PADOP o 1154 1155 MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_ 1156 1157 void 1158 PVOP_pv(o) 1159 B::PVOP o 1160 CODE: 1161 /* 1162 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts 1163 * whereas other PVOPs point to a null terminated string. 1164 */ 1165 if (o->op_type == OP_TRANS && 1166 (o->op_private & OPpTRANS_COMPLEMENT) && 1167 !(o->op_private & OPpTRANS_DELETE)) 1168 { 1169 const short* const tbl = (short*)o->op_pv; 1170 const short entries = 257 + tbl[256]; 1171 ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP); 1172 } 1173 else if (o->op_type == OP_TRANS) { 1174 ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP); 1175 } 1176 else 1177 ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP); 1178 1179 #define LOOP_redoop(o) o->op_redoop 1180 #define LOOP_nextop(o) o->op_nextop 1181 #define LOOP_lastop(o) o->op_lastop 1182 1183 MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_ 1184 1185 1186 B::OP 1187 LOOP_redoop(o) 1188 B::LOOP o 1189 1190 B::OP 1191 LOOP_nextop(o) 1192 B::LOOP o 1193 1194 B::OP 1195 LOOP_lastop(o) 1196 B::LOOP o 1197 1198 #define COP_label(o) CopLABEL(o) 1199 #define COP_stashpv(o) CopSTASHPV(o) 1200 #define COP_stash(o) CopSTASH(o) 1201 #define COP_file(o) CopFILE(o) 1202 #define COP_filegv(o) CopFILEGV(o) 1203 #define COP_cop_seq(o) o->cop_seq 1204 #define COP_arybase(o) CopARYBASE_get(o) 1205 #define COP_line(o) CopLINE(o) 1206 #define COP_hints(o) CopHINTS_get(o) 1207 #if PERL_VERSION < 9 1208 # define COP_warnings(o) o->cop_warnings 1209 # define COP_io(o) o->cop_io 1210 #endif 1211 1212 MODULE = B PACKAGE = B::COP PREFIX = COP_ 1213 1214 #if PERL_VERSION >= 11 1215 1216 const char * 1217 COP_label(o) 1218 B::COP o 1219 1220 #else 1221 1222 char * 1223 COP_label(o) 1224 B::COP o 1225 1226 #endif 1227 1228 char * 1229 COP_stashpv(o) 1230 B::COP o 1231 1232 B::HV 1233 COP_stash(o) 1234 B::COP o 1235 1236 char * 1237 COP_file(o) 1238 B::COP o 1239 1240 B::GV 1241 COP_filegv(o) 1242 B::COP o 1243 1244 1245 U32 1246 COP_cop_seq(o) 1247 B::COP o 1248 1249 I32 1250 COP_arybase(o) 1251 B::COP o 1252 1253 U32 1254 COP_line(o) 1255 B::COP o 1256 1257 #if PERL_VERSION >= 9 1258 1259 void 1260 COP_warnings(o) 1261 B::COP o 1262 PPCODE: 1263 ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings); 1264 XSRETURN(1); 1265 1266 void 1267 COP_io(o) 1268 B::COP o 1269 PPCODE: 1270 ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o); 1271 XSRETURN(1); 1272 1273 B::RHE 1274 COP_hints_hash(o) 1275 B::COP o 1276 CODE: 1277 RETVAL = o->cop_hints_hash; 1278 OUTPUT: 1279 RETVAL 1280 1281 #else 1282 1283 B::SV 1284 COP_warnings(o) 1285 B::COP o 1286 1287 B::SV 1288 COP_io(o) 1289 B::COP o 1290 1291 #endif 1292 1293 U32 1294 COP_hints(o) 1295 B::COP o 1296 1297 MODULE = B PACKAGE = B::SV 1298 1299 U32 1300 SvTYPE(sv) 1301 B::SV sv 1302 1303 #define object_2svref(sv) sv 1304 #define SVREF SV * 1305 1306 SVREF 1307 object_2svref(sv) 1308 B::SV sv 1309 1310 MODULE = B PACKAGE = B::SV PREFIX = Sv 1311 1312 U32 1313 SvREFCNT(sv) 1314 B::SV sv 1315 1316 U32 1317 SvFLAGS(sv) 1318 B::SV sv 1319 1320 U32 1321 SvPOK(sv) 1322 B::SV sv 1323 1324 U32 1325 SvROK(sv) 1326 B::SV sv 1327 1328 U32 1329 SvMAGICAL(sv) 1330 B::SV sv 1331 1332 MODULE = B PACKAGE = B::IV PREFIX = Sv 1333 1334 IV 1335 SvIV(sv) 1336 B::IV sv 1337 1338 IV 1339 SvIVX(sv) 1340 B::IV sv 1341 1342 UV 1343 SvUVX(sv) 1344 B::IV sv 1345 1346 1347 MODULE = B PACKAGE = B::IV 1348 1349 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv)) 1350 1351 int 1352 needs64bits(sv) 1353 B::IV sv 1354 1355 void 1356 packiv(sv) 1357 B::IV sv 1358 CODE: 1359 if (sizeof(IV) == 8) { 1360 U32 wp[2]; 1361 const IV iv = SvIVX(sv); 1362 /* 1363 * The following way of spelling 32 is to stop compilers on 1364 * 32-bit architectures from moaning about the shift count 1365 * being >= the width of the type. Such architectures don't 1366 * reach this code anyway (unless sizeof(IV) > 8 but then 1367 * everything else breaks too so I'm not fussed at the moment). 1368 */ 1369 #ifdef UV_IS_QUAD 1370 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4)); 1371 #else 1372 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4)); 1373 #endif 1374 wp[1] = htonl(iv & 0xffffffff); 1375 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP); 1376 } else { 1377 U32 w = htonl((U32)SvIVX(sv)); 1378 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP); 1379 } 1380 1381 1382 #if PERL_VERSION >= 11 1383 1384 B::SV 1385 RV(sv) 1386 B::IV sv 1387 CODE: 1388 if( SvROK(sv) ) { 1389 RETVAL = SvRV(sv); 1390 } 1391 else { 1392 croak( "argument is not SvROK" ); 1393 } 1394 OUTPUT: 1395 RETVAL 1396 1397 #endif 1398 1399 MODULE = B PACKAGE = B::NV PREFIX = Sv 1400 1401 NV 1402 SvNV(sv) 1403 B::NV sv 1404 1405 NV 1406 SvNVX(sv) 1407 B::NV sv 1408 1409 U32 1410 COP_SEQ_RANGE_LOW(sv) 1411 B::NV sv 1412 1413 U32 1414 COP_SEQ_RANGE_HIGH(sv) 1415 B::NV sv 1416 1417 U32 1418 PARENT_PAD_INDEX(sv) 1419 B::NV sv 1420 1421 U32 1422 PARENT_FAKELEX_FLAGS(sv) 1423 B::NV sv 1424 1425 #if PERL_VERSION < 11 1426 1427 MODULE = B PACKAGE = B::RV PREFIX = Sv 1428 1429 B::SV 1430 SvRV(sv) 1431 B::RV sv 1432 1433 #endif 1434 1435 MODULE = B PACKAGE = B::PV PREFIX = Sv 1436 1437 char* 1438 SvPVX(sv) 1439 B::PV sv 1440 1441 B::SV 1442 SvRV(sv) 1443 B::PV sv 1444 CODE: 1445 if( SvROK(sv) ) { 1446 RETVAL = SvRV(sv); 1447 } 1448 else { 1449 croak( "argument is not SvROK" ); 1450 } 1451 OUTPUT: 1452 RETVAL 1453 1454 void 1455 SvPV(sv) 1456 B::PV sv 1457 CODE: 1458 ST(0) = sv_newmortal(); 1459 if( SvPOK(sv) ) { 1460 /* FIXME - we need a better way for B to identify PVs that are 1461 in the pads as variable names. */ 1462 if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) { 1463 /* It claims to be longer than the space allocated for it - 1464 presuambly it's a variable name in the pad */ 1465 sv_setpv(ST(0), SvPV_nolen_const(sv)); 1466 } else { 1467 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv)); 1468 } 1469 SvFLAGS(ST(0)) |= SvUTF8(sv); 1470 } 1471 else { 1472 /* XXX for backward compatibility, but should fail */ 1473 /* croak( "argument is not SvPOK" ); */ 1474 sv_setpvn(ST(0), NULL, 0); 1475 } 1476 1477 # This used to read 257. I think that that was buggy - should have been 258. 1478 # (The "\0", the flags byte, and 256 for the table. Not that anything 1479 # anywhere calls this method. NWC. 1480 void 1481 SvPVBM(sv) 1482 B::PV sv 1483 CODE: 1484 ST(0) = sv_newmortal(); 1485 sv_setpvn(ST(0), SvPVX_const(sv), 1486 SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0)); 1487 1488 1489 STRLEN 1490 SvLEN(sv) 1491 B::PV sv 1492 1493 STRLEN 1494 SvCUR(sv) 1495 B::PV sv 1496 1497 MODULE = B PACKAGE = B::PVMG PREFIX = Sv 1498 1499 void 1500 SvMAGIC(sv) 1501 B::PVMG sv 1502 MAGIC * mg = NO_INIT 1503 PPCODE: 1504 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) 1505 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg)); 1506 1507 MODULE = B PACKAGE = B::PVMG 1508 1509 B::HV 1510 SvSTASH(sv) 1511 B::PVMG sv 1512 1513 MODULE = B PACKAGE = B::REGEXP 1514 1515 #if PERL_VERSION >= 11 1516 1517 IV 1518 REGEX(sv) 1519 B::REGEXP sv 1520 CODE: 1521 /* FIXME - can we code this method more efficiently? */ 1522 RETVAL = PTR2IV(sv); 1523 OUTPUT: 1524 RETVAL 1525 1526 SV* 1527 precomp(sv) 1528 B::REGEXP sv 1529 CODE: 1530 RETVAL = newSVpvn( RX_PRECOMP(sv), RX_PRELEN(sv) ); 1531 OUTPUT: 1532 RETVAL 1533 1534 #endif 1535 1536 #define MgMOREMAGIC(mg) mg->mg_moremagic 1537 #define MgPRIVATE(mg) mg->mg_private 1538 #define MgTYPE(mg) mg->mg_type 1539 #define MgFLAGS(mg) mg->mg_flags 1540 #define MgOBJ(mg) mg->mg_obj 1541 #define MgLENGTH(mg) mg->mg_len 1542 #define MgREGEX(mg) PTR2IV(mg->mg_obj) 1543 1544 MODULE = B PACKAGE = B::MAGIC PREFIX = Mg 1545 1546 B::MAGIC 1547 MgMOREMAGIC(mg) 1548 B::MAGIC mg 1549 CODE: 1550 if( MgMOREMAGIC(mg) ) { 1551 RETVAL = MgMOREMAGIC(mg); 1552 } 1553 else { 1554 XSRETURN_UNDEF; 1555 } 1556 OUTPUT: 1557 RETVAL 1558 1559 U16 1560 MgPRIVATE(mg) 1561 B::MAGIC mg 1562 1563 char 1564 MgTYPE(mg) 1565 B::MAGIC mg 1566 1567 U8 1568 MgFLAGS(mg) 1569 B::MAGIC mg 1570 1571 B::SV 1572 MgOBJ(mg) 1573 B::MAGIC mg 1574 1575 IV 1576 MgREGEX(mg) 1577 B::MAGIC mg 1578 CODE: 1579 if(mg->mg_type == PERL_MAGIC_qr) { 1580 RETVAL = MgREGEX(mg); 1581 } 1582 else { 1583 croak( "REGEX is only meaningful on r-magic" ); 1584 } 1585 OUTPUT: 1586 RETVAL 1587 1588 SV* 1589 precomp(mg) 1590 B::MAGIC mg 1591 CODE: 1592 if (mg->mg_type == PERL_MAGIC_qr) { 1593 REGEXP* rx = (REGEXP*)mg->mg_obj; 1594 RETVAL = Nullsv; 1595 if( rx ) 1596 RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) ); 1597 } 1598 else { 1599 croak( "precomp is only meaningful on r-magic" ); 1600 } 1601 OUTPUT: 1602 RETVAL 1603 1604 I32 1605 MgLENGTH(mg) 1606 B::MAGIC mg 1607 1608 void 1609 MgPTR(mg) 1610 B::MAGIC mg 1611 CODE: 1612 ST(0) = sv_newmortal(); 1613 if (mg->mg_ptr){ 1614 if (mg->mg_len >= 0){ 1615 sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len); 1616 } else if (mg->mg_len == HEf_SVKEY) { 1617 ST(0) = make_sv_object(aTHX_ 1618 sv_newmortal(), (SV*)mg->mg_ptr); 1619 } 1620 } 1621 1622 MODULE = B PACKAGE = B::PVLV PREFIX = Lv 1623 1624 U32 1625 LvTARGOFF(sv) 1626 B::PVLV sv 1627 1628 U32 1629 LvTARGLEN(sv) 1630 B::PVLV sv 1631 1632 char 1633 LvTYPE(sv) 1634 B::PVLV sv 1635 1636 B::SV 1637 LvTARG(sv) 1638 B::PVLV sv 1639 1640 MODULE = B PACKAGE = B::BM PREFIX = Bm 1641 1642 I32 1643 BmUSEFUL(sv) 1644 B::BM sv 1645 1646 U32 1647 BmPREVIOUS(sv) 1648 B::BM sv 1649 1650 U8 1651 BmRARE(sv) 1652 B::BM sv 1653 1654 void 1655 BmTABLE(sv) 1656 B::BM sv 1657 STRLEN len = NO_INIT 1658 char * str = NO_INIT 1659 CODE: 1660 str = SvPV(sv, len); 1661 /* Boyer-Moore table is just after string and its safety-margin \0 */ 1662 ST(0) = newSVpvn_flags(str + len + PERL_FBM_TABLE_OFFSET, 256, SVs_TEMP); 1663 1664 MODULE = B PACKAGE = B::GV PREFIX = Gv 1665 1666 void 1667 GvNAME(gv) 1668 B::GV gv 1669 CODE: 1670 #if PERL_VERSION >= 10 1671 ST(0) = sv_2mortal(newSVhek(GvNAME_HEK(gv))); 1672 #else 1673 ST(0) = newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP); 1674 #endif 1675 1676 bool 1677 is_empty(gv) 1678 B::GV gv 1679 CODE: 1680 RETVAL = GvGP(gv) == Null(GP*); 1681 OUTPUT: 1682 RETVAL 1683 1684 bool 1685 isGV_with_GP(gv) 1686 B::GV gv 1687 CODE: 1688 #if PERL_VERSION >= 9 1689 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE; 1690 #else 1691 RETVAL = TRUE; /* In 5.8 and earlier they all are. */ 1692 #endif 1693 OUTPUT: 1694 RETVAL 1695 1696 void* 1697 GvGP(gv) 1698 B::GV gv 1699 1700 B::HV 1701 GvSTASH(gv) 1702 B::GV gv 1703 1704 B::SV 1705 GvSV(gv) 1706 B::GV gv 1707 1708 B::IO 1709 GvIO(gv) 1710 B::GV gv 1711 1712 B::FM 1713 GvFORM(gv) 1714 B::GV gv 1715 CODE: 1716 RETVAL = (SV*)GvFORM(gv); 1717 OUTPUT: 1718 RETVAL 1719 1720 B::AV 1721 GvAV(gv) 1722 B::GV gv 1723 1724 B::HV 1725 GvHV(gv) 1726 B::GV gv 1727 1728 B::GV 1729 GvEGV(gv) 1730 B::GV gv 1731 1732 B::CV 1733 GvCV(gv) 1734 B::GV gv 1735 1736 U32 1737 GvCVGEN(gv) 1738 B::GV gv 1739 1740 U32 1741 GvLINE(gv) 1742 B::GV gv 1743 1744 char * 1745 GvFILE(gv) 1746 B::GV gv 1747 1748 B::GV 1749 GvFILEGV(gv) 1750 B::GV gv 1751 1752 MODULE = B PACKAGE = B::GV 1753 1754 U32 1755 GvREFCNT(gv) 1756 B::GV gv 1757 1758 U8 1759 GvFLAGS(gv) 1760 B::GV gv 1761 1762 MODULE = B PACKAGE = B::IO PREFIX = Io 1763 1764 long 1765 IoLINES(io) 1766 B::IO io 1767 1768 long 1769 IoPAGE(io) 1770 B::IO io 1771 1772 long 1773 IoPAGE_LEN(io) 1774 B::IO io 1775 1776 long 1777 IoLINES_LEFT(io) 1778 B::IO io 1779 1780 char * 1781 IoTOP_NAME(io) 1782 B::IO io 1783 1784 B::GV 1785 IoTOP_GV(io) 1786 B::IO io 1787 1788 char * 1789 IoFMT_NAME(io) 1790 B::IO io 1791 1792 B::GV 1793 IoFMT_GV(io) 1794 B::IO io 1795 1796 char * 1797 IoBOTTOM_NAME(io) 1798 B::IO io 1799 1800 B::GV 1801 IoBOTTOM_GV(io) 1802 B::IO io 1803 1804 #if PERL_VERSION <= 8 1805 1806 short 1807 IoSUBPROCESS(io) 1808 B::IO io 1809 1810 #endif 1811 1812 bool 1813 IsSTD(io,name) 1814 B::IO io 1815 const char* name 1816 PREINIT: 1817 PerlIO* handle = 0; 1818 CODE: 1819 if( strEQ( name, "stdin" ) ) { 1820 handle = PerlIO_stdin(); 1821 } 1822 else if( strEQ( name, "stdout" ) ) { 1823 handle = PerlIO_stdout(); 1824 } 1825 else if( strEQ( name, "stderr" ) ) { 1826 handle = PerlIO_stderr(); 1827 } 1828 else { 1829 croak( "Invalid value '%s'", name ); 1830 } 1831 RETVAL = handle == IoIFP(io); 1832 OUTPUT: 1833 RETVAL 1834 1835 MODULE = B PACKAGE = B::IO 1836 1837 char 1838 IoTYPE(io) 1839 B::IO io 1840 1841 U8 1842 IoFLAGS(io) 1843 B::IO io 1844 1845 MODULE = B PACKAGE = B::AV PREFIX = Av 1846 1847 SSize_t 1848 AvFILL(av) 1849 B::AV av 1850 1851 SSize_t 1852 AvMAX(av) 1853 B::AV av 1854 1855 #if PERL_VERSION < 9 1856 1857 1858 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off 1859 1860 IV 1861 AvOFF(av) 1862 B::AV av 1863 1864 #endif 1865 1866 void 1867 AvARRAY(av) 1868 B::AV av 1869 PPCODE: 1870 if (AvFILL(av) >= 0) { 1871 SV **svp = AvARRAY(av); 1872 I32 i; 1873 for (i = 0; i <= AvFILL(av); i++) 1874 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i])); 1875 } 1876 1877 void 1878 AvARRAYelt(av, idx) 1879 B::AV av 1880 int idx 1881 PPCODE: 1882 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av)) 1883 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx]))); 1884 else 1885 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL)); 1886 1887 #if PERL_VERSION < 9 1888 1889 MODULE = B PACKAGE = B::AV 1890 1891 U8 1892 AvFLAGS(av) 1893 B::AV av 1894 1895 #endif 1896 1897 MODULE = B PACKAGE = B::FM PREFIX = Fm 1898 1899 IV 1900 FmLINES(form) 1901 B::FM form 1902 1903 MODULE = B PACKAGE = B::CV PREFIX = Cv 1904 1905 U32 1906 CvCONST(cv) 1907 B::CV cv 1908 1909 B::HV 1910 CvSTASH(cv) 1911 B::CV cv 1912 1913 B::OP 1914 CvSTART(cv) 1915 B::CV cv 1916 CODE: 1917 RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv); 1918 OUTPUT: 1919 RETVAL 1920 1921 B::OP 1922 CvROOT(cv) 1923 B::CV cv 1924 CODE: 1925 RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv); 1926 OUTPUT: 1927 RETVAL 1928 1929 B::GV 1930 CvGV(cv) 1931 B::CV cv 1932 1933 char * 1934 CvFILE(cv) 1935 B::CV cv 1936 1937 long 1938 CvDEPTH(cv) 1939 B::CV cv 1940 1941 B::AV 1942 CvPADLIST(cv) 1943 B::CV cv 1944 1945 B::CV 1946 CvOUTSIDE(cv) 1947 B::CV cv 1948 1949 U32 1950 CvOUTSIDE_SEQ(cv) 1951 B::CV cv 1952 1953 void 1954 CvXSUB(cv) 1955 B::CV cv 1956 CODE: 1957 ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0)); 1958 1959 1960 void 1961 CvXSUBANY(cv) 1962 B::CV cv 1963 CODE: 1964 ST(0) = CvCONST(cv) ? 1965 make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) : 1966 sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0)); 1967 1968 MODULE = B PACKAGE = B::CV 1969 1970 U16 1971 CvFLAGS(cv) 1972 B::CV cv 1973 1974 MODULE = B PACKAGE = B::CV PREFIX = cv_ 1975 1976 B::SV 1977 cv_const_sv(cv) 1978 B::CV cv 1979 1980 1981 MODULE = B PACKAGE = B::HV PREFIX = Hv 1982 1983 STRLEN 1984 HvFILL(hv) 1985 B::HV hv 1986 1987 STRLEN 1988 HvMAX(hv) 1989 B::HV hv 1990 1991 I32 1992 HvKEYS(hv) 1993 B::HV hv 1994 1995 I32 1996 HvRITER(hv) 1997 B::HV hv 1998 1999 char * 2000 HvNAME(hv) 2001 B::HV hv 2002 2003 #if PERL_VERSION < 9 2004 2005 B::PMOP 2006 HvPMROOT(hv) 2007 B::HV hv 2008 2009 #endif 2010 2011 void 2012 HvARRAY(hv) 2013 B::HV hv 2014 PPCODE: 2015 if (HvKEYS(hv) > 0) { 2016 SV *sv; 2017 char *key; 2018 I32 len; 2019 (void)hv_iterinit(hv); 2020 EXTEND(sp, HvKEYS(hv) * 2); 2021 while ((sv = hv_iternextsv(hv, &key, &len))) { 2022 mPUSHp(key, len); 2023 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv)); 2024 } 2025 } 2026 2027 MODULE = B PACKAGE = B::HE PREFIX = He 2028 2029 B::SV 2030 HeVAL(he) 2031 B::HE he 2032 2033 U32 2034 HeHASH(he) 2035 B::HE he 2036 2037 B::SV 2038 HeSVKEY_force(he) 2039 B::HE he 2040 2041 MODULE = B PACKAGE = B::RHE PREFIX = RHE_ 2042 2043 #if PERL_VERSION >= 9 2044 2045 SV* 2046 RHE_HASH(h) 2047 B::RHE h 2048 CODE: 2049 RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) ); 2050 OUTPUT: 2051 RETVAL 2052 2053 #endif 2054