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