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