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     ALIAS:
1279         io = 1
1280     PPCODE:
1281 #if PERL_VERSION >= 9
1282         ST(0) = ix ? make_cop_io_object(aTHX_ o) : make_warnings_object(aTHX_ o);
1283 #else
1284         ST(0) = make_sv_object(aTHX_ NULL, ix ? o->cop_io : o->cop_warnings);
1285 #endif
1286         XSRETURN(1);
1287
1288 #if PERL_VERSION >= 9
1289
1290 B::RHE
1291 COP_hints_hash(o)
1292         B::COP o
1293     CODE:
1294         RETVAL = CopHINTHASH_get(o);
1295     OUTPUT:
1296         RETVAL
1297
1298 #endif
1299
1300 MODULE = B      PACKAGE = B::SV
1301
1302 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1303
1304 U32
1305 REFCNT(sv)
1306         B::SV   sv
1307     ALIAS:
1308         FLAGS = 0xFFFFFFFF
1309         SvTYPE = SVTYPEMASK
1310         POK = SVf_POK
1311         ROK = SVf_ROK
1312         MAGICAL = MAGICAL_FLAG_BITS
1313     CODE:
1314         RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1315     OUTPUT:
1316         RETVAL
1317
1318 void
1319 object_2svref(sv)
1320         B::SV   sv
1321     PPCODE:
1322         ST(0) = sv_2mortal(newRV(sv));
1323         XSRETURN(1);
1324
1325 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1326
1327 IV
1328 SvIV(sv)
1329         B::IV   sv
1330
1331 MODULE = B      PACKAGE = B::IV
1332
1333 #define sv_SVp          0x00000
1334 #define sv_IVp          0x10000
1335 #define sv_UVp          0x20000
1336 #define sv_STRLENp      0x30000
1337 #define sv_U32p         0x40000
1338 #define sv_U8p          0x50000
1339 #define sv_char_pp      0x60000
1340 #define sv_NVp          0x70000
1341 #define sv_char_p       0x80000
1342 #define sv_SSize_tp     0x90000
1343 #define sv_I32p         0xA0000
1344 #define sv_U16p         0xB0000
1345
1346 #define IV_ivx_ix       sv_IVp | offsetof(struct xpviv, xiv_iv)
1347 #define IV_uvx_ix       sv_UVp | offsetof(struct xpvuv, xuv_uv)
1348 #define NV_nvx_ix       sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1349
1350 #if PERL_VERSION >= 10
1351 #define NV_cop_seq_range_low_ix \
1352                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1353 #define NV_cop_seq_range_high_ix \
1354                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1355 #define NV_parent_pad_index_ix \
1356                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1357 #define NV_parent_fakelex_flags_ix \
1358                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1359 #else
1360 #define NV_cop_seq_range_low_ix \
1361                         sv_NVp | offsetof(struct xpvnv, xnv_nv)
1362 #define NV_cop_seq_range_high_ix \
1363                         sv_UVp | offsetof(struct xpvnv, xuv_uv)
1364 #define NV_parent_pad_index_ix \
1365                         sv_NVp | offsetof(struct xpvnv, xnv_nv)
1366 #define NV_parent_fakelex_flags_ix \
1367                         sv_UVp | offsetof(struct xpvnv, xuv_uv)
1368 #endif
1369
1370 #define PV_cur_ix       sv_STRLENp | offsetof(struct xpv, xpv_cur)
1371 #define PV_len_ix       sv_STRLENp | offsetof(struct xpv, xpv_len)
1372
1373 #define PVMG_stash_ix   sv_SVp | offsetof(struct xpvmg, xmg_stash)
1374
1375 #if PERL_VERSION >= 10
1376 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1377 #define PVBM_previous_ix    sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1378 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1379 #else
1380 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvbm, xbm_useful)
1381 #define PVBM_previous_ix    sv_U16p | offsetof(struct xpvbm, xbm_previous)
1382 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvbm, xbm_rare)
1383 #endif
1384
1385 #define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1386 #define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1387 #define PVLV_targ_ix    sv_SVp | offsetof(struct xpvlv, xlv_targ)
1388 #define PVLV_type_ix    sv_char_p | offsetof(struct xpvlv, xlv_type)
1389
1390 #if PERL_VERSION >= 10
1391 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1392 #define PVGV_flags_ix   sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
1393 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xiv_iv)
1394 #else
1395 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xgv_stash)
1396 #define PVGV_flags_ix   sv_U8p | offsetof(struct xpvgv, xgv_flags)
1397 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xio_lines)
1398 #endif
1399
1400 #define PVIO_page_ix        sv_IVp | offsetof(struct xpvio, xio_page)
1401 #define PVIO_page_len_ix    sv_IVp | offsetof(struct xpvio, xio_page_len)
1402 #define PVIO_lines_left_ix  sv_IVp | offsetof(struct xpvio, xio_lines_left)
1403 #define PVIO_top_name_ix    sv_char_pp | offsetof(struct xpvio, xio_top_name)
1404 #define PVIO_top_gv_ix      sv_SVp | offsetof(struct xpvio, xio_top_gv)
1405 #define PVIO_fmt_name_ix    sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1406 #define PVIO_fmt_gv_ix      sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1407 #define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1408 #define PVIO_bottom_gv_ix   sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1409 #define PVIO_type_ix        sv_char_p | offsetof(struct xpvio, xio_type)
1410 #define PVIO_flags_ix       sv_U8p | offsetof(struct xpvio, xio_flags)
1411
1412 #define PVAV_max_ix     sv_SSize_tp | offsetof(struct xpvav, xav_max)
1413
1414 #define PVFM_lines_ix   sv_IVp | offsetof(struct xpvfm, xfm_lines)
1415
1416 #define PVCV_stash_ix   sv_SVp | offsetof(struct xpvcv, xcv_stash)
1417 #define PVCV_gv_ix      sv_SVp | offsetof(struct xpvcv, xcv_gv)
1418 #define PVCV_file_ix    sv_char_pp | offsetof(struct xpvcv, xcv_file)
1419 #define PVCV_depth_ix   sv_I32p | offsetof(struct xpvcv, xcv_depth)
1420 #define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
1421 #define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1422 #define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1423 #define PVCV_flags_ix   sv_U16p | offsetof(struct xpvcv, xcv_flags)
1424
1425 #define PVHV_max_ix     sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1426
1427 #if PERL_VERSION > 12
1428 #define PVHV_keys_ix    sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1429 #else
1430 #define PVHV_keys_ix    sv_IVp | offsetof(struct xpvhv, xhv_keys)
1431 #endif
1432
1433 # The type checking code in B has always been identical for all SV types,
1434 # irrespective of whether the action is actually defined on that SV.
1435 # We should fix this
1436 void
1437 IVX(sv)
1438         B::SV           sv
1439     ALIAS:
1440         B::IV::IVX = IV_ivx_ix
1441         B::IV::UVX = IV_uvx_ix
1442         B::NV::NVX = NV_nvx_ix
1443         B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1444         B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1445         B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1446         B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
1447         B::PV::CUR = PV_cur_ix
1448         B::PV::LEN = PV_len_ix
1449         B::PVMG::SvSTASH = PVMG_stash_ix
1450         B::PVLV::TARGOFF = PVLV_targoff_ix
1451         B::PVLV::TARGLEN = PVLV_targlen_ix
1452         B::PVLV::TARG = PVLV_targ_ix
1453         B::PVLV::TYPE = PVLV_type_ix
1454         B::GV::STASH = PVGV_stash_ix
1455         B::GV::GvFLAGS = PVGV_flags_ix
1456         B::BM::USEFUL = PVBM_useful_ix
1457         B::BM::PREVIOUS = PVBM_previous_ix
1458         B::BM::RARE = PVBM_rare_ix
1459         B::IO::LINES =  PVIO_lines_ix
1460         B::IO::PAGE = PVIO_page_ix
1461         B::IO::PAGE_LEN = PVIO_page_len_ix
1462         B::IO::LINES_LEFT = PVIO_lines_left_ix
1463         B::IO::TOP_NAME = PVIO_top_name_ix
1464         B::IO::TOP_GV = PVIO_top_gv_ix
1465         B::IO::FMT_NAME = PVIO_fmt_name_ix
1466         B::IO::FMT_GV = PVIO_fmt_gv_ix
1467         B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1468         B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1469         B::IO::IoTYPE = PVIO_type_ix
1470         B::IO::IoFLAGS = PVIO_flags_ix
1471         B::AV::MAX = PVAV_max_ix
1472         B::FM::LINES = PVFM_lines_ix
1473         B::CV::STASH = PVCV_stash_ix
1474         B::CV::GV = PVCV_gv_ix
1475         B::CV::FILE = PVCV_file_ix
1476         B::CV::DEPTH = PVCV_depth_ix
1477         B::CV::PADLIST = PVCV_padlist_ix
1478         B::CV::OUTSIDE = PVCV_outside_ix
1479         B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1480         B::CV::CvFLAGS = PVCV_flags_ix
1481         B::HV::MAX = PVHV_max_ix
1482         B::HV::KEYS = PVHV_keys_ix
1483     PREINIT:
1484         char *ptr;
1485         SV *ret;
1486     PPCODE:
1487         ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1488         switch ((U8)(ix >> 16)) {
1489         case (U8)(sv_SVp >> 16):
1490             ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1491             break;
1492         case (U8)(sv_IVp >> 16):
1493             ret = sv_2mortal(newSViv(*((IV *)ptr)));
1494             break;
1495         case (U8)(sv_UVp >> 16):
1496             ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1497             break;
1498         case (U8)(sv_STRLENp >> 16):
1499             ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1500             break;
1501         case (U8)(sv_U32p >> 16):
1502             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1503             break;
1504         case (U8)(sv_U8p >> 16):
1505             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1506             break;
1507         case (U8)(sv_char_pp >> 16):
1508             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1509             break;
1510         case (U8)(sv_NVp >> 16):
1511             ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1512             break;
1513         case (U8)(sv_char_p >> 16):
1514             ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1515             break;
1516         case (U8)(sv_SSize_tp >> 16):
1517             ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1518             break;
1519         case (U8)(sv_I32p >> 16):
1520             ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1521             break;
1522         case (U8)(sv_U16p >> 16):
1523             ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1524             break;
1525         }
1526         ST(0) = ret;
1527         XSRETURN(1);
1528
1529 void
1530 packiv(sv)
1531         B::IV   sv
1532     ALIAS:
1533         needs64bits = 1
1534     CODE:
1535         if (ix) {
1536             ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1537         } else if (sizeof(IV) == 8) {
1538             U32 wp[2];
1539             const IV iv = SvIVX(sv);
1540             /*
1541              * The following way of spelling 32 is to stop compilers on
1542              * 32-bit architectures from moaning about the shift count
1543              * being >= the width of the type. Such architectures don't
1544              * reach this code anyway (unless sizeof(IV) > 8 but then
1545              * everything else breaks too so I'm not fussed at the moment).
1546              */
1547 #ifdef UV_IS_QUAD
1548             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1549 #else
1550             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1551 #endif
1552             wp[1] = htonl(iv & 0xffffffff);
1553             ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1554         } else {
1555             U32 w = htonl((U32)SvIVX(sv));
1556             ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1557         }
1558
1559 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1560
1561 NV
1562 SvNV(sv)
1563         B::NV   sv
1564
1565 #if PERL_VERSION < 11
1566
1567 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1568
1569 B::SV
1570 SvRV(sv)
1571         B::RV   sv
1572
1573 #else
1574
1575 MODULE = B      PACKAGE = B::REGEXP
1576
1577 void
1578 REGEX(sv)
1579         B::REGEXP       sv
1580     ALIAS:
1581         precomp = 1
1582     PPCODE:
1583         if (ix) {
1584             PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1585         } else {
1586             dXSTARG;
1587             /* FIXME - can we code this method more efficiently?  */
1588             PUSHi(PTR2IV(sv));
1589         }
1590
1591 #endif
1592
1593 MODULE = B      PACKAGE = B::PV
1594
1595 B::SV
1596 RV(sv)
1597         B::PV   sv
1598     CODE:
1599         if( SvROK(sv) ) {
1600             RETVAL = SvRV(sv);
1601         }
1602         else {
1603             croak( "argument is not SvROK" );
1604         }
1605     OUTPUT:
1606         RETVAL
1607
1608 void
1609 PV(sv)
1610         B::PV   sv
1611     ALIAS:
1612         PVX = 1
1613         PVBM = 2
1614         B::BM::TABLE = 3
1615     PREINIT:
1616         const char *p;
1617         STRLEN len = 0;
1618         U32 utf8 = 0;
1619     CODE:
1620         if (ix == 3) {
1621             p = SvPV(sv, len);
1622             /* Boyer-Moore table is just after string and its safety-margin \0 */
1623             p += len + PERL_FBM_TABLE_OFFSET;
1624             len = 256;
1625         } else if (ix == 2) {
1626             /* This used to read 257. I think that that was buggy - should have
1627                been 258. (The "\0", the flags byte, and 256 for the table.  Not
1628                that anything anywhere calls this method.  NWC.  */
1629             /* Also, the start pointer has always been SvPVX(sv). Surely it
1630                should be SvPVX(sv) + SvCUR(sv)?  The code has faithfully been
1631                refactored with this behaviour, since PVBM was added in
1632                651aa52ea1faa806.  */
1633             p = SvPVX_const(sv);
1634             len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1635         } else if (ix) {
1636             p = SvPVX(sv);
1637             len = strlen(p);
1638         } else if (SvPOK(sv)) {
1639             len = SvCUR(sv);
1640             p = SvPVX_const(sv);
1641             utf8 = SvUTF8(sv);
1642 #if PERL_VERSION < 10
1643             /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1644                in SvCUR(), which meant we had to attempt this special casing
1645                to avoid tripping up over variable names in the pads.  */
1646             if((SvLEN(sv) && len >= SvLEN(sv))) {
1647                 /* It claims to be longer than the space allocated for it -
1648                    presuambly it's a variable name in the pad  */
1649                 len = strlen(p);
1650             }
1651 #endif
1652         }
1653         else {
1654             /* XXX for backward compatibility, but should fail */
1655             /* croak( "argument is not SvPOK" ); */
1656             p = NULL;
1657         }
1658         ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
1659
1660 MODULE = B      PACKAGE = B::PVMG
1661
1662 void
1663 MAGIC(sv)
1664         B::PVMG sv
1665         MAGIC * mg = NO_INIT
1666     PPCODE:
1667         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1668             XPUSHs(make_mg_object(aTHX_ mg));
1669
1670 MODULE = B      PACKAGE = B::MAGIC
1671
1672 void
1673 MOREMAGIC(mg)
1674         B::MAGIC        mg
1675     ALIAS:
1676         PRIVATE = 1
1677         TYPE = 2
1678         FLAGS = 3
1679         LEN = 4
1680         OBJ = 5
1681         PTR = 6
1682         REGEX = 7
1683         precomp = 8
1684     PPCODE:
1685         switch (ix) {
1686         case 0:
1687             XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1688                                     : &PL_sv_undef);
1689             break;
1690         case 1:
1691             mPUSHu(mg->mg_private);
1692             break;
1693         case 2:
1694             PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1695             break;
1696         case 3:
1697             mPUSHu(mg->mg_flags);
1698             break;
1699         case 4:
1700             mPUSHi(mg->mg_len);
1701             break;
1702         case 5:
1703             PUSHs(make_sv_object(aTHX_ NULL, mg->mg_obj));
1704             break;
1705         case 6:
1706             if (mg->mg_ptr) {
1707                 if (mg->mg_len >= 0) {
1708                     PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
1709                 } else if (mg->mg_len == HEf_SVKEY) {
1710                     PUSHs(make_sv_object(aTHX_ NULL, (SV*)mg->mg_ptr));
1711                 } else
1712                     PUSHs(sv_newmortal());
1713             } else
1714                 PUSHs(sv_newmortal());
1715             break;
1716         case 7:
1717             if(mg->mg_type == PERL_MAGIC_qr) {
1718                 mPUSHi(PTR2IV(mg->mg_obj));
1719             } else {
1720                 croak("REGEX is only meaningful on r-magic");
1721             }
1722             break;
1723         case 8:
1724             if (mg->mg_type == PERL_MAGIC_qr) {
1725                 REGEXP *rx = (REGEXP *)mg->mg_obj;
1726                 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1727                                      rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
1728             } else {
1729                 croak( "precomp is only meaningful on r-magic" );
1730             }
1731             break;
1732         }
1733
1734 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1735
1736 void
1737 GvNAME(gv)
1738         B::GV   gv
1739     ALIAS:
1740         FILE = 1
1741         B::HV::NAME = 2
1742     CODE:
1743 #if PERL_VERSION >= 10
1744         ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1745                                         : (ix == 1 ? GvFILE_HEK(gv)
1746                                                    : HvNAME_HEK((HV *)gv))));
1747 #else
1748         ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1749                     : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
1750 #endif
1751
1752 bool
1753 is_empty(gv)
1754         B::GV   gv
1755     ALIAS:
1756         isGV_with_GP = 1
1757     CODE:
1758         if (ix) {
1759 #if PERL_VERSION >= 9
1760             RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1761 #else
1762             RETVAL = TRUE; /* In 5.8 and earlier they all are.  */
1763 #endif
1764         } else {
1765             RETVAL = GvGP(gv) == Null(GP*);
1766         }
1767     OUTPUT:
1768         RETVAL
1769
1770 void*
1771 GvGP(gv)
1772         B::GV   gv
1773
1774 #define GP_sv_ix        SVp | offsetof(struct gp, gp_sv)
1775 #define GP_io_ix        SVp | offsetof(struct gp, gp_io)
1776 #define GP_cv_ix        SVp | offsetof(struct gp, gp_cv)
1777 #define GP_cvgen_ix     U32p | offsetof(struct gp, gp_cvgen)
1778 #define GP_refcnt_ix    U32p | offsetof(struct gp, gp_refcnt)
1779 #define GP_hv_ix        SVp | offsetof(struct gp, gp_hv)
1780 #define GP_av_ix        SVp | offsetof(struct gp, gp_av)
1781 #define GP_form_ix      SVp | offsetof(struct gp, gp_form)
1782 #define GP_egv_ix       SVp | offsetof(struct gp, gp_egv)
1783 #define GP_line_ix      line_tp | offsetof(struct gp, gp_line)
1784
1785 void
1786 SV(gv)
1787         B::GV   gv
1788     ALIAS:
1789         SV = GP_sv_ix
1790         IO = GP_io_ix
1791         CV = GP_cv_ix
1792         CVGEN = GP_cvgen_ix
1793         GvREFCNT = GP_refcnt_ix
1794         HV = GP_hv_ix
1795         AV = GP_av_ix
1796         FORM = GP_form_ix
1797         EGV = GP_egv_ix
1798         LINE = GP_line_ix
1799     PREINIT:
1800         GP *gp;
1801         char *ptr;
1802         SV *ret;
1803     PPCODE:
1804         gp = GvGP(gv);
1805         if (!gp) {
1806             const GV *const gv = CvGV(cv);
1807             Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1808         }
1809         ptr = (ix & 0xFFFF) + (char *)gp;
1810         switch ((U8)(ix >> 16)) {
1811         case (U8)(SVp >> 16):
1812             ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1813             break;
1814         case (U8)(U32p >> 16):
1815             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1816             break;
1817         case (U8)(line_tp >> 16):
1818             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1819             break;
1820         }
1821         ST(0) = ret;
1822         XSRETURN(1);
1823
1824 B::GV
1825 GvFILEGV(gv)
1826         B::GV   gv
1827
1828 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1829
1830 #if PERL_VERSION <= 8
1831
1832 short
1833 IoSUBPROCESS(io)
1834         B::IO   io
1835
1836 #endif
1837
1838 bool
1839 IsSTD(io,name)
1840         B::IO   io
1841         const char*     name
1842     PREINIT:
1843         PerlIO* handle = 0;
1844     CODE:
1845         if( strEQ( name, "stdin" ) ) {
1846             handle = PerlIO_stdin();
1847         }
1848         else if( strEQ( name, "stdout" ) ) {
1849             handle = PerlIO_stdout();
1850         }
1851         else if( strEQ( name, "stderr" ) ) {
1852             handle = PerlIO_stderr();
1853         }
1854         else {
1855             croak( "Invalid value '%s'", name );
1856         }
1857         RETVAL = handle == IoIFP(io);
1858     OUTPUT:
1859         RETVAL
1860
1861 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1862
1863 SSize_t
1864 AvFILL(av)
1865         B::AV   av
1866
1867 void
1868 AvARRAY(av)
1869         B::AV   av
1870     PPCODE:
1871         if (AvFILL(av) >= 0) {
1872             SV **svp = AvARRAY(av);
1873             I32 i;
1874             for (i = 0; i <= AvFILL(av); i++)
1875                 XPUSHs(make_sv_object(aTHX_ NULL, svp[i]));
1876         }
1877
1878 void
1879 AvARRAYelt(av, idx)
1880         B::AV   av
1881         int     idx
1882     PPCODE:
1883         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1884             XPUSHs(make_sv_object(aTHX_ NULL, (AvARRAY(av)[idx])));
1885         else
1886             XPUSHs(make_sv_object(aTHX_ NULL, NULL));
1887
1888 #if PERL_VERSION < 9
1889
1890 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1891
1892 IV
1893 AvOFF(av)
1894         B::AV   av
1895
1896 MODULE = B      PACKAGE = B::AV
1897
1898 U8
1899 AvFLAGS(av)
1900         B::AV   av
1901
1902 #endif
1903
1904 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1905
1906 U32
1907 CvCONST(cv)
1908         B::CV   cv
1909
1910 B::OP
1911 CvSTART(cv)
1912         B::CV   cv
1913     ALIAS:
1914         ROOT = 1
1915     CODE:
1916         RETVAL = CvISXSUB(cv) ? NULL : ix ? CvROOT(cv) : CvSTART(cv);
1917     OUTPUT:
1918         RETVAL
1919
1920 void
1921 CvXSUB(cv)
1922         B::CV   cv
1923     ALIAS:
1924         XSUBANY = 1
1925     CODE:
1926         ST(0) = ix && CvCONST(cv)
1927             ? make_sv_object(aTHX_ NULL, (SV *)CvXSUBANY(cv).any_ptr)
1928             : sv_2mortal(newSViv(CvISXSUB(cv)
1929                                  ? (ix ? CvXSUBANY(cv).any_iv
1930                                        : PTR2IV(CvXSUB(cv)))
1931                                  : 0));
1932
1933 MODULE = B      PACKAGE = B::CV         PREFIX = cv_
1934
1935 B::SV
1936 cv_const_sv(cv)
1937         B::CV   cv
1938
1939 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1940
1941 STRLEN
1942 HvFILL(hv)
1943         B::HV   hv
1944
1945 I32
1946 HvRITER(hv)
1947         B::HV   hv
1948
1949 #if PERL_VERSION < 9
1950
1951 B::PMOP
1952 HvPMROOT(hv)
1953         B::HV   hv
1954
1955 #endif
1956
1957 void
1958 HvARRAY(hv)
1959         B::HV   hv
1960     PPCODE:
1961         if (HvKEYS(hv) > 0) {
1962             SV *sv;
1963             char *key;
1964             I32 len;
1965             (void)hv_iterinit(hv);
1966             EXTEND(sp, HvKEYS(hv) * 2);
1967             while ((sv = hv_iternextsv(hv, &key, &len))) {
1968                 mPUSHp(key, len);
1969                 PUSHs(make_sv_object(aTHX_ NULL, sv));
1970             }
1971         }
1972
1973 MODULE = B      PACKAGE = B::HE         PREFIX = He
1974
1975 B::SV
1976 HeVAL(he)
1977         B::HE he
1978     ALIAS:
1979         SVKEY_force = 1
1980     CODE:
1981         RETVAL = ix ? HeSVKEY_force(he) : HeVAL(he);
1982     OUTPUT:
1983         RETVAL
1984
1985 U32
1986 HeHASH(he)
1987         B::HE he
1988
1989 MODULE = B      PACKAGE = B::RHE
1990
1991 #if PERL_VERSION >= 9
1992
1993 SV*
1994 HASH(h)
1995         B::RHE h
1996     CODE:
1997         RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
1998     OUTPUT:
1999         RETVAL
2000
2001 #endif