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 >= 9
  25     "B::BIND",
  26 #endif
  27     "B::IV",
  28     "B::NV",
  29     "B::RV",
  30     "B::PV",
  31     "B::PVIV",
  32     "B::PVNV",
  33     "B::PVMG",
  34 #if PERL_VERSION <= 8
  35     "B::BM",
  36 #endif
  37 #if PERL_VERSION >= 9
  38     "B::GV",
  39 #endif
  40     "B::PVLV",
  41     "B::AV",
  42     "B::HV",
  43     "B::CV",
  44 #if PERL_VERSION <= 8
  45     "B::GV",
  46 #endif
  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 } opclass;
  65
  66 static const char* const opclassnames[] = {
  67     "B::NULL",
  68     "B::OP",
  69     "B::UNOP",
  70     "B::BINOP",
  71     "B::LOGOP",
  72     "B::LISTOP",
  73     "B::PMOP",
  74     "B::SVOP",
  75     "B::PADOP",
  76     "B::PVOP",
  77     "B::LOOP",
  78     "B::COP"
  79 };
  80
  81 static const size_t opsizes[] = {
  82     0,
  83     sizeof(OP),
  84     sizeof(UNOP),
  85     sizeof(BINOP),
  86     sizeof(LOGOP),
  87     sizeof(LISTOP),
  88     sizeof(PMOP),
  89     sizeof(SVOP),
  90     sizeof(PADOP),
  91     sizeof(PVOP),
  92     sizeof(LOOP),
  93     sizeof(COP)
  94 };
  95
  96 #define MY_CXT_KEY "B::_guts" XS_VERSION
  97
  98 typedef struct {
  99     int         x_walkoptree_debug;     /* Flag for walkoptree debug hook */
 100     SV *        x_specialsv_list[7];
 101 } my_cxt_t;
 102
 103 START_MY_CXT
 104
 105 #define walkoptree_debug        (MY_CXT.x_walkoptree_debug)
 106 #define specialsv_list          (MY_CXT.x_specialsv_list)
 107
 108 static opclass
 109 cc_opclass(pTHX_ const OP *o)
 110 {
 111     if (!o)
 112         return OPc_NULL;
 113
 114     if (o->op_type == 0)
 115         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 116
 117     if (o->op_type == OP_SASSIGN)
 118         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 119
 120     if (o->op_type == OP_AELEMFAST) {
 121         if (o->op_flags & OPf_SPECIAL)
 122             return OPc_BASEOP;
 123         else
 124 #ifdef USE_ITHREADS
 125             return OPc_PADOP;
 126 #else
 127             return OPc_SVOP;
 128 #endif
 129     }
 130
 131 #ifdef USE_ITHREADS
 132     if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
 133         o->op_type == OP_RCATLINE)
 134         return OPc_PADOP;
 135 #endif
 136
 137     switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 138     case OA_BASEOP:
 139         return OPc_BASEOP;
 140
 141     case OA_UNOP:
 142         return OPc_UNOP;
 143
 144     case OA_BINOP:
 145         return OPc_BINOP;
 146
 147     case OA_LOGOP:
 148         return OPc_LOGOP;
 149
 150     case OA_LISTOP:
 151         return OPc_LISTOP;
 152
 153     case OA_PMOP:
 154         return OPc_PMOP;
 155
 156     case OA_SVOP:
 157         return OPc_SVOP;
 158
 159     case OA_PADOP:
 160         return OPc_PADOP;
 161
 162     case OA_PVOP_OR_SVOP:
 163         /*
 164          * Character translations (tr///) are usually a PVOP, keeping a
 165          * pointer to a table of shorts used to look up translations.
 166          * Under utf8, however, a simple table isn't practical; instead,
 167          * the OP is an SVOP, and the SV is a reference to a swash
 168          * (i.e., an RV pointing to an HV).
 169          */
 170         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 171                 ? OPc_SVOP : OPc_PVOP;
 172
 173     case OA_LOOP:
 174         return OPc_LOOP;
 175
 176     case OA_COP:
 177         return OPc_COP;
 178
 179     case OA_BASEOP_OR_UNOP:
 180         /*
 181          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 182          * whether parens were seen. perly.y uses OPf_SPECIAL to
 183          * signal whether a BASEOP had empty parens or none.
 184          * Some other UNOPs are created later, though, so the best
 185          * test is OPf_KIDS, which is set in newUNOP.
 186          */
 187         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 188
 189     case OA_FILESTATOP:
 190         /*
 191          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 192          * the OPf_REF flag to distinguish between OP types instead of the
 193          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 194          * return OPc_UNOP so that walkoptree can find our children. If
 195          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 196          * (no argument to the operator) it's an OP; with OPf_REF set it's
 197          * an SVOP (and op_sv is the GV for the filehandle argument).
 198          */
 199         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 200 #ifdef USE_ITHREADS
 201                 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 202 #else
 203                 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 204 #endif
 205     case OA_LOOPEXOP:
 206         /*
 207          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 208          * label was omitted (in which case it's a BASEOP) or else a term was
 209          * seen. In this last case, all except goto are definitely PVOP but
 210          * goto is either a PVOP (with an ordinary constant label), an UNOP
 211          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 212          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 213          * get set.
 214          */
 215         if (o->op_flags & OPf_STACKED)
 216             return OPc_UNOP;
 217         else if (o->op_flags & OPf_SPECIAL)
 218             return OPc_BASEOP;
 219         else
 220             return OPc_PVOP;
 221     }
 222     warn("can't determine class of operator %s, assuming BASEOP\n",
 223          PL_op_name[o->op_type]);
 224     return OPc_BASEOP;
 225 }
 226
 227 static char *
 228 cc_opclassname(pTHX_ const OP *o)
 229 {
 230     return (char *)opclassnames[cc_opclass(aTHX_ o)];
 231 }
 232
 233 static SV *
 234 make_sv_object(pTHX_ SV *arg, SV *sv)
 235 {
 236     const char *type = 0;
 237     IV iv;
 238     dMY_CXT;
 239
 240     for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
 241         if (sv == specialsv_list[iv]) {
 242             type = "B::SPECIAL";
 243             break;
 244         }
 245     }
 246     if (!type) {
 247         type = svclassnames[SvTYPE(sv)];
 248         iv = PTR2IV(sv);
 249     }
 250     sv_setiv(newSVrv(arg, type), iv);
 251     return arg;
 252 }
 253
 254 static SV *
 255 make_temp_object(pTHX_ SV *arg, SV *temp)
 256 {
 257     SV *target;
 258     const char *const type = svclassnames[SvTYPE(temp)];
 259     const IV iv = PTR2IV(temp);
 260
 261     target = newSVrv(arg, type);
 262     sv_setiv(target, iv);
 263
 264     /* Need to keep our "temp" around as long as the target exists.
 265        Simplest way seems to be to hang it from magic, and let that clear
 266        it up.  No vtable, so won't actually get in the way of anything.  */
 267     sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
 268     /* magic object has had its reference count increased, so we must drop
 269        our reference.  */
 270     SvREFCNT_dec(temp);
 271     return arg;
 272 }
 273
 274 static SV *
 275 make_warnings_object(pTHX_ SV *arg, STRLEN *warnings)
 276 {
 277     const char *type = 0;
 278     dMY_CXT;
 279     IV iv = sizeof(specialsv_list)/sizeof(SV*);
 280
 281     /* Counting down is deliberate. Before the split between make_sv_object
 282        and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
 283        were both 0, so you could never get a B::SPECIAL for pWARN_STD  */
 284
 285     while (iv--) {
 286         if ((SV*)warnings == specialsv_list[iv]) {
 287             type = "B::SPECIAL";
 288             break;
 289         }
 290     }
 291     if (type) {
 292         sv_setiv(newSVrv(arg, type), iv);
 293         return arg;
 294     } else {
 295         /* B assumes that warnings are a regular SV. Seems easier to keep it
 296            happy by making them into a regular SV.  */
 297         return make_temp_object(aTHX_ arg,
 298                                 newSVpvn((char *)(warnings + 1), *warnings));
 299     }
 300 }
 301
 302 static SV *
 303 make_cop_io_object(pTHX_ SV *arg, COP *cop)
 304 {
 305     if (CopHINTS_get(cop) & HINT_LEXICAL_IO) {
 306         /* I feel you should be able to simply SvREFCNT_inc the return value
 307            from this, but if you do (and restore the line
 308            my $ioix = $cop->io->ix;
 309            in B::COP::bsave in Bytecode.pm, then you get errors about
 310            "attempt to free temp prematurely ... during global destruction.
 311            The SV's flags are consistent with the error, but quite how the
 312            temp escaped from the save stack is not clear.  */
 313         SV *value = Perl_refcounted_he_fetch(aTHX_ cop->cop_hints_hash,
 314                                              0, "open", 4, 0, 0);
 315         return make_temp_object(aTHX_ arg, newSVsv(value));
 316     } else {
 317         return make_sv_object(aTHX_ arg, NULL);
 318     }
 319 }
 320
 321 static SV *
 322 make_mg_object(pTHX_ SV *arg, MAGIC *mg)
 323 {
 324     sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
 325     return arg;
 326 }
 327
 328 static SV *
 329 cstring(pTHX_ SV *sv, bool perlstyle)
 330 {
 331     SV *sstr = newSVpvn("", 0);
 332
 333     if (!SvOK(sv))
 334         sv_setpvn(sstr, "0", 1);
 335     else if (perlstyle && SvUTF8(sv)) {
 336         SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
 337         const STRLEN len = SvCUR(sv);
 338         const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
 339         sv_setpvn(sstr,"\"",1);
 340         while (*s)
 341         {
 342             if (*s == '"')
 343                 sv_catpvn(sstr, "\\\"", 2);
 344             else if (*s == '$')
 345                 sv_catpvn(sstr, "\\$", 2);
 346             else if (*s == '@')
 347                 sv_catpvn(sstr, "\\@", 2);
 348             else if (*s == '\\')
 349             {
 350                 if (strchr("nrftax\\",*(s+1)))
 351                     sv_catpvn(sstr, s++, 2);
 352                 else
 353                     sv_catpvn(sstr, "\\\\", 2);
 354             }
 355             else /* should always be printable */
 356                 sv_catpvn(sstr, s, 1);
 357             ++s;
 358         }
 359         sv_catpv(sstr, "\"");
 360         return sstr;
 361     }
 362     else
 363     {
 364         /* XXX Optimise? */
 365         STRLEN len;
 366         const char *s = SvPV(sv, len);
 367         sv_catpv(sstr, "\"");
 368         for (; len; len--, s++)
 369         {
 370             /* At least try a little for readability */
 371             if (*s == '"')
 372                 sv_catpv(sstr, "\\\"");
 373             else if (*s == '\\')
 374                 sv_catpv(sstr, "\\\\");
 375             /* trigraphs - bleagh */
 376             else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
 377                 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
 378                 sprintf(escbuff, "\\%03o", '?');
 379                 sv_catpv(sstr, escbuff);
 380             }
 381             else if (perlstyle && *s == '$')
 382                 sv_catpv(sstr, "\\$");
 383             else if (perlstyle && *s == '@')
 384                 sv_catpv(sstr, "\\@");
 385 #ifdef EBCDIC
 386             else if (isPRINT(*s))
 387 #else
 388             else if (*s >= ' ' && *s < 127)
 389 #endif /* EBCDIC */
 390                 sv_catpvn(sstr, s, 1);
 391             else if (*s == '\n')
 392                 sv_catpv(sstr, "\\n");
 393             else if (*s == '\r')
 394                 sv_catpv(sstr, "\\r");
 395             else if (*s == '\t')
 396                 sv_catpv(sstr, "\\t");
 397             else if (*s == '\a')
 398                 sv_catpv(sstr, "\\a");
 399             else if (*s == '\b')
 400                 sv_catpv(sstr, "\\b");
 401             else if (*s == '\f')
 402                 sv_catpv(sstr, "\\f");
 403             else if (!perlstyle && *s == '\v')
 404                 sv_catpv(sstr, "\\v");
 405             else
 406             {
 407                 /* Don't want promotion of a signed -1 char in sprintf args */
 408                 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
 409                 const unsigned char c = (unsigned char) *s;
 410                 sprintf(escbuff, "\\%03o", c);
 411                 sv_catpv(sstr, escbuff);
 412             }
 413             /* XXX Add line breaks if string is long */
 414         }
 415         sv_catpv(sstr, "\"");
 416     }
 417     return sstr;
 418 }
 419
 420 static SV *
 421 cchar(pTHX_ SV *sv)
 422 {
 423     SV *sstr = newSVpvn("'", 1);
 424     const char *s = SvPV_nolen(sv);
 425
 426     if (*s == '\'')
 427         sv_catpvn(sstr, "\\'", 2);
 428     else if (*s == '\\')
 429         sv_catpvn(sstr, "\\\\", 2);
 430 #ifdef EBCDIC
 431     else if (isPRINT(*s))
 432 #else
 433     else if (*s >= ' ' && *s < 127)
 434 #endif /* EBCDIC */
 435         sv_catpvn(sstr, s, 1);
 436     else if (*s == '\n')
 437         sv_catpvn(sstr, "\\n", 2);
 438     else if (*s == '\r')
 439         sv_catpvn(sstr, "\\r", 2);
 440     else if (*s == '\t')
 441         sv_catpvn(sstr, "\\t", 2);
 442     else if (*s == '\a')
 443         sv_catpvn(sstr, "\\a", 2);
 444     else if (*s == '\b')
 445         sv_catpvn(sstr, "\\b", 2);
 446     else if (*s == '\f')
 447         sv_catpvn(sstr, "\\f", 2);
 448     else if (*s == '\v')
 449         sv_catpvn(sstr, "\\v", 2);
 450     else
 451     {
 452         /* no trigraph support */
 453         char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
 454         /* Don't want promotion of a signed -1 char in sprintf args */
 455         unsigned char c = (unsigned char) *s;
 456         sprintf(escbuff, "\\%03o", c);
 457         sv_catpv(sstr, escbuff);
 458     }
 459     sv_catpvn(sstr, "'", 1);
 460     return sstr;
 461 }
 462
 463 static void
 464 walkoptree(pTHX_ SV *opsv, const char *method)
 465 {
 466     dSP;
 467     OP *o, *kid;
 468     dMY_CXT;
 469
 470     if (!SvROK(opsv))
 471         croak("opsv is not a reference");
 472     opsv = sv_mortalcopy(opsv);
 473     o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
 474     if (walkoptree_debug) {
 475         PUSHMARK(sp);
 476         XPUSHs(opsv);
 477         PUTBACK;
 478         perl_call_method("walkoptree_debug", G_DISCARD);
 479     }
 480     PUSHMARK(sp);
 481     XPUSHs(opsv);
 482     PUTBACK;
 483     perl_call_method(method, G_DISCARD);
 484     if (o && (o->op_flags & OPf_KIDS)) {
 485         for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
 486             /* Use the same opsv. Rely on methods not to mess it up. */
 487             sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
 488             walkoptree(aTHX_ opsv, method);
 489         }
 490     }
 491     if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
 492             && (kid = cPMOPo->op_pmreplroot))
 493     {
 494         sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
 495         walkoptree(aTHX_ opsv, method);
 496     }
 497 }
 498
 499 static SV **
 500 oplist(pTHX_ OP *o, SV **SP)
 501 {
 502     for(; o; o = o->op_next) {
 503         SV *opsv;
 504 #if PERL_VERSION >= 9
 505         if (o->op_opt == 0)
 506             break;
 507         o->op_opt = 0;
 508 #else
 509         if (o->op_seq == 0)
 510             break;
 511         o->op_seq = 0;
 512 #endif
 513         opsv = sv_newmortal();
 514         sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
 515         XPUSHs(opsv);
 516         switch (o->op_type) {
 517         case OP_SUBST:
 518             SP = oplist(aTHX_ cPMOPo->op_pmreplstart, SP);
 519             continue;
 520         case OP_SORT:
 521             if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
 522                 OP *kid = cLISTOPo->op_first->op_sibling;   /* pass pushmark */
 523                 kid = kUNOP->op_first;                      /* pass rv2gv */
 524                 kid = kUNOP->op_first;                      /* pass leave */
 525                 SP = oplist(aTHX_ kid->op_next, SP);
 526             }
 527             continue;
 528         }
 529         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 530         case OA_LOGOP:
 531             SP = oplist(aTHX_ cLOGOPo->op_other, SP);
 532             break;
 533         case OA_LOOP:
 534             SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
 535             SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
 536             SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
 537             break;
 538         }
 539     }
 540     return SP;
 541 }
 542
 543 typedef OP      *B__OP;
 544 typedef UNOP    *B__UNOP;
 545 typedef BINOP   *B__BINOP;
 546 typedef LOGOP   *B__LOGOP;
 547 typedef LISTOP  *B__LISTOP;
 548 typedef PMOP    *B__PMOP;
 549 typedef SVOP    *B__SVOP;
 550 typedef PADOP   *B__PADOP;
 551 typedef PVOP    *B__PVOP;
 552 typedef LOOP    *B__LOOP;
 553 typedef COP     *B__COP;
 554
 555 typedef SV      *B__SV;
 556 typedef SV      *B__IV;
 557 typedef SV      *B__PV;
 558 typedef SV      *B__NV;
 559 typedef SV      *B__PVMG;
 560 typedef SV      *B__PVLV;
 561 typedef SV      *B__BM;
 562 typedef SV      *B__RV;
 563 typedef SV      *B__FM;
 564 typedef AV      *B__AV;
 565 typedef HV      *B__HV;
 566 typedef CV      *B__CV;
 567 typedef GV      *B__GV;
 568 typedef IO      *B__IO;
 569
 570 typedef MAGIC   *B__MAGIC;
 571 typedef HE      *B__HE;
 572 typedef struct refcounted_he    *B__RHE;
 573
 574 MODULE = B      PACKAGE = B     PREFIX = B_
 575
 576 PROTOTYPES: DISABLE
 577
 578 BOOT:
 579 {
 580     HV *stash = gv_stashpvn("B", 1, TRUE);
 581     AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
 582     MY_CXT_INIT;
 583     specialsv_list[0] = Nullsv;
 584     specialsv_list[1] = &PL_sv_undef;
 585     specialsv_list[2] = &PL_sv_yes;
 586     specialsv_list[3] = &PL_sv_no;
 587     specialsv_list[4] = (SV *) pWARN_ALL;
 588     specialsv_list[5] = (SV *) pWARN_NONE;
 589     specialsv_list[6] = (SV *) pWARN_STD;
 590 #if PERL_VERSION <= 8
 591 #  define CVf_ASSERTION 0
 592 #endif
 593 #include "defsubs.h"
 594 }
 595
 596 #define B_main_cv()     PL_main_cv
 597 #define B_init_av()     PL_initav
 598 #define B_inc_gv()      PL_incgv
 599 #define B_check_av()    PL_checkav_save
 600 #define B_unitcheck_av()        PL_unitcheckav_save
 601 #define B_begin_av()    PL_beginav_save
 602 #define B_end_av()      PL_endav
 603 #define B_main_root()   PL_main_root
 604 #define B_main_start()  PL_main_start
 605 #define B_amagic_generation()   PL_amagic_generation
 606 #define B_sub_generation()      PL_sub_generation
 607 #define B_defstash()    PL_defstash
 608 #define B_curstash()    PL_curstash
 609 #define B_dowarn()      PL_dowarn
 610 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
 611 #define B_sv_undef()    &PL_sv_undef
 612 #define B_sv_yes()      &PL_sv_yes
 613 #define B_sv_no()       &PL_sv_no
 614 #define B_formfeed()    PL_formfeed
 615 #ifdef USE_ITHREADS
 616 #define B_regex_padav() PL_regex_padav
 617 #endif
 618
 619 B::AV
 620 B_init_av()
 621
 622 B::AV
 623 B_check_av()
 624
 625 B::AV
 626 B_unitcheck_av()
 627
 628 B::AV
 629 B_begin_av()
 630
 631 B::AV
 632 B_end_av()
 633
 634 B::GV
 635 B_inc_gv()
 636
 637 #ifdef USE_ITHREADS
 638
 639 B::AV
 640 B_regex_padav()
 641
 642 #endif
 643
 644 B::CV
 645 B_main_cv()
 646
 647 B::OP
 648 B_main_root()
 649
 650 B::OP
 651 B_main_start()
 652
 653 long
 654 B_amagic_generation()
 655
 656 long
 657 B_sub_generation()
 658
 659 B::AV
 660 B_comppadlist()
 661
 662 B::SV
 663 B_sv_undef()
 664
 665 B::SV
 666 B_sv_yes()
 667
 668 B::SV
 669 B_sv_no()
 670
 671 B::HV
 672 B_curstash()
 673
 674 B::HV
 675 B_defstash()
 676
 677 U8
 678 B_dowarn()
 679
 680 B::SV
 681 B_formfeed()
 682
 683 void
 684 B_warnhook()
 685     CODE:
 686         ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
 687
 688 void
 689 B_diehook()
 690     CODE:
 691         ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
 692
 693 MODULE = B      PACKAGE = B
 694
 695 void
 696 walkoptree(opsv, method)
 697         SV *    opsv
 698         const char *    method
 699     CODE:
 700         walkoptree(aTHX_ opsv, method);
 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 B::SV
 719 svref_2object(sv)
 720         SV *    sv
 721     CODE:
 722         if (!SvROK(sv))
 723             croak("argument is not a reference");
 724         RETVAL = (SV*)SvRV(sv);
 725     OUTPUT:
 726         RETVAL
 727
 728 void
 729 opnumber(name)
 730 const char *    name
 731 CODE:
 732 {
 733  int i;
 734  IV  result = -1;
 735  ST(0) = sv_newmortal();
 736  if (strncmp(name,"pp_",3) == 0)
 737    name += 3;
 738  for (i = 0; i < PL_maxo; i++)
 739   {
 740    if (strcmp(name, PL_op_name[i]) == 0)
 741     {
 742      result = i;
 743      break;
 744     }
 745   }
 746  sv_setiv(ST(0),result);
 747 }
 748
 749 void
 750 ppname(opnum)
 751         int     opnum
 752     CODE:
 753         ST(0) = sv_newmortal();
 754         if (opnum >= 0 && opnum < PL_maxo) {
 755             sv_setpvn(ST(0), "pp_", 3);
 756             sv_catpv(ST(0), PL_op_name[opnum]);
 757         }
 758
 759 void
 760 hash(sv)
 761         SV *    sv
 762     CODE:
 763         STRLEN len;
 764         U32 hash = 0;
 765         char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
 766         const char *s = SvPV(sv, len);
 767         PERL_HASH(hash, s, len);
 768         sprintf(hexhash, "0x%"UVxf, (UV)hash);
 769         ST(0) = sv_2mortal(newSVpv(hexhash, 0));
 770
 771 #define cast_I32(foo) (I32)foo
 772 IV
 773 cast_I32(i)
 774         IV      i
 775
 776 void
 777 minus_c()
 778     CODE:
 779         PL_minus_c = TRUE;
 780
 781 void
 782 save_BEGINs()
 783     CODE:
 784         PL_savebegin = TRUE;
 785
 786 SV *
 787 cstring(sv)
 788         SV *    sv
 789     CODE:
 790         RETVAL = cstring(aTHX_ sv, 0);
 791     OUTPUT:
 792         RETVAL
 793
 794 SV *
 795 perlstring(sv)
 796         SV *    sv
 797     CODE:
 798         RETVAL = cstring(aTHX_ sv, 1);
 799     OUTPUT:
 800         RETVAL
 801
 802 SV *
 803 cchar(sv)
 804         SV *    sv
 805     CODE:
 806         RETVAL = cchar(aTHX_ sv);
 807     OUTPUT:
 808         RETVAL
 809
 810 void
 811 threadsv_names()
 812     PPCODE:
 813 #if PERL_VERSION <= 8
 814 # ifdef USE_5005THREADS
 815         int i;
 816         const STRLEN len = strlen(PL_threadsv_names);
 817
 818         EXTEND(sp, len);
 819         for (i = 0; i < len; i++)
 820             PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
 821 # endif
 822 #endif
 823
 824 #define OP_next(o)      o->op_next
 825 #define OP_sibling(o)   o->op_sibling
 826 #define OP_desc(o)      (char *)PL_op_desc[o->op_type]
 827 #define OP_targ(o)      o->op_targ
 828 #define OP_type(o)      o->op_type
 829 #if PERL_VERSION >= 9
 830 #  define OP_opt(o)     o->op_opt
 831 #  define OP_static(o)  o->op_static
 832 #else
 833 #  define OP_seq(o)     o->op_seq
 834 #endif
 835 #define OP_flags(o)     o->op_flags
 836 #define OP_private(o)   o->op_private
 837 #define OP_spare(o)     o->op_spare
 838
 839 MODULE = B      PACKAGE = B::OP         PREFIX = OP_
 840
 841 size_t
 842 OP_size(o)
 843         B::OP           o
 844     CODE:
 845         RETVAL = opsizes[cc_opclass(aTHX_ o)];
 846     OUTPUT:
 847         RETVAL
 848
 849 B::OP
 850 OP_next(o)
 851         B::OP           o
 852
 853 B::OP
 854 OP_sibling(o)
 855         B::OP           o
 856
 857 char *
 858 OP_name(o)
 859         B::OP           o
 860     CODE:
 861         RETVAL = (char *)PL_op_name[o->op_type];
 862     OUTPUT:
 863         RETVAL
 864
 865
 866 void
 867 OP_ppaddr(o)
 868         B::OP           o
 869     PREINIT:
 870         int i;
 871         SV *sv = sv_newmortal();
 872     CODE:
 873         sv_setpvn(sv, "PL_ppaddr[OP_", 13);
 874         sv_catpv(sv, PL_op_name[o->op_type]);
 875         for (i=13; (STRLEN)i < SvCUR(sv); ++i)
 876             SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
 877         sv_catpv(sv, "]");
 878         ST(0) = sv;
 879
 880 char *
 881 OP_desc(o)
 882         B::OP           o
 883
 884 PADOFFSET
 885 OP_targ(o)
 886         B::OP           o
 887
 888 U16
 889 OP_type(o)
 890         B::OP           o
 891
 892 #if PERL_VERSION >= 9
 893
 894 U8
 895 OP_opt(o)
 896         B::OP           o
 897
 898 U8
 899 OP_static(o)
 900         B::OP           o
 901
 902 #else
 903
 904 U16
 905 OP_seq(o)
 906         B::OP           o
 907
 908 #endif
 909
 910 U8
 911 OP_flags(o)
 912         B::OP           o
 913
 914 U8
 915 OP_private(o)
 916         B::OP           o
 917
 918 #if PERL_VERSION >= 9
 919
 920 U8
 921 OP_spare(o)
 922         B::OP           o
 923
 924 #endif
 925
 926 void
 927 OP_oplist(o)
 928         B::OP           o
 929     PPCODE:
 930         SP = oplist(aTHX_ o, SP);
 931
 932 #define UNOP_first(o)   o->op_first
 933
 934 MODULE = B      PACKAGE = B::UNOP               PREFIX = UNOP_
 935
 936 B::OP
 937 UNOP_first(o)
 938         B::UNOP o
 939
 940 #define BINOP_last(o)   o->op_last
 941
 942 MODULE = B      PACKAGE = B::BINOP              PREFIX = BINOP_
 943
 944 B::OP
 945 BINOP_last(o)
 946         B::BINOP        o
 947
 948 #define LOGOP_other(o)  o->op_other
 949
 950 MODULE = B      PACKAGE = B::LOGOP              PREFIX = LOGOP_
 951
 952 B::OP
 953 LOGOP_other(o)
 954         B::LOGOP        o
 955
 956 MODULE = B      PACKAGE = B::LISTOP             PREFIX = LISTOP_
 957
 958 U32
 959 LISTOP_children(o)
 960         B::LISTOP       o
 961         OP *            kid = NO_INIT
 962         int             i = NO_INIT
 963     CODE:
 964         i = 0;
 965         for (kid = o->op_first; kid; kid = kid->op_sibling)
 966             i++;
 967         RETVAL = i;
 968     OUTPUT:
 969         RETVAL
 970
 971 #define PMOP_pmreplroot(o)      o->op_pmreplroot
 972 #define PMOP_pmreplstart(o)     o->op_pmreplstart
 973 #define PMOP_pmnext(o)          o->op_pmnext
 974 #define PMOP_pmregexp(o)        PM_GETRE(o)
 975 #ifdef USE_ITHREADS
 976 #define PMOP_pmoffset(o)        o->op_pmoffset
 977 #define PMOP_pmstashpv(o)       o->op_pmstashpv
 978 #else
 979 #define PMOP_pmstash(o)         o->op_pmstash
 980 #endif
 981 #define PMOP_pmflags(o)         o->op_pmflags
 982 #define PMOP_pmpermflags(o)     o->op_pmpermflags
 983 #define PMOP_pmdynflags(o)      o->op_pmdynflags
 984
 985 MODULE = B      PACKAGE = B::PMOP               PREFIX = PMOP_
 986
 987 void
 988 PMOP_pmreplroot(o)
 989         B::PMOP         o
 990         OP *            root = NO_INIT
 991     CODE:
 992         ST(0) = sv_newmortal();
 993         root = o->op_pmreplroot;
 994         /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
 995         if (o->op_type == OP_PUSHRE) {
 996 #ifdef USE_ITHREADS
 997             sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
 998 #else
 999             sv_setiv(newSVrv(ST(0), root ?
1000                              svclassnames[SvTYPE((SV*)root)] : "B::SV"),
1001                      PTR2IV(root));
1002 #endif
1003         }
1004         else {
1005             sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
1006         }
1007
1008 B::OP
1009 PMOP_pmreplstart(o)
1010         B::PMOP         o
1011
1012 B::PMOP
1013 PMOP_pmnext(o)
1014         B::PMOP         o
1015
1016 #ifdef USE_ITHREADS
1017
1018 IV
1019 PMOP_pmoffset(o)
1020         B::PMOP         o
1021
1022 char*
1023 PMOP_pmstashpv(o)
1024         B::PMOP         o
1025
1026 #else
1027
1028 B::HV
1029 PMOP_pmstash(o)
1030         B::PMOP         o
1031
1032 #endif
1033
1034 U32
1035 PMOP_pmflags(o)
1036         B::PMOP         o
1037
1038 U32
1039 PMOP_pmpermflags(o)
1040         B::PMOP         o
1041
1042 U8
1043 PMOP_pmdynflags(o)
1044         B::PMOP         o
1045
1046 void
1047 PMOP_precomp(o)
1048         B::PMOP         o
1049         REGEXP *        rx = NO_INIT
1050     CODE:
1051         ST(0) = sv_newmortal();
1052         rx = PM_GETRE(o);
1053         if (rx)
1054             sv_setpvn(ST(0), rx->precomp, rx->prelen);
1055
1056 #define SVOP_sv(o)     cSVOPo->op_sv
1057 #define SVOP_gv(o)     ((GV*)cSVOPo->op_sv)
1058
1059 MODULE = B      PACKAGE = B::SVOP               PREFIX = SVOP_
1060
1061 B::SV
1062 SVOP_sv(o)
1063         B::SVOP o
1064
1065 B::GV
1066 SVOP_gv(o)
1067         B::SVOP o
1068
1069 #define PADOP_padix(o)  o->op_padix
1070 #define PADOP_sv(o)     (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
1071 #define PADOP_gv(o)     ((o->op_padix \
1072                           && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
1073                          ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
1074
1075 MODULE = B      PACKAGE = B::PADOP              PREFIX = PADOP_
1076
1077 PADOFFSET
1078 PADOP_padix(o)
1079         B::PADOP o
1080
1081 B::SV
1082 PADOP_sv(o)
1083         B::PADOP o
1084
1085 B::GV
1086 PADOP_gv(o)
1087         B::PADOP o
1088
1089 MODULE = B      PACKAGE = B::PVOP               PREFIX = PVOP_
1090
1091 void
1092 PVOP_pv(o)
1093         B::PVOP o
1094     CODE:
1095         /*
1096          * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
1097          * whereas other PVOPs point to a null terminated string.
1098          */
1099         if (o->op_type == OP_TRANS &&
1100                 (o->op_private & OPpTRANS_COMPLEMENT) &&
1101                 !(o->op_private & OPpTRANS_DELETE))
1102         {
1103             const short* const tbl = (short*)o->op_pv;
1104             const short entries = 257 + tbl[256];
1105             ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
1106         }
1107         else if (o->op_type == OP_TRANS) {
1108             ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
1109         }
1110         else
1111             ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
1112
1113 #define LOOP_redoop(o)  o->op_redoop
1114 #define LOOP_nextop(o)  o->op_nextop
1115 #define LOOP_lastop(o)  o->op_lastop
1116
1117 MODULE = B      PACKAGE = B::LOOP               PREFIX = LOOP_
1118
1119
1120 B::OP
1121 LOOP_redoop(o)
1122         B::LOOP o
1123
1124 B::OP
1125 LOOP_nextop(o)
1126         B::LOOP o
1127
1128 B::OP
1129 LOOP_lastop(o)
1130         B::LOOP o
1131
1132 #define COP_label(o)    o->cop_label
1133 #define COP_stashpv(o)  CopSTASHPV(o)
1134 #define COP_stash(o)    CopSTASH(o)
1135 #define COP_file(o)     CopFILE(o)
1136 #define COP_filegv(o)   CopFILEGV(o)
1137 #define COP_cop_seq(o)  o->cop_seq
1138 #define COP_arybase(o)  CopARYBASE_get(o)
1139 #define COP_line(o)     CopLINE(o)
1140 #define COP_hints(o)    CopHINTS_get(o)
1141
1142 MODULE = B      PACKAGE = B::COP                PREFIX = COP_
1143
1144 char *
1145 COP_label(o)
1146         B::COP  o
1147
1148 char *
1149 COP_stashpv(o)
1150         B::COP  o
1151
1152 B::HV
1153 COP_stash(o)
1154         B::COP  o
1155
1156 char *
1157 COP_file(o)
1158         B::COP  o
1159
1160 B::GV
1161 COP_filegv(o)
1162        B::COP  o
1163
1164
1165 U32
1166 COP_cop_seq(o)
1167         B::COP  o
1168
1169 I32
1170 COP_arybase(o)
1171         B::COP  o
1172
1173 U32
1174 COP_line(o)
1175         B::COP  o
1176
1177 void
1178 COP_warnings(o)
1179         B::COP  o
1180         PPCODE:
1181         ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1182         XSRETURN(1);
1183
1184 void
1185 COP_io(o)
1186         B::COP  o
1187         PPCODE:
1188         ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
1189         XSRETURN(1);
1190
1191 U32
1192 COP_hints(o)
1193         B::COP  o
1194
1195 B::RHE
1196 COP_hints_hash(o)
1197         B::COP o
1198     CODE:
1199         RETVAL = o->cop_hints_hash;
1200     OUTPUT:
1201         RETVAL
1202
1203 MODULE = B      PACKAGE = B::SV
1204
1205 U32
1206 SvTYPE(sv)
1207         B::SV   sv
1208
1209 #define object_2svref(sv)       sv
1210 #define SVREF SV *
1211
1212 SVREF
1213 object_2svref(sv)
1214         B::SV   sv
1215
1216 MODULE = B      PACKAGE = B::SV         PREFIX = Sv
1217
1218 U32
1219 SvREFCNT(sv)
1220         B::SV   sv
1221
1222 U32
1223 SvFLAGS(sv)
1224         B::SV   sv
1225
1226 U32
1227 SvPOK(sv)
1228         B::SV   sv
1229
1230 U32
1231 SvROK(sv)
1232         B::SV   sv
1233
1234 U32
1235 SvMAGICAL(sv)
1236         B::SV   sv
1237
1238 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1239
1240 IV
1241 SvIV(sv)
1242         B::IV   sv
1243
1244 IV
1245 SvIVX(sv)
1246         B::IV   sv
1247
1248 UV
1249 SvUVX(sv)
1250         B::IV   sv
1251
1252
1253 MODULE = B      PACKAGE = B::IV
1254
1255 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1256
1257 int
1258 needs64bits(sv)
1259         B::IV   sv
1260
1261 void
1262 packiv(sv)
1263         B::IV   sv
1264     CODE:
1265         if (sizeof(IV) == 8) {
1266             U32 wp[2];
1267             const IV iv = SvIVX(sv);
1268             /*
1269              * The following way of spelling 32 is to stop compilers on
1270              * 32-bit architectures from moaning about the shift count
1271              * being >= the width of the type. Such architectures don't
1272              * reach this code anyway (unless sizeof(IV) > 8 but then
1273              * everything else breaks too so I'm not fussed at the moment).
1274              */
1275 #ifdef UV_IS_QUAD
1276             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1277 #else
1278             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1279 #endif
1280             wp[1] = htonl(iv & 0xffffffff);
1281             ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
1282         } else {
1283             U32 w = htonl((U32)SvIVX(sv));
1284             ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
1285         }
1286
1287 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1288
1289 NV
1290 SvNV(sv)
1291         B::NV   sv
1292
1293 NV
1294 SvNVX(sv)
1295         B::NV   sv
1296
1297 U32
1298 COP_SEQ_RANGE_LOW(sv)
1299         B::NV   sv
1300
1301 U32
1302 COP_SEQ_RANGE_HIGH(sv)
1303         B::NV   sv
1304
1305 U32
1306 PARENT_PAD_INDEX(sv)
1307         B::NV   sv
1308
1309 U32
1310 PARENT_FAKELEX_FLAGS(sv)
1311         B::NV   sv
1312
1313 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1314
1315 B::SV
1316 SvRV(sv)
1317         B::RV   sv
1318
1319 MODULE = B      PACKAGE = B::PV         PREFIX = Sv
1320
1321 char*
1322 SvPVX(sv)
1323         B::PV   sv
1324
1325 B::SV
1326 SvRV(sv)
1327         B::PV   sv
1328     CODE:
1329         if( SvROK(sv) ) {
1330             RETVAL = SvRV(sv);
1331         }
1332         else {
1333             croak( "argument is not SvROK" );
1334         }
1335     OUTPUT:
1336         RETVAL
1337
1338 void
1339 SvPV(sv)
1340         B::PV   sv
1341     CODE:
1342         ST(0) = sv_newmortal();
1343         if( SvPOK(sv) ) {
1344             /* FIXME - we need a better way for B to identify PVs that are
1345                in the pads as variable names.  */
1346             if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1347                 /* It claims to be longer than the space allocated for it -
1348                    presuambly it's a variable name in the pad  */
1349                 sv_setpv(ST(0), SvPV_nolen_const(sv));
1350             } else {
1351                 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1352             }
1353             SvFLAGS(ST(0)) |= SvUTF8(sv);
1354         }
1355         else {
1356             /* XXX for backward compatibility, but should fail */
1357             /* croak( "argument is not SvPOK" ); */
1358             sv_setpvn(ST(0), NULL, 0);
1359         }
1360
1361 # This used to read 257. I think that that was buggy - should have been 258.
1362 # (The "\0", the flags byte, and 256 for the table.  Not that anything
1363 # anywhere calls this method.  NWC.
1364 void
1365 SvPVBM(sv)
1366         B::PV   sv
1367     CODE:
1368         ST(0) = sv_newmortal();
1369         sv_setpvn(ST(0), SvPVX_const(sv),
1370             SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0));
1371
1372
1373 STRLEN
1374 SvLEN(sv)
1375         B::PV   sv
1376
1377 STRLEN
1378 SvCUR(sv)
1379         B::PV   sv
1380
1381 MODULE = B      PACKAGE = B::PVMG       PREFIX = Sv
1382
1383 void
1384 SvMAGIC(sv)
1385         B::PVMG sv
1386         MAGIC * mg = NO_INIT
1387     PPCODE:
1388         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1389             XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1390
1391 MODULE = B      PACKAGE = B::PVMG
1392
1393 B::HV
1394 SvSTASH(sv)
1395         B::PVMG sv
1396
1397 #define MgMOREMAGIC(mg) mg->mg_moremagic
1398 #define MgPRIVATE(mg) mg->mg_private
1399 #define MgTYPE(mg) mg->mg_type
1400 #define MgFLAGS(mg) mg->mg_flags
1401 #define MgOBJ(mg) mg->mg_obj
1402 #define MgLENGTH(mg) mg->mg_len
1403 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1404
1405 MODULE = B      PACKAGE = B::MAGIC      PREFIX = Mg
1406
1407 B::MAGIC
1408 MgMOREMAGIC(mg)
1409         B::MAGIC        mg
1410      CODE:
1411         if( MgMOREMAGIC(mg) ) {
1412             RETVAL = MgMOREMAGIC(mg);
1413         }
1414         else {
1415             XSRETURN_UNDEF;
1416         }
1417      OUTPUT:
1418         RETVAL
1419
1420 U16
1421 MgPRIVATE(mg)
1422         B::MAGIC        mg
1423
1424 char
1425 MgTYPE(mg)
1426         B::MAGIC        mg
1427
1428 U8
1429 MgFLAGS(mg)
1430         B::MAGIC        mg
1431
1432 B::SV
1433 MgOBJ(mg)
1434         B::MAGIC        mg
1435
1436 IV
1437 MgREGEX(mg)
1438         B::MAGIC        mg
1439     CODE:
1440         if(mg->mg_type == PERL_MAGIC_qr) {
1441             RETVAL = MgREGEX(mg);
1442         }
1443         else {
1444             croak( "REGEX is only meaningful on r-magic" );
1445         }
1446     OUTPUT:
1447         RETVAL
1448
1449 SV*
1450 precomp(mg)
1451         B::MAGIC        mg
1452     CODE:
1453         if (mg->mg_type == PERL_MAGIC_qr) {
1454             REGEXP* rx = (REGEXP*)mg->mg_obj;
1455             RETVAL = Nullsv;
1456             if( rx )
1457                 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1458         }
1459         else {
1460             croak( "precomp is only meaningful on r-magic" );
1461         }
1462     OUTPUT:
1463         RETVAL
1464
1465 I32
1466 MgLENGTH(mg)
1467         B::MAGIC        mg
1468
1469 void
1470 MgPTR(mg)
1471         B::MAGIC        mg
1472     CODE:
1473         ST(0) = sv_newmortal();
1474         if (mg->mg_ptr){
1475                 if (mg->mg_len >= 0){
1476                         sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1477                 } else if (mg->mg_len == HEf_SVKEY) {
1478                         ST(0) = make_sv_object(aTHX_
1479                                     sv_newmortal(), (SV*)mg->mg_ptr);
1480                 }
1481         }
1482
1483 MODULE = B      PACKAGE = B::PVLV       PREFIX = Lv
1484
1485 U32
1486 LvTARGOFF(sv)
1487         B::PVLV sv
1488
1489 U32
1490 LvTARGLEN(sv)
1491         B::PVLV sv
1492
1493 char
1494 LvTYPE(sv)
1495         B::PVLV sv
1496
1497 B::SV
1498 LvTARG(sv)
1499         B::PVLV sv
1500
1501 MODULE = B      PACKAGE = B::BM         PREFIX = Bm
1502
1503 I32
1504 BmUSEFUL(sv)
1505         B::BM   sv
1506
1507 U32
1508 BmPREVIOUS(sv)
1509         B::BM   sv
1510
1511 U8
1512 BmRARE(sv)
1513         B::BM   sv
1514
1515 void
1516 BmTABLE(sv)
1517         B::BM   sv
1518         STRLEN  len = NO_INIT
1519         char *  str = NO_INIT
1520     CODE:
1521         str = SvPV(sv, len);
1522         /* Boyer-Moore table is just after string and its safety-margin \0 */
1523         ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256));
1524
1525 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1526
1527 void
1528 GvNAME(gv)
1529         B::GV   gv
1530     CODE:
1531         ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1532
1533 bool
1534 is_empty(gv)
1535         B::GV   gv
1536     CODE:
1537         RETVAL = GvGP(gv) == Null(GP*);
1538     OUTPUT:
1539         RETVAL
1540
1541 void*
1542 GvGP(gv)
1543         B::GV   gv
1544
1545 B::HV
1546 GvSTASH(gv)
1547         B::GV   gv
1548
1549 B::SV
1550 GvSV(gv)
1551         B::GV   gv
1552
1553 B::IO
1554 GvIO(gv)
1555         B::GV   gv
1556
1557 B::FM
1558 GvFORM(gv)
1559         B::GV   gv
1560     CODE:
1561         RETVAL = (SV*)GvFORM(gv);
1562     OUTPUT:
1563         RETVAL
1564
1565 B::AV
1566 GvAV(gv)
1567         B::GV   gv
1568
1569 B::HV
1570 GvHV(gv)
1571         B::GV   gv
1572
1573 B::GV
1574 GvEGV(gv)
1575         B::GV   gv
1576
1577 B::CV
1578 GvCV(gv)
1579         B::GV   gv
1580
1581 U32
1582 GvCVGEN(gv)
1583         B::GV   gv
1584
1585 U32
1586 GvLINE(gv)
1587         B::GV   gv
1588
1589 char *
1590 GvFILE(gv)
1591         B::GV   gv
1592
1593 B::GV
1594 GvFILEGV(gv)
1595         B::GV   gv
1596
1597 MODULE = B      PACKAGE = B::GV
1598
1599 U32
1600 GvREFCNT(gv)
1601         B::GV   gv
1602
1603 U8
1604 GvFLAGS(gv)
1605         B::GV   gv
1606
1607 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1608
1609 long
1610 IoLINES(io)
1611         B::IO   io
1612
1613 long
1614 IoPAGE(io)
1615         B::IO   io
1616
1617 long
1618 IoPAGE_LEN(io)
1619         B::IO   io
1620
1621 long
1622 IoLINES_LEFT(io)
1623         B::IO   io
1624
1625 char *
1626 IoTOP_NAME(io)
1627         B::IO   io
1628
1629 B::GV
1630 IoTOP_GV(io)
1631         B::IO   io
1632
1633 char *
1634 IoFMT_NAME(io)
1635         B::IO   io
1636
1637 B::GV
1638 IoFMT_GV(io)
1639         B::IO   io
1640
1641 char *
1642 IoBOTTOM_NAME(io)
1643         B::IO   io
1644
1645 B::GV
1646 IoBOTTOM_GV(io)
1647         B::IO   io
1648
1649 short
1650 IoSUBPROCESS(io)
1651         B::IO   io
1652
1653 bool
1654 IsSTD(io,name)
1655         B::IO   io
1656         const char*     name
1657     PREINIT:
1658         PerlIO* handle = 0;
1659     CODE:
1660         if( strEQ( name, "stdin" ) ) {
1661             handle = PerlIO_stdin();
1662         }
1663         else if( strEQ( name, "stdout" ) ) {
1664             handle = PerlIO_stdout();
1665         }
1666         else if( strEQ( name, "stderr" ) ) {
1667             handle = PerlIO_stderr();
1668         }
1669         else {
1670             croak( "Invalid value '%s'", name );
1671         }
1672         RETVAL = handle == IoIFP(io);
1673     OUTPUT:
1674         RETVAL
1675
1676 MODULE = B      PACKAGE = B::IO
1677
1678 char
1679 IoTYPE(io)
1680         B::IO   io
1681
1682 U8
1683 IoFLAGS(io)
1684         B::IO   io
1685
1686 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1687
1688 SSize_t
1689 AvFILL(av)
1690         B::AV   av
1691
1692 SSize_t
1693 AvMAX(av)
1694         B::AV   av
1695
1696 #if PERL_VERSION < 9
1697
1698
1699 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1700
1701 IV
1702 AvOFF(av)
1703         B::AV   av
1704
1705 #endif
1706
1707 void
1708 AvARRAY(av)
1709         B::AV   av
1710     PPCODE:
1711         if (AvFILL(av) >= 0) {
1712             SV **svp = AvARRAY(av);
1713             I32 i;
1714             for (i = 0; i <= AvFILL(av); i++)
1715                 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1716         }
1717
1718 void
1719 AvARRAYelt(av, idx)
1720         B::AV   av
1721         int     idx
1722     PPCODE:
1723         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1724             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1725         else
1726             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1727
1728 #if PERL_VERSION < 9
1729
1730 MODULE = B      PACKAGE = B::AV
1731
1732 U8
1733 AvFLAGS(av)
1734         B::AV   av
1735
1736 #endif
1737
1738 MODULE = B      PACKAGE = B::FM         PREFIX = Fm
1739
1740 IV
1741 FmLINES(form)
1742         B::FM   form
1743
1744 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1745
1746 U32
1747 CvCONST(cv)
1748         B::CV   cv
1749
1750 B::HV
1751 CvSTASH(cv)
1752         B::CV   cv
1753
1754 B::OP
1755 CvSTART(cv)
1756         B::CV   cv
1757     CODE:
1758         RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1759     OUTPUT:
1760         RETVAL
1761
1762 B::OP
1763 CvROOT(cv)
1764         B::CV   cv
1765     CODE:
1766         RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1767     OUTPUT:
1768         RETVAL
1769
1770 B::GV
1771 CvGV(cv)
1772         B::CV   cv
1773
1774 char *
1775 CvFILE(cv)
1776         B::CV   cv
1777
1778 long
1779 CvDEPTH(cv)
1780         B::CV   cv
1781
1782 B::AV
1783 CvPADLIST(cv)
1784         B::CV   cv
1785
1786 B::CV
1787 CvOUTSIDE(cv)
1788         B::CV   cv
1789
1790 U32
1791 CvOUTSIDE_SEQ(cv)
1792         B::CV   cv
1793
1794 void
1795 CvXSUB(cv)
1796         B::CV   cv
1797     CODE:
1798         ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
1799
1800
1801 void
1802 CvXSUBANY(cv)
1803         B::CV   cv
1804     CODE:
1805         ST(0) = CvCONST(cv) ?
1806             make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
1807             sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
1808
1809 MODULE = B    PACKAGE = B::CV
1810
1811 U16
1812 CvFLAGS(cv)
1813       B::CV   cv
1814
1815 MODULE = B      PACKAGE = B::CV         PREFIX = cv_
1816
1817 B::SV
1818 cv_const_sv(cv)
1819         B::CV   cv
1820
1821
1822 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1823
1824 STRLEN
1825 HvFILL(hv)
1826         B::HV   hv
1827
1828 STRLEN
1829 HvMAX(hv)
1830         B::HV   hv
1831
1832 I32
1833 HvKEYS(hv)
1834         B::HV   hv
1835
1836 I32
1837 HvRITER(hv)
1838         B::HV   hv
1839
1840 char *
1841 HvNAME(hv)
1842         B::HV   hv
1843
1844 #if PERL_VERSION < 9
1845
1846 B::PMOP
1847 HvPMROOT(hv)
1848         B::HV   hv
1849
1850 #endif
1851
1852 void
1853 HvARRAY(hv)
1854         B::HV   hv
1855     PPCODE:
1856         if (HvKEYS(hv) > 0) {
1857             SV *sv;
1858             char *key;
1859             I32 len;
1860             (void)hv_iterinit(hv);
1861             EXTEND(sp, HvKEYS(hv) * 2);
1862             while ((sv = hv_iternextsv(hv, &key, &len))) {
1863                 PUSHs(newSVpvn(key, len));
1864                 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
1865             }
1866         }
1867
1868 MODULE = B      PACKAGE = B::HE         PREFIX = He
1869
1870 B::SV
1871 HeVAL(he)
1872         B::HE he
1873
1874 U32
1875 HeHASH(he)
1876         B::HE he
1877
1878 B::SV
1879 HeSVKEY_force(he)
1880         B::HE he
1881
1882 MODULE = B      PACKAGE = B::RHE        PREFIX = RHE_
1883
1884 SV*
1885 RHE_HASH(h)
1886         B::RHE h
1887     CODE:
1888         RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );
1889     OUTPUT:
1890         RETVAL