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
 992 MODULE = B      PACKAGE = B::PMOP               PREFIX = PMOP_
 993
 994 void
 995 PMOP_pmreplroot(o)
 996         B::PMOP         o
 997         OP *            root = NO_INIT
 998     CODE:
 999         ST(0) = sv_newmortal();
1000         root = o->op_pmreplroot;
1001         /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1002         if (o->op_type == OP_PUSHRE) {
1003 #ifdef USE_ITHREADS
1004             sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
1005 #else
1006             sv_setiv(newSVrv(ST(0), root ?
1007                              svclassnames[SvTYPE((SV*)root)] : "B::SV"),
1008                      PTR2IV(root));
1009 #endif
1010         }
1011         else {
1012             sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
1013         }
1014
1015 B::OP
1016 PMOP_pmreplstart(o)
1017         B::PMOP         o
1018
1019 #if PERL_VERSION < 9
1020
1021 B::PMOP
1022 PMOP_pmnext(o)
1023         B::PMOP         o
1024
1025 #endif
1026
1027 #ifdef USE_ITHREADS
1028
1029 IV
1030 PMOP_pmoffset(o)
1031         B::PMOP         o
1032
1033 char*
1034 PMOP_pmstashpv(o)
1035         B::PMOP         o
1036
1037 #else
1038
1039 B::HV
1040 PMOP_pmstash(o)
1041         B::PMOP         o
1042
1043 #endif
1044
1045 U32
1046 PMOP_pmflags(o)
1047         B::PMOP         o
1048
1049 void
1050 PMOP_precomp(o)
1051         B::PMOP         o
1052         REGEXP *        rx = NO_INIT
1053     CODE:
1054         ST(0) = sv_newmortal();
1055         rx = PM_GETRE(o);
1056         if (rx)
1057             sv_setpvn(ST(0), rx->precomp, rx->prelen);
1058
1059 void
1060 PMOP_reflags(o)
1061         B::PMOP         o
1062         REGEXP *        rx = NO_INIT
1063     CODE:
1064         ST(0) = sv_newmortal();
1065         rx = PM_GETRE(o);
1066         if (rx)
1067             sv_setuv(ST(0), rx->extflags);
1068
1069 #define SVOP_sv(o)     cSVOPo->op_sv
1070 #define SVOP_gv(o)     ((GV*)cSVOPo->op_sv)
1071
1072 MODULE = B      PACKAGE = B::SVOP               PREFIX = SVOP_
1073
1074 B::SV
1075 SVOP_sv(o)
1076         B::SVOP o
1077
1078 B::GV
1079 SVOP_gv(o)
1080         B::SVOP o
1081
1082 #define PADOP_padix(o)  o->op_padix
1083 #define PADOP_sv(o)     (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
1084 #define PADOP_gv(o)     ((o->op_padix \
1085                           && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
1086                          ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
1087
1088 MODULE = B      PACKAGE = B::PADOP              PREFIX = PADOP_
1089
1090 PADOFFSET
1091 PADOP_padix(o)
1092         B::PADOP o
1093
1094 B::SV
1095 PADOP_sv(o)
1096         B::PADOP o
1097
1098 B::GV
1099 PADOP_gv(o)
1100         B::PADOP o
1101
1102 MODULE = B      PACKAGE = B::PVOP               PREFIX = PVOP_
1103
1104 void
1105 PVOP_pv(o)
1106         B::PVOP o
1107     CODE:
1108         /*
1109          * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
1110          * whereas other PVOPs point to a null terminated string.
1111          */
1112         if (o->op_type == OP_TRANS &&
1113                 (o->op_private & OPpTRANS_COMPLEMENT) &&
1114                 !(o->op_private & OPpTRANS_DELETE))
1115         {
1116             const short* const tbl = (short*)o->op_pv;
1117             const short entries = 257 + tbl[256];
1118             ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
1119         }
1120         else if (o->op_type == OP_TRANS) {
1121             ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
1122         }
1123         else
1124             ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
1125
1126 #define LOOP_redoop(o)  o->op_redoop
1127 #define LOOP_nextop(o)  o->op_nextop
1128 #define LOOP_lastop(o)  o->op_lastop
1129
1130 MODULE = B      PACKAGE = B::LOOP               PREFIX = LOOP_
1131
1132
1133 B::OP
1134 LOOP_redoop(o)
1135         B::LOOP o
1136
1137 B::OP
1138 LOOP_nextop(o)
1139         B::LOOP o
1140
1141 B::OP
1142 LOOP_lastop(o)
1143         B::LOOP o
1144
1145 #define COP_label(o)    o->cop_label
1146 #define COP_stashpv(o)  CopSTASHPV(o)
1147 #define COP_stash(o)    CopSTASH(o)
1148 #define COP_file(o)     CopFILE(o)
1149 #define COP_filegv(o)   CopFILEGV(o)
1150 #define COP_cop_seq(o)  o->cop_seq
1151 #define COP_arybase(o)  CopARYBASE_get(o)
1152 #define COP_line(o)     CopLINE(o)
1153 #define COP_hints(o)    CopHINTS_get(o)
1154 #if PERL_VERSION < 9
1155 #  define COP_warnings(o)  o->cop_warnings
1156 #  define COP_io(o)     o->cop_io
1157 #endif
1158
1159 MODULE = B      PACKAGE = B::COP                PREFIX = COP_
1160
1161 char *
1162 COP_label(o)
1163         B::COP  o
1164
1165 char *
1166 COP_stashpv(o)
1167         B::COP  o
1168
1169 B::HV
1170 COP_stash(o)
1171         B::COP  o
1172
1173 char *
1174 COP_file(o)
1175         B::COP  o
1176
1177 B::GV
1178 COP_filegv(o)
1179        B::COP  o
1180
1181
1182 U32
1183 COP_cop_seq(o)
1184         B::COP  o
1185
1186 I32
1187 COP_arybase(o)
1188         B::COP  o
1189
1190 U32
1191 COP_line(o)
1192         B::COP  o
1193
1194 #if PERL_VERSION >= 9
1195
1196 void
1197 COP_warnings(o)
1198         B::COP  o
1199         PPCODE:
1200         ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1201         XSRETURN(1);
1202
1203 void
1204 COP_io(o)
1205         B::COP  o
1206         PPCODE:
1207         ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
1208         XSRETURN(1);
1209
1210 B::RHE
1211 COP_hints_hash(o)
1212         B::COP o
1213     CODE:
1214         RETVAL = o->cop_hints_hash;
1215     OUTPUT:
1216         RETVAL
1217
1218 #else
1219
1220 B::SV
1221 COP_warnings(o)
1222         B::COP  o
1223
1224 B::SV
1225 COP_io(o)
1226         B::COP  o
1227
1228 #endif
1229
1230 U32
1231 COP_hints(o)
1232         B::COP  o
1233
1234 MODULE = B      PACKAGE = B::SV
1235
1236 U32
1237 SvTYPE(sv)
1238         B::SV   sv
1239
1240 #define object_2svref(sv)       sv
1241 #define SVREF SV *
1242
1243 SVREF
1244 object_2svref(sv)
1245         B::SV   sv
1246
1247 MODULE = B      PACKAGE = B::SV         PREFIX = Sv
1248
1249 U32
1250 SvREFCNT(sv)
1251         B::SV   sv
1252
1253 U32
1254 SvFLAGS(sv)
1255         B::SV   sv
1256
1257 U32
1258 SvPOK(sv)
1259         B::SV   sv
1260
1261 U32
1262 SvROK(sv)
1263         B::SV   sv
1264
1265 U32
1266 SvMAGICAL(sv)
1267         B::SV   sv
1268
1269 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1270
1271 IV
1272 SvIV(sv)
1273         B::IV   sv
1274
1275 IV
1276 SvIVX(sv)
1277         B::IV   sv
1278
1279 UV
1280 SvUVX(sv)
1281         B::IV   sv
1282
1283
1284 MODULE = B      PACKAGE = B::IV
1285
1286 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1287
1288 int
1289 needs64bits(sv)
1290         B::IV   sv
1291
1292 void
1293 packiv(sv)
1294         B::IV   sv
1295     CODE:
1296         if (sizeof(IV) == 8) {
1297             U32 wp[2];
1298             const IV iv = SvIVX(sv);
1299             /*
1300              * The following way of spelling 32 is to stop compilers on
1301              * 32-bit architectures from moaning about the shift count
1302              * being >= the width of the type. Such architectures don't
1303              * reach this code anyway (unless sizeof(IV) > 8 but then
1304              * everything else breaks too so I'm not fussed at the moment).
1305              */
1306 #ifdef UV_IS_QUAD
1307             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1308 #else
1309             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1310 #endif
1311             wp[1] = htonl(iv & 0xffffffff);
1312             ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
1313         } else {
1314             U32 w = htonl((U32)SvIVX(sv));
1315             ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
1316         }
1317
1318 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1319
1320 NV
1321 SvNV(sv)
1322         B::NV   sv
1323
1324 NV
1325 SvNVX(sv)
1326         B::NV   sv
1327
1328 U32
1329 COP_SEQ_RANGE_LOW(sv)
1330         B::NV   sv
1331
1332 U32
1333 COP_SEQ_RANGE_HIGH(sv)
1334         B::NV   sv
1335
1336 U32
1337 PARENT_PAD_INDEX(sv)
1338         B::NV   sv
1339
1340 U32
1341 PARENT_FAKELEX_FLAGS(sv)
1342         B::NV   sv
1343
1344 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1345
1346 B::SV
1347 SvRV(sv)
1348         B::RV   sv
1349
1350 MODULE = B      PACKAGE = B::PV         PREFIX = Sv
1351
1352 char*
1353 SvPVX(sv)
1354         B::PV   sv
1355
1356 B::SV
1357 SvRV(sv)
1358         B::PV   sv
1359     CODE:
1360         if( SvROK(sv) ) {
1361             RETVAL = SvRV(sv);
1362         }
1363         else {
1364             croak( "argument is not SvROK" );
1365         }
1366     OUTPUT:
1367         RETVAL
1368
1369 void
1370 SvPV(sv)
1371         B::PV   sv
1372     CODE:
1373         ST(0) = sv_newmortal();
1374         if( SvPOK(sv) ) {
1375             /* FIXME - we need a better way for B to identify PVs that are
1376                in the pads as variable names.  */
1377             if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1378                 /* It claims to be longer than the space allocated for it -
1379                    presuambly it's a variable name in the pad  */
1380                 sv_setpv(ST(0), SvPV_nolen_const(sv));
1381             } else {
1382                 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1383             }
1384             SvFLAGS(ST(0)) |= SvUTF8(sv);
1385         }
1386         else {
1387             /* XXX for backward compatibility, but should fail */
1388             /* croak( "argument is not SvPOK" ); */
1389             sv_setpvn(ST(0), NULL, 0);
1390         }
1391
1392 # This used to read 257. I think that that was buggy - should have been 258.
1393 # (The "\0", the flags byte, and 256 for the table.  Not that anything
1394 # anywhere calls this method.  NWC.
1395 void
1396 SvPVBM(sv)
1397         B::PV   sv
1398     CODE:
1399         ST(0) = sv_newmortal();
1400         sv_setpvn(ST(0), SvPVX_const(sv),
1401             SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0));
1402
1403
1404 STRLEN
1405 SvLEN(sv)
1406         B::PV   sv
1407
1408 STRLEN
1409 SvCUR(sv)
1410         B::PV   sv
1411
1412 MODULE = B      PACKAGE = B::PVMG       PREFIX = Sv
1413
1414 void
1415 SvMAGIC(sv)
1416         B::PVMG sv
1417         MAGIC * mg = NO_INIT
1418     PPCODE:
1419         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1420             XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1421
1422 MODULE = B      PACKAGE = B::PVMG
1423
1424 B::HV
1425 SvSTASH(sv)
1426         B::PVMG sv
1427
1428 #define MgMOREMAGIC(mg) mg->mg_moremagic
1429 #define MgPRIVATE(mg) mg->mg_private
1430 #define MgTYPE(mg) mg->mg_type
1431 #define MgFLAGS(mg) mg->mg_flags
1432 #define MgOBJ(mg) mg->mg_obj
1433 #define MgLENGTH(mg) mg->mg_len
1434 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1435
1436 MODULE = B      PACKAGE = B::MAGIC      PREFIX = Mg
1437
1438 B::MAGIC
1439 MgMOREMAGIC(mg)
1440         B::MAGIC        mg
1441      CODE:
1442         if( MgMOREMAGIC(mg) ) {
1443             RETVAL = MgMOREMAGIC(mg);
1444         }
1445         else {
1446             XSRETURN_UNDEF;
1447         }
1448      OUTPUT:
1449         RETVAL
1450
1451 U16
1452 MgPRIVATE(mg)
1453         B::MAGIC        mg
1454
1455 char
1456 MgTYPE(mg)
1457         B::MAGIC        mg
1458
1459 U8
1460 MgFLAGS(mg)
1461         B::MAGIC        mg
1462
1463 B::SV
1464 MgOBJ(mg)
1465         B::MAGIC        mg
1466
1467 IV
1468 MgREGEX(mg)
1469         B::MAGIC        mg
1470     CODE:
1471         if(mg->mg_type == PERL_MAGIC_qr) {
1472             RETVAL = MgREGEX(mg);
1473         }
1474         else {
1475             croak( "REGEX is only meaningful on r-magic" );
1476         }
1477     OUTPUT:
1478         RETVAL
1479
1480 SV*
1481 precomp(mg)
1482         B::MAGIC        mg
1483     CODE:
1484         if (mg->mg_type == PERL_MAGIC_qr) {
1485             REGEXP* rx = (REGEXP*)mg->mg_obj;
1486             RETVAL = Nullsv;
1487             if( rx )
1488                 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1489         }
1490         else {
1491             croak( "precomp is only meaningful on r-magic" );
1492         }
1493     OUTPUT:
1494         RETVAL
1495
1496 I32
1497 MgLENGTH(mg)
1498         B::MAGIC        mg
1499
1500 void
1501 MgPTR(mg)
1502         B::MAGIC        mg
1503     CODE:
1504         ST(0) = sv_newmortal();
1505         if (mg->mg_ptr){
1506                 if (mg->mg_len >= 0){
1507                         sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1508                 } else if (mg->mg_len == HEf_SVKEY) {
1509                         ST(0) = make_sv_object(aTHX_
1510                                     sv_newmortal(), (SV*)mg->mg_ptr);
1511                 }
1512         }
1513
1514 MODULE = B      PACKAGE = B::PVLV       PREFIX = Lv
1515
1516 U32
1517 LvTARGOFF(sv)
1518         B::PVLV sv
1519
1520 U32
1521 LvTARGLEN(sv)
1522         B::PVLV sv
1523
1524 char
1525 LvTYPE(sv)
1526         B::PVLV sv
1527
1528 B::SV
1529 LvTARG(sv)
1530         B::PVLV sv
1531
1532 MODULE = B      PACKAGE = B::BM         PREFIX = Bm
1533
1534 I32
1535 BmUSEFUL(sv)
1536         B::BM   sv
1537
1538 U32
1539 BmPREVIOUS(sv)
1540         B::BM   sv
1541
1542 U8
1543 BmRARE(sv)
1544         B::BM   sv
1545
1546 void
1547 BmTABLE(sv)
1548         B::BM   sv
1549         STRLEN  len = NO_INIT
1550         char *  str = NO_INIT
1551     CODE:
1552         str = SvPV(sv, len);
1553         /* Boyer-Moore table is just after string and its safety-margin \0 */
1554         ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256));
1555
1556 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1557
1558 void
1559 GvNAME(gv)
1560         B::GV   gv
1561     CODE:
1562         ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1563
1564 bool
1565 is_empty(gv)
1566         B::GV   gv
1567     CODE:
1568         RETVAL = GvGP(gv) == Null(GP*);
1569     OUTPUT:
1570         RETVAL
1571
1572 void*
1573 GvGP(gv)
1574         B::GV   gv
1575
1576 B::HV
1577 GvSTASH(gv)
1578         B::GV   gv
1579
1580 B::SV
1581 GvSV(gv)
1582         B::GV   gv
1583
1584 B::IO
1585 GvIO(gv)
1586         B::GV   gv
1587
1588 B::FM
1589 GvFORM(gv)
1590         B::GV   gv
1591     CODE:
1592         RETVAL = (SV*)GvFORM(gv);
1593     OUTPUT:
1594         RETVAL
1595
1596 B::AV
1597 GvAV(gv)
1598         B::GV   gv
1599
1600 B::HV
1601 GvHV(gv)
1602         B::GV   gv
1603
1604 B::GV
1605 GvEGV(gv)
1606         B::GV   gv
1607
1608 B::CV
1609 GvCV(gv)
1610         B::GV   gv
1611
1612 U32
1613 GvCVGEN(gv)
1614         B::GV   gv
1615
1616 U32
1617 GvLINE(gv)
1618         B::GV   gv
1619
1620 char *
1621 GvFILE(gv)
1622         B::GV   gv
1623
1624 B::GV
1625 GvFILEGV(gv)
1626         B::GV   gv
1627
1628 MODULE = B      PACKAGE = B::GV
1629
1630 U32
1631 GvREFCNT(gv)
1632         B::GV   gv
1633
1634 U8
1635 GvFLAGS(gv)
1636         B::GV   gv
1637
1638 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1639
1640 long
1641 IoLINES(io)
1642         B::IO   io
1643
1644 long
1645 IoPAGE(io)
1646         B::IO   io
1647
1648 long
1649 IoPAGE_LEN(io)
1650         B::IO   io
1651
1652 long
1653 IoLINES_LEFT(io)
1654         B::IO   io
1655
1656 char *
1657 IoTOP_NAME(io)
1658         B::IO   io
1659
1660 B::GV
1661 IoTOP_GV(io)
1662         B::IO   io
1663
1664 char *
1665 IoFMT_NAME(io)
1666         B::IO   io
1667
1668 B::GV
1669 IoFMT_GV(io)
1670         B::IO   io
1671
1672 char *
1673 IoBOTTOM_NAME(io)
1674         B::IO   io
1675
1676 B::GV
1677 IoBOTTOM_GV(io)
1678         B::IO   io
1679
1680 short
1681 IoSUBPROCESS(io)
1682         B::IO   io
1683
1684 bool
1685 IsSTD(io,name)
1686         B::IO   io
1687         const char*     name
1688     PREINIT:
1689         PerlIO* handle = 0;
1690     CODE:
1691         if( strEQ( name, "stdin" ) ) {
1692             handle = PerlIO_stdin();
1693         }
1694         else if( strEQ( name, "stdout" ) ) {
1695             handle = PerlIO_stdout();
1696         }
1697         else if( strEQ( name, "stderr" ) ) {
1698             handle = PerlIO_stderr();
1699         }
1700         else {
1701             croak( "Invalid value '%s'", name );
1702         }
1703         RETVAL = handle == IoIFP(io);
1704     OUTPUT:
1705         RETVAL
1706
1707 MODULE = B      PACKAGE = B::IO
1708
1709 char
1710 IoTYPE(io)
1711         B::IO   io
1712
1713 U8
1714 IoFLAGS(io)
1715         B::IO   io
1716
1717 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1718
1719 SSize_t
1720 AvFILL(av)
1721         B::AV   av
1722
1723 SSize_t
1724 AvMAX(av)
1725         B::AV   av
1726
1727 #if PERL_VERSION < 9
1728
1729
1730 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1731
1732 IV
1733 AvOFF(av)
1734         B::AV   av
1735
1736 #endif
1737
1738 void
1739 AvARRAY(av)
1740         B::AV   av
1741     PPCODE:
1742         if (AvFILL(av) >= 0) {
1743             SV **svp = AvARRAY(av);
1744             I32 i;
1745             for (i = 0; i <= AvFILL(av); i++)
1746                 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1747         }
1748
1749 void
1750 AvARRAYelt(av, idx)
1751         B::AV   av
1752         int     idx
1753     PPCODE:
1754         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1755             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1756         else
1757             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1758
1759 #if PERL_VERSION < 9
1760
1761 MODULE = B      PACKAGE = B::AV
1762
1763 U8
1764 AvFLAGS(av)
1765         B::AV   av
1766
1767 #endif
1768
1769 MODULE = B      PACKAGE = B::FM         PREFIX = Fm
1770
1771 IV
1772 FmLINES(form)
1773         B::FM   form
1774
1775 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1776
1777 U32
1778 CvCONST(cv)
1779         B::CV   cv
1780
1781 B::HV
1782 CvSTASH(cv)
1783         B::CV   cv
1784
1785 B::OP
1786 CvSTART(cv)
1787         B::CV   cv
1788     CODE:
1789         RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1790     OUTPUT:
1791         RETVAL
1792
1793 B::OP
1794 CvROOT(cv)
1795         B::CV   cv
1796     CODE:
1797         RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1798     OUTPUT:
1799         RETVAL
1800
1801 B::GV
1802 CvGV(cv)
1803         B::CV   cv
1804
1805 char *
1806 CvFILE(cv)
1807         B::CV   cv
1808
1809 long
1810 CvDEPTH(cv)
1811         B::CV   cv
1812
1813 B::AV
1814 CvPADLIST(cv)
1815         B::CV   cv
1816
1817 B::CV
1818 CvOUTSIDE(cv)
1819         B::CV   cv
1820
1821 U32
1822 CvOUTSIDE_SEQ(cv)
1823         B::CV   cv
1824
1825 void
1826 CvXSUB(cv)
1827         B::CV   cv
1828     CODE:
1829         ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
1830
1831
1832 void
1833 CvXSUBANY(cv)
1834         B::CV   cv
1835     CODE:
1836         ST(0) = CvCONST(cv) ?
1837             make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
1838             sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
1839
1840 MODULE = B    PACKAGE = B::CV
1841
1842 U16
1843 CvFLAGS(cv)
1844       B::CV   cv
1845
1846 MODULE = B      PACKAGE = B::CV         PREFIX = cv_
1847
1848 B::SV
1849 cv_const_sv(cv)
1850         B::CV   cv
1851
1852
1853 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1854
1855 STRLEN
1856 HvFILL(hv)
1857         B::HV   hv
1858
1859 STRLEN
1860 HvMAX(hv)
1861         B::HV   hv
1862
1863 I32
1864 HvKEYS(hv)
1865         B::HV   hv
1866
1867 I32
1868 HvRITER(hv)
1869         B::HV   hv
1870
1871 char *
1872 HvNAME(hv)
1873         B::HV   hv
1874
1875 #if PERL_VERSION < 9
1876
1877 B::PMOP
1878 HvPMROOT(hv)
1879         B::HV   hv
1880
1881 #endif
1882
1883 void
1884 HvARRAY(hv)
1885         B::HV   hv
1886     PPCODE:
1887         if (HvKEYS(hv) > 0) {
1888             SV *sv;
1889             char *key;
1890             I32 len;
1891             (void)hv_iterinit(hv);
1892             EXTEND(sp, HvKEYS(hv) * 2);
1893             while ((sv = hv_iternextsv(hv, &key, &len))) {
1894                 PUSHs(newSVpvn(key, len));
1895                 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
1896             }
1897         }
1898
1899 MODULE = B      PACKAGE = B::HE         PREFIX = He
1900
1901 B::SV
1902 HeVAL(he)
1903         B::HE he
1904
1905 U32
1906 HeHASH(he)
1907         B::HE he
1908
1909 B::SV
1910 HeSVKEY_force(he)
1911         B::HE he
1912
1913 MODULE = B      PACKAGE = B::RHE        PREFIX = RHE_
1914
1915 #if PERL_VERSION >= 9
1916
1917 SV*
1918 RHE_HASH(h)
1919         B::RHE h
1920     CODE:
1921         RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );
1922     OUTPUT:
1923         RETVAL
1924
1925 #endif