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