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