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