ext/B/B.xs

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