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