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