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