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
 625
 626 #ifdef MULTIPLICITY
 627 #  define ASSIGN_COMMON_ALIAS(prefix, var) \
 628     STMT_START { XSANY.any_i32 = STRUCT_OFFSET(struct interpreter, prefix##var); } STMT_END
 629 #else
 630 #  define ASSIGN_COMMON_ALIAS(prefix, var) \
 631     STMT_START { XSANY.any_ptr = (void *)&PL_##var; } STMT_END
 632 #endif
 633
 634 /* This needs to be ALIASed in a custom way, hence can't easily be defined as
 635    a regular XSUB.  */
 636 static XSPROTO(intrpvar_sv_common); /* prototype to pass -Wmissing-prototypes */
 637 static XSPROTO(intrpvar_sv_common)
 638 {
 639     dVAR;
 640     dXSARGS;
 641     SV *ret;
 642     if (items != 0)
 643        croak_xs_usage(cv,  "");
 644 #ifdef MULTIPLICITY
 645     ret = *(SV **)(XSANY.any_i32 + (char *)my_perl);
 646 #else
 647     ret = *(SV **)(XSANY.any_ptr);
 648 #endif
 649     ST(0) = make_sv_object(aTHX_ ret);
 650     XSRETURN(1);
 651 }
 652
 653
 654
 655 #define SVp                 0x0
 656 #define U32p                0x1
 657 #define line_tp             0x2
 658 #define OPp                 0x3
 659 #define PADOFFSETp          0x4
 660 #define U8p                 0x5
 661 #define IVp                 0x6
 662 #define char_pp             0x7
 663 /* Keep this last:  */
 664 #define op_offset_special   0x8
 665
 666 /* table that drives most of the B::*OP methods */
 667
 668 struct OP_methods {
 669     const char *name;
 670     U8 namelen;
 671     U8    type; /* if op_offset_special, access is handled on a case-by-case basis */
 672     U16 offset;
 673 } op_methods[] = {
 674   { STR_WITH_LEN("next"),    OPp,    STRUCT_OFFSET(struct op, op_next),     },/* 0*/
 675   { STR_WITH_LEN("sibling"), op_offset_special, 0,                          },/* 1*/
 676   { STR_WITH_LEN("targ"),    PADOFFSETp, STRUCT_OFFSET(struct op, op_targ), },/* 2*/
 677   { STR_WITH_LEN("flags"),   U8p,    STRUCT_OFFSET(struct op, op_flags),    },/* 3*/
 678   { STR_WITH_LEN("private"), U8p,    STRUCT_OFFSET(struct op, op_private),  },/* 4*/
 679   { STR_WITH_LEN("first"),   OPp,    STRUCT_OFFSET(struct unop, op_first),  },/* 5*/
 680   { STR_WITH_LEN("last"),    OPp,    STRUCT_OFFSET(struct binop, op_last),  },/* 6*/
 681   { STR_WITH_LEN("other"),   OPp,    STRUCT_OFFSET(struct logop, op_other), },/* 7*/
 682   { STR_WITH_LEN("pmreplstart"), op_offset_special, 0,                 },/* 8*/
 683   { STR_WITH_LEN("redoop"),  OPp,    STRUCT_OFFSET(struct loop, op_redoop), },/* 9*/
 684   { STR_WITH_LEN("nextop"),  OPp,    STRUCT_OFFSET(struct loop, op_nextop), },/*10*/
 685   { STR_WITH_LEN("lastop"),  OPp,    STRUCT_OFFSET(struct loop, op_lastop), },/*11*/
 686   { STR_WITH_LEN("pmflags"), U32p,   STRUCT_OFFSET(struct pmop, op_pmflags),},/*12*/
 687 #if PERL_VERSION >= 17
 688   { STR_WITH_LEN("code_list"),OPp,   STRUCT_OFFSET(struct pmop, op_code_list),},/*13*/
 689 #else
 690   { STR_WITH_LEN("code_list"),op_offset_special, 0,                         }, /*13*/
 691 #endif
 692   { STR_WITH_LEN("sv"),      SVp,     STRUCT_OFFSET(struct svop, op_sv),    },/*14*/
 693   { STR_WITH_LEN("gv"),      SVp,     STRUCT_OFFSET(struct svop, op_sv),    },/*15*/
 694   { STR_WITH_LEN("padix"),   PADOFFSETp,STRUCT_OFFSET(struct padop, op_padix),},/*16*/
 695   { STR_WITH_LEN("cop_seq"), U32p,    STRUCT_OFFSET(struct cop, cop_seq),   },/*17*/
 696   { STR_WITH_LEN("line"),    line_tp, STRUCT_OFFSET(struct cop, cop_line),  },/*18*/
 697   { STR_WITH_LEN("hints"),   U32p,    STRUCT_OFFSET(struct cop, cop_hints), },/*19*/
 698 #ifdef USE_ITHREADS
 699   { STR_WITH_LEN("pmoffset"),IVp,     STRUCT_OFFSET(struct pmop, op_pmoffset),},/*20*/
 700   { STR_WITH_LEN("filegv"),  op_offset_special, 0,                     },/*21*/
 701   { STR_WITH_LEN("file"),    char_pp, STRUCT_OFFSET(struct cop, cop_file),  },/*22*/
 702   { STR_WITH_LEN("stash"),   op_offset_special, 0,                     },/*23*/
 703 #  if PERL_VERSION < 17
 704   { STR_WITH_LEN("stashpv"), char_pp, STRUCT_OFFSET(struct cop, cop_stashpv),}, /*24*/
 705   { STR_WITH_LEN("stashoff"),op_offset_special, 0,                     },/*25*/
 706 #  else
 707   { STR_WITH_LEN("stashpv"), op_offset_special, 0,                     },/*24*/
 708   { STR_WITH_LEN("stashoff"),PADOFFSETp,STRUCT_OFFSET(struct cop,cop_stashoff),},/*25*/
 709 #  endif
 710 #else
 711   { STR_WITH_LEN("pmoffset"),op_offset_special, 0,                     },/*20*/
 712   { STR_WITH_LEN("filegv"),  SVp,     STRUCT_OFFSET(struct cop, cop_filegv),},/*21*/
 713   { STR_WITH_LEN("file"),    op_offset_special, 0,                     },/*22*/
 714   { STR_WITH_LEN("stash"),   SVp,     STRUCT_OFFSET(struct cop, cop_stash), },/*23*/
 715   { STR_WITH_LEN("stashpv"), op_offset_special, 0,                     },/*24*/
 716   { STR_WITH_LEN("stashoff"),op_offset_special, 0,                     },/*25*/
 717 #endif
 718   { STR_WITH_LEN("size"),    op_offset_special, 0,                     },/*26*/
 719   { STR_WITH_LEN("name"),    op_offset_special, 0,                     },/*27*/
 720   { STR_WITH_LEN("desc"),    op_offset_special, 0,                     },/*28*/
 721   { STR_WITH_LEN("ppaddr"),  op_offset_special, 0,                     },/*29*/
 722   { STR_WITH_LEN("type"),    op_offset_special, 0,                     },/*30*/
 723   { STR_WITH_LEN("opt"),     op_offset_special, 0,                     },/*31*/
 724   { STR_WITH_LEN("spare"),   op_offset_special, 0,                     },/*32*/
 725   { STR_WITH_LEN("children"),op_offset_special, 0,                     },/*33*/
 726   { STR_WITH_LEN("pmreplroot"), op_offset_special, 0,                  },/*34*/
 727   { STR_WITH_LEN("pmstashpv"), op_offset_special, 0,                   },/*35*/
 728   { STR_WITH_LEN("pmstash"), op_offset_special, 0,                     },/*36*/
 729   { STR_WITH_LEN("precomp"), op_offset_special, 0,                     },/*37*/
 730   { STR_WITH_LEN("reflags"), op_offset_special, 0,                     },/*38*/
 731   { STR_WITH_LEN("sv"),      op_offset_special, 0,                     },/*39*/
 732   { STR_WITH_LEN("gv"),      op_offset_special, 0,                     },/*40*/
 733   { STR_WITH_LEN("pv"),      op_offset_special, 0,                     },/*41*/
 734   { STR_WITH_LEN("label"),   op_offset_special, 0,                     },/*42*/
 735   { STR_WITH_LEN("arybase"), op_offset_special, 0,                     },/*43*/
 736   { STR_WITH_LEN("warnings"),op_offset_special, 0,                     },/*44*/
 737   { STR_WITH_LEN("io"),      op_offset_special, 0,                     },/*45*/
 738   { STR_WITH_LEN("hints_hash"),op_offset_special, 0,                   },/*46*/
 739 #if PERL_VERSION >= 17
 740   { STR_WITH_LEN("slabbed"), op_offset_special, 0,                     },/*47*/
 741   { STR_WITH_LEN("savefree"),op_offset_special, 0,                     },/*48*/
 742   { STR_WITH_LEN("static"),  op_offset_special, 0,                     },/*49*/
 743 #  if PERL_VERSION >= 19
 744   { STR_WITH_LEN("folded"),  op_offset_special, 0,                     },/*50*/
 745   { STR_WITH_LEN("lastsib"), op_offset_special, 0,                     },/*51*/
 746   { STR_WITH_LEN("parent"),  op_offset_special, 0,                     },/*52*/
 747 #  endif
 748 #endif
 749 #if PERL_VERSION >= 21
 750   { STR_WITH_LEN("first"),   op_offset_special, 0,                     },/*53*/
 751   { STR_WITH_LEN("meth_sv"), op_offset_special, 0,                     },/*54*/
 752 #endif
 753 };
 754
 755 #include "const-c.inc"
 756
 757 MODULE = B      PACKAGE = B
 758
 759 INCLUDE: const-xs.inc
 760
 761 PROTOTYPES: DISABLE
 762
 763 BOOT:
 764 {
 765     CV *cv;
 766     const char *file = __FILE__;
 767     MY_CXT_INIT;
 768     specialsv_list[0] = Nullsv;
 769     specialsv_list[1] = &PL_sv_undef;
 770     specialsv_list[2] = &PL_sv_yes;
 771     specialsv_list[3] = &PL_sv_no;
 772     specialsv_list[4] = (SV *) pWARN_ALL;
 773     specialsv_list[5] = (SV *) pWARN_NONE;
 774     specialsv_list[6] = (SV *) pWARN_STD;
 775
 776     cv = newXS("B::init_av", intrpvar_sv_common, file);
 777     ASSIGN_COMMON_ALIAS(I, initav);
 778     cv = newXS("B::check_av", intrpvar_sv_common, file);
 779     ASSIGN_COMMON_ALIAS(I, checkav_save);
 780     cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
 781     ASSIGN_COMMON_ALIAS(I, unitcheckav_save);
 782     cv = newXS("B::begin_av", intrpvar_sv_common, file);
 783     ASSIGN_COMMON_ALIAS(I, beginav_save);
 784     cv = newXS("B::end_av", intrpvar_sv_common, file);
 785     ASSIGN_COMMON_ALIAS(I, endav);
 786     cv = newXS("B::main_cv", intrpvar_sv_common, file);
 787     ASSIGN_COMMON_ALIAS(I, main_cv);
 788     cv = newXS("B::inc_gv", intrpvar_sv_common, file);
 789     ASSIGN_COMMON_ALIAS(I, incgv);
 790     cv = newXS("B::defstash", intrpvar_sv_common, file);
 791     ASSIGN_COMMON_ALIAS(I, defstash);
 792     cv = newXS("B::curstash", intrpvar_sv_common, file);
 793     ASSIGN_COMMON_ALIAS(I, curstash);
 794 #ifdef PL_formfeed
 795     cv = newXS("B::formfeed", intrpvar_sv_common, file);
 796     ASSIGN_COMMON_ALIAS(I, formfeed);
 797 #endif
 798 #ifdef USE_ITHREADS
 799     cv = newXS("B::regex_padav", intrpvar_sv_common, file);
 800     ASSIGN_COMMON_ALIAS(I, regex_padav);
 801 #endif
 802     cv = newXS("B::warnhook", intrpvar_sv_common, file);
 803     ASSIGN_COMMON_ALIAS(I, warnhook);
 804     cv = newXS("B::diehook", intrpvar_sv_common, file);
 805     ASSIGN_COMMON_ALIAS(I, diehook);
 806 }
 807
 808 #ifndef PL_formfeed
 809
 810 void
 811 formfeed()
 812     PPCODE:
 813         PUSHs(make_sv_object(aTHX_ GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV))));
 814
 815 #endif
 816
 817 long
 818 amagic_generation()
 819     CODE:
 820         RETVAL = PL_amagic_generation;
 821     OUTPUT:
 822         RETVAL
 823
 824 void
 825 comppadlist()
 826     PREINIT:
 827         PADLIST *padlist = CvPADLIST(PL_main_cv ? PL_main_cv : PL_compcv);
 828     PPCODE:
 829 #ifdef PadlistARRAY
 830         {
 831             SV * const rv = sv_newmortal();
 832             sv_setiv(newSVrv(rv, padlist ? "B::PADLIST" : "B::NULL"),
 833                      PTR2IV(padlist));
 834             PUSHs(rv);
 835         }
 836 #else
 837         PUSHs(make_sv_object(aTHX_ (SV *)padlist));
 838 #endif
 839
 840 void
 841 sv_undef()
 842     ALIAS:
 843         sv_no = 1
 844         sv_yes = 2
 845     PPCODE:
 846         PUSHs(make_sv_object(aTHX_ ix > 1 ? &PL_sv_yes
 847                                           : ix < 1 ? &PL_sv_undef
 848                                                    : &PL_sv_no));
 849
 850 void
 851 main_root()
 852     ALIAS:
 853         main_start = 1
 854     PPCODE:
 855         PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root));
 856
 857 UV
 858 sub_generation()
 859     ALIAS:
 860         dowarn = 1
 861     CODE:
 862         RETVAL = ix ? PL_dowarn : PL_sub_generation;
 863     OUTPUT:
 864         RETVAL
 865
 866 void
 867 walkoptree(op, method)
 868         B::OP op
 869         const char *    method
 870     CODE:
 871         (void) walkoptree(aTHX_ op, method, &PL_sv_undef);
 872
 873 int
 874 walkoptree_debug(...)
 875     CODE:
 876         dMY_CXT;
 877         RETVAL = walkoptree_debug;
 878         if (items > 0 && SvTRUE(ST(1)))
 879             walkoptree_debug = 1;
 880     OUTPUT:
 881         RETVAL
 882
 883 #define address(sv) PTR2IV(sv)
 884
 885 IV
 886 address(sv)
 887         SV *    sv
 888
 889 void
 890 svref_2object(sv)
 891         SV *    sv
 892     PPCODE:
 893         if (!SvROK(sv))
 894             croak("argument is not a reference");
 895         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
 896
 897 void
 898 opnumber(name)
 899 const char *    name
 900 CODE:
 901 {
 902  int i;
 903  IV  result = -1;
 904  ST(0) = sv_newmortal();
 905  if (strncmp(name,"pp_",3) == 0)
 906    name += 3;
 907  for (i = 0; i < PL_maxo; i++)
 908   {
 909    if (strcmp(name, PL_op_name[i]) == 0)
 910     {
 911      result = i;
 912      break;
 913     }
 914   }
 915  sv_setiv(ST(0),result);
 916 }
 917
 918 void
 919 ppname(opnum)
 920         int     opnum
 921     CODE:
 922         ST(0) = sv_newmortal();
 923         if (opnum >= 0 && opnum < PL_maxo)
 924             Perl_sv_setpvf(aTHX_ ST(0), "pp_%s", PL_op_name[opnum]);
 925
 926 void
 927 hash(sv)
 928         SV *    sv
 929     CODE:
 930         STRLEN len;
 931         U32 hash = 0;
 932         const char *s = SvPVbyte(sv, len);
 933         PERL_HASH(hash, s, len);
 934         ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
 935
 936 #define cast_I32(foo) (I32)foo
 937 IV
 938 cast_I32(i)
 939         IV      i
 940
 941 void
 942 minus_c()
 943     ALIAS:
 944         save_BEGINs = 1
 945     CODE:
 946         if (ix)
 947             PL_savebegin = TRUE;
 948         else
 949             PL_minus_c = TRUE;
 950
 951 void
 952 cstring(sv)
 953         SV *    sv
 954     ALIAS:
 955         perlstring = 1
 956         cchar = 2
 957     PPCODE:
 958         PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, (bool)ix));
 959
 960 void
 961 threadsv_names()
 962     PPCODE:
 963
 964
 965
 966
 967 MODULE = B      PACKAGE = B::OP
 968
 969
 970 # The type checking code in B has always been identical for all OP types,
 971 # irrespective of whether the action is actually defined on that OP.
 972 # We should fix this
 973 void
 974 next(o)
 975         B::OP           o
 976     ALIAS:
 977         B::OP::next          =  0
 978         B::OP::sibling       =  1
 979         B::OP::targ          =  2
 980         B::OP::flags         =  3
 981         B::OP::private       =  4
 982         B::UNOP::first       =  5
 983         B::BINOP::last       =  6
 984         B::LOGOP::other      =  7
 985         B::PMOP::pmreplstart =  8
 986         B::LOOP::redoop      =  9
 987         B::LOOP::nextop      = 10
 988         B::LOOP::lastop      = 11
 989         B::PMOP::pmflags     = 12
 990         B::PMOP::code_list   = 13
 991         B::SVOP::sv          = 14
 992         B::SVOP::gv          = 15
 993         B::PADOP::padix      = 16
 994         B::COP::cop_seq      = 17
 995         B::COP::line         = 18
 996         B::COP::hints        = 19
 997         B::PMOP::pmoffset    = 20
 998         B::COP::filegv       = 21
 999         B::COP::file         = 22
