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 #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     bool custom = 0;
 117
 118     if (!o)
 119         return OPc_NULL;
 120
 121     if (o->op_type == 0)
 122         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 123
 124     if (o->op_type == OP_SASSIGN)
 125         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 126
 127     if (o->op_type == OP_AELEMFAST) {
 128 #if PERL_VERSION <= 14
 129         if (o->op_flags & OPf_SPECIAL)
 130             return OPc_BASEOP;
 131         else
 132 #endif
 133 #ifdef USE_ITHREADS
 134             return OPc_PADOP;
 135 #else
 136             return OPc_SVOP;
 137 #endif
 138     }
 139
 140 #ifdef USE_ITHREADS
 141     if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
 142         o->op_type == OP_RCATLINE)
 143         return OPc_PADOP;
 144 #endif
 145
 146     if (o->op_type == OP_CUSTOM)
 147         custom = 1;
 148
 149     switch (OP_CLASS(o)) {
 150     case OA_BASEOP:
 151         return OPc_BASEOP;
 152
 153     case OA_UNOP:
 154         return OPc_UNOP;
 155
 156     case OA_BINOP:
 157         return OPc_BINOP;
 158
 159     case OA_LOGOP:
 160         return OPc_LOGOP;
 161
 162     case OA_LISTOP:
 163         return OPc_LISTOP;
 164
 165     case OA_PMOP:
 166         return OPc_PMOP;
 167
 168     case OA_SVOP:
 169         return OPc_SVOP;
 170
 171     case OA_PADOP:
 172         return OPc_PADOP;
 173
 174     case OA_PVOP_OR_SVOP:
 175         /*
 176          * Character translations (tr///) are usually a PVOP, keeping a
 177          * pointer to a table of shorts used to look up translations.
 178          * Under utf8, however, a simple table isn't practical; instead,
 179          * the OP is an SVOP (or, under threads, a PADOP),
 180          * and the SV is a reference to a swash
 181          * (i.e., an RV pointing to an HV).
 182          */
 183         return (!custom &&
 184                    (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 185                )
 186 #if  defined(USE_ITHREADS) \
 187   && (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION >= 9))
 188                 ? OPc_PADOP : OPc_PVOP;
 189 #else
 190                 ? OPc_SVOP : OPc_PVOP;
 191 #endif
 192
 193     case OA_LOOP:
 194         return OPc_LOOP;
 195
 196     case OA_COP:
 197         return OPc_COP;
 198
 199     case OA_BASEOP_OR_UNOP:
 200         /*
 201          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 202          * whether parens were seen. perly.y uses OPf_SPECIAL to
 203          * signal whether a BASEOP had empty parens or none.
 204          * Some other UNOPs are created later, though, so the best
 205          * test is OPf_KIDS, which is set in newUNOP.
 206          */
 207         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 208
 209     case OA_FILESTATOP:
 210         /*
 211          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 212          * the OPf_REF flag to distinguish between OP types instead of the
 213          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 214          * return OPc_UNOP so that walkoptree can find our children. If
 215          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 216          * (no argument to the operator) it's an OP; with OPf_REF set it's
 217          * an SVOP (and op_sv is the GV for the filehandle argument).
 218          */
 219         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 220 #ifdef USE_ITHREADS
 221                 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 222 #else
 223                 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 224 #endif
 225     case OA_LOOPEXOP:
 226         /*
 227          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 228          * label was omitted (in which case it's a BASEOP) or else a term was
 229          * seen. In this last case, all except goto are definitely PVOP but
 230          * goto is either a PVOP (with an ordinary constant label), an UNOP
 231          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 232          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 233          * get set.
 234          */
 235         if (o->op_flags & OPf_STACKED)
 236             return OPc_UNOP;
 237         else if (o->op_flags & OPf_SPECIAL)
 238             return OPc_BASEOP;
 239         else
 240             return OPc_PVOP;
 241     }
 242     warn("can't determine class of operator %s, assuming BASEOP\n",
 243          OP_NAME(o));
 244     return OPc_BASEOP;
 245 }
 246
 247 static SV *
 248 make_op_object(pTHX_ const OP *o)
 249 {
 250     SV *opsv = sv_newmortal();
 251     sv_setiv(newSVrv(opsv, opclassnames[cc_opclass(aTHX_ o)]), PTR2IV(o));
 252     return opsv;
 253 }
 254
 255 static SV *
 256 make_sv_object(pTHX_ SV *sv)
 257 {
 258     SV *const arg = sv_newmortal();
 259     const char *type = 0;
 260     IV iv;
 261     dMY_CXT;
 262
 263     for (iv = 0; iv < (IV)(sizeof(specialsv_list)/sizeof(SV*)); iv++) {
 264         if (sv == specialsv_list[iv]) {
 265             type = "B::SPECIAL";
 266             break;
 267         }
 268     }
 269     if (!type) {
 270         type = svclassnames[SvTYPE(sv)];
 271         iv = PTR2IV(sv);
 272     }
 273     sv_setiv(newSVrv(arg, type), iv);
 274     return arg;
 275 }
 276
 277 #if PERL_VERSION >= 9
 278 static SV *
 279 make_temp_object(pTHX_ SV *temp)
 280 {
 281     SV *target;
 282     SV *arg = sv_newmortal();
 283     const char *const type = svclassnames[SvTYPE(temp)];
 284     const IV iv = PTR2IV(temp);
 285
 286     target = newSVrv(arg, type);
 287     sv_setiv(target, iv);
 288
 289     /* Need to keep our "temp" around as long as the target exists.
 290        Simplest way seems to be to hang it from magic, and let that clear
 291        it up.  No vtable, so won't actually get in the way of anything.  */
 292     sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
 293     /* magic object has had its reference count increased, so we must drop
 294        our reference.  */
 295     SvREFCNT_dec(temp);
 296     return arg;
 297 }
 298
 299 static SV *
 300 make_warnings_object(pTHX_ const COP *const cop)
 301 {
 302     const STRLEN *const warnings = cop->cop_warnings;
 303     const char *type = 0;
 304     dMY_CXT;
 305     IV iv = sizeof(specialsv_list)/sizeof(SV*);
 306
 307     /* Counting down is deliberate. Before the split between make_sv_object
 308        and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
 309        were both 0, so you could never get a B::SPECIAL for pWARN_STD  */
 310
 311     while (iv--) {
 312         if ((SV*)warnings == specialsv_list[iv]) {
 313             type = "B::SPECIAL";
 314             break;
 315         }
 316     }
 317     if (type) {
 318         SV *arg = sv_newmortal();
 319         sv_setiv(newSVrv(arg, type), iv);
 320         return arg;
 321     } else {
 322         /* B assumes that warnings are a regular SV. Seems easier to keep it
 323            happy by making them into a regular SV.  */
 324         return make_temp_object(aTHX_ newSVpvn((char *)(warnings + 1), *warnings));
 325     }
 326 }
 327
 328 static SV *
 329 make_cop_io_object(pTHX_ COP *cop)
 330 {
 331     SV *const value = newSV(0);
 332
 333     Perl_emulate_cop_io(aTHX_ cop, value);
 334
 335     if(SvOK(value)) {
 336         return make_sv_object(aTHX_ value);
 337     } else {
 338         SvREFCNT_dec(value);
 339         return make_sv_object(aTHX_ NULL);
 340     }
 341 }
 342 #endif
 343
 344 static SV *
 345 make_mg_object(pTHX_ MAGIC *mg)
 346 {
 347     SV *arg = sv_newmortal();
 348     sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
 349     return arg;
 350 }
 351
 352 static SV *
 353 cstring(pTHX_ SV *sv, bool perlstyle)
 354 {
 355     SV *sstr;
 356
 357     if (!SvOK(sv))
 358         return newSVpvs_flags("0", SVs_TEMP);
 359
 360     sstr = newSVpvs_flags("\"", SVs_TEMP);
 361
 362     if (perlstyle && SvUTF8(sv)) {
 363         SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
 364         const STRLEN len = SvCUR(sv);
 365         const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
 366         while (*s)
 367         {
 368             if (*s == '"')
 369                 sv_catpvs(sstr, "\\\"");
 370             else if (*s == '$')
 371                 sv_catpvs(sstr, "\\$");
 372             else if (*s == '@')
 373                 sv_catpvs(sstr, "\\@");
 374             else if (*s == '\\')
 375             {
 376                 if (strchr("nrftax\\",*(s+1)))
 377                     sv_catpvn(sstr, s++, 2);
 378                 else
 379                     sv_catpvs(sstr, "\\\\");
 380             }
 381             else /* should always be printable */
 382                 sv_catpvn(sstr, s, 1);
 383             ++s;
 384         }
 385     }
 386     else
 387     {
 388         /* XXX Optimise? */
 389         STRLEN len;
 390         const char *s = SvPV(sv, len);
 391         for (; len; len--, s++)
 392         {
 393             /* At least try a little for readability */
 394             if (*s == '"')
 395                 sv_catpvs(sstr, "\\\"");
 396             else if (*s == '\\')
 397                 sv_catpvs(sstr, "\\\\");
 398             /* trigraphs - bleagh */
 399             else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
 400                 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?');
 401             }
 402             else if (perlstyle && *s == '$')
 403                 sv_catpvs(sstr, "\\$");
 404             else if (perlstyle && *s == '@')
 405                 sv_catpvs(sstr, "\\@");
 406 #ifdef EBCDIC
 407             else if (isPRINT(*s))
 408 #else
 409             else if (*s >= ' ' && *s < 127)
 410 #endif /* EBCDIC */
 411                 sv_catpvn(sstr, s, 1);
 412             else if (*s == '\n')
 413                 sv_catpvs(sstr, "\\n");
 414             else if (*s == '\r')
 415                 sv_catpvs(sstr, "\\r");
 416             else if (*s == '\t')
 417                 sv_catpvs(sstr, "\\t");
 418             else if (*s == '\a')
 419                 sv_catpvs(sstr, "\\a");
 420             else if (*s == '\b')
 421                 sv_catpvs(sstr, "\\b");
 422             else if (*s == '\f')
 423                 sv_catpvs(sstr, "\\f");
 424             else if (!perlstyle && *s == '\v')
 425                 sv_catpvs(sstr, "\\v");
 426             else
 427             {
 428                 /* Don't want promotion of a signed -1 char in sprintf args */
 429                 const unsigned char c = (unsigned char) *s;
 430                 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
 431             }
 432             /* XXX Add line breaks if string is long */
 433         }
 434     }
 435     sv_catpvs(sstr, "\"");
 436     return sstr;
 437 }
 438
 439 static SV *
 440 cchar(pTHX_ SV *sv)
 441 {
 442     SV *sstr = newSVpvs_flags("'", SVs_TEMP);
 443     const char *s = SvPV_nolen(sv);
 444     /* Don't want promotion of a signed -1 char in sprintf args */
 445     const unsigned char c = (unsigned char) *s;
 446
 447     if (c == '\'')
 448         sv_catpvs(sstr, "\\'");
 449     else if (c == '\\')
 450         sv_catpvs(sstr, "\\\\");
 451 #ifdef EBCDIC
 452     else if (isPRINT(c))
 453 #else
 454     else if (c >= ' ' && c < 127)
 455 #endif /* EBCDIC */
 456         sv_catpvn(sstr, s, 1);
 457     else if (c == '\n')
 458         sv_catpvs(sstr, "\\n");
 459     else if (c == '\r')
 460         sv_catpvs(sstr, "\\r");
 461     else if (c == '\t')
 462         sv_catpvs(sstr, "\\t");
 463     else if (c == '\a')
 464         sv_catpvs(sstr, "\\a");
 465     else if (c == '\b')
 466         sv_catpvs(sstr, "\\b");
 467     else if (c == '\f')
 468         sv_catpvs(sstr, "\\f");
 469     else if (c == '\v')
 470         sv_catpvs(sstr, "\\v");
 471     else
 472         Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
 473     sv_catpvs(sstr, "'");
 474     return sstr;
 475 }
 476
 477 #if PERL_VERSION >= 9
 478 #  define PMOP_pmreplstart(o)   o->op_pmstashstartu.op_pmreplstart
 479 #  define PMOP_pmreplroot(o)    o->op_pmreplrootu.op_pmreplroot
 480 #else
 481 #  define PMOP_pmreplstart(o)   o->op_pmreplstart
 482 #  define PMOP_pmreplroot(o)    o->op_pmreplroot
 483 #  define PMOP_pmpermflags(o)   o->op_pmpermflags
 484 #  define PMOP_pmdynflags(o)      o->op_pmdynflags
 485 #endif
 486
 487 static SV *
 488 walkoptree(pTHX_ OP *o, const char *method, SV *ref)
 489 {
 490     dSP;
 491     OP *kid;
 492     SV *object;
 493     const char *const classname = opclassnames[cc_opclass(aTHX_ o)];
 494     dMY_CXT;
 495
 496     /* Check that no-one has changed our reference, or is holding a reference
 497        to it.  */
 498     if (SvREFCNT(ref) == 1 && SvROK(ref) && SvTYPE(ref) == SVt_RV
 499         && (object = SvRV(ref)) && SvREFCNT(object) == 1
 500         && SvTYPE(object) == SVt_PVMG && SvIOK_only(object)
 501         && !SvMAGICAL(object) && !SvMAGIC(object) && SvSTASH(object)) {
 502         /* Looks good, so rebless it for the class we need:  */
 503         sv_bless(ref, gv_stashpv(classname, GV_ADD));
 504     } else {
 505         /* Need to make a new one. */
 506         ref = sv_newmortal();
 507         object = newSVrv(ref, classname);
 508     }
 509     sv_setiv(object, PTR2IV(o));
 510
 511     if (walkoptree_debug) {
 512         PUSHMARK(sp);
 513         XPUSHs(ref);
 514         PUTBACK;
 515         perl_call_method("walkoptree_debug", G_DISCARD);
 516     }
 517     PUSHMARK(sp);
 518     XPUSHs(ref);
 519     PUTBACK;
 520     perl_call_method(method, G_DISCARD);
 521     if (o && (o->op_flags & OPf_KIDS)) {
 522         for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
 523             ref = walkoptree(aTHX_ kid, method, ref);
 524         }
 525     }
 526     if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
 527            && (kid = PMOP_pmreplroot(cPMOPo)))
 528     {
 529         ref = walkoptree(aTHX_ kid, method, ref);
 530     }
 531     return ref;
 532 }
 533
 534 static SV **
 535 oplist(pTHX_ OP *o, SV **SP)
 536 {
 537     for(; o; o = o->op_next) {
 538 #if PERL_VERSION >= 9
 539         if (o->op_opt == 0)
 540             break;
 541         o->op_opt = 0;
 542 #else
 543         if (o->op_seq == 0)
 544             break;
 545         o->op_seq = 0;
 546 #endif
 547         XPUSHs(make_op_object(aTHX_ o));
 548         switch (o->op_type) {
 549         case OP_SUBST:
 550             SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP);
 551             continue;
 552         case OP_SORT:
 553             if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
 554                 OP *kid = cLISTOPo->op_first->op_sibling;   /* pass pushmark */
 555                 kid = kUNOP->op_first;                      /* pass rv2gv */
 556                 kid = kUNOP->op_first;                      /* pass leave */
 557                 SP = oplist(aTHX_ kid->op_next, SP);
 558             }
 559             continue;
 560         }
 561         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 562         case OA_LOGOP:
 563             SP = oplist(aTHX_ cLOGOPo->op_other, SP);
 564             break;
 565         case OA_LOOP:
 566             SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
 567             SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
 568             SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
 569             break;
 570         }
 571     }
 572     return SP;
 573 }
 574
 575 typedef OP      *B__OP;
 576 typedef UNOP    *B__UNOP;
 577 typedef BINOP   *B__BINOP;
 578 typedef LOGOP   *B__LOGOP;
 579 typedef LISTOP  *B__LISTOP;
 580 typedef PMOP    *B__PMOP;
 581 typedef SVOP    *B__SVOP;
 582 typedef PADOP   *B__PADOP;
 583 typedef PVOP    *B__PVOP;
 584 typedef LOOP    *B__LOOP;
 585 typedef COP     *B__COP;
 586
 587 typedef SV      *B__SV;
 588 typedef SV      *B__IV;
 589 typedef SV      *B__PV;
 590 typedef SV      *B__NV;
 591 typedef SV      *B__PVMG;
 592 #if PERL_VERSION >= 11
 593 typedef SV      *B__REGEXP;
 594 #endif
 595 typedef SV      *B__PVLV;
 596 typedef SV      *B__BM;
 597 typedef SV      *B__RV;
 598 typedef SV      *B__FM;
 599 typedef AV      *B__AV;
 600 typedef HV      *B__HV;
 601 typedef CV      *B__CV;
 602 typedef GV      *B__GV;
 603 typedef IO      *B__IO;
 604
 605 typedef MAGIC   *B__MAGIC;
 606 typedef HE      *B__HE;
 607 #if PERL_VERSION >= 9
 608 typedef struct refcounted_he    *B__RHE;
 609 #endif
 610
 611 #ifdef MULTIPLICITY
 612 #  define ASSIGN_COMMON_ALIAS(prefix, var) \
 613     STMT_START { XSANY.any_i32 = offsetof(struct interpreter, prefix##var); } STMT_END
 614 #else
 615 #  define ASSIGN_COMMON_ALIAS(prefix, var) \
 616     STMT_START { XSANY.any_ptr = (void *)&PL_##var; } STMT_END
 617 #endif
 618
 619 /* This needs to be ALIASed in a custom way, hence can't easily be defined as
 620    a regular XSUB.  */
 621 static XSPROTO(intrpvar_sv_common); /* prototype to pass -Wmissing-prototypes */
 622 static XSPROTO(intrpvar_sv_common)
 623 {
 624     dVAR;
 625     dXSARGS;
 626     SV *ret;
 627     if (items != 0)
 628        croak_xs_usage(cv,  "");
 629 #ifdef MULTIPLICITY
 630     ret = *(SV **)(XSANY.any_i32 + (char *)my_perl);
 631 #else
 632     ret = *(SV **)(XSANY.any_ptr);
 633 #endif
 634     ST(0) = make_sv_object(aTHX_ ret);
 635     XSRETURN(1);
 636 }
 637
 638 #include "const-c.inc"
 639
 640 MODULE = B      PACKAGE = B
 641
 642 INCLUDE: const-xs.inc
 643
 644 PROTOTYPES: DISABLE
 645
 646 BOOT:
 647 {
 648     CV *cv;
 649     const char *file = __FILE__;
 650     MY_CXT_INIT;
 651     specialsv_list[0] = Nullsv;
 652     specialsv_list[1] = &PL_sv_undef;
 653     specialsv_list[2] = &PL_sv_yes;
 654     specialsv_list[3] = &PL_sv_no;
 655     specialsv_list[4] = (SV *) pWARN_ALL;
 656     specialsv_list[5] = (SV *) pWARN_NONE;
 657     specialsv_list[6] = (SV *) pWARN_STD;
 658
 659     cv = newXS("B::init_av", intrpvar_sv_common, file);
 660     ASSIGN_COMMON_ALIAS(I, initav);
 661     cv = newXS("B::check_av", intrpvar_sv_common, file);
 662     ASSIGN_COMMON_ALIAS(I, checkav_save);
 663 #if PERL_VERSION >= 9
 664     cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
 665     ASSIGN_COMMON_ALIAS(I, unitcheckav_save);
 666 #endif
 667     cv = newXS("B::begin_av", intrpvar_sv_common, file);
 668     ASSIGN_COMMON_ALIAS(I, beginav_save);
 669     cv = newXS("B::end_av", intrpvar_sv_common, file);
 670     ASSIGN_COMMON_ALIAS(I, endav);
 671     cv = newXS("B::main_cv", intrpvar_sv_common, file);
 672     ASSIGN_COMMON_ALIAS(I, main_cv);
 673     cv = newXS("B::inc_gv", intrpvar_sv_common, file);
 674     ASSIGN_COMMON_ALIAS(I, incgv);
 675     cv = newXS("B::defstash", intrpvar_sv_common, file);
 676     ASSIGN_COMMON_ALIAS(I, defstash);
 677     cv = newXS("B::curstash", intrpvar_sv_common, file);
 678     ASSIGN_COMMON_ALIAS(I, curstash);
 679     cv = newXS("B::formfeed", intrpvar_sv_common, file);
 680     ASSIGN_COMMON_ALIAS(I, formfeed);
 681 #ifdef USE_ITHREADS
 682     cv = newXS("B::regex_padav", intrpvar_sv_common, file);
 683     ASSIGN_COMMON_ALIAS(I, regex_padav);
 684 #endif
 685     cv = newXS("B::warnhook", intrpvar_sv_common, file);
 686     ASSIGN_COMMON_ALIAS(I, warnhook);
 687     cv = newXS("B::diehook", intrpvar_sv_common, file);
 688     ASSIGN_COMMON_ALIAS(I, diehook);
 689 }
 690
 691 long
 692 amagic_generation()
 693     CODE:
 694         RETVAL = PL_amagic_generation;
 695     OUTPUT:
 696         RETVAL
 697
 698 void
 699 comppadlist()
 700     PPCODE:
 701         PUSHs(make_sv_object(aTHX_ (SV *)(PL_main_cv ? CvPADLIST(PL_main_cv)
 702                                                      : CvPADLIST(PL_compcv))));
 703
 704 void
 705 sv_undef()
 706     ALIAS:
 707         sv_no = 1
 708         sv_yes = 2
 709     PPCODE:
 710         PUSHs(make_sv_object(aTHX_ ix > 1 ? &PL_sv_yes
 711                                           : ix < 1 ? &PL_sv_undef
 712                                                    : &PL_sv_no));
 713
 714 void
 715 main_root()
 716     ALIAS:
 717         main_start = 1
 718     PPCODE:
 719         PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root));
 720
 721 UV
 722 sub_generation()
 723     ALIAS:
 724         dowarn = 1
 725     CODE:
 726         RETVAL = ix ? PL_dowarn : PL_sub_generation;
 727     OUTPUT:
 728         RETVAL
 729
 730 void
 731 walkoptree(op, method)
 732         B::OP op
 733         const char *    method
 734     CODE:
 735         (void) walkoptree(aTHX_ op, method, &PL_sv_undef);
 736
 737 int
 738 walkoptree_debug(...)
 739     CODE:
 740         dMY_CXT;
 741         RETVAL = walkoptree_debug;
 742         if (items > 0 && SvTRUE(ST(1)))
 743             walkoptree_debug = 1;
 744     OUTPUT:
 745         RETVAL
 746
 747 #define address(sv) PTR2IV(sv)
 748
 749 IV
 750 address(sv)
 751         SV *    sv
 752
 753 void
 754 svref_2object(sv)
 755         SV *    sv
 756     PPCODE:
 757         if (!SvROK(sv))
 758             croak("argument is not a reference");
 759         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
 760
 761 void
 762 opnumber(name)
 763 const char *    name
 764 CODE:
 765 {
 766  int i;
 767  IV  result = -1;
 768  ST(0) = sv_newmortal();
 769  if (strncmp(name,"pp_",3) == 0)
 770    name += 3;
 771  for (i = 0; i < PL_maxo; i++)
 772   {
 773    if (strcmp(name, PL_op_name[i]) == 0)
 774     {
 775      result = i;
 776      break;
 777     }
 778   }
 779  sv_setiv(ST(0),result);
 780 }
 781
 782 void
 783 ppname(opnum)
 784         int     opnum
 785     CODE:
 786         ST(0) = sv_newmortal();
 787         if (opnum >= 0 && opnum < PL_maxo) {
 788             sv_setpvs(ST(0), "pp_");
 789             sv_catpv(ST(0), PL_op_name[opnum]);
 790         }
 791
 792 void
 793 hash(sv)
 794         SV *    sv
 795     CODE:
 796         STRLEN len;
 797         U32 hash = 0;
 798         const char *s = SvPVbyte(sv, len);
 799         PERL_HASH(hash, s, len);
 800         ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
 801
 802 #define cast_I32(foo) (I32)foo
 803 IV
 804 cast_I32(i)
 805         IV      i
 806
 807 void
 808 minus_c()
 809     ALIAS:
 810         save_BEGINs = 1
 811     CODE:
 812         if (ix)
 813             PL_savebegin = TRUE;
 814         else
 815             PL_minus_c = TRUE;
 816
 817 void
 818 cstring(sv)
 819         SV *    sv
 820     ALIAS:
 821         perlstring = 1
 822         cchar = 2
 823     PPCODE:
 824         PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, (bool)ix));
 825
 826 void
 827 threadsv_names()
 828     PPCODE:
 829 #if PERL_VERSION <= 8
 830 # ifdef USE_5005THREADS
 831         int i;
 832         const STRLEN len = strlen(PL_threadsv_names);
 833
 834         EXTEND(sp, len);
 835         for (i = 0; i < len; i++)
 836             PUSHs(newSVpvn_flags(&PL_threadsv_names[i], 1, SVs_TEMP));
 837 # endif
 838 #endif
 839
 840 #define SVp             0x00000
 841 #define U32p            0x10000
 842 #define line_tp         0x20000
 843 #define OPp             0x30000
 844 #define PADOFFSETp      0x40000
 845 #define U8p             0x50000
 846 #define IVp             0x60000
 847 #define char_pp         0x70000
 848
 849 #define OP_next_ix              OPp | offsetof(struct op, op_next)
 850 #define OP_sibling_ix           OPp | offsetof(struct op, op_sibling)
 851 #define UNOP_first_ix           OPp | offsetof(struct unop, op_first)
 852 #define BINOP_last_ix           OPp | offsetof(struct binop, op_last)
 853 #define LOGOP_other_ix          OPp | offsetof(struct logop, op_other)
 854 #if PERL_VERSION >= 9
 855 #  define PMOP_pmreplstart_ix \
 856                 OPp | offsetof(struct pmop, op_pmstashstartu.op_pmreplstart)
 857 #else
 858 #  define PMOP_pmreplstart_ix   OPp | offsetof(struct pmop, op_pmreplstart)
 859 #endif
 860 #define LOOP_redoop_ix          OPp | offsetof(struct loop, op_redoop)
 861 #define LOOP_nextop_ix          OPp | offsetof(struct loop, op_nextop)
 862 #define LOOP_lastop_ix          OPp | offsetof(struct loop, op_lastop)
 863
 864 #define OP_targ_ix              PADOFFSETp | offsetof(struct op, op_targ)
 865 #define OP_flags_ix             U8p | offsetof(struct op, op_flags)
 866 #define OP_private_ix           U8p | offsetof(struct op, op_private)
 867
 868 #define PMOP_pmflags_ix         U32p | offsetof(struct pmop, op_pmflags)
 869
 870 #ifdef USE_ITHREADS
 871 #define PMOP_pmoffset_ix        IVp | offsetof(struct pmop, op_pmoffset)
 872 #endif
 873
 874 #  Yes, B::SV::sv and B::SV::gv really do end up generating identical code.
 875 #define SVOP_sv_ix              SVp | offsetof(struct svop, op_sv)
 876 #define SVOP_gv_ix              SVp | offsetof(struct svop, op_sv)
 877
 878 #define PADOP_padix_ix          PADOFFSETp | offsetof(struct padop, op_padix)
 879
 880 #define COP_seq_ix              U32p | offsetof(struct cop, cop_seq)
 881 #define COP_line_ix             line_tp | offsetof(struct cop, cop_line)
 882 #if PERL_VERSION >= 9
 883 #define COP_hints_ix            U32p | offsetof(struct cop, cop_hints)
 884 #else
 885 #define COP_hints_ix            U8p | offsetof(struct cop, op_private)
 886 #endif
 887
 888 #ifdef USE_ITHREADS
 889 #define COP_stashpv_ix          char_pp | offsetof(struct cop, cop_stashpv)
 890 #define COP_file_ix             char_pp | offsetof(struct cop, cop_file)
 891 #else
 892 #define COP_stash_ix            SVp | offsetof(struct cop, cop_stash)
 893 #define COP_filegv_ix           SVp | offsetof(struct cop, cop_filegv)
 894 #endif
 895
 896 MODULE = B      PACKAGE = B::OP
 897
 898 size_t
 899 size(o)
 900         B::OP           o
 901     CODE:
 902         RETVAL = opsizes[cc_opclass(aTHX_ o)];
 903     OUTPUT:
 904         RETVAL
 905
 906 # The type checking code in B has always been identical for all OP types,
 907 # irrespective of whether the action is actually defined on that OP.
 908 # We should fix this
 909 void
 910 next(o)
 911         B::OP           o
 912     ALIAS:
 913         B::OP::next = OP_next_ix
 914         B::OP::sibling = OP_sibling_ix
 915         B::OP::targ = OP_targ_ix
 916         B::OP::flags = OP_flags_ix
 917         B::OP::private = OP_private_ix
 918         B::UNOP::first = UNOP_first_ix
 919         B::BINOP::last = BINOP_last_ix
 920         B::LOGOP::other = LOGOP_other_ix
 921         B::PMOP::pmreplstart = PMOP_pmreplstart_ix
 922         B::LOOP::redoop = LOOP_redoop_ix
 923         B::LOOP::nextop = LOOP_nextop_ix
 924         B::LOOP::lastop = LOOP_lastop_ix
 925         B::PMOP::pmflags = PMOP_pmflags_ix
 926         B::SVOP::sv = SVOP_sv_ix
 927         B::SVOP::gv = SVOP_gv_ix
 928         B::PADOP::padix = PADOP_padix_ix
 929         B::COP::cop_seq = COP_seq_ix
 930         B::COP::line = COP_line_ix
 931         B::COP::hints = COP_hints_ix
 932     PREINIT:
 933         char *ptr;
 934         SV *ret;
 935     PPCODE:
 936         ptr = (ix & 0xFFFF) + (char *)o;
 937         switch ((U8)(ix >> 16)) {
 938         case (U8)(OPp >> 16):
 939             ret = make_op_object(aTHX_ *((OP **)ptr));
 940             break;
 941         case (U8)(PADOFFSETp >> 16):
 942             ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
 943             break;
 944         case (U8)(U8p >> 16):
 945             ret = sv_2mortal(newSVuv(*((U8*)ptr)));
 946             break;
 947         case (U8)(U32p >> 16):
 948             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
 949             break;
 950         case (U8)(SVp >> 16):
 951             ret = make_sv_object(aTHX_ *((SV **)ptr));
 952             break;
 953         case (U8)(line_tp >> 16):
 954             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
 955             break;
 956 #ifdef USE_ITHREADS
 957         case (U8)(IVp >> 16):
 958             ret = sv_2mortal(newSViv(*((IV*)ptr)));
 959             break;
 960         case (U8)(char_pp >> 16):
 961             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
 962             break;
 963 #endif
 964         default:
 965             croak("Illegal alias 0x%08x for B::*next", (unsigned)ix);
 966
 967         }
 968         ST(0) = ret;
 969         XSRETURN(1);
 970
 971 char *
 972 name(o)
 973         B::OP           o
 974     ALIAS:
 975         desc = 1
 976     CODE:
 977         RETVAL = (char *)(ix ? OP_DESC(o) : OP_NAME(o));
 978     OUTPUT:
 979         RETVAL
 980
 981 void
 982 ppaddr(o)
 983         B::OP           o
 984     PREINIT:
 985         int i;
 986         SV *sv = newSVpvs_flags("PL_ppaddr[OP_", SVs_TEMP);
 987     CODE:
 988         sv_catpv(sv, PL_op_name[o->op_type]);
 989         for (i=13; (STRLEN)i < SvCUR(sv); ++i)
 990             SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
 991         sv_catpvs(sv, "]");
 992         ST(0) = sv;
 993
 994 #if PERL_VERSION >= 9
 995 #  These 3 are all bitfields, so we can't take their addresses.
 996 UV
 997 type(o)
 998         B::OP           o
 999     ALIAS:
