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