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