ext/B/B.xs

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