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