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