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 char *svclassnames[] = {
  23     "B::NULL",
  24     "B::IV",
  25     "B::NV",
  26     "B::RV",
  27     "B::PV",
  28     "B::PVIV",
  29     "B::PVNV",
  30     "B::PVMG",
  31     "B::BM",
  32     "B::PVLV",
  33     "B::AV",
  34     "B::HV",
  35     "B::CV",
  36     "B::GV",
  37     "B::FM",
  38     "B::IO",
  39 };
  40
  41 typedef enum {
  42     OPc_NULL,   /* 0 */
  43     OPc_BASEOP, /* 1 */
  44     OPc_UNOP,   /* 2 */
  45     OPc_BINOP,  /* 3 */
  46     OPc_LOGOP,  /* 4 */
  47     OPc_LISTOP, /* 5 */
  48     OPc_PMOP,   /* 6 */
  49     OPc_SVOP,   /* 7 */
  50     OPc_PADOP,  /* 8 */
  51     OPc_PVOP,   /* 9 */
  52     OPc_CVOP,   /* 10 */
  53     OPc_LOOP,   /* 11 */
  54     OPc_COP     /* 12 */
  55 } opclass;
  56
  57 static char *opclassnames[] = {
  58     "B::NULL",
  59     "B::OP",
  60     "B::UNOP",
  61     "B::BINOP",
  62     "B::LOGOP",
  63     "B::LISTOP",
  64     "B::PMOP",
  65     "B::SVOP",
  66     "B::PADOP",
  67     "B::PVOP",
  68     "B::CVOP",
  69     "B::LOOP",
  70     "B::COP"
  71 };
  72
  73 #define MY_CXT_KEY "B::_guts" XS_VERSION
  74
  75 typedef struct {
  76     int         x_walkoptree_debug;     /* Flag for walkoptree debug hook */
  77     SV *        x_specialsv_list[7];
  78 } my_cxt_t;
  79
  80 START_MY_CXT
  81
  82 #define walkoptree_debug        (MY_CXT.x_walkoptree_debug)
  83 #define specialsv_list          (MY_CXT.x_specialsv_list)
  84
  85 static opclass
  86 cc_opclass(pTHX_ OP *o)
  87 {
  88     if (!o)
  89         return OPc_NULL;
  90
  91     if (o->op_type == 0)
  92         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
  93
  94     if (o->op_type == OP_SASSIGN)
  95         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
  96
  97 #ifdef USE_ITHREADS
  98     if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
  99         o->op_type == OP_AELEMFAST || o->op_type == OP_RCATLINE)
 100         return OPc_PADOP;
 101 #endif
 102
 103     switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 104     case OA_BASEOP:
 105         return OPc_BASEOP;
 106
 107     case OA_UNOP:
 108         return OPc_UNOP;
 109
 110     case OA_BINOP:
 111         return OPc_BINOP;
 112
 113     case OA_LOGOP:
 114         return OPc_LOGOP;
 115
 116     case OA_LISTOP:
 117         return OPc_LISTOP;
 118
 119     case OA_PMOP:
 120         return OPc_PMOP;
 121
 122     case OA_SVOP:
 123         return OPc_SVOP;
 124
 125     case OA_PADOP:
 126         return OPc_PADOP;
 127
 128     case OA_PVOP_OR_SVOP:
 129         /*
 130          * Character translations (tr///) are usually a PVOP, keeping a
 131          * pointer to a table of shorts used to look up translations.
 132          * Under utf8, however, a simple table isn't practical; instead,
 133          * the OP is an SVOP, and the SV is a reference to a swash
 134          * (i.e., an RV pointing to an HV).
 135          */
 136         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 137                 ? OPc_SVOP : OPc_PVOP;
 138
 139     case OA_LOOP:
 140         return OPc_LOOP;
 141
 142     case OA_COP:
 143         return OPc_COP;
 144
 145     case OA_BASEOP_OR_UNOP:
 146         /*
 147          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 148          * whether parens were seen. perly.y uses OPf_SPECIAL to
 149          * signal whether a BASEOP had empty parens or none.
 150          * Some other UNOPs are created later, though, so the best
 151          * test is OPf_KIDS, which is set in newUNOP.
 152          */
 153         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 154
 155     case OA_FILESTATOP:
 156         /*
 157          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 158          * the OPf_REF flag to distinguish between OP types instead of the
 159          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 160          * return OPc_UNOP so that walkoptree can find our children. If
 161          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 162          * (no argument to the operator) it's an OP; with OPf_REF set it's
 163          * an SVOP (and op_sv is the GV for the filehandle argument).
 164          */
 165         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 166 #ifdef USE_ITHREADS
 167                 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 168 #else
 169                 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 170 #endif
 171     case OA_LOOPEXOP:
 172         /*
 173          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 174          * label was omitted (in which case it's a BASEOP) or else a term was
 175          * seen. In this last case, all except goto are definitely PVOP but
 176          * goto is either a PVOP (with an ordinary constant label), an UNOP
 177          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 178          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 179          * get set.
 180          */
 181         if (o->op_flags & OPf_STACKED)
 182             return OPc_UNOP;
 183         else if (o->op_flags & OPf_SPECIAL)
 184             return OPc_BASEOP;
 185         else
 186             return OPc_PVOP;
 187     }
 188     warn("can't determine class of operator %s, assuming BASEOP\n",
 189          PL_op_name[o->op_type]);
 190     return OPc_BASEOP;
 191 }
 192
 193 static char *
 194 cc_opclassname(pTHX_ OP *o)
 195 {
 196     return opclassnames[cc_opclass(aTHX_ o)];
 197 }
 198
 199 static SV *
 200 make_sv_object(pTHX_ SV *arg, SV *sv)
 201 {
 202     char *type = 0;
 203     IV iv;
 204     dMY_CXT;
 205
 206     for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
 207         if (sv == specialsv_list[iv]) {
 208             type = "B::SPECIAL";
 209             break;
 210         }
 211     }
 212     if (!type) {
 213         type = svclassnames[SvTYPE(sv)];
 214         iv = PTR2IV(sv);
 215     }
 216     sv_setiv(newSVrv(arg, type), iv);
 217     return arg;
 218 }
 219
 220 static SV *
 221 make_mg_object(pTHX_ SV *arg, MAGIC *mg)
 222 {
 223     sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
 224     return arg;
 225 }
 226
 227 static SV *
 228 cstring(pTHX_ SV *sv, bool perlstyle)
 229 {
 230     SV *sstr = newSVpvn("", 0);
 231     STRLEN len;
 232     char *s;
 233     char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
 234
 235     if (!SvOK(sv))
 236         sv_setpvn(sstr, "0", 1);
 237     else if (perlstyle && SvUTF8(sv))
 238     {
 239         SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
 240         len = SvCUR(sv);
 241         s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
 242         sv_setpv(sstr,"\"");
 243         while (*s)
 244         {
 245             if (*s == '"')
 246                 sv_catpv(sstr, "\\\"");
 247             else if (*s == '$')
 248                 sv_catpv(sstr, "\\$");
 249             else if (*s == '@')
 250                 sv_catpv(sstr, "\\@");
 251             else if (*s == '\\')
 252             {
 253                 if (strchr("nrftax\\",*(s+1)))
 254                     sv_catpvn(sstr, s++, 2);
 255                 else
 256                     sv_catpv(sstr, "\\\\");
 257             }
 258             else /* should always be printable */
 259                 sv_catpvn(sstr, s, 1);
 260             ++s;
 261         }
 262         sv_catpv(sstr, "\"");
 263         return sstr;
 264     }
 265     else
 266     {
 267         /* XXX Optimise? */
 268         s = SvPV(sv, len);
 269         sv_catpv(sstr, "\"");
 270         for (; len; len--, s++)
 271         {
 272             /* At least try a little for readability */
 273             if (*s == '"')
 274                 sv_catpv(sstr, "\\\"");
 275             else if (*s == '\\')
 276                 sv_catpv(sstr, "\\\\");
 277             /* trigraphs - bleagh */
 278             else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?')
 279             {
 280                 sprintf(escbuff, "\\%03o", '?');
 281                 sv_catpv(sstr, escbuff);
 282             }
 283             else if (perlstyle && *s == '$')
 284                 sv_catpv(sstr, "\\$");
 285             else if (perlstyle && *s == '@')
 286                 sv_catpv(sstr, "\\@");
 287 #ifdef EBCDIC
 288             else if (isPRINT(*s))
 289 #else
 290             else if (*s >= ' ' && *s < 127)
 291 #endif /* EBCDIC */
 292                 sv_catpvn(sstr, s, 1);
 293             else if (*s == '\n')
 294                 sv_catpv(sstr, "\\n");
 295             else if (*s == '\r')
 296                 sv_catpv(sstr, "\\r");
 297             else if (*s == '\t')
 298                 sv_catpv(sstr, "\\t");
 299             else if (*s == '\a')
 300                 sv_catpv(sstr, "\\a");
 301             else if (*s == '\b')
 302                 sv_catpv(sstr, "\\b");
 303             else if (*s == '\f')
 304                 sv_catpv(sstr, "\\f");
 305             else if (!perlstyle && *s == '\v')
 306                 sv_catpv(sstr, "\\v");
 307             else
 308             {
 309                 /* Don't want promotion of a signed -1 char in sprintf args */
 310                 unsigned char c = (unsigned char) *s;
 311                 sprintf(escbuff, "\\%03o", c);
 312                 sv_catpv(sstr, escbuff);
 313             }
 314             /* XXX Add line breaks if string is long */
 315         }
 316         sv_catpv(sstr, "\"");
 317     }
 318     return sstr;
 319 }
 320
 321 static SV *
 322 cchar(pTHX_ SV *sv)
 323 {
 324     SV *sstr = newSVpvn("'", 1);
 325     STRLEN n_a;
 326     char *s = SvPV(sv, n_a);
 327
 328     if (*s == '\'')
 329         sv_catpv(sstr, "\\'");
 330     else if (*s == '\\')
 331         sv_catpv(sstr, "\\\\");
 332 #ifdef EBCDIC
 333     else if (isPRINT(*s))
 334 #else
 335     else if (*s >= ' ' && *s < 127)
 336 #endif /* EBCDIC */
 337         sv_catpvn(sstr, s, 1);
 338     else if (*s == '\n')
 339         sv_catpv(sstr, "\\n");
 340     else if (*s == '\r')
 341         sv_catpv(sstr, "\\r");
 342     else if (*s == '\t')
 343         sv_catpv(sstr, "\\t");
 344     else if (*s == '\a')
 345         sv_catpv(sstr, "\\a");
 346     else if (*s == '\b')
 347         sv_catpv(sstr, "\\b");
 348     else if (*s == '\f')
 349         sv_catpv(sstr, "\\f");
 350     else if (*s == '\v')
 351         sv_catpv(sstr, "\\v");
 352     else
 353     {
 354         /* no trigraph support */
 355         char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
 356         /* Don't want promotion of a signed -1 char in sprintf args */
 357         unsigned char c = (unsigned char) *s;
 358         sprintf(escbuff, "\\%03o", c);
 359         sv_catpv(sstr, escbuff);
 360     }
 361     sv_catpv(sstr, "'");
 362     return sstr;
 363 }
 364
 365 void
 366 walkoptree(pTHX_ SV *opsv, char *method)
 367 {
 368     dSP;
 369     OP *o, *kid;
 370     dMY_CXT;
 371
 372     if (!SvROK(opsv))
 373         croak("opsv is not a reference");
 374     opsv = sv_mortalcopy(opsv);
 375     o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
 376     if (walkoptree_debug) {
 377         PUSHMARK(sp);
 378         XPUSHs(opsv);
 379         PUTBACK;
 380         perl_call_method("walkoptree_debug", G_DISCARD);
 381     }
 382     PUSHMARK(sp);
 383     XPUSHs(opsv);
 384     PUTBACK;
 385     perl_call_method(method, G_DISCARD);
 386     if (o && (o->op_flags & OPf_KIDS)) {
 387         for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
 388             /* Use the same opsv. Rely on methods not to mess it up. */
 389             sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
 390             walkoptree(aTHX_ opsv, method);
 391         }
 392     }
 393     if (o && (cc_opclass(aTHX_ o) == OPc_PMOP)
 394             && (kid = cPMOPo->op_pmreplroot))
 395     {
 396         sv_setiv(newSVrv(opsv, opclassnames[OPc_PMOP]), PTR2IV(kid));
 397         walkoptree(aTHX_ opsv, method);
 398     }
 399 }
 400
 401 typedef OP      *B__OP;
 402 typedef UNOP    *B__UNOP;
 403 typedef BINOP   *B__BINOP;
 404 typedef LOGOP   *B__LOGOP;
 405 typedef LISTOP  *B__LISTOP;
 406 typedef PMOP    *B__PMOP;
 407 typedef SVOP    *B__SVOP;
 408 typedef PADOP   *B__PADOP;
 409 typedef PVOP    *B__PVOP;
 410 typedef LOOP    *B__LOOP;
 411 typedef COP     *B__COP;
 412
 413 typedef SV      *B__SV;
 414 typedef SV      *B__IV;
 415 typedef SV      *B__PV;
 416 typedef SV      *B__NV;
 417 typedef SV      *B__PVMG;
 418 typedef SV      *B__PVLV;
 419 typedef SV      *B__BM;
 420 typedef SV      *B__RV;
 421 typedef AV      *B__AV;
 422 typedef HV      *B__HV;
 423 typedef CV      *B__CV;
 424 typedef GV      *B__GV;
 425 typedef IO      *B__IO;
 426
 427 typedef MAGIC   *B__MAGIC;
 428
 429 MODULE = B      PACKAGE = B     PREFIX = B_
 430
 431 PROTOTYPES: DISABLE
 432
 433 BOOT:
 434 {
 435     HV *stash = gv_stashpvn("B", 1, TRUE);
 436     AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
 437     MY_CXT_INIT;
 438     specialsv_list[0] = Nullsv;
 439     specialsv_list[1] = &PL_sv_undef;
 440     specialsv_list[2] = &PL_sv_yes;
 441     specialsv_list[3] = &PL_sv_no;
 442     specialsv_list[4] = pWARN_ALL;
 443     specialsv_list[5] = pWARN_NONE;
 444     specialsv_list[6] = pWARN_STD;
 445 #include "defsubs.h"
 446 }
 447
 448 #define B_main_cv()     PL_main_cv
 449 #define B_init_av()     PL_initav
 450 #define B_check_av()    PL_checkav_save
 451 #define B_begin_av()    PL_beginav_save
 452 #define B_end_av()      PL_endav
 453 #define B_main_root()   PL_main_root
 454 #define B_main_start()  PL_main_start
 455 #define B_amagic_generation()   PL_amagic_generation
 456 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
 457 #define B_sv_undef()    &PL_sv_undef
 458 #define B_sv_yes()      &PL_sv_yes
 459 #define B_sv_no()       &PL_sv_no
 460 #ifdef USE_ITHREADS
 461 #define B_regex_padav() PL_regex_padav
 462 #endif
 463
 464 B::AV
 465 B_init_av()
 466
 467 B::AV
 468 B_check_av()
 469
 470 B::AV
 471 B_begin_av()
 472
 473 B::AV
 474 B_end_av()
 475
 476 #ifdef USE_ITHREADS
 477
 478 B::AV
 479 B_regex_padav()
 480
 481 #endif
 482
 483 B::CV
 484 B_main_cv()
 485
 486 B::OP
 487 B_main_root()
 488
 489 B::OP
 490 B_main_start()
 491
 492 long
 493 B_amagic_generation()
 494
 495 B::AV
 496 B_comppadlist()
 497
 498 B::SV
 499 B_sv_undef()
 500
 501 B::SV
 502 B_sv_yes()
 503
 504 B::SV
 505 B_sv_no()
 506
 507 MODULE = B      PACKAGE = B
 508
 509
 510 void
 511 walkoptree(opsv, method)
 512         SV *    opsv
 513         char *  method
 514     CODE:
 515         walkoptree(aTHX_ opsv, method);
 516
 517 int
 518 walkoptree_debug(...)
 519     CODE:
 520         dMY_CXT;
 521         RETVAL = walkoptree_debug;
 522         if (items > 0 && SvTRUE(ST(1)))
 523             walkoptree_debug = 1;
 524     OUTPUT:
 525         RETVAL
 526
 527 #define address(sv) PTR2IV(sv)
 528
 529 IV
 530 address(sv)
 531         SV *    sv
 532
 533 B::SV
 534 svref_2object(sv)
 535         SV *    sv
 536     CODE:
 537         if (!SvROK(sv))
 538             croak("argument is not a reference");
 539         RETVAL = (SV*)SvRV(sv);
 540     OUTPUT:
 541         RETVAL
 542
 543 void
 544 opnumber(name)
 545 char *  name
 546 CODE:
 547 {
 548  int i;
 549  IV  result = -1;
 550  ST(0) = sv_newmortal();
 551  if (strncmp(name,"pp_",3) == 0)
 552    name += 3;
 553  for (i = 0; i < PL_maxo; i++)
 554   {
 555    if (strcmp(name, PL_op_name[i]) == 0)
 556     {
 557      result = i;
 558      break;
 559     }
 560   }
 561  sv_setiv(ST(0),result);
 562 }
 563
 564 void
 565 ppname(opnum)
 566         int     opnum
 567     CODE:
 568         ST(0) = sv_newmortal();
 569         if (opnum >= 0 && opnum < PL_maxo) {
 570             sv_setpvn(ST(0), "pp_", 3);
 571             sv_catpv(ST(0), PL_op_name[opnum]);
 572         }
 573
 574 void
 575 hash(sv)
 576         SV *    sv
 577     CODE:
 578         char *s;
 579         STRLEN len;
 580         U32 hash = 0;
 581         char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
 582         s = SvPV(sv, len);
 583         PERL_HASH(hash, s, len);
 584         sprintf(hexhash, "0x%"UVxf, (UV)hash);
 585         ST(0) = sv_2mortal(newSVpv(hexhash, 0));
 586
 587 #define cast_I32(foo) (I32)foo
 588 IV
 589 cast_I32(i)
 590         IV      i
 591
 592 void
 593 minus_c()
 594     CODE:
 595         PL_minus_c = TRUE;
 596
 597 void
 598 save_BEGINs()
 599     CODE:
 600         PL_savebegin = TRUE;
 601
 602 SV *
 603 cstring(sv)
 604         SV *    sv
 605     CODE:
 606         RETVAL = cstring(aTHX_ sv, 0);
 607     OUTPUT:
 608         RETVAL
 609
 610 SV *
 611 perlstring(sv)
 612         SV *    sv
 613     CODE:
 614         RETVAL = cstring(aTHX_ sv, 1);
 615     OUTPUT:
 616         RETVAL
 617
 618 SV *
 619 cchar(sv)
 620         SV *    sv
 621     CODE:
 622         RETVAL = cchar(aTHX_ sv);
 623     OUTPUT:
 624         RETVAL
 625
 626 void
 627 threadsv_names()
 628     PPCODE:
 629
 630
 631 #define OP_next(o)      o->op_next
 632 #define OP_sibling(o)   o->op_sibling
 633 #define OP_desc(o)      PL_op_desc[o->op_type]
 634 #define OP_targ(o)      o->op_targ
 635 #define OP_type(o)      o->op_type
 636 #define OP_seq(o)       o->op_seq
 637 #define OP_flags(o)     o->op_flags
 638 #define OP_private(o)   o->op_private
 639
 640 MODULE = B      PACKAGE = B::OP         PREFIX = OP_
 641
 642 B::OP
 643 OP_next(o)
 644         B::OP           o
 645
 646 B::OP
 647 OP_sibling(o)
 648         B::OP           o
 649
 650 char *
 651 OP_name(o)
 652         B::OP           o
 653     CODE:
 654         RETVAL = PL_op_name[o->op_type];
 655     OUTPUT:
 656         RETVAL
 657
 658
 659 void
 660 OP_ppaddr(o)
 661         B::OP           o
 662     PREINIT:
 663         int i;
 664         SV *sv = sv_newmortal();
 665     CODE:
 666         sv_setpvn(sv, "PL_ppaddr[OP_", 13);
 667         sv_catpv(sv, PL_op_name[o->op_type]);
 668         for (i=13; (STRLEN)i < SvCUR(sv); ++i)
 669             SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
 670         sv_catpv(sv, "]");
 671         ST(0) = sv;
 672
 673 char *
 674 OP_desc(o)
 675         B::OP           o
 676
 677 PADOFFSET
 678 OP_targ(o)
 679         B::OP           o
 680
 681 U16
 682 OP_type(o)
 683         B::OP           o
 684
 685 U16
 686 OP_seq(o)
 687         B::OP           o
 688
 689 U8
 690 OP_flags(o)
 691         B::OP           o
 692
 693 U8
 694 OP_private(o)
 695         B::OP           o
 696
 697 #define UNOP_first(o)   o->op_first
 698
 699 MODULE = B      PACKAGE = B::UNOP               PREFIX = UNOP_
 700
 701 B::OP
 702 UNOP_first(o)
 703         B::UNOP o
 704
 705 #define BINOP_last(o)   o->op_last
 706
 707 MODULE = B      PACKAGE = B::BINOP              PREFIX = BINOP_
 708
 709 B::OP
 710 BINOP_last(o)
 711         B::BINOP        o
 712
 713 #define LOGOP_other(o)  o->op_other
 714
 715 MODULE = B      PACKAGE = B::LOGOP              PREFIX = LOGOP_
 716
 717 B::OP
 718 LOGOP_other(o)
 719         B::LOGOP        o
 720
 721 MODULE = B      PACKAGE = B::LISTOP             PREFIX = LISTOP_
 722
 723 U32
 724 LISTOP_children(o)
 725         B::LISTOP       o
 726         OP *            kid = NO_INIT
 727         int             i = NO_INIT
 728     CODE:
 729         i = 0;
 730         for (kid = o->op_first; kid; kid = kid->op_sibling)
 731             i++;
 732         RETVAL = i;
 733     OUTPUT:
 734         RETVAL
 735
 736 #define PMOP_pmreplroot(o)      o->op_pmreplroot
 737 #define PMOP_pmreplstart(o)     o->op_pmreplstart
 738 #define PMOP_pmnext(o)          o->op_pmnext
 739 #define PMOP_pmregexp(o)        PM_GETRE(o)
 740 #ifdef USE_ITHREADS
 741 #define PMOP_pmoffset(o)        o->op_pmoffset
 742 #endif
 743 #define PMOP_pmflags(o)         o->op_pmflags
 744 #define PMOP_pmpermflags(o)     o->op_pmpermflags
 745 #define PMOP_pmdynflags(o)      o->op_pmdynflags
 746
 747 MODULE = B      PACKAGE = B::PMOP               PREFIX = PMOP_
 748
 749 void
 750 PMOP_pmreplroot(o)
 751         B::PMOP         o
 752         OP *            root = NO_INIT
 753     CODE:
 754         ST(0) = sv_newmortal();
 755         root = o->op_pmreplroot;
 756         /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
 757         if (o->op_type == OP_PUSHRE) {
 758 #ifdef USE_ITHREADS
 759             sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
 760 #else
 761             sv_setiv(newSVrv(ST(0), root ?
 762                              svclassnames[SvTYPE((SV*)root)] : "B::SV"),
 763                      PTR2IV(root));
 764 #endif
 765         }
 766         else {
 767             sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
 768         }
 769
 770 B::OP
 771 PMOP_pmreplstart(o)
 772         B::PMOP         o
 773
 774 B::PMOP
 775 PMOP_pmnext(o)
 776         B::PMOP         o
 777
 778 #ifdef USE_ITHREADS
 779
 780 IV
 781 PMOP_pmoffset(o)
 782         B::PMOP         o
 783
 784 #endif
 785
 786 U32
 787 PMOP_pmflags(o)
 788         B::PMOP         o
 789
 790 U32
 791 PMOP_pmpermflags(o)
 792         B::PMOP         o
 793
 794 U8
 795 PMOP_pmdynflags(o)
 796         B::PMOP         o
 797
 798 void
 799 PMOP_precomp(o)
 800         B::PMOP         o
 801         REGEXP *        rx = NO_INIT
 802     CODE:
 803         ST(0) = sv_newmortal();
 804         rx = PM_GETRE(o);
 805         if (rx)
 806             sv_setpvn(ST(0), rx->precomp, rx->prelen);
 807
 808 #define SVOP_sv(o)     cSVOPo->op_sv
 809 #define SVOP_gv(o)     ((GV*)cSVOPo->op_sv)
 810
 811 MODULE = B      PACKAGE = B::SVOP               PREFIX = SVOP_
 812
 813 B::SV
 814 SVOP_sv(o)
 815         B::SVOP o
 816
 817 B::GV
 818 SVOP_gv(o)
 819         B::SVOP o
 820
 821 #define PADOP_padix(o)  o->op_padix
 822 #define PADOP_sv(o)     (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
 823 #define PADOP_gv(o)     ((o->op_padix \
 824                           && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
 825                          ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
 826
 827 MODULE = B      PACKAGE = B::PADOP              PREFIX = PADOP_
 828
 829 PADOFFSET
 830 PADOP_padix(o)
 831         B::PADOP o
 832
 833 B::SV
 834 PADOP_sv(o)
 835         B::PADOP o
 836
 837 B::GV
 838 PADOP_gv(o)
 839         B::PADOP o
 840
 841 MODULE = B      PACKAGE = B::PVOP               PREFIX = PVOP_
 842
 843 void
 844 PVOP_pv(o)
 845         B::PVOP o
 846     CODE:
 847         /*
 848          * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
 849          * whereas other PVOPs point to a null terminated string.
 850          */
 851         if (o->op_type == OP_TRANS &&
 852                 (o->op_private & OPpTRANS_COMPLEMENT) &&
 853                 !(o->op_private & OPpTRANS_DELETE))
 854         {
 855             short* tbl = (short*)o->op_pv;
 856             short entries = 257 + tbl[256];
 857             ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
 858         }
 859         else if (o->op_type == OP_TRANS) {
 860             ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
 861         }
 862         else
 863             ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
 864
 865 #define LOOP_redoop(o)  o->op_redoop
 866 #define LOOP_nextop(o)  o->op_nextop
 867 #define LOOP_lastop(o)  o->op_lastop
 868
 869 MODULE = B      PACKAGE = B::LOOP               PREFIX = LOOP_
 870
 871
 872 B::OP
 873 LOOP_redoop(o)
 874         B::LOOP o
 875
 876 B::OP
 877 LOOP_nextop(o)
 878         B::LOOP o
 879
 880 B::OP
 881 LOOP_lastop(o)
 882         B::LOOP o
 883
 884 #define COP_label(o)    o->cop_label
 885 #define COP_stashpv(o)  CopSTASHPV(o)
 886 #define COP_stash(o)    CopSTASH(o)
 887 #define COP_file(o)     CopFILE(o)
 888 #define COP_cop_seq(o)  o->cop_seq
 889 #define COP_arybase(o)  o->cop_arybase
 890 #define COP_line(o)     CopLINE(o)
 891 #define COP_warnings(o) o->cop_warnings
 892 #define COP_io(o)       o->cop_io
 893
 894 MODULE = B      PACKAGE = B::COP                PREFIX = COP_
 895
 896 char *
 897 COP_label(o)
 898         B::COP  o
 899
 900 char *
 901 COP_stashpv(o)
 902         B::COP  o
 903
 904 B::HV
 905 COP_stash(o)
 906         B::COP  o
 907
 908 char *
 909 COP_file(o)
 910         B::COP  o
 911
 912 U32
 913 COP_cop_seq(o)
 914         B::COP  o
 915
 916 I32
 917 COP_arybase(o)
 918         B::COP  o
 919
 920 U16
 921 COP_line(o)
 922         B::COP  o
 923
 924 B::SV
 925 COP_warnings(o)
 926         B::COP  o
 927
 928 B::SV
 929 COP_io(o)
 930         B::COP  o
 931
 932 MODULE = B      PACKAGE = B::SV         PREFIX = Sv
 933
 934 U32
 935 SvREFCNT(sv)
 936         B::SV   sv
 937
 938 U32
 939 SvFLAGS(sv)
 940         B::SV   sv
 941
 942 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
 943
 944 IV
 945 SvIV(sv)
 946         B::IV   sv
 947
 948 IV
 949 SvIVX(sv)
 950         B::IV   sv
 951
 952 UV
 953 SvUVX(sv)
 954         B::IV   sv
 955
 956
 957 MODULE = B      PACKAGE = B::IV
 958
 959 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
 960
 961 int
 962 needs64bits(sv)
 963         B::IV   sv
 964
 965 void
 966 packiv(sv)
 967         B::IV   sv
 968     CODE:
 969         if (sizeof(IV) == 8) {
 970             U32 wp[2];
 971             IV iv = SvIVX(sv);
 972             /*
 973              * The following way of spelling 32 is to stop compilers on
 974              * 32-bit architectures from moaning about the shift count
 975              * being >= the width of the type. Such architectures don't
 976              * reach this code anyway (unless sizeof(IV) > 8 but then
 977              * everything else breaks too so I'm not fussed at the moment).
 978              */
 979 #ifdef UV_IS_QUAD
 980             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
 981 #else
 982             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
 983 #endif
 984             wp[1] = htonl(iv & 0xffffffff);
 985             ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
 986         } else {
 987             U32 w = htonl((U32)SvIVX(sv));
 988             ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
 989         }
 990
 991 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
 992
 993 NV
 994 SvNV(sv)
 995         B::NV   sv
 996
 997 NV
 998 SvNVX(sv)
 999         B::NV   sv
