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