ext/B/B.xs

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