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