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