1000         B::COP::stash        = 23
1001         B::COP::stashpv      = 24
1002         B::COP::stashoff     = 25
1003         B::OP::size          = 26
1004         B::OP::name          = 27
1005         B::OP::desc          = 28
1006         B::OP::ppaddr        = 29
1007         B::OP::type          = 30
1008         B::OP::opt           = 31
1009         B::OP::spare         = 32
1010         B::LISTOP::children  = 33
1011         B::PMOP::pmreplroot  = 34
1012         B::PMOP::pmstashpv   = 35
1013         B::PMOP::pmstash     = 36
1014         B::PMOP::precomp     = 37
1015         B::PMOP::reflags     = 38
1016         B::PADOP::sv         = 39
1017         B::PADOP::gv         = 40
1018         B::PVOP::pv          = 41
1019         B::COP::label        = 42
1020         B::COP::arybase      = 43
1021         B::COP::warnings     = 44
1022         B::COP::io           = 45
1023         B::COP::hints_hash   = 46
1024         B::OP::slabbed       = 47
1025         B::OP::savefree      = 48
1026         B::OP::static        = 49
1027         B::OP::folded        = 50
1028         B::OP::lastsib       = 51
1029         B::OP::parent        = 52
1030         B::METHOP::first     = 53
1031         B::METHOP::meth_sv   = 54
1032     PREINIT:
1033         SV *ret;
1034     PPCODE:
1035         if (ix < 0 || (U32)ix >= C_ARRAY_LENGTH(op_methods))
1036             croak("Illegal alias %d for B::*OP::next", (int)ix);
1037         ret = get_overlay_object(aTHX_ o,
1038                             op_methods[ix].name, op_methods[ix].namelen);
1039         if (ret) {
1040             ST(0) = ret;
1041             XSRETURN(1);
1042         }
1043
1044         /* handle non-direct field access */
1045
1046         if (op_methods[ix].type == op_offset_special)
1047             switch (ix) {
1048             case 1: /* B::OP::op_sibling */
1049                 ret = make_op_object(aTHX_ OP_SIBLING(o));
1050                 break;
1051
1052             case 8: /* B::PMOP::pmreplstart */
1053                 ret = make_op_object(aTHX_
1054                                 cPMOPo->op_type == OP_SUBST
1055                                     ?  cPMOPo->op_pmstashstartu.op_pmreplstart
1056                                     : NULL
1057                       );
1058                 break;
1059 #ifdef USE_ITHREADS
1060             case 21: /* B::COP::filegv */
1061                 ret = make_sv_object(aTHX_ (SV *)CopFILEGV((COP*)o));
1062                 break;
1063 #endif
1064 #ifndef USE_ITHREADS
1065             case 22: /* B::COP::file */
1066                 ret = sv_2mortal(newSVpv(CopFILE((COP*)o), 0));
1067                 break;
1068 #endif
1069 #ifdef USE_ITHREADS
1070             case 23: /* B::COP::stash */
1071                 ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o));
1072                 break;
1073 #endif
1074 #if PERL_VERSION >= 17 || !defined USE_ITHREADS
1075             case 24: /* B::COP::stashpv */
1076 #  if PERL_VERSION >= 17
1077                 ret = sv_2mortal(CopSTASH((COP*)o)
1078                                 && SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV
1079                     ? newSVhek(HvNAME_HEK(CopSTASH((COP*)o)))
1080                     : &PL_sv_undef);
1081 #  else
1082                 ret = sv_2mortal(newSVpv(CopSTASHPV((COP*)o), 0));
1083 #  endif
1084                 break;
1085 #endif
1086             case 26: /* B::OP::size */
1087                 ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)])));
1088                 break;
1089             case 27: /* B::OP::name */
1090             case 28: /* B::OP::desc */
1091                 ret = sv_2mortal(newSVpv(
1092                             (char *)(ix == 28 ? OP_DESC(o) : OP_NAME(o)), 0));
1093                 break;
1094             case 29: /* B::OP::ppaddr */
1095                 {
1096                     int i;
1097                     ret = sv_2mortal(Perl_newSVpvf(aTHX_ "PL_ppaddr[OP_%s]",
1098                                                   PL_op_name[o->op_type]));
1099                     for (i=13; (STRLEN)i < SvCUR(ret); ++i)
1100                         SvPVX(ret)[i] = toUPPER(SvPVX(ret)[i]);
1101                 }
1102                 break;
1103             case 30: /* B::OP::type  */
1104             case 31: /* B::OP::opt   */
1105             case 32: /* B::OP::spare */
1106 #if PERL_VERSION >= 17
1107             case 47: /* B::OP::slabbed  */
1108             case 48: /* B::OP::savefree */
1109             case 49: /* B::OP::static   */
1110 #if PERL_VERSION >= 19
1111             case 50: /* B::OP::folded   */
1112             case 51: /* B::OP::lastsib  */
1113 #endif
1114 #endif
1115             /* These are all bitfields, so we can't take their addresses */
1116                 ret = sv_2mortal(newSVuv((UV)(
1117                                       ix == 30 ? o->op_type
1118                                     : ix == 31 ? o->op_opt
1119                                     : ix == 47 ? o->op_slabbed
1120                                     : ix == 48 ? o->op_savefree
1121                                     : ix == 49 ? o->op_static
1122                                     : ix == 50 ? o->op_folded
1123                                     : ix == 51 ? o->op_lastsib
1124                                     :            o->op_spare)));
1125                 break;
1126             case 33: /* B::LISTOP::children */
1127                 {
1128                     OP *kid;
1129                     UV i = 0;
1130                     for (kid = ((LISTOP*)o)->op_first; kid; kid = OP_SIBLING(kid))
1131                         i++;
1132                     ret = sv_2mortal(newSVuv(i));
1133                 }
1134                 break;
1135             case 34: /* B::PMOP::pmreplroot */
1136                 if (cPMOPo->op_type == OP_PUSHRE) {
1137 #ifdef USE_ITHREADS
1138                     ret = sv_newmortal();
1139                     sv_setiv(ret, cPMOPo->op_pmreplrootu.op_pmtargetoff);
1140 #else
1141                     GV *const target = cPMOPo->op_pmreplrootu.op_pmtargetgv;
1142                     ret = sv_newmortal();
1143                     sv_setiv(newSVrv(ret, target ?
1144                                      svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1145                              PTR2IV(target));
1146 #endif
1147                 }
1148                 else {
1149                     OP *const root = cPMOPo->op_pmreplrootu.op_pmreplroot;
1150                     ret = make_op_object(aTHX_ root);
1151                 }
1152                 break;
1153 #ifdef USE_ITHREADS
1154             case 35: /* B::PMOP::pmstashpv */
1155                 ret = sv_2mortal(newSVpv(PmopSTASHPV(cPMOPo),0));
1156                 break;
1157 #else
1158             case 36: /* B::PMOP::pmstash */
1159                 ret = make_sv_object(aTHX_ (SV *) PmopSTASH(cPMOPo));
1160                 break;
1161 #endif
1162             case 37: /* B::PMOP::precomp */
1163             case 38: /* B::PMOP::reflags */
1164                 {
1165                     REGEXP *rx = PM_GETRE(cPMOPo);
1166                     ret = sv_newmortal();
1167                     if (rx) {
1168                         if (ix==38) {
1169                             sv_setuv(ret, RX_EXTFLAGS(rx));
1170                         }
1171                         else {
1172                             sv_setpvn(ret, RX_PRECOMP(rx), RX_PRELEN(rx));
1173                             if (RX_UTF8(rx))
1174                                 SvUTF8_on(ret);
1175                         }
1176                     }
1177                 }
1178                 break;
1179             case 39: /* B::PADOP::sv */
1180             case 40: /* B::PADOP::gv */
1181                 /* PADOPs should only be created on threaded builds.
1182                  * They don't have an sv or gv field, just an op_padix
1183                  * field. Leave it to the caller to retrieve padix
1184                  * and look up th value in the pad. Don't do it here,
1185                  * becuase PL_curpad is the pad of the caller, not the
1186                  * pad of the sub the op is part of */
1187                 ret = make_sv_object(aTHX_ NULL);
1188                 break;
1189             case 41: /* B::PVOP::pv */
1190                 /* OP_TRANS uses op_pv to point to a table of 256 or >=258
1191                  * shorts whereas other PVOPs point to a null terminated
1192                  * string.  */
1193                 if (    (cPVOPo->op_type == OP_TRANS
1194                         || cPVOPo->op_type == OP_TRANSR) &&
1195                         (cPVOPo->op_private & OPpTRANS_COMPLEMENT) &&
1196                         !(cPVOPo->op_private & OPpTRANS_DELETE))
1197                 {
1198                     const short* const tbl = (short*)cPVOPo->op_pv;
1199                     const short entries = 257 + tbl[256];
1200                     ret = newSVpvn_flags(cPVOPo->op_pv, entries * sizeof(short), SVs_TEMP);
1201                 }
1202                 else if (cPVOPo->op_type == OP_TRANS || cPVOPo->op_type == OP_TRANSR) {
1203                     ret = newSVpvn_flags(cPVOPo->op_pv, 256 * sizeof(short), SVs_TEMP);
1204                 }
1205                 else
1206                     ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP);
1207                 break;
1208             case 42: /* B::COP::label */
1209                 ret = sv_2mortal(newSVpv(CopLABEL(cCOPo),0));
1210                 break;
1211             case 43: /* B::COP::arybase */
1212                 ret = sv_2mortal(newSVuv(0));
1213                 break;
1214             case 44: /* B::COP::warnings */
1215                 ret = make_warnings_object(aTHX_ cCOPo);
1216                 break;
1217             case 45: /* B::COP::io */
1218                 ret = make_cop_io_object(aTHX_ cCOPo);
1219                 break;
1220             case 46: /* B::COP::hints_hash */
1221                 ret = sv_newmortal();
1222                 sv_setiv(newSVrv(ret, "B::RHE"),
1223                         PTR2IV(CopHINTHASH_get(cCOPo)));
1224                 break;
1225             case 52: /* B::OP::parent */
1226                 ret = make_op_object(aTHX_ op_parent(o));
1227                 break;
1228             case 53: /* B::METHOP::first   */
1229                 /* METHOP struct has an op_first/op_meth_sv union
1230                  * as its first extra field. How to interpret the
1231                  * union depends on the op type. For the purposes of
1232                  * B, we treat it as a struct with both fields present,
1233                  * where one of the fields always happens to be null
1234                  * (i.e. we return NULL in preference to croaking with
1235                  * 'method not implemented').
1236                  */
1237                 ret = make_op_object(aTHX_
1238                             o->op_type == OP_METHOD
1239                                 ? cMETHOPx(o)->op_u.op_first : NULL);
1240                 break;
1241             case 54: /* B::METHOP::meth_sv */
1242                 /* see comment above about METHOP */
1243                 ret = make_sv_object(aTHX_
1244                             o->op_type == OP_METHOD
1245                                 ? NULL : cMETHOPx(o)->op_u.op_meth_sv);
1246                 break;
1247             default:
1248                 croak("method %s not implemented", op_methods[ix].name);
1249         } else {
1250             /* do a direct structure offset lookup */
1251             const char *const ptr = (char *)o + op_methods[ix].offset;
1252             switch (op_methods[ix].type) {
1253             case OPp:
1254                 ret = make_op_object(aTHX_ *((OP **)ptr));
1255                 break;
1256             case PADOFFSETp:
1257                 ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
1258                 break;
1259             case U8p:
1260                 ret = sv_2mortal(newSVuv(*((U8*)ptr)));
1261                 break;
1262             case U32p:
1263                 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1264                 break;
1265             case SVp:
1266                 ret = make_sv_object(aTHX_ *((SV **)ptr));
1267                 break;
1268             case line_tp:
1269                 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1270                 break;
1271             case IVp:
1272                 ret = sv_2mortal(newSViv(*((IV*)ptr)));
1273                 break;
1274             case char_pp:
1275                 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1276                 break;
1277             default:
1278                 croak("Illegal type 0x%x for B::*OP::%s",
1279                       (unsigned)op_methods[ix].type, op_methods[ix].name);
1280             }
1281         }
1282         ST(0) = ret;
1283         XSRETURN(1);
1284
1285
1286 void
1287 oplist(o)
1288         B::OP           o
1289     PPCODE:
1290         SP = oplist(aTHX_ o, SP);
1291
1292
1293 MODULE = B      PACKAGE = B::SV
1294
1295 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1296
1297 U32
1298 REFCNT(sv)
1299         B::SV   sv
1300     ALIAS:
1301         FLAGS = 0xFFFFFFFF
1302         SvTYPE = SVTYPEMASK
1303         POK = SVf_POK
1304         ROK = SVf_ROK
1305         MAGICAL = MAGICAL_FLAG_BITS
1306     CODE:
1307         RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1308     OUTPUT:
1309         RETVAL
1310
1311 void
1312 object_2svref(sv)
1313         B::SV   sv
1314     PPCODE:
1315         ST(0) = sv_2mortal(newRV(sv));
1316         XSRETURN(1);
1317
1318 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1319
1320 IV
1321 SvIV(sv)
1322         B::IV   sv
1323
1324 MODULE = B      PACKAGE = B::IV
1325
1326 #define sv_SVp          0x00000
1327 #define sv_IVp          0x10000
1328 #define sv_UVp          0x20000
1329 #define sv_STRLENp      0x30000
1330 #define sv_U32p         0x40000
1331 #define sv_U8p          0x50000
1332 #define sv_char_pp      0x60000
1333 #define sv_NVp          0x70000
1334 #define sv_char_p       0x80000
1335 #define sv_SSize_tp     0x90000
1336 #define sv_I32p         0xA0000
1337 #define sv_U16p         0xB0000
1338
1339 #define IV_ivx_ix       sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_iv)
1340 #define IV_uvx_ix       sv_UVp | STRUCT_OFFSET(struct xpvuv, xuv_uv)
1341 #define NV_nvx_ix       sv_NVp | STRUCT_OFFSET(struct xpvnv, xnv_u.xnv_nv)
1342
1343 #define NV_cop_seq_range_low_ix \
1344                         sv_U32p | STRUCT_OFFSET(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1345 #define NV_cop_seq_range_high_ix \
1346                         sv_U32p | STRUCT_OFFSET(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1347 #define NV_parent_pad_index_ix \
1348                         sv_U32p | STRUCT_OFFSET(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1349 #define NV_parent_fakelex_flags_ix \
1350                         sv_U32p | STRUCT_OFFSET(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1351
1352 #define PV_cur_ix       sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_cur)
1353 #define PV_len_ix       sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_len)
1354
1355 #define PVMG_stash_ix   sv_SVp | STRUCT_OFFSET(struct xpvmg, xmg_stash)
1356
1357 #if PERL_VERSION > 18
1358 #    define PVBM_useful_ix      sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_u.xivu_iv)
1359 #elif PERL_VERSION > 14
1360 #    define PVBM_useful_ix      sv_I32p | STRUCT_OFFSET(struct xpvgv, xnv_u.xbm_s.xbm_useful)
1361 #else
1362 #define PVBM_useful_ix  sv_I32p | STRUCT_OFFSET(struct xpvgv, xiv_u.xivu_i32)
1363 #endif
1364
1365 #define PVLV_targoff_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targoff)
1366 #define PVLV_targlen_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targlen)
1367 #define PVLV_targ_ix    sv_SVp | STRUCT_OFFSET(struct xpvlv, xlv_targ)
1368 #define PVLV_type_ix    sv_char_p | STRUCT_OFFSET(struct xpvlv, xlv_type)
1369
1370 #define PVGV_stash_ix   sv_SVp | STRUCT_OFFSET(struct xpvgv, xnv_u.xgv_stash)
1371 #define PVGV_flags_ix   sv_STRLENp | STRUCT_OFFSET(struct xpvgv, xpv_cur)
1372 #define PVIO_lines_ix   sv_IVp | STRUCT_OFFSET(struct xpvio, xiv_iv)
1373
1374 #define PVIO_page_ix        sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page)
1375 #define PVIO_page_len_ix    sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page_len)
1376 #define PVIO_lines_left_ix  sv_IVp | STRUCT_OFFSET(struct xpvio, xio_lines_left)
1377 #define PVIO_top_name_ix    sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_top_name)
1378 #define PVIO_top_gv_ix      sv_SVp | STRUCT_OFFSET(struct xpvio, xio_top_gv)
1379 #define PVIO_fmt_name_ix    sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_fmt_name)
1380 #define PVIO_fmt_gv_ix      sv_SVp | STRUCT_OFFSET(struct xpvio, xio_fmt_gv)
1381 #define PVIO_bottom_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_bottom_name)
1382 #define PVIO_bottom_gv_ix   sv_SVp | STRUCT_OFFSET(struct xpvio, xio_bottom_gv)
1383 #define PVIO_type_ix        sv_char_p | STRUCT_OFFSET(struct xpvio, xio_type)
1384 #define PVIO_flags_ix       sv_U8p | STRUCT_OFFSET(struct xpvio, xio_flags)
1385
1386 #define PVAV_max_ix     sv_SSize_tp | STRUCT_OFFSET(struct xpvav, xav_max)
1387
1388 #define PVCV_stash_ix   sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_stash)
1389 #if PERL_VERSION > 17 || (PERL_VERSION == 17 && PERL_SUBVERSION >= 3)
1390 # define PVCV_gv_ix     sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv_u.xcv_gv)
1391 #else
1392 # define PVCV_gv_ix     sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv)
1393 #endif
1394 #define PVCV_file_ix    sv_char_pp | STRUCT_OFFSET(struct xpvcv, xcv_file)
1395 #define PVCV_outside_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_outside)
1396 #define PVCV_outside_seq_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_outside_seq)
1397 #define PVCV_flags_ix   sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_flags)
1398
1399 #define PVHV_max_ix     sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_max)
1400
1401 #if PERL_VERSION > 12
1402 #define PVHV_keys_ix    sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_keys)
1403 #else
1404 #define PVHV_keys_ix    sv_IVp | STRUCT_OFFSET(struct xpvhv, xhv_keys)
1405 #endif
1406
1407 # The type checking code in B has always been identical for all SV types,
1408 # irrespective of whether the action is actually defined on that SV.
1409 # We should fix this
1410 void
1411 IVX(sv)
1412         B::SV           sv
1413     ALIAS:
1414         B::IV::IVX = IV_ivx_ix
1415         B::IV::UVX = IV_uvx_ix
1416         B::NV::NVX = NV_nvx_ix
1417         B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1418         B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1419         B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1420         B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
1421         B::PV::CUR = PV_cur_ix
1422         B::PV::LEN = PV_len_ix
1423         B::PVMG::SvSTASH = PVMG_stash_ix
1424         B::PVLV::TARGOFF = PVLV_targoff_ix
1425         B::PVLV::TARGLEN = PVLV_targlen_ix
1426         B::PVLV::TARG = PVLV_targ_ix
1427         B::PVLV::TYPE = PVLV_type_ix
1428         B::GV::STASH = PVGV_stash_ix
1429         B::GV::GvFLAGS = PVGV_flags_ix
1430         B::BM::USEFUL = PVBM_useful_ix
1431         B::IO::LINES =  PVIO_lines_ix
1432         B::IO::PAGE = PVIO_page_ix
1433         B::IO::PAGE_LEN = PVIO_page_len_ix
1434         B::IO::LINES_LEFT = PVIO_lines_left_ix
1435         B::IO::TOP_NAME = PVIO_top_name_ix
1436         B::IO::TOP_GV = PVIO_top_gv_ix
1437         B::IO::FMT_NAME = PVIO_fmt_name_ix
1438         B::IO::FMT_GV = PVIO_fmt_gv_ix
1439         B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1440         B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1441         B::IO::IoTYPE = PVIO_type_ix
1442         B::IO::IoFLAGS = PVIO_flags_ix
1443         B::AV::MAX = PVAV_max_ix
1444         B::CV::STASH = PVCV_stash_ix
1445         B::CV::FILE = PVCV_file_ix
1446         B::CV::OUTSIDE = PVCV_outside_ix
1447         B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1448         B::CV::CvFLAGS = PVCV_flags_ix
1449         B::HV::MAX = PVHV_max_ix
1450         B::HV::KEYS = PVHV_keys_ix
1451     PREINIT:
1452         char *ptr;
1453         SV *ret;
1454     PPCODE:
1455         ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1456         switch ((U8)(ix >> 16)) {
1457         case (U8)(sv_SVp >> 16):
1458             ret = make_sv_object(aTHX_ *((SV **)ptr));
1459             break;
1460         case (U8)(sv_IVp >> 16):
1461             ret = sv_2mortal(newSViv(*((IV *)ptr)));
1462             break;
1463         case (U8)(sv_UVp >> 16):
1464             ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1465             break;
1466         case (U8)(sv_STRLENp >> 16):
1467             ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1468             break;
1469         case (U8)(sv_U32p >> 16):
1470             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1471             break;
1472         case (U8)(sv_U8p >> 16):
1473             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1474             break;
1475         case (U8)(sv_char_pp >> 16):
1476             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1477             break;
1478         case (U8)(sv_NVp >> 16):
1479             ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1480             break;
1481         case (U8)(sv_char_p >> 16):
1482             ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1483             break;
1484         case (U8)(sv_SSize_tp >> 16):
1485             ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1486             break;
1487         case (U8)(sv_I32p >> 16):
1488             ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1489             break;
1490         case (U8)(sv_U16p >> 16):
1491             ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1492             break;
1493         default:
1494             croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
1495         }
1496         ST(0) = ret;
1497         XSRETURN(1);
1498
1499 void
1500 packiv(sv)
1501         B::IV   sv
1502     ALIAS:
1503         needs64bits = 1
1504     CODE:
1505         if (ix) {
1506             ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1507         } else if (sizeof(IV) == 8) {
1508             U32 wp[2];
1509             const IV iv = SvIVX(sv);
1510             /*
1511              * The following way of spelling 32 is to stop compilers on
1512              * 32-bit architectures from moaning about the shift count
1513              * being >= the width of the type. Such architectures don't
1514              * reach this code anyway (unless sizeof(IV) > 8 but then
1515              * everything else breaks too so I'm not fussed at the moment).
1516              */
1517 #ifdef UV_IS_QUAD
1518             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1519 #else
1520             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1521 #endif
1522             wp[1] = htonl(iv & 0xffffffff);
1523             ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1524         } else {
1525             U32 w = htonl((U32)SvIVX(sv));
1526             ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1527         }
1528
1529 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1530
1531 NV
1532 SvNV(sv)
1533         B::NV   sv
1534
1535 #if PERL_VERSION < 11
1536
1537 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1538
1539 void
1540 SvRV(sv)
1541         B::RV   sv
1542     PPCODE:
1543         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1544
1545 #else
1546
1547 MODULE = B      PACKAGE = B::REGEXP
1548
1549 void
1550 REGEX(sv)
1551         B::REGEXP       sv
1552     ALIAS:
1553         precomp = 1
1554         qr_anoncv = 2
1555     PPCODE:
1556         if (ix == 1) {
1557             PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1558         } else if (ix) {
1559             PUSHs(make_sv_object(aTHX_ (SV *)ReANY(sv)->qr_anoncv));
1560         } else {
1561             dXSTARG;
1562             /* FIXME - can we code this method more efficiently?  */
1563             PUSHi(PTR2IV(sv));
1564         }
1565
1566 #endif
1567
1568 MODULE = B      PACKAGE = B::PV
1569
1570 void
1571 RV(sv)
1572         B::PV   sv
1573     PPCODE:
1574         if (!SvROK(sv))
1575             croak( "argument is not SvROK" );
1576         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1577
1578 void
1579 PV(sv)
1580         B::PV   sv
1581     ALIAS:
1582         PVX = 1
1583         PVBM = 2
1584         B::BM::TABLE = 3
1585     PREINIT:
1586         const char *p;
1587         STRLEN len = 0;
1588         U32 utf8 = 0;
1589     CODE:
1590         if (ix == 3) {
1591 #ifndef PERL_FBM_TABLE_OFFSET
1592             const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm);
1593
1594             if (!mg)
1595                 croak("argument to B::BM::TABLE is not a PVBM");
1596             p = mg->mg_ptr;
1597             len = mg->mg_len;
1598 #else
1599             p = SvPV(sv, len);
1600             /* Boyer-Moore table is just after string and its safety-margin \0 */
1601             p += len + PERL_FBM_TABLE_OFFSET;
1602             len = 256;
1603 #endif
1604         } else if (ix == 2) {
1605             /* This used to read 257. I think that that was buggy - should have
1606                been 258. (The "\0", the flags byte, and 256 for the table.)
1607                The only user of this method is B::Bytecode in B::PV::bsave.
1608                I'm guessing that nothing tested the runtime correctness of
1609                output of bytecompiled string constant arguments to index (etc).
1610
1611                Note the start pointer is and has always been SvPVX(sv), not
1612                SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1613                first used by the compiler in 651aa52ea1faa806. It's used to
1614                get a "complete" dump of the buffer at SvPVX(), not just the
1615                PVBM table. This permits the generated bytecode to "load"
1616                SvPVX in "one" hit.
1617
1618                5.15 and later store the BM table via MAGIC, so the compiler
1619                should handle this just fine without changes if PVBM now
1620                always returns the SvPVX() buffer.  */
1621 #ifdef isREGEXP
1622             p = isREGEXP(sv)
1623                  ? RX_WRAPPED_const((REGEXP*)sv)
1624                  : SvPVX_const(sv);
1625 #else
1626             p = SvPVX_const(sv);
1627 #endif
1628 #ifdef PERL_FBM_TABLE_OFFSET
1629             len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1630 #else
1631             len = SvCUR(sv);
1632 #endif
1633         } else if (ix) {
1634 #ifdef isREGEXP
1635             p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv);
1636 #else
1637             p = SvPVX(sv);
1638 #endif
1639             len = strlen(p);
1640         } else if (SvPOK(sv)) {
1641             len = SvCUR(sv);
1642             p = SvPVX_const(sv);
1643             utf8 = SvUTF8(sv);
1644         }
1645 #ifdef isREGEXP
1646         else if (isREGEXP(sv)) {
1647             len = SvCUR(sv);
1648             p = RX_WRAPPED_const((REGEXP*)sv);
1649             utf8 = SvUTF8(sv);
1650         }
1651 #endif
1652         else {
1653             /* XXX for backward compatibility, but should fail */
1654             /* croak( "argument is not SvPOK" ); */
1655             p = NULL;
1656         }
1657         ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
1658
1659 MODULE = B      PACKAGE = B::PVMG
1660
1661 void
1662 MAGIC(sv)
1663         B::PVMG sv
1664         MAGIC * mg = NO_INIT
1665     PPCODE:
1666         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1667             XPUSHs(make_mg_object(aTHX_ mg));
1668
1669 MODULE = B      PACKAGE = B::MAGIC
1670
1671 void
1672 MOREMAGIC(mg)
1673         B::MAGIC        mg
1674     ALIAS:
1675         PRIVATE = 1
1676         TYPE = 2
1677         FLAGS = 3
1678         LENGTH = 4
1679         OBJ = 5
1680         PTR = 6
1681         REGEX = 7
1682         precomp = 8
1683     PPCODE:
1684         switch (ix) {
1685         case 0:
1686             XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1687                                     : &PL_sv_undef);
1688             break;
1689         case 1:
1690             mPUSHu(mg->mg_private);
1691             break;
1692         case 2:
1693             PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1694             break;
1695         case 3:
1696             mPUSHu(mg->mg_flags);
1697             break;
1698         case 4:
1699             mPUSHi(mg->mg_len);
1700             break;
1701         case 5:
1702             PUSHs(make_sv_object(aTHX_ mg->mg_obj));
1703             break;
1704         case 6:
1705             if (mg->mg_ptr) {
1706                 if (mg->mg_len >= 0) {
1707                     PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
1708                 } else if (mg->mg_len == HEf_SVKEY) {
1709                     PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
1710                 } else
1711                     PUSHs(sv_newmortal());
1712             } else
1713                 PUSHs(sv_newmortal());
1714             break;
1715         case 7:
1716             if(mg->mg_type == PERL_MAGIC_qr) {
1717                 mPUSHi(PTR2IV(mg->mg_obj));
1718             } else {
1719                 croak("REGEX is only meaningful on r-magic");
1720             }
1721             break;
1722         case 8:
1723             if (mg->mg_type == PERL_MAGIC_qr) {
1724                 REGEXP *rx = (REGEXP *)mg->mg_obj;
1725                 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1726                                      rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
1727             } else {
1728                 croak( "precomp is only meaningful on r-magic" );
1729             }
1730             break;
1731         }
1732
1733 MODULE = B      PACKAGE = B::BM         PREFIX = Bm
1734
1735 U32
1736 BmPREVIOUS(sv)
1737         B::BM   sv
1738     CODE:
1739 #if PERL_VERSION >= 19
1740         PERL_UNUSED_VAR(sv);
1741 #endif
1742         RETVAL = BmPREVIOUS(sv);
1743     OUTPUT:
1744         RETVAL
1745
1746
1747 U8
1748 BmRARE(sv)
1749         B::BM   sv
1750     CODE:
1751 #if PERL_VERSION >= 19
1752         PERL_UNUSED_VAR(sv);
1753 #endif
1754         RETVAL = BmRARE(sv);
1755     OUTPUT:
1756         RETVAL
1757
1758
1759 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1760
1761 void
1762 GvNAME(gv)
1763         B::GV   gv
1764     ALIAS:
1765         FILE = 1
1766         B::HV::NAME = 2
1767     CODE:
1768         ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1769                                         : (ix == 1 ? GvFILE_HEK(gv)
1770                                                    : HvNAME_HEK((HV *)gv))));
1771
1772 bool
1773 is_empty(gv)
1774         B::GV   gv
1775     ALIAS:
1776         isGV_with_GP = 1
1777     CODE:
1778         if (ix) {
1779             RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1780         } else {
1781             RETVAL = GvGP(gv) == Null(GP*);
1782         }
1783     OUTPUT:
1784         RETVAL
1785
1786 void*
1787 GvGP(gv)
1788         B::GV   gv
1789
1790 #define GP_sv_ix        (SVp << 16) | STRUCT_OFFSET(struct gp, gp_sv)
1791 #define GP_io_ix        (SVp << 16) | STRUCT_OFFSET(struct gp, gp_io)
1792 #define GP_cv_ix        (SVp << 16) | STRUCT_OFFSET(struct gp, gp_cv)
1793 #define GP_cvgen_ix     (U32p << 16) | STRUCT_OFFSET(struct gp, gp_cvgen)
1794 #define GP_refcnt_ix    (U32p << 16) | STRUCT_OFFSET(struct gp, gp_refcnt)
1795 #define GP_hv_ix        (SVp << 16) | STRUCT_OFFSET(struct gp, gp_hv)
1796 #define GP_av_ix        (SVp << 16) | STRUCT_OFFSET(struct gp, gp_av)
1797 #define GP_form_ix      (SVp << 16) | STRUCT_OFFSET(struct gp, gp_form)
1798 #define GP_egv_ix       (SVp << 16) | STRUCT_OFFSET(struct gp, gp_egv)
1799
1800 void
1801 SV(gv)
1802         B::GV   gv
1803     ALIAS:
1804         SV = GP_sv_ix
1805         IO = GP_io_ix
1806         CV = GP_cv_ix
1807         CVGEN = GP_cvgen_ix
1808         GvREFCNT = GP_refcnt_ix
1809         HV = GP_hv_ix
1810         AV = GP_av_ix
1811         FORM = GP_form_ix
1812         EGV = GP_egv_ix
1813     PREINIT:
1814         GP *gp;
1815         char *ptr;
1816         SV *ret;
1817     PPCODE:
1818         gp = GvGP(gv);
1819         if (!gp) {
1820             const GV *const gv = CvGV(cv);
1821             Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1822         }
1823         ptr = (ix & 0xFFFF) + (char *)gp;
1824         switch ((U8)(ix >> 16)) {
1825         case SVp:
1826             ret = make_sv_object(aTHX_ *((SV **)ptr));
1827             break;
1828         case U32p:
1829             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1830             break;
1831         default:
1832             croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
1833         }
1834         ST(0) = ret;
1835         XSRETURN(1);
1836
1837 U32
1838 GvLINE(gv)
1839         B::GV   gv
1840
1841 U32
1842 GvGPFLAGS(gv)
1843         B::GV   gv
1844
1845 void
1846 FILEGV(gv)
1847         B::GV   gv
1848     PPCODE:
1849         PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
1850
1851 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1852
1853
1854 bool
1855 IsSTD(io,name)
1856         B::IO   io
1857         const char*     name
1858     PREINIT:
1859         PerlIO* handle = 0;
1860     CODE:
1861         if( strEQ( name, "stdin" ) ) {
1862             handle = PerlIO_stdin();
1863         }
1864         else if( strEQ( name, "stdout" ) ) {
1865             handle = PerlIO_stdout();
1866         }
1867         else if( strEQ( name, "stderr" ) ) {
1868             handle = PerlIO_stderr();
1869         }
1870         else {
1871             croak( "Invalid value '%s'", name );
1872         }
1873         RETVAL = handle == IoIFP(io);
1874     OUTPUT:
1875         RETVAL
1876
1877 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1878
1879 SSize_t
1880 AvFILL(av)
1881         B::AV   av
1882
1883 void
1884 AvARRAY(av)
1885         B::AV   av
1886     PPCODE:
1887         if (AvFILL(av) >= 0) {
1888             SV **svp = AvARRAY(av);
1889             I32 i;
1890             for (i = 0; i <= AvFILL(av); i++)
1891                 XPUSHs(make_sv_object(aTHX_ svp[i]));
1892         }
1893
1894 void
1895 AvARRAYelt(av, idx)
1896         B::AV   av
1897         int     idx
1898     PPCODE:
1899         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1900             XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
1901         else
1902             XPUSHs(make_sv_object(aTHX_ NULL));
1903
1904
1905 MODULE = B      PACKAGE = B::FM         PREFIX = Fm
1906
1907 IV
1908 FmLINES(format)
1909         B::FM   format
1910     CODE:
1911         PERL_UNUSED_VAR(format);
1912        RETVAL = 0;
1913     OUTPUT:
1914         RETVAL
1915
1916
1917 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1918
1919 U32
1920 CvCONST(cv)
1921         B::CV   cv
1922
1923 void
1924 CvSTART(cv)
1925         B::CV   cv
1926     ALIAS:
1927         ROOT = 1
1928     PPCODE:
1929         PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1930                              : ix ? CvROOT(cv) : CvSTART(cv)));
1931
1932 I32
1933 CvDEPTH(cv)
1934         B::CV   cv
1935
1936 #ifdef PadlistARRAY
1937
1938 B::PADLIST
1939 CvPADLIST(cv)
1940         B::CV   cv
1941     CODE:
1942         RETVAL = CvISXSUB(cv) ? NULL : CvPADLIST(cv);
1943     OUTPUT:
1944         RETVAL
1945
1946 #else
1947
1948 B::AV
1949 CvPADLIST(cv)
1950         B::CV   cv
1951     PPCODE:
1952         PUSHs(make_sv_object(aTHX_ (SV *)CvPADLIST(cv)));
1953
1954
1955 #endif
1956
1957 SV *
1958 CvHSCXT(cv)
1959         B::CV   cv
1960     CODE:
1961         RETVAL = newSVuv(CvISXSUB(cv) ? PTR2UV(CvHSCXT(cv)) : 0);
1962     OUTPUT:
1963         RETVAL
1964
1965 void
1966 CvXSUB(cv)
1967         B::CV   cv
1968     ALIAS:
1969         XSUBANY = 1
1970     CODE:
1971         ST(0) = ix && CvCONST(cv)
1972             ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
1973             : sv_2mortal(newSViv(CvISXSUB(cv)
1974                                  ? (ix ? CvXSUBANY(cv).any_iv
1975                                        : PTR2IV(CvXSUB(cv)))
1976                                  : 0));
1977
1978 void
1979 const_sv(cv)
1980         B::CV   cv
1981     PPCODE:
1982         PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
1983
1984 void
1985 GV(cv)
1986         B::CV cv
1987     CODE:
1988         ST(0) = make_sv_object(aTHX_ (SV*)CvGV(cv));
1989
1990 #if PERL_VERSION > 17
1991
1992 SV *
1993 NAME_HEK(cv)
1994         B::CV cv
1995     CODE:
1996         RETVAL = CvNAMED(cv) ? newSVhek(CvNAME_HEK(cv)) : &PL_sv_undef;
1997     OUTPUT:
1998         RETVAL
1999
2000 #endif
2001
2002 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
2003
2004 STRLEN
2005 HvFILL(hv)
2006         B::HV   hv
2007
2008 I32
2009 HvRITER(hv)
2010         B::HV   hv
2011
2012 void
2013 HvARRAY(hv)
2014         B::HV   hv
2015     PPCODE:
2016         if (HvUSEDKEYS(hv) > 0) {
2017             HE *he;
2018             (void)hv_iterinit(hv);
2019             EXTEND(sp, HvUSEDKEYS(hv) * 2);
2020             while ((he = hv_iternext(hv))) {
2021                 if (HeSVKEY(he)) {
2022                     mPUSHs(HeSVKEY(he));
2023                 } else if (HeKUTF8(he)) {
2024                     PUSHs(newSVpvn_flags(HeKEY(he), HeKLEN(he), SVf_UTF8|SVs_TEMP));
2025                 } else {
2026                     mPUSHp(HeKEY(he), HeKLEN(he));
2027                 }
2028                 PUSHs(make_sv_object(aTHX_ HeVAL(he)));
2029             }
2030         }
2031
2032 MODULE = B      PACKAGE = B::HE         PREFIX = He
2033
2034 void
2035 HeVAL(he)
2036         B::HE he
2037     ALIAS:
2038         SVKEY_force = 1
2039     PPCODE:
2040         PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
2041
2042 U32
2043 HeHASH(he)
2044         B::HE he
2045
2046 MODULE = B      PACKAGE = B::RHE
2047
2048 SV*
2049 HASH(h)
2050         B::RHE h
2051     CODE:
2052         RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
2053     OUTPUT:
2054         RETVAL
2055
2056
2057 #ifdef PadlistARRAY
2058
2059 MODULE = B      PACKAGE = B::PADLIST    PREFIX = Padlist
2060
2061 SSize_t
2062 PadlistMAX(padlist)
2063         B::PADLIST      padlist
2064     ALIAS: B::PADNAMELIST::MAX = 0
2065     CODE:
2066         PERL_UNUSED_VAR(ix);
2067         RETVAL = PadlistMAX(padlist);
2068     OUTPUT:
2069         RETVAL
2070
2071 B::PADNAMELIST
2072 PadlistNAMES(padlist)
2073         B::PADLIST      padlist
2074
2075 void
2076 PadlistARRAY(padlist)
2077         B::PADLIST      padlist
2078     PPCODE:
2079         if (PadlistMAX(padlist) >= 0) {
2080             dXSTARG;
2081             PAD **padp = PadlistARRAY(padlist);
2082             SSize_t i;
2083             sv_setiv(newSVrv(TARG, PadlistNAMES(padlist)
2084                                     ? "B::PADNAMELIST"
2085                                     : "B::NULL"),
2086                      PTR2IV(PadlistNAMES(padlist)));
2087             XPUSHTARG;
2088             for (i = 1; i <= PadlistMAX(padlist); i++)
2089                 XPUSHs(make_sv_object(aTHX_ (SV *)padp[i]));
2090         }
2091
2092 void
2093 PadlistARRAYelt(padlist, idx)
2094         B::PADLIST      padlist
2095         SSize_t         idx
2096     PPCODE:
2097         if (idx < 0 || idx > PadlistMAX(padlist))
2098             XPUSHs(make_sv_object(aTHX_ NULL));
2099         else if (!idx) {
2100             PL_stack_sp--;
2101             PUSHMARK(PL_stack_sp-1);
2102             XS_B__PADLIST_NAMES(aTHX_ cv);
2103             return;
2104         }
2105         else
2106             XPUSHs(make_sv_object(aTHX_
2107                                   (SV *)PadlistARRAY(padlist)[idx]));
2108
2109 U32
2110 PadlistREFCNT(padlist)
2111         B::PADLIST      padlist
2112     CODE:
2113         PERL_UNUSED_VAR(padlist);
2114         RETVAL = PadlistREFCNT(padlist);
2115     OUTPUT:
2116         RETVAL
2117
2118 #endif
2119
2120 MODULE = B      PACKAGE = B::PADNAMELIST        PREFIX = Padnamelist
2121
2122 void
2123 PadnamelistARRAY(pnl)
2124         B::PADNAMELIST  pnl
2125     PPCODE:
2126         if (PadnamelistMAX(pnl) >= 0) {
2127             PADNAME **padp = PadnamelistARRAY(pnl);
2128             SSize_t i = 0;
2129             for (; i <= PadnamelistMAX(pnl); i++)
2130                 XPUSHs(make_sv_object(aTHX_ padp[i]));
2131         }
2132
2133 void
2134 PadnamelistARRAYelt(pnl, idx)
2135         B::PADNAMELIST  pnl
2136         SSize_t         idx
2137     PPCODE:
2138         if (idx < 0 || idx > PadnamelistMAX(pnl))
2139             XPUSHs(make_sv_object(aTHX_ NULL));
2140         else
2141             XPUSHs(make_sv_object(aTHX_
2142                                   (SV *)PadnamelistARRAY(pnl)[idx]));
2143
2144 U32
2145 PadnamelistREFCNT(pnl)
2146         B::PADNAMELIST  pnl