ext/B/B.xs

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