1000
1001 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1002
1003 B::SV
1004 SvRV(sv)
1005         B::RV   sv
1006
1007 MODULE = B      PACKAGE = B::PV         PREFIX = Sv
1008
1009 char*
1010 SvPVX(sv)
1011         B::PV   sv
1012
1013 B::SV
1014 SvRV(sv)
1015         B::PV   sv
1016     CODE:
1017         if( SvROK(sv) ) {
1018             RETVAL = SvRV(sv);
1019         }
1020         else {
1021             croak( "argument is not SvROK" );
1022         }
1023     OUTPUT:
1024         RETVAL
1025
1026 void
1027 SvPV(sv)
1028         B::PV   sv
1029     CODE:
1030         ST(0) = sv_newmortal();
1031         if( SvPOK(sv) ) {
1032             sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
1033             SvFLAGS(ST(0)) |= SvUTF8(sv);
1034         }
1035         else {
1036             /* XXX for backward compatibility, but should fail */
1037             /* croak( "argument is not SvPOK" ); */
1038             sv_setpvn(ST(0), NULL, 0);
1039         }
1040
1041 STRLEN
1042 SvLEN(sv)
1043         B::PV   sv
1044
1045 STRLEN
1046 SvCUR(sv)
1047         B::PV   sv
1048
1049 MODULE = B      PACKAGE = B::PVMG       PREFIX = Sv
1050
1051 void
1052 SvMAGIC(sv)
1053         B::PVMG sv
1054         MAGIC * mg = NO_INIT
1055     PPCODE:
1056         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1057             XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1058
1059 MODULE = B      PACKAGE = B::PVMG
1060
1061 B::HV
1062 SvSTASH(sv)
1063         B::PVMG sv
1064
1065 #define MgMOREMAGIC(mg) mg->mg_moremagic
1066 #define MgPRIVATE(mg) mg->mg_private
1067 #define MgTYPE(mg) mg->mg_type
1068 #define MgFLAGS(mg) mg->mg_flags
1069 #define MgOBJ(mg) mg->mg_obj
1070 #define MgLENGTH(mg) mg->mg_len
1071 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1072
1073 MODULE = B      PACKAGE = B::MAGIC      PREFIX = Mg
1074
1075 B::MAGIC
1076 MgMOREMAGIC(mg)
1077         B::MAGIC        mg
1078      CODE:
1079         if( MgMOREMAGIC(mg) ) {
1080             RETVAL = MgMOREMAGIC(mg);
1081         }
1082         else {
1083             XSRETURN_UNDEF;
1084         }
1085      OUTPUT:
1086         RETVAL
1087
1088 U16
1089 MgPRIVATE(mg)
1090         B::MAGIC        mg
1091
1092 char
1093 MgTYPE(mg)
1094         B::MAGIC        mg
1095
1096 U8
1097 MgFLAGS(mg)
1098         B::MAGIC        mg
1099
1100 B::SV
1101 MgOBJ(mg)
1102         B::MAGIC        mg
1103     CODE:
1104         if( mg->mg_type != 'r' ) {
1105             RETVAL = MgOBJ(mg);
1106         }
1107         else {
1108             croak( "OBJ is not meaningful on r-magic" );
1109         }
1110     OUTPUT:
1111         RETVAL
1112
1113 IV
1114 MgREGEX(mg)
1115         B::MAGIC        mg
1116     CODE:
1117         if( mg->mg_type == 'r' ) {
1118             RETVAL = MgREGEX(mg);
1119         }
1120         else {
1121             croak( "REGEX is only meaningful on r-magic" );
1122         }
1123     OUTPUT:
1124         RETVAL
1125
1126 SV*
1127 precomp(mg)
1128         B::MAGIC        mg
1129     CODE:
1130         if (mg->mg_type == 'r') {
1131             REGEXP* rx = (REGEXP*)mg->mg_obj;
1132             if( rx )
1133                 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1134         }
1135         else {
1136             croak( "precomp is only meaningful on r-magic" );
1137         }
1138     OUTPUT:
1139         RETVAL
1140
1141 I32
1142 MgLENGTH(mg)
1143         B::MAGIC        mg
1144
1145 void
1146 MgPTR(mg)
1147         B::MAGIC        mg
1148     CODE:
1149         ST(0) = sv_newmortal();
1150         if (mg->mg_ptr){
1151                 if (mg->mg_len >= 0){
1152                         sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1153                 } else {
1154                         if (mg->mg_len == HEf_SVKEY)
1155                                 sv_setsv(ST(0),newRV((SV*)mg->mg_ptr));
1156                 }
1157         }
1158
1159 MODULE = B      PACKAGE = B::PVLV       PREFIX = Lv
1160
1161 U32
1162 LvTARGOFF(sv)
1163         B::PVLV sv
1164
1165 U32
1166 LvTARGLEN(sv)
1167         B::PVLV sv
1168
1169 char
1170 LvTYPE(sv)
1171         B::PVLV sv
1172
1173 B::SV
1174 LvTARG(sv)
1175         B::PVLV sv
1176
1177 MODULE = B      PACKAGE = B::BM         PREFIX = Bm
1178
1179 I32
1180 BmUSEFUL(sv)
1181         B::BM   sv
1182
1183 U16
1184 BmPREVIOUS(sv)
1185         B::BM   sv
1186
1187 U8
1188 BmRARE(sv)
1189         B::BM   sv
1190
1191 void
1192 BmTABLE(sv)
1193         B::BM   sv
1194         STRLEN  len = NO_INIT
1195         char *  str = NO_INIT
1196     CODE:
1197         str = SvPV(sv, len);
1198         /* Boyer-Moore table is just after string and its safety-margin \0 */
1199         ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
1200
1201 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1202
1203 void
1204 GvNAME(gv)
1205         B::GV   gv
1206     CODE:
1207         ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1208
1209 bool
1210 is_empty(gv)
1211         B::GV   gv
1212     CODE:
1213         RETVAL = GvGP(gv) == Null(GP*);
1214     OUTPUT:
1215         RETVAL
1216
1217 B::HV
1218 GvSTASH(gv)
1219         B::GV   gv
1220
1221 B::SV
1222 GvSV(gv)
1223         B::GV   gv
1224
1225 B::IO
1226 GvIO(gv)
1227         B::GV   gv
1228
1229 B::CV
1230 GvFORM(gv)
1231         B::GV   gv
1232
1233 B::AV
1234 GvAV(gv)
1235         B::GV   gv
1236
1237 B::HV
1238 GvHV(gv)
1239         B::GV   gv
1240
1241 B::GV
1242 GvEGV(gv)
1243         B::GV   gv
1244
1245 B::CV
1246 GvCV(gv)
1247         B::GV   gv
1248
1249 U32
1250 GvCVGEN(gv)
1251         B::GV   gv
1252
1253 U16
1254 GvLINE(gv)
1255         B::GV   gv
1256
1257 char *
1258 GvFILE(gv)
1259         B::GV   gv
1260
1261 B::GV
1262 GvFILEGV(gv)
1263         B::GV   gv
1264
1265 MODULE = B      PACKAGE = B::GV
1266
1267 U32
1268 GvREFCNT(gv)
1269         B::GV   gv
1270
1271 U8
1272 GvFLAGS(gv)
1273         B::GV   gv
1274
1275 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1276
1277 long
1278 IoLINES(io)
1279         B::IO   io
1280
1281 long
1282 IoPAGE(io)
1283         B::IO   io
1284
1285 long
1286 IoPAGE_LEN(io)
1287         B::IO   io
1288
1289 long
1290 IoLINES_LEFT(io)
1291         B::IO   io
1292
1293 char *
1294 IoTOP_NAME(io)
1295         B::IO   io
1296
1297 B::GV
1298 IoTOP_GV(io)
1299         B::IO   io
1300
1301 char *
1302 IoFMT_NAME(io)
1303         B::IO   io
1304
1305 B::GV
1306 IoFMT_GV(io)
1307         B::IO   io
1308
1309 char *
1310 IoBOTTOM_NAME(io)
1311         B::IO   io
1312
1313 B::GV
1314 IoBOTTOM_GV(io)
1315         B::IO   io
1316
1317 short
1318 IoSUBPROCESS(io)
1319         B::IO   io
1320
1321 bool
1322 IsSTD(io,name)
1323         B::IO   io
1324         char*   name
1325     PREINIT:
1326         PerlIO* handle = 0;
1327     CODE:
1328         if( strEQ( name, "stdin" ) ) {
1329             handle = PerlIO_stdin();
1330         }
1331         else if( strEQ( name, "stdout" ) ) {
1332             handle = PerlIO_stdout();
1333         }
1334         else if( strEQ( name, "stderr" ) ) {
1335             handle = PerlIO_stderr();
1336         }
1337         else {
1338             croak( "Invalid value '%s'", name );
1339         }
1340         RETVAL = handle == IoIFP(io);
1341     OUTPUT:
1342         RETVAL
1343
1344 MODULE = B      PACKAGE = B::IO
1345
1346 char
1347 IoTYPE(io)
1348         B::IO   io
1349
1350 U8
1351 IoFLAGS(io)
1352         B::IO   io
1353
1354 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1355
1356 SSize_t
1357 AvFILL(av)
1358         B::AV   av
1359
1360 SSize_t
1361 AvMAX(av)
1362         B::AV   av
1363
1364 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1365
1366 IV
1367 AvOFF(av)
1368         B::AV   av
1369
1370 void
1371 AvARRAY(av)
1372         B::AV   av
1373     PPCODE:
1374         if (AvFILL(av) >= 0) {
1375             SV **svp = AvARRAY(av);
1376             I32 i;
1377             for (i = 0; i <= AvFILL(av); i++)
1378                 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1379         }
1380
1381 MODULE = B      PACKAGE = B::AV
1382
1383 U8
1384 AvFLAGS(av)
1385         B::AV   av
1386
1387 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1388
1389 B::HV
1390 CvSTASH(cv)
1391         B::CV   cv
1392
1393 B::OP
1394 CvSTART(cv)
1395         B::CV   cv
1396
1397 B::OP
1398 CvROOT(cv)
1399         B::CV   cv
1400
1401 B::GV
1402 CvGV(cv)
1403         B::CV   cv
1404
1405 char *
1406 CvFILE(cv)
1407         B::CV   cv
1408
1409 long
1410 CvDEPTH(cv)
1411         B::CV   cv
1412
1413 B::AV
1414 CvPADLIST(cv)
1415         B::CV   cv
1416
1417 B::CV
1418 CvOUTSIDE(cv)
1419         B::CV   cv
1420
1421 U32
1422 CvOUTSIDE_SEQ(cv)
1423         B::CV   cv
1424
1425 void
1426 CvXSUB(cv)
1427         B::CV   cv
1428     CODE:
1429         ST(0) = sv_2mortal(newSViv(PTR2IV(CvXSUB(cv))));
1430
1431
1432 void
1433 CvXSUBANY(cv)
1434         B::CV   cv
1435     CODE:
1436         ST(0) = CvCONST(cv) ?
1437                     make_sv_object(aTHX_ sv_newmortal(),CvXSUBANY(cv).any_ptr) :
1438                     sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
1439
1440 MODULE = B    PACKAGE = B::CV
1441
1442 U16
1443 CvFLAGS(cv)
1444       B::CV   cv
1445
1446 MODULE = B      PACKAGE = B::CV         PREFIX = cv_
1447
1448 B::SV
1449 cv_const_sv(cv)
1450         B::CV   cv
1451
1452
1453 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1454
1455 STRLEN
1456 HvFILL(hv)
1457         B::HV   hv
1458
1459 STRLEN
1460 HvMAX(hv)
1461         B::HV   hv
1462
1463 I32
1464 HvKEYS(hv)
1465         B::HV   hv
1466
1467 I32
1468 HvRITER(hv)
1469         B::HV   hv
1470
1471 char *
1472 HvNAME(hv)
1473         B::HV   hv
1474
1475 B::PMOP
1476 HvPMROOT(hv)
1477         B::HV   hv
1478
1479 void
1480 HvARRAY(hv)
1481         B::HV   hv
1482     PPCODE:
1483         if (HvKEYS(hv) > 0) {
1484             SV *sv;
1485             char *key;
1486             I32 len;
1487             (void)hv_iterinit(hv);
1488             EXTEND(sp, HvKEYS(hv) * 2);
1489             while ((sv = hv_iternextsv(hv, &key, &len))) {
1490                 PUSHs(newSVpvn(key, len));
1491                 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
1492             }
1493         }