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