ext/B/B.xs

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