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