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