ext/B/B.xs

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