1000         opt = 1
1001         spare = 2
1002     CODE:
1003         switch(ix) {
1004           case 1:
1005             RETVAL = o->op_opt;
1006             break;
1007           case 2:
1008             RETVAL = o->op_spare;
1009             break;
1010           default:
1011             RETVAL = o->op_type;
1012         }
1013     OUTPUT:
1014         RETVAL
1015
1016 #else
1017
1018 UV
1019 type(o)
1020         B::OP           o
1021     ALIAS:
1022         seq = 1
1023     CODE:
1024         switch(ix) {
1025           case 1:
1026             RETVAL = o->op_seq;
1027             break;
1028           default:
1029             RETVAL = o->op_type;
1030         }
1031     OUTPUT:
1032         RETVAL
1033
1034 #endif
1035
1036 void
1037 oplist(o)
1038         B::OP           o
1039     PPCODE:
1040         SP = oplist(aTHX_ o, SP);
1041
1042 MODULE = B      PACKAGE = B::LISTOP
1043
1044 U32
1045 children(o)
1046         B::LISTOP       o
1047         OP *            kid = NO_INIT
1048         int             i = NO_INIT
1049     CODE:
1050         i = 0;
1051         for (kid = o->op_first; kid; kid = kid->op_sibling)
1052             i++;
1053         RETVAL = i;
1054     OUTPUT:
1055         RETVAL
1056
1057 MODULE = B      PACKAGE = B::PMOP               PREFIX = PMOP_
1058
1059 #if PERL_VERSION <= 8
1060
1061 void
1062 PMOP_pmreplroot(o)
1063         B::PMOP         o
1064         OP *            root = NO_INIT
1065     CODE:
1066         root = o->op_pmreplroot;
1067         /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1068         if (o->op_type == OP_PUSHRE) {
1069             ST(0) = sv_newmortal();
1070 #  ifdef USE_ITHREADS
1071             sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
1072 #  else
1073             sv_setiv(newSVrv(ST(0), root ?
1074                              svclassnames[SvTYPE((SV*)root)] : "B::SV"),
1075                      PTR2IV(root));
1076 #  endif
1077         }
1078         else {
1079             ST(0) = make_op_object(aTHX_ root);
1080         }
1081
1082 #else
1083
1084 void
1085 PMOP_pmreplroot(o)
1086         B::PMOP         o
1087     CODE:
1088         if (o->op_type == OP_PUSHRE) {
1089 #  ifdef USE_ITHREADS
1090             ST(0) = sv_newmortal();
1091             sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1092 #  else
1093             GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1094             ST(0) = sv_newmortal();
1095             sv_setiv(newSVrv(ST(0), target ?
1096                              svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1097                      PTR2IV(target));
1098 #  endif
1099         }
1100         else {
1101             OP *const root = o->op_pmreplrootu.op_pmreplroot;
1102             ST(0) = make_op_object(aTHX_ root);
1103         }
1104
1105 #endif
1106
1107 #ifdef USE_ITHREADS
1108 #define PMOP_pmstashpv(o)       PmopSTASHPV(o);
1109
1110 char*
1111 PMOP_pmstashpv(o)
1112         B::PMOP         o
1113
1114 #else
1115
1116 void
1117 PMOP_pmstash(o)
1118         B::PMOP         o
1119     PPCODE:
1120         PUSHs(make_sv_object(aTHX_ (SV *) PmopSTASH(o)));
1121
1122 #endif
1123
1124 #if PERL_VERSION < 9
1125
1126 void
1127 PMOP_pmnext(o)
1128         B::PMOP         o
1129     PPCODE:
1130         PUSHs(make_op_object(aTHX_ o->op_pmnext));
1131
1132 U32
1133 PMOP_pmpermflags(o)
1134         B::PMOP         o
1135
1136 U8
1137 PMOP_pmdynflags(o)
1138         B::PMOP         o
1139
1140 #endif
1141
1142 void
1143 PMOP_precomp(o)
1144         B::PMOP         o
1145     PREINIT:
1146         dXSI32;
1147         REGEXP *rx;
1148     CODE:
1149         rx = PM_GETRE(o);
1150         ST(0) = sv_newmortal();
1151         if (rx) {
1152 #if PERL_VERSION >= 9
1153             if (ix) {
1154                 sv_setuv(ST(0), RX_EXTFLAGS(rx));
1155             } else
1156 #endif
1157             {
1158                 sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
1159             }
1160         }
1161
1162 BOOT:
1163 {
1164         CV *cv;
1165 #ifdef USE_ITHREADS
1166         cv = newXS("B::PMOP::pmoffset", XS_B__OP_next, __FILE__);
1167         XSANY.any_i32 = PMOP_pmoffset_ix;
1168         cv = newXS("B::COP::stashpv", XS_B__OP_next, __FILE__);
1169         XSANY.any_i32 = COP_stashpv_ix;
1170         cv = newXS("B::COP::file", XS_B__OP_next, __FILE__);
1171         XSANY.any_i32 = COP_file_ix;
1172 #else
1173         cv = newXS("B::COP::stash", XS_B__OP_next, __FILE__);
1174         XSANY.any_i32 = COP_stash_ix;
1175         cv = newXS("B::COP::filegv", XS_B__OP_next, __FILE__);
1176         XSANY.any_i32 = COP_filegv_ix;
1177 #endif
1178 #if PERL_VERSION >= 9
1179         cv = newXS("B::PMOP::reflags", XS_B__PMOP_precomp, __FILE__);
1180         XSANY.any_i32 = 1;
1181 #endif
1182 }
1183
1184 MODULE = B      PACKAGE = B::PADOP
1185
1186 void
1187 sv(o)
1188         B::PADOP o
1189     PREINIT:
1190         SV *ret;
1191     ALIAS:
1192         gv = 1
1193     PPCODE:
1194         /* It happens that the output typemaps for B::SV and B::GV are
1195            identical. The "smarts" are in make_sv_object(), which determines
1196            which class to use based on SvTYPE(), rather than anything baked in
1197            at compile time.  */
1198         if (o->op_padix) {
1199             ret = PAD_SVl(o->op_padix);
1200             if (ix && SvTYPE(ret) != SVt_PVGV)
1201                 ret = NULL;
1202         } else {
1203             ret = NULL;
1204         }
1205         PUSHs(make_sv_object(aTHX_ ret));
1206
1207 MODULE = B      PACKAGE = B::PVOP
1208
1209 void
1210 pv(o)
1211         B::PVOP o
1212     CODE:
1213         /*
1214          * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
1215          * whereas other PVOPs point to a null terminated string.
1216          */
1217         if ((o->op_type == OP_TRANS || o->op_type == OP_TRANSR) &&
1218                 (o->op_private & OPpTRANS_COMPLEMENT) &&
1219                 !(o->op_private & OPpTRANS_DELETE))
1220         {
1221             const short* const tbl = (short*)o->op_pv;
1222             const short entries = 257 + tbl[256];
1223             ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
1224         }
1225         else if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
1226             ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
1227         }
1228         else
1229             ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
1230
1231 #define COP_label(o)    CopLABEL(o)
1232
1233 MODULE = B      PACKAGE = B::COP                PREFIX = COP_
1234
1235 const char *
1236 COP_label(o)
1237         B::COP  o
1238
1239 # Both pairs of accessors are provided for both ithreads and not, but for each,
1240 # one pair is direct structure access, and 1 pair "faked up" with a more complex
1241 # macro. We implement the direct structure access pair using the common code
1242 # above (B::OP::next)
1243
1244 #ifdef USE_ITHREADS
1245
1246 void
1247 COP_stash(o)
1248         B::COP  o
1249     ALIAS:
1250         filegv = 1
1251     PPCODE:
1252         PUSHs(make_sv_object(aTHX_
1253                              ix ? (SV *)CopFILEGV(o) : (SV *)CopSTASH(o)));
1254
1255 #else
1256
1257 char *
1258 COP_stashpv(o)
1259         B::COP  o
1260     ALIAS:
1261         file = 1
1262     CODE:
1263         RETVAL = ix ? CopFILE(o) : CopSTASHPV(o);
1264     OUTPUT:
1265         RETVAL
1266
1267 #endif
1268
1269 I32
1270 COP_arybase(o)
1271         B::COP  o
1272     CODE:
1273         RETVAL = 0;
1274     OUTPUT:
1275         RETVAL
1276
1277 void
1278 COP_warnings(o)
1279         B::COP  o
1280     ALIAS:
1281         io = 1
1282     PPCODE:
1283 #if PERL_VERSION >= 9
1284         ST(0) = ix ? make_cop_io_object(aTHX_ o) : make_warnings_object(aTHX_ o);
1285 #else
1286         ST(0) = make_sv_object(aTHX_ ix ? o->cop_io : o->cop_warnings);
1287 #endif
1288         XSRETURN(1);
1289
1290 #if PERL_VERSION >= 9
1291
1292 B::RHE
1293 COP_hints_hash(o)
1294         B::COP o
1295     CODE:
1296         RETVAL = CopHINTHASH_get(o);
1297     OUTPUT:
1298         RETVAL
1299
1300 #endif
1301
1302 MODULE = B      PACKAGE = B::SV
1303
1304 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1305
1306 U32
1307 REFCNT(sv)
1308         B::SV   sv
1309     ALIAS:
1310         FLAGS = 0xFFFFFFFF
1311         SvTYPE = SVTYPEMASK
1312         POK = SVf_POK
1313         ROK = SVf_ROK
1314         MAGICAL = MAGICAL_FLAG_BITS
1315     CODE:
1316         RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1317     OUTPUT:
1318         RETVAL
1319
1320 void
1321 object_2svref(sv)
1322         B::SV   sv
1323     PPCODE:
1324         ST(0) = sv_2mortal(newRV(sv));
1325         XSRETURN(1);
1326
1327 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1328
1329 IV
1330 SvIV(sv)
1331         B::IV   sv
1332
1333 MODULE = B      PACKAGE = B::IV
1334
1335 #define sv_SVp          0x00000
1336 #define sv_IVp          0x10000
1337 #define sv_UVp          0x20000
1338 #define sv_STRLENp      0x30000
1339 #define sv_U32p         0x40000
1340 #define sv_U8p          0x50000
1341 #define sv_char_pp      0x60000
1342 #define sv_NVp          0x70000
1343 #define sv_char_p       0x80000
1344 #define sv_SSize_tp     0x90000
1345 #define sv_I32p         0xA0000
1346 #define sv_U16p         0xB0000
1347
1348 #define IV_ivx_ix       sv_IVp | offsetof(struct xpviv, xiv_iv)
1349 #define IV_uvx_ix       sv_UVp | offsetof(struct xpvuv, xuv_uv)
1350 #define NV_nvx_ix       sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1351
1352 #if PERL_VERSION >= 10
1353 #define NV_cop_seq_range_low_ix \
1354                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1355 #define NV_cop_seq_range_high_ix \
1356                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1357 #define NV_parent_pad_index_ix \
1358                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1359 #define NV_parent_fakelex_flags_ix \
1360                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1361 #else
1362 #define NV_cop_seq_range_low_ix \
1363                         sv_NVp | offsetof(struct xpvnv, xnv_nv)
1364 #define NV_cop_seq_range_high_ix \
1365                         sv_UVp | offsetof(struct xpvnv, xuv_uv)
1366 #define NV_parent_pad_index_ix \
1367                         sv_NVp | offsetof(struct xpvnv, xnv_nv)
1368 #define NV_parent_fakelex_flags_ix \
1369                         sv_UVp | offsetof(struct xpvnv, xuv_uv)
1370 #endif
1371
1372 #define PV_cur_ix       sv_STRLENp | offsetof(struct xpv, xpv_cur)
1373 #define PV_len_ix       sv_STRLENp | offsetof(struct xpv, xpv_len)
1374
1375 #define PVMG_stash_ix   sv_SVp | offsetof(struct xpvmg, xmg_stash)
1376
1377 #if PERL_VERSION >= 10
1378 #  if PERL_VERSION > 14
1379 #    define PVBM_useful_ix      sv_I32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_useful)
1380 #    define PVBM_previous_ix    sv_UVp | offsetof(struct xpvuv, xuv_uv)
1381 #  else
1382 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1383 #define PVBM_previous_ix    sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1384 #  endif
1385 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1386 #else
1387 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvbm, xbm_useful)
1388 #define PVBM_previous_ix    sv_U16p | offsetof(struct xpvbm, xbm_previous)
1389 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvbm, xbm_rare)
1390 #endif
1391
1392 #define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1393 #define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1394 #define PVLV_targ_ix    sv_SVp | offsetof(struct xpvlv, xlv_targ)
1395 #define PVLV_type_ix    sv_char_p | offsetof(struct xpvlv, xlv_type)
1396
1397 #if PERL_VERSION >= 10
1398 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1399 #define PVGV_flags_ix   sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
1400 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xiv_iv)
1401 #else
1402 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xgv_stash)
1403 #define PVGV_flags_ix   sv_U8p | offsetof(struct xpvgv, xgv_flags)
1404 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xio_lines)
1405 #endif
1406
1407 #define PVIO_page_ix        sv_IVp | offsetof(struct xpvio, xio_page)
1408 #define PVIO_page_len_ix    sv_IVp | offsetof(struct xpvio, xio_page_len)
1409 #define PVIO_lines_left_ix  sv_IVp | offsetof(struct xpvio, xio_lines_left)
1410 #define PVIO_top_name_ix    sv_char_pp | offsetof(struct xpvio, xio_top_name)
1411 #define PVIO_top_gv_ix      sv_SVp | offsetof(struct xpvio, xio_top_gv)
1412 #define PVIO_fmt_name_ix    sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1413 #define PVIO_fmt_gv_ix      sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1414 #define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1415 #define PVIO_bottom_gv_ix   sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1416 #define PVIO_type_ix        sv_char_p | offsetof(struct xpvio, xio_type)
1417 #define PVIO_flags_ix       sv_U8p | offsetof(struct xpvio, xio_flags)
1418
1419 #define PVAV_max_ix     sv_SSize_tp | offsetof(struct xpvav, xav_max)
1420
1421 #define PVFM_lines_ix   sv_IVp | offsetof(struct xpvfm, xfm_lines)
1422
1423 #define PVCV_stash_ix   sv_SVp | offsetof(struct xpvcv, xcv_stash)
1424 #define PVCV_gv_ix      sv_SVp | offsetof(struct xpvcv, xcv_gv)
1425 #define PVCV_file_ix    sv_char_pp | offsetof(struct xpvcv, xcv_file)
1426 #define PVCV_depth_ix   sv_I32p | offsetof(struct xpvcv, xcv_depth)
1427 #define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
1428 #define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1429 #define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1430 #define PVCV_flags_ix   sv_U16p | offsetof(struct xpvcv, xcv_flags)
1431
1432 #define PVHV_max_ix     sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1433
1434 #if PERL_VERSION > 12
1435 #define PVHV_keys_ix    sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1436 #else
1437 #define PVHV_keys_ix    sv_IVp | offsetof(struct xpvhv, xhv_keys)
1438 #endif
1439
1440 # The type checking code in B has always been identical for all SV types,
1441 # irrespective of whether the action is actually defined on that SV.
1442 # We should fix this
1443 void
1444 IVX(sv)
1445         B::SV           sv
1446     ALIAS:
1447         B::IV::IVX = IV_ivx_ix
1448         B::IV::UVX = IV_uvx_ix
1449         B::NV::NVX = NV_nvx_ix
1450         B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1451         B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1452         B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1453         B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
1454         B::PV::CUR = PV_cur_ix
1455         B::PV::LEN = PV_len_ix
1456         B::PVMG::SvSTASH = PVMG_stash_ix
1457         B::PVLV::TARGOFF = PVLV_targoff_ix
1458         B::PVLV::TARGLEN = PVLV_targlen_ix
1459         B::PVLV::TARG = PVLV_targ_ix
1460         B::PVLV::TYPE = PVLV_type_ix
1461         B::GV::STASH = PVGV_stash_ix
1462         B::GV::GvFLAGS = PVGV_flags_ix
1463         B::BM::USEFUL = PVBM_useful_ix
1464         B::BM::PREVIOUS = PVBM_previous_ix
1465         B::BM::RARE = PVBM_rare_ix
1466         B::IO::LINES =  PVIO_lines_ix
1467         B::IO::PAGE = PVIO_page_ix
1468         B::IO::PAGE_LEN = PVIO_page_len_ix
1469         B::IO::LINES_LEFT = PVIO_lines_left_ix
1470         B::IO::TOP_NAME = PVIO_top_name_ix
1471         B::IO::TOP_GV = PVIO_top_gv_ix
1472         B::IO::FMT_NAME = PVIO_fmt_name_ix
1473         B::IO::FMT_GV = PVIO_fmt_gv_ix
1474         B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1475         B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1476         B::IO::IoTYPE = PVIO_type_ix
1477         B::IO::IoFLAGS = PVIO_flags_ix
1478         B::AV::MAX = PVAV_max_ix
1479         B::FM::LINES = PVFM_lines_ix
1480         B::CV::STASH = PVCV_stash_ix
1481         B::CV::GV = PVCV_gv_ix
1482         B::CV::FILE = PVCV_file_ix
1483         B::CV::DEPTH = PVCV_depth_ix
1484         B::CV::PADLIST = PVCV_padlist_ix
1485         B::CV::OUTSIDE = PVCV_outside_ix
1486         B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1487         B::CV::CvFLAGS = PVCV_flags_ix
1488         B::HV::MAX = PVHV_max_ix
1489         B::HV::KEYS = PVHV_keys_ix
1490     PREINIT:
1491         char *ptr;
1492         SV *ret;
1493     PPCODE:
1494         ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1495         switch ((U8)(ix >> 16)) {
1496         case (U8)(sv_SVp >> 16):
1497             ret = make_sv_object(aTHX_ *((SV **)ptr));
1498             break;
1499         case (U8)(sv_IVp >> 16):
1500             ret = sv_2mortal(newSViv(*((IV *)ptr)));
1501             break;
1502         case (U8)(sv_UVp >> 16):
1503             ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1504             break;
1505         case (U8)(sv_STRLENp >> 16):
1506             ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1507             break;
1508         case (U8)(sv_U32p >> 16):
1509             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1510             break;
1511         case (U8)(sv_U8p >> 16):
1512             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1513             break;
1514         case (U8)(sv_char_pp >> 16):
1515             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1516             break;
1517         case (U8)(sv_NVp >> 16):
1518             ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1519             break;
1520         case (U8)(sv_char_p >> 16):
1521             ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1522             break;
1523         case (U8)(sv_SSize_tp >> 16):
1524             ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1525             break;
1526         case (U8)(sv_I32p >> 16):
1527             ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1528             break;
1529         case (U8)(sv_U16p >> 16):
1530             ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1531             break;
1532         default:
1533             croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
1534         }
1535         ST(0) = ret;
1536         XSRETURN(1);
1537
1538 void
1539 packiv(sv)
1540         B::IV   sv
1541     ALIAS:
1542         needs64bits = 1
1543     CODE:
1544         if (ix) {
1545             ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1546         } else if (sizeof(IV) == 8) {
1547             U32 wp[2];
1548             const IV iv = SvIVX(sv);
1549             /*
1550              * The following way of spelling 32 is to stop compilers on
1551              * 32-bit architectures from moaning about the shift count
1552              * being >= the width of the type. Such architectures don't
1553              * reach this code anyway (unless sizeof(IV) > 8 but then
1554              * everything else breaks too so I'm not fussed at the moment).
1555              */
1556 #ifdef UV_IS_QUAD
1557             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1558 #else
1559             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1560 #endif
1561             wp[1] = htonl(iv & 0xffffffff);
1562             ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1563         } else {
1564             U32 w = htonl((U32)SvIVX(sv));
1565             ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1566         }
1567
1568 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1569
1570 NV
1571 SvNV(sv)
1572         B::NV   sv
1573
1574 #if PERL_VERSION < 11
1575
1576 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1577
1578 void
1579 SvRV(sv)
1580         B::RV   sv
1581     PPCODE:
1582         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1583
1584 #else
1585
1586 MODULE = B      PACKAGE = B::REGEXP
1587
1588 void
1589 REGEX(sv)
1590         B::REGEXP       sv
1591     ALIAS:
1592         precomp = 1
1593     PPCODE:
1594         if (ix) {
1595             PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1596         } else {
1597             dXSTARG;
1598             /* FIXME - can we code this method more efficiently?  */
1599             PUSHi(PTR2IV(sv));
1600         }
1601
1602 #endif
1603
1604 MODULE = B      PACKAGE = B::PV
1605
1606 void
1607 RV(sv)
1608         B::PV   sv
1609     PPCODE:
1610         if (!SvROK(sv))
1611             croak( "argument is not SvROK" );
1612         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1613
1614 void
1615 PV(sv)
1616         B::PV   sv
1617     ALIAS:
1618         PVX = 1
1619         PVBM = 2
1620         B::BM::TABLE = 3
1621     PREINIT:
1622         const char *p;
1623         STRLEN len = 0;
1624         U32 utf8 = 0;
1625     CODE:
1626         if (ix == 3) {
1627 #ifndef PERL_FBM_TABLE_OFFSET
1628             const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm);
1629
1630             if (!mg)
1631                 croak("argument to B::BM::TABLE is not a PVBM");
1632             p = mg->mg_ptr;
1633             len = mg->mg_len;
1634 #else
1635             p = SvPV(sv, len);
1636             /* Boyer-Moore table is just after string and its safety-margin \0 */
1637             p += len + PERL_FBM_TABLE_OFFSET;
1638             len = 256;
1639 #endif
1640         } else if (ix == 2) {
1641             /* This used to read 257. I think that that was buggy - should have
1642                been 258. (The "\0", the flags byte, and 256 for the table.)
1643                The only user of this method is B::Bytecode in B::PV::bsave.
1644                I'm guessing that nothing tested the runtime correctness of
1645                output of bytecompiled string constant arguments to index (etc).
1646
1647                Note the start pointer is and has always been SvPVX(sv), not
1648                SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1649                first used by the compiler in 651aa52ea1faa806. It's used to
1650                get a "complete" dump of the buffer at SvPVX(), not just the
1651                PVBM table. This permits the generated bytecode to "load"
1652                SvPVX in "one" hit.
1653
1654                5.15 and later store the BM table via MAGIC, so the compiler
1655                should handle this just fine without changes if PVBM now
1656                always returns the SvPVX() buffer.  */
1657             p = SvPVX_const(sv);
1658 #ifdef PERL_FBM_TABLE_OFFSET
1659             len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1660 #else
1661             len = SvCUR(sv);
1662 #endif
1663         } else if (ix) {
1664             p = SvPVX(sv);
1665             len = strlen(p);
1666         } else if (SvPOK(sv)) {
1667             len = SvCUR(sv);
1668             p = SvPVX_const(sv);
1669             utf8 = SvUTF8(sv);
1670 #if PERL_VERSION < 10
1671             /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1672                in SvCUR(), which meant we had to attempt this special casing
1673                to avoid tripping up over variable names in the pads.  */
1674             if((SvLEN(sv) && len >= SvLEN(sv))) {
1675                 /* It claims to be longer than the space allocated for it -
1676                    presumably it's a variable name in the pad  */
1677                 len = strlen(p);
1678             }
1679 #endif
1680         }
1681         else {
1682             /* XXX for backward compatibility, but should fail */
1683             /* croak( "argument is not SvPOK" ); */
1684             p = NULL;
1685         }
1686         ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
1687
1688 MODULE = B      PACKAGE = B::PVMG
1689
1690 void
1691 MAGIC(sv)
1692         B::PVMG sv
1693         MAGIC * mg = NO_INIT
1694     PPCODE:
1695         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1696             XPUSHs(make_mg_object(aTHX_ mg));
1697
1698 MODULE = B      PACKAGE = B::MAGIC
1699
1700 void
1701 MOREMAGIC(mg)
1702         B::MAGIC        mg
1703     ALIAS:
1704         PRIVATE = 1
1705         TYPE = 2
1706         FLAGS = 3
1707         LENGTH = 4
1708         OBJ = 5
1709         PTR = 6
1710         REGEX = 7
1711         precomp = 8
1712     PPCODE:
1713         switch (ix) {
1714         case 0:
1715             XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1716                                     : &PL_sv_undef);
1717             break;
1718         case 1:
1719             mPUSHu(mg->mg_private);
1720             break;
1721         case 2:
1722             PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1723             break;
1724         case 3:
1725             mPUSHu(mg->mg_flags);
1726             break;
1727         case 4:
1728             mPUSHi(mg->mg_len);
1729             break;
1730         case 5:
1731             PUSHs(make_sv_object(aTHX_ mg->mg_obj));
1732             break;
1733         case 6:
1734             if (mg->mg_ptr) {
1735                 if (mg->mg_len >= 0) {
1736                     PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
1737                 } else if (mg->mg_len == HEf_SVKEY) {
1738                     PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
1739                 } else
1740                     PUSHs(sv_newmortal());
1741             } else
1742                 PUSHs(sv_newmortal());
1743             break;
1744         case 7:
1745             if(mg->mg_type == PERL_MAGIC_qr) {
1746                 mPUSHi(PTR2IV(mg->mg_obj));
1747             } else {
1748                 croak("REGEX is only meaningful on r-magic");
1749             }
1750             break;
1751         case 8:
1752             if (mg->mg_type == PERL_MAGIC_qr) {
1753                 REGEXP *rx = (REGEXP *)mg->mg_obj;
1754                 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1755                                      rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
1756             } else {
1757                 croak( "precomp is only meaningful on r-magic" );
1758             }
1759             break;
1760         }
1761
1762 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1763
1764 void
1765 GvNAME(gv)
1766         B::GV   gv
1767     ALIAS:
1768         FILE = 1
1769         B::HV::NAME = 2
1770     CODE:
1771 #if PERL_VERSION >= 10
1772         ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1773                                         : (ix == 1 ? GvFILE_HEK(gv)
1774                                                    : HvNAME_HEK((HV *)gv))));
1775 #else
1776         ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1777                     : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
1778 #endif
1779
1780 bool
1781 is_empty(gv)
1782         B::GV   gv
1783     ALIAS:
1784         isGV_with_GP = 1
1785     CODE:
1786         if (ix) {
1787 #if PERL_VERSION >= 9
1788             RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1789 #else
1790             RETVAL = TRUE; /* In 5.8 and earlier they all are.  */
1791 #endif
1792         } else {
1793             RETVAL = GvGP(gv) == Null(GP*);
1794         }
1795     OUTPUT:
1796         RETVAL
1797
1798 void*
1799 GvGP(gv)
1800         B::GV   gv
1801
1802 #define GP_sv_ix        SVp | offsetof(struct gp, gp_sv)
1803 #define GP_io_ix        SVp | offsetof(struct gp, gp_io)
1804 #define GP_cv_ix        SVp | offsetof(struct gp, gp_cv)
1805 #define GP_cvgen_ix     U32p | offsetof(struct gp, gp_cvgen)
1806 #define GP_refcnt_ix    U32p | offsetof(struct gp, gp_refcnt)
1807 #define GP_hv_ix        SVp | offsetof(struct gp, gp_hv)
1808 #define GP_av_ix        SVp | offsetof(struct gp, gp_av)
1809 #define GP_form_ix      SVp | offsetof(struct gp, gp_form)
1810 #define GP_egv_ix       SVp | offsetof(struct gp, gp_egv)
1811 #define GP_line_ix      line_tp | offsetof(struct gp, gp_line)
1812
1813 void
1814 SV(gv)
1815         B::GV   gv
1816     ALIAS:
1817         SV = GP_sv_ix
1818         IO = GP_io_ix
1819         CV = GP_cv_ix
1820         CVGEN = GP_cvgen_ix
1821         GvREFCNT = GP_refcnt_ix
1822         HV = GP_hv_ix
1823         AV = GP_av_ix
1824         FORM = GP_form_ix
1825         EGV = GP_egv_ix
1826         LINE = GP_line_ix
1827     PREINIT:
1828         GP *gp;
1829         char *ptr;
1830         SV *ret;
1831     PPCODE:
1832         gp = GvGP(gv);
1833         if (!gp) {
1834             const GV *const gv = CvGV(cv);
1835             Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1836         }
1837         ptr = (ix & 0xFFFF) + (char *)gp;
1838         switch ((U8)(ix >> 16)) {
1839         case (U8)(SVp >> 16):
1840             ret = make_sv_object(aTHX_ *((SV **)ptr));
1841             break;
1842         case (U8)(U32p >> 16):
1843             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1844             break;
1845         case (U8)(line_tp >> 16):
1846             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1847             break;
1848         default:
1849             croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
1850         }
1851         ST(0) = ret;
1852         XSRETURN(1);
1853
1854 void
1855 FILEGV(gv)
1856         B::GV   gv
1857     PPCODE:
1858         PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
1859
1860 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1861
1862 #if PERL_VERSION <= 8
1863
1864 short
1865 IoSUBPROCESS(io)
1866         B::IO   io
1867
1868 #endif
1869
1870 bool
1871 IsSTD(io,name)
1872         B::IO   io
1873         const char*     name
1874     PREINIT:
1875         PerlIO* handle = 0;
1876     CODE:
1877         if( strEQ( name, "stdin" ) ) {
1878             handle = PerlIO_stdin();
1879         }
1880         else if( strEQ( name, "stdout" ) ) {
1881             handle = PerlIO_stdout();
1882         }
1883         else if( strEQ( name, "stderr" ) ) {
1884             handle = PerlIO_stderr();
1885         }
1886         else {
1887             croak( "Invalid value '%s'", name );
1888         }
1889         RETVAL = handle == IoIFP(io);
1890     OUTPUT:
1891         RETVAL
1892
1893 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1894
1895 SSize_t
1896 AvFILL(av)
1897         B::AV   av
1898
1899 void
1900 AvARRAY(av)
1901         B::AV   av
1902     PPCODE:
1903         if (AvFILL(av) >= 0) {
1904             SV **svp = AvARRAY(av);
1905             I32 i;
1906             for (i = 0; i <= AvFILL(av); i++)
1907                 XPUSHs(make_sv_object(aTHX_ svp[i]));
1908         }
1909
1910 void
1911 AvARRAYelt(av, idx)
1912         B::AV   av
1913         int     idx
1914     PPCODE:
1915         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1916             XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
1917         else
1918             XPUSHs(make_sv_object(aTHX_ NULL));
1919
1920 #if PERL_VERSION < 9
1921
1922 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1923
1924 IV
1925 AvOFF(av)
1926         B::AV   av
1927
1928 MODULE = B      PACKAGE = B::AV
1929
1930 U8
1931 AvFLAGS(av)
1932         B::AV   av
1933
1934 #endif
1935
1936 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1937
1938 U32
1939 CvCONST(cv)
1940         B::CV   cv
1941
1942 void
1943 CvSTART(cv)
1944         B::CV   cv
1945     ALIAS:
1946         ROOT = 1
1947     PPCODE:
1948         PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1949                              : ix ? CvROOT(cv) : CvSTART(cv)));
1950
1951 void
1952 CvXSUB(cv)
1953         B::CV   cv
1954     ALIAS:
1955         XSUBANY = 1
1956     CODE:
1957         ST(0) = ix && CvCONST(cv)
1958             ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
1959             : sv_2mortal(newSViv(CvISXSUB(cv)
1960                                  ? (ix ? CvXSUBANY(cv).any_iv
1961                                        : PTR2IV(CvXSUB(cv)))
1962                                  : 0));
1963
1964 void
1965 const_sv(cv)
1966         B::CV   cv
1967     PPCODE:
1968         PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
1969
1970 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1971
1972 STRLEN
1973 HvFILL(hv)
1974         B::HV   hv
1975
1976 I32
1977 HvRITER(hv)
1978         B::HV   hv
1979
1980 #if PERL_VERSION < 9
1981
1982 B::PMOP
1983 HvPMROOT(hv)
1984         B::HV   hv
1985     PPCODE:
1986         PUSHs(make_op_object(aTHX_ HvPMROOT(hv)));
1987
1988 #endif
1989
1990 void
1991 HvARRAY(hv)
1992         B::HV   hv
1993     PPCODE:
1994         if (HvUSEDKEYS(hv) > 0) {
1995             SV *sv;
1996             char *key;
1997             I32 len;
1998             (void)hv_iterinit(hv);
1999             EXTEND(sp, HvUSEDKEYS(hv) * 2);
2000             while ((sv = hv_iternextsv(hv, &key, &len))) {
2001                 mPUSHp(key, len);
2002                 PUSHs(make_sv_object(aTHX_ sv));
2003             }
2004         }
2005
2006 MODULE = B      PACKAGE = B::HE         PREFIX = He
2007
2008 void
2009 HeVAL(he)
2010         B::HE he
2011     ALIAS:
2012         SVKEY_force = 1
2013     PPCODE:
2014         PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
2015
2016 U32
2017 HeHASH(he)
2018         B::HE he
2019
2020 MODULE = B      PACKAGE = B::RHE
2021
2022 #if PERL_VERSION >= 9
2023
2024 SV*
2025 HASH(h)
2026         B::RHE h
2027     CODE:
2028         RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
2029     OUTPUT:
2030         RETVAL
2031
2032 #endif