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 OPpPAD_STATE 0
 601 #endif
 602 #include "defsubs.h"
 603 }
 604
 605 #define B_main_cv()     PL_main_cv
 606 #define B_init_av()     PL_initav
 607 #define B_inc_gv()      PL_incgv
 608 #define B_check_av()    PL_checkav_save
 609 #if PERL_VERSION > 8
 610 #  define B_unitcheck_av()      PL_unitcheckav_save
 611 #else
 612 #  define B_unitcheck_av()      NULL
 613 #endif
 614 #define B_begin_av()    PL_beginav_save
 615 #define B_end_av()      PL_endav
 616 #define B_main_root()   PL_main_root
 617 #define B_main_start()  PL_main_start
 618 #define B_amagic_generation()   PL_amagic_generation
 619 #define B_sub_generation()      PL_sub_generation
 620 #define B_defstash()    PL_defstash
 621 #define B_curstash()    PL_curstash
 622 #define B_dowarn()      PL_dowarn
 623 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
 624 #define B_sv_undef()    &PL_sv_undef
 625 #define B_sv_yes()      &PL_sv_yes
 626 #define B_sv_no()       &PL_sv_no
 627 #define B_formfeed()    PL_formfeed
 628 #ifdef USE_ITHREADS
 629 #define B_regex_padav() PL_regex_padav
 630 #endif
 631
 632 B::AV
 633 B_init_av()
 634
 635 B::AV
 636 B_check_av()
 637
 638 #if PERL_VERSION >= 9
 639
 640 B::AV
 641 B_unitcheck_av()
 642
 643 #endif
 644
 645 B::AV
 646 B_begin_av()
 647
 648 B::AV
 649 B_end_av()
 650
 651 B::GV
 652 B_inc_gv()
 653
 654 #ifdef USE_ITHREADS
 655
 656 B::AV
 657 B_regex_padav()
 658
 659 #endif
 660
 661 B::CV
 662 B_main_cv()
 663
 664 B::OP
 665 B_main_root()
 666
 667 B::OP
 668 B_main_start()
 669
 670 long
 671 B_amagic_generation()
 672
 673 long
 674 B_sub_generation()
 675
 676 B::AV
 677 B_comppadlist()
 678
 679 B::SV
 680 B_sv_undef()
 681
 682 B::SV
 683 B_sv_yes()
 684
 685 B::SV
 686 B_sv_no()
 687
 688 B::HV
 689 B_curstash()
 690
 691 B::HV
 692 B_defstash()
 693
 694 U8
 695 B_dowarn()
 696
 697 B::SV
 698 B_formfeed()
 699
 700 void
 701 B_warnhook()
 702     CODE:
 703         ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
 704
 705 void
 706 B_diehook()
 707     CODE:
 708         ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
 709
 710 MODULE = B      PACKAGE = B
 711
 712 void
 713 walkoptree(opsv, method)
 714         SV *    opsv
 715         const char *    method
 716     CODE:
 717         walkoptree(aTHX_ opsv, method);
 718
 719 int
 720 walkoptree_debug(...)
 721     CODE:
 722         dMY_CXT;
 723         RETVAL = walkoptree_debug;
 724         if (items > 0 && SvTRUE(ST(1)))
 725             walkoptree_debug = 1;
 726     OUTPUT:
 727         RETVAL
 728
 729 #define address(sv) PTR2IV(sv)
 730
 731 IV
 732 address(sv)
 733         SV *    sv
 734
 735 B::SV
 736 svref_2object(sv)
 737         SV *    sv
 738     CODE:
 739         if (!SvROK(sv))
 740             croak("argument is not a reference");
 741         RETVAL = (SV*)SvRV(sv);
 742     OUTPUT:
 743         RETVAL
 744
 745 void
 746 opnumber(name)
 747 const char *    name
 748 CODE:
 749 {
 750  int i;
 751  IV  result = -1;
 752  ST(0) = sv_newmortal();
 753  if (strncmp(name,"pp_",3) == 0)
 754    name += 3;
 755  for (i = 0; i < PL_maxo; i++)
 756   {
 757    if (strcmp(name, PL_op_name[i]) == 0)
 758     {
 759      result = i;
 760      break;
 761     }
 762   }
 763  sv_setiv(ST(0),result);
 764 }
 765
 766 void
 767 ppname(opnum)
 768         int     opnum
 769     CODE:
 770         ST(0) = sv_newmortal();
 771         if (opnum >= 0 && opnum < PL_maxo) {
 772             sv_setpvn(ST(0), "pp_", 3);
 773             sv_catpv(ST(0), PL_op_name[opnum]);
 774         }
 775
 776 void
 777 hash(sv)
 778         SV *    sv
 779     CODE:
 780         STRLEN len;
 781         U32 hash = 0;
 782         char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
 783         const char *s = SvPV(sv, len);
 784         PERL_HASH(hash, s, len);
 785         sprintf(hexhash, "0x%"UVxf, (UV)hash);
 786         ST(0) = sv_2mortal(newSVpv(hexhash, 0));
 787
 788 #define cast_I32(foo) (I32)foo
 789 IV
 790 cast_I32(i)
 791         IV      i
 792
 793 void
 794 minus_c()
 795     CODE:
 796         PL_minus_c = TRUE;
 797
 798 void
 799 save_BEGINs()
 800     CODE:
 801         PL_savebegin = TRUE;
 802
 803 SV *
 804 cstring(sv)
 805         SV *    sv
 806     CODE:
 807         RETVAL = cstring(aTHX_ sv, 0);
 808     OUTPUT:
 809         RETVAL
 810
 811 SV *
 812 perlstring(sv)
 813         SV *    sv
 814     CODE:
 815         RETVAL = cstring(aTHX_ sv, 1);
 816     OUTPUT:
 817         RETVAL
 818
 819 SV *
 820 cchar(sv)
 821         SV *    sv
 822     CODE:
 823         RETVAL = cchar(aTHX_ sv);
 824     OUTPUT:
 825         RETVAL
 826
 827 void
 828 threadsv_names()
 829     PPCODE:
 830 #if PERL_VERSION <= 8
 831 # ifdef USE_5005THREADS
 832         int i;
 833         const STRLEN len = strlen(PL_threadsv_names);
 834
 835         EXTEND(sp, len);
 836         for (i = 0; i < len; i++)
 837             PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
 838 # endif
 839 #endif
 840
 841 #define OP_next(o)      o->op_next
 842 #define OP_sibling(o)   o->op_sibling
 843 #define OP_desc(o)      (char *)PL_op_desc[o->op_type]
 844 #define OP_targ(o)      o->op_targ
 845 #define OP_type(o)      o->op_type
 846 #if PERL_VERSION >= 9
 847 #  define OP_opt(o)     o->op_opt
 848 #  define OP_static(o)  o->op_static
 849 #else
 850 #  define OP_seq(o)     o->op_seq
 851 #endif
 852 #define OP_flags(o)     o->op_flags
 853 #define OP_private(o)   o->op_private
 854 #define OP_spare(o)     o->op_spare
 855
 856 MODULE = B      PACKAGE = B::OP         PREFIX = OP_
 857
 858 size_t
 859 OP_size(o)
 860         B::OP           o
 861     CODE:
 862         RETVAL = opsizes[cc_opclass(aTHX_ o)];
 863     OUTPUT:
 864         RETVAL
 865
 866 B::OP
 867 OP_next(o)
 868         B::OP           o
 869
 870 B::OP
 871 OP_sibling(o)
 872         B::OP           o
 873
 874 char *
 875 OP_name(o)
 876         B::OP           o
 877     CODE:
 878         RETVAL = (char *)PL_op_name[o->op_type];
 879     OUTPUT:
 880         RETVAL
 881
 882
 883 void
 884 OP_ppaddr(o)
 885         B::OP           o
 886     PREINIT:
 887         int i;
 888         SV *sv = sv_newmortal();
 889     CODE:
 890         sv_setpvn(sv, "PL_ppaddr[OP_", 13);
 891         sv_catpv(sv, PL_op_name[o->op_type]);
 892         for (i=13; (STRLEN)i < SvCUR(sv); ++i)
 893             SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
 894         sv_catpv(sv, "]");
 895         ST(0) = sv;
 896
 897 char *
 898 OP_desc(o)
 899         B::OP           o
 900
 901 PADOFFSET
 902 OP_targ(o)
 903         B::OP           o
 904
 905 U16
 906 OP_type(o)
 907         B::OP           o
 908
 909 #if PERL_VERSION >= 9
 910
 911 U8
 912 OP_opt(o)
 913         B::OP           o
 914
 915 U8
 916 OP_static(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 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1375
1376 NV
1377 SvNV(sv)
1378         B::NV   sv
1379
1380 NV
1381 SvNVX(sv)
1382         B::NV   sv
1383
1384 U32
1385 COP_SEQ_RANGE_LOW(sv)
1386         B::NV   sv
1387
1388 U32
1389 COP_SEQ_RANGE_HIGH(sv)
1390         B::NV   sv
1391
1392 U32
1393 PARENT_PAD_INDEX(sv)
1394         B::NV   sv
1395
1396 U32
1397 PARENT_FAKELEX_FLAGS(sv)
1398         B::NV   sv
1399
1400 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1401
1402 B::SV
1403 SvRV(sv)
1404         B::RV   sv
1405
1406 MODULE = B      PACKAGE = B::PV         PREFIX = Sv
1407
1408 char*
1409 SvPVX(sv)
1410         B::PV   sv
1411
1412 B::SV
1413 SvRV(sv)
1414         B::PV   sv
1415     CODE:
1416         if( SvROK(sv) ) {
1417             RETVAL = SvRV(sv);
1418         }
1419         else {
1420             croak( "argument is not SvROK" );
1421         }
1422     OUTPUT:
1423         RETVAL
1424
1425 void
1426 SvPV(sv)
1427         B::PV   sv
1428     CODE:
1429         ST(0) = sv_newmortal();
1430         if( SvPOK(sv) ) {
1431             /* FIXME - we need a better way for B to identify PVs that are
1432                in the pads as variable names.  */
1433             if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1434                 /* It claims to be longer than the space allocated for it -
1435                    presuambly it's a variable name in the pad  */
1436                 sv_setpv(ST(0), SvPV_nolen_const(sv));
1437             } else {
1438                 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1439             }
1440             SvFLAGS(ST(0)) |= SvUTF8(sv);
1441         }
1442         else {
1443             /* XXX for backward compatibility, but should fail */
1444             /* croak( "argument is not SvPOK" ); */
1445             sv_setpvn(ST(0), NULL, 0);
1446         }
1447
1448 # This used to read 257. I think that that was buggy - should have been 258.
1449 # (The "\0", the flags byte, and 256 for the table.  Not that anything
1450 # anywhere calls this method.  NWC.
1451 void
1452 SvPVBM(sv)
1453         B::PV   sv
1454     CODE:
1455         ST(0) = sv_newmortal();
1456         sv_setpvn(ST(0), SvPVX_const(sv),
1457             SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0));
1458
1459
1460 STRLEN
1461 SvLEN(sv)
1462         B::PV   sv
1463
1464 STRLEN
1465 SvCUR(sv)
1466         B::PV   sv
1467
1468 MODULE = B      PACKAGE = B::PVMG       PREFIX = Sv
1469
1470 void
1471 SvMAGIC(sv)
1472         B::PVMG sv
1473         MAGIC * mg = NO_INIT
1474     PPCODE:
1475         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1476             XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1477
1478 MODULE = B      PACKAGE = B::PVMG
1479
1480 B::HV
1481 SvSTASH(sv)
1482         B::PVMG sv
1483
1484 #define MgMOREMAGIC(mg) mg->mg_moremagic
1485 #define MgPRIVATE(mg) mg->mg_private
1486 #define MgTYPE(mg) mg->mg_type
1487 #define MgFLAGS(mg) mg->mg_flags
1488 #define MgOBJ(mg) mg->mg_obj
1489 #define MgLENGTH(mg) mg->mg_len
1490 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1491
1492 MODULE = B      PACKAGE = B::MAGIC      PREFIX = Mg
1493
1494 B::MAGIC
1495 MgMOREMAGIC(mg)
1496         B::MAGIC        mg
1497      CODE:
1498         if( MgMOREMAGIC(mg) ) {
1499             RETVAL = MgMOREMAGIC(mg);
1500         }
1501         else {
1502             XSRETURN_UNDEF;
1503         }
1504      OUTPUT:
1505         RETVAL
1506
1507 U16
1508 MgPRIVATE(mg)
1509         B::MAGIC        mg
1510
1511 char
1512 MgTYPE(mg)
1513         B::MAGIC        mg
1514
1515 U8
1516 MgFLAGS(mg)
1517         B::MAGIC        mg
1518
1519 B::SV
1520 MgOBJ(mg)
1521         B::MAGIC        mg
1522
1523 IV
1524 MgREGEX(mg)
1525         B::MAGIC        mg
1526     CODE:
1527         if(mg->mg_type == PERL_MAGIC_qr) {
1528             RETVAL = MgREGEX(mg);
1529         }
1530         else {
1531             croak( "REGEX is only meaningful on r-magic" );
1532         }
1533     OUTPUT:
1534         RETVAL
1535
1536 SV*
1537 precomp(mg)
1538         B::MAGIC        mg
1539     CODE:
1540         if (mg->mg_type == PERL_MAGIC_qr) {
1541             REGEXP* rx = (REGEXP*)mg->mg_obj;
1542             RETVAL = Nullsv;
1543             if( rx )
1544                 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1545         }
1546         else {
1547             croak( "precomp is only meaningful on r-magic" );
1548         }
1549     OUTPUT:
1550         RETVAL
1551
1552 I32
1553 MgLENGTH(mg)
1554         B::MAGIC        mg
1555
1556 void
1557 MgPTR(mg)
1558         B::MAGIC        mg
1559     CODE:
1560         ST(0) = sv_newmortal();
1561         if (mg->mg_ptr){
1562                 if (mg->mg_len >= 0){
1563                         sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1564                 } else if (mg->mg_len == HEf_SVKEY) {
1565                         ST(0) = make_sv_object(aTHX_
1566                                     sv_newmortal(), (SV*)mg->mg_ptr);
1567                 }
1568         }
1569
1570 MODULE = B      PACKAGE = B::PVLV       PREFIX = Lv
1571
1572 U32
1573 LvTARGOFF(sv)
1574         B::PVLV sv
1575
1576 U32
1577 LvTARGLEN(sv)
1578         B::PVLV sv
1579
1580 char
1581 LvTYPE(sv)
1582         B::PVLV sv
1583
1584 B::SV
1585 LvTARG(sv)
1586         B::PVLV sv
1587
1588 MODULE = B      PACKAGE = B::BM         PREFIX = Bm
1589
1590 I32
1591 BmUSEFUL(sv)
1592         B::BM   sv
1593
1594 U32
1595 BmPREVIOUS(sv)
1596         B::BM   sv
1597
1598 U8
1599 BmRARE(sv)
1600         B::BM   sv
1601
1602 void
1603 BmTABLE(sv)
1604         B::BM   sv
1605         STRLEN  len = NO_INIT
1606         char *  str = NO_INIT
1607     CODE:
1608         str = SvPV(sv, len);
1609         /* Boyer-Moore table is just after string and its safety-margin \0 */
1610         ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256));
1611
1612 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1613
1614 void
1615 GvNAME(gv)
1616         B::GV   gv
1617     CODE:
1618         ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1619
1620 bool
1621 is_empty(gv)
1622         B::GV   gv
1623     CODE:
1624         RETVAL = GvGP(gv) == Null(GP*);
1625     OUTPUT:
1626         RETVAL
1627
1628 void*
1629 GvGP(gv)
1630         B::GV   gv
1631
1632 B::HV
1633 GvSTASH(gv)
1634         B::GV   gv
1635
1636 B::SV
1637 GvSV(gv)
1638         B::GV   gv
1639
1640 B::IO
1641 GvIO(gv)
1642         B::GV   gv
1643
1644 B::FM
1645 GvFORM(gv)
1646         B::GV   gv
1647     CODE:
1648         RETVAL = (SV*)GvFORM(gv);
1649     OUTPUT:
1650         RETVAL
1651
1652 B::AV
1653 GvAV(gv)
1654         B::GV   gv
1655
1656 B::HV
1657 GvHV(gv)
1658         B::GV   gv
1659
1660 B::GV
1661 GvEGV(gv)
1662         B::GV   gv
1663
1664 B::CV
1665 GvCV(gv)
1666         B::GV   gv
1667
1668 U32
1669 GvCVGEN(gv)
1670         B::GV   gv
1671
1672 U32
1673 GvLINE(gv)
1674         B::GV   gv
1675
1676 char *
1677 GvFILE(gv)
1678         B::GV   gv
1679
1680 B::GV
1681 GvFILEGV(gv)
1682         B::GV   gv
1683
1684 MODULE = B      PACKAGE = B::GV
1685
1686 U32
1687 GvREFCNT(gv)
1688         B::GV   gv
1689
1690 U8
1691 GvFLAGS(gv)
1692         B::GV   gv
1693
1694 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1695
1696 long
1697 IoLINES(io)
1698         B::IO   io
1699
1700 long
1701 IoPAGE(io)
1702         B::IO   io
1703
1704 long
1705 IoPAGE_LEN(io)
1706         B::IO   io
1707
1708 long
1709 IoLINES_LEFT(io)
1710         B::IO   io
1711
1712 char *
1713 IoTOP_NAME(io)
1714         B::IO   io
1715
1716 B::GV
1717 IoTOP_GV(io)
1718         B::IO   io
1719
1720 char *
1721 IoFMT_NAME(io)
1722         B::IO   io
1723
1724 B::GV
1725 IoFMT_GV(io)
1726         B::IO   io
1727
1728 char *
1729 IoBOTTOM_NAME(io)
1730         B::IO   io
1731
1732 B::GV
1733 IoBOTTOM_GV(io)
1734         B::IO   io
1735
1736 short
1737 IoSUBPROCESS(io)
1738         B::IO   io
1739
1740 bool
1741 IsSTD(io,name)
1742         B::IO   io
1743         const char*     name
1744     PREINIT:
1745         PerlIO* handle = 0;
1746     CODE:
1747         if( strEQ( name, "stdin" ) ) {
1748             handle = PerlIO_stdin();
1749         }
1750         else if( strEQ( name, "stdout" ) ) {
1751             handle = PerlIO_stdout();
1752         }
1753         else if( strEQ( name, "stderr" ) ) {
1754             handle = PerlIO_stderr();
1755         }
1756         else {
1757             croak( "Invalid value '%s'", name );
1758         }
1759         RETVAL = handle == IoIFP(io);
1760     OUTPUT:
1761         RETVAL
1762
1763 MODULE = B      PACKAGE = B::IO
1764
1765 char
1766 IoTYPE(io)
1767         B::IO   io
1768
1769 U8
1770 IoFLAGS(io)
1771         B::IO   io
1772
1773 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1774
1775 SSize_t
1776 AvFILL(av)
1777         B::AV   av
1778
1779 SSize_t
1780 AvMAX(av)
1781         B::AV   av
1782
1783 #if PERL_VERSION < 9
1784
1785
1786 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1787
1788 IV
1789 AvOFF(av)
1790         B::AV   av
1791
1792 #endif
1793
1794 void
1795 AvARRAY(av)
1796         B::AV   av
1797     PPCODE:
1798         if (AvFILL(av) >= 0) {
1799             SV **svp = AvARRAY(av);
1800             I32 i;
1801             for (i = 0; i <= AvFILL(av); i++)
1802                 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1803         }
1804
1805 void
1806 AvARRAYelt(av, idx)
1807         B::AV   av
1808         int     idx
1809     PPCODE:
1810         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1811             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1812         else
1813             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1814
1815 #if PERL_VERSION < 9
1816
1817 MODULE = B      PACKAGE = B::AV
1818
1819 U8
1820 AvFLAGS(av)
1821         B::AV   av
1822
1823 #endif
1824
1825 MODULE = B      PACKAGE = B::FM         PREFIX = Fm
1826
1827 IV
1828 FmLINES(form)
1829         B::FM   form
1830
1831 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1832
1833 U32
1834 CvCONST(cv)
1835         B::CV   cv
1836
1837 B::HV
1838 CvSTASH(cv)
1839         B::CV   cv
1840
1841 B::OP
1842 CvSTART(cv)
1843         B::CV   cv
1844     CODE:
1845         RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1846     OUTPUT:
1847         RETVAL
1848
1849 B::OP
1850 CvROOT(cv)
1851         B::CV   cv
1852     CODE:
1853         RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1854     OUTPUT:
1855         RETVAL
1856
1857 B::GV
1858 CvGV(cv)
1859         B::CV   cv
1860
1861 char *
1862 CvFILE(cv)
1863         B::CV   cv
1864
1865 long
1866 CvDEPTH(cv)
1867         B::CV   cv
1868
1869 B::AV
1870 CvPADLIST(cv)
1871         B::CV   cv
1872
1873 B::CV
1874 CvOUTSIDE(cv)
1875         B::CV   cv
1876
1877 U32
1878 CvOUTSIDE_SEQ(cv)
1879         B::CV   cv
1880
1881 void
1882 CvXSUB(cv)
1883         B::CV   cv
1884     CODE:
1885         ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
1886
1887
1888 void
1889 CvXSUBANY(cv)
1890         B::CV   cv
1891     CODE:
1892         ST(0) = CvCONST(cv) ?
1893             make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
1894             sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
1895
1896 MODULE = B    PACKAGE = B::CV
1897
1898 U16
1899 CvFLAGS(cv)
1900       B::CV   cv
1901
1902 MODULE = B      PACKAGE = B::CV         PREFIX = cv_
1903
1904 B::SV
1905 cv_const_sv(cv)
1906         B::CV   cv
1907
1908
1909 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1910
1911 STRLEN
1912 HvFILL(hv)
1913         B::HV   hv
1914
1915 STRLEN
1916 HvMAX(hv)
1917         B::HV   hv
1918
1919 I32
1920 HvKEYS(hv)
1921         B::HV   hv
1922
1923 I32
1924 HvRITER(hv)
1925         B::HV   hv
1926
1927 char *
1928 HvNAME(hv)
1929         B::HV   hv
1930
1931 #if PERL_VERSION < 9
1932
1933 B::PMOP
1934 HvPMROOT(hv)
1935         B::HV   hv
1936
1937 #endif
1938
1939 void
1940 HvARRAY(hv)
1941         B::HV   hv
1942     PPCODE:
1943         if (HvKEYS(hv) > 0) {
1944             SV *sv;
1945             char *key;
1946             I32 len;
1947             (void)hv_iterinit(hv);
1948             EXTEND(sp, HvKEYS(hv) * 2);
1949             while ((sv = hv_iternextsv(hv, &key, &len))) {
1950                 PUSHs(newSVpvn(key, len));
1951                 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
1952             }
1953         }
1954
1955 MODULE = B      PACKAGE = B::HE         PREFIX = He
1956
1957 B::SV
1958 HeVAL(he)
1959         B::HE he
1960
1961 U32
1962 HeHASH(he)
1963         B::HE he
1964
1965 B::SV
1966 HeSVKEY_force(he)
1967         B::HE he
1968
1969 MODULE = B      PACKAGE = B::RHE        PREFIX = RHE_
1970
1971 #if PERL_VERSION >= 9
1972
1973 SV*
1974 RHE_HASH(h)
1975         B::RHE h
1976     CODE:
1977         RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );
1978     OUTPUT:
1979         RETVAL
1980
1981 #endif