ext/B/B.xs

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