ext/B/B.xs

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