projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
B, B::C, perlcc, t/TEST
[p5sagit/p5-mst-13.2.git] / ext / B / B.xs
CommitLineData
a8a597b2 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
c5be433b 10#define PERL_NO_GET_CONTEXT
a8a597b2 11#include "EXTERN.h"
12#include "perl.h"
13#include "XSUB.h"
a8a597b2 14
51aa15f3 15#ifdef PerlIO
16typedef PerlIO * InputStream;
17#else
18typedef FILE * InputStream;
19#endif
20
21
a8a597b2 22static 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
41typedef enum {
42 OPc_NULL, /* 0 */
43 OPc_BASEOP, /* 1 */
44 OPc_UNOP, /* 2 */
45 OPc_BINOP, /* 3 */
46 OPc_LOGOP, /* 4 */
1a67a97c 47 OPc_LISTOP, /* 5 */
48 OPc_PMOP, /* 6 */
49 OPc_SVOP, /* 7 */
7934575e 50 OPc_PADOP, /* 8 */
1a67a97c 51 OPc_PVOP, /* 9 */
52 OPc_CVOP, /* 10 */
53 OPc_LOOP, /* 11 */
54 OPc_COP /* 12 */
a8a597b2 55} opclass;
56
57static char *opclassnames[] = {
58 "B::NULL",
59 "B::OP",
60 "B::UNOP",
61 "B::BINOP",
62 "B::LOGOP",
a8a597b2 63 "B::LISTOP",
64 "B::PMOP",
65 "B::SVOP",
7934575e 66 "B::PADOP",
a8a597b2 67 "B::PVOP",
68 "B::CVOP",
69 "B::LOOP",
70 "B::COP"
71};
72
df3728a2 73#define MY_CXT_KEY "B::_guts" XS_VERSION
a8a597b2 74
89ca4ac7 75typedef struct {
76 int x_walkoptree_debug; /* Flag for walkoptree debug hook */
b326da91 77 SV * x_specialsv_list[7];
89ca4ac7 78} my_cxt_t;
79
80START_MY_CXT
81
82#define walkoptree_debug (MY_CXT.x_walkoptree_debug)
83#define specialsv_list (MY_CXT.x_specialsv_list)
e8edd1e6 84
a8a597b2 85static opclass
cea2e8a9 86cc_opclass(pTHX_ OP *o)
a8a597b2 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
18228111 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
22c35a8c 102 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
a8a597b2 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
a8a597b2 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
7934575e 124 case OA_PADOP:
125 return OPc_PADOP;
a8a597b2 126
293d3ffa 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;
a8a597b2 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
45f6cd40 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.
a8a597b2 151 */
45f6cd40 152 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
a8a597b2 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
7934575e 162 * an SVOP (and op_sv is the GV for the filehandle argument).
a8a597b2 163 */
164 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
93865851 165#ifdef USE_ITHREADS
166 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
167#else
7934575e 168 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
93865851 169#endif
a8a597b2 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",
22c35a8c 188 PL_op_name[o->op_type]);
a8a597b2 189 return OPc_BASEOP;
190}
191
192static char *
cea2e8a9 193cc_opclassname(pTHX_ OP *o)
a8a597b2 194{
cea2e8a9 195 return opclassnames[cc_opclass(aTHX_ o)];
a8a597b2 196}
197
198static SV *
cea2e8a9 199make_sv_object(pTHX_ SV *arg, SV *sv)
a8a597b2 200{
201 char *type = 0;
202 IV iv;
89ca4ac7 203 dMY_CXT;
a8a597b2 204
e8edd1e6 205 for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
206 if (sv == specialsv_list[iv]) {
a8a597b2 207 type = "B::SPECIAL";
208 break;
209 }
210 }
211 if (!type) {
212 type = svclassnames[SvTYPE(sv)];
56431972 213 iv = PTR2IV(sv);
a8a597b2 214 }
215 sv_setiv(newSVrv(arg, type), iv);
216 return arg;
217}
218
219static SV *
cea2e8a9 220make_mg_object(pTHX_ SV *arg, MAGIC *mg)
a8a597b2 221{
56431972 222 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
a8a597b2 223 return arg;
224}
225
226static SV *
cea2e8a9 227cstring(pTHX_ SV *sv)
a8a597b2 228{
79cb57f6 229 SV *sstr = newSVpvn("", 0);
a8a597b2 230 STRLEN len;
231 char *s;
b326da91 232 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
a8a597b2 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, "\\\\");
b326da91 248 /* trigraphs - bleagh */
249 else if (*s == '?' && len>=3 && s[1] == '?')
250 {
251 sprintf(escbuff, "\\%03o", '?');
252 sv_catpv(sstr, escbuff);
253 }
a8a597b2 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 {
a8a597b2 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
284static SV *
cea2e8a9 285cchar(pTHX_ SV *sv)
a8a597b2 286{
79cb57f6 287 SV *sstr = newSVpvn("'", 1);
2d8e6c8d 288 STRLEN n_a;
289 char *s = SvPV(sv, n_a);
a8a597b2 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
a8a597b2 324void
cea2e8a9 325walkoptree(pTHX_ SV *opsv, char *method)
a8a597b2 326{
327 dSP;
328 OP *o;
89ca4ac7 329 dMY_CXT;
330
a8a597b2 331 if (!SvROK(opsv))
332 croak("opsv is not a reference");
333 opsv = sv_mortalcopy(opsv);
56431972 334 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
a8a597b2 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. */
56431972 349 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
cea2e8a9 350 walkoptree(aTHX_ opsv, method);
a8a597b2 351 }
352 }
353}
354
355typedef OP *B__OP;
356typedef UNOP *B__UNOP;
357typedef BINOP *B__BINOP;
358typedef LOGOP *B__LOGOP;
a8a597b2 359typedef LISTOP *B__LISTOP;
360typedef PMOP *B__PMOP;
361typedef SVOP *B__SVOP;
7934575e 362typedef PADOP *B__PADOP;
a8a597b2 363typedef PVOP *B__PVOP;
364typedef LOOP *B__LOOP;
365typedef COP *B__COP;
366
367typedef SV *B__SV;
368typedef SV *B__IV;
369typedef SV *B__PV;
370typedef SV *B__NV;
371typedef SV *B__PVMG;
372typedef SV *B__PVLV;
373typedef SV *B__BM;
374typedef SV *B__RV;
375typedef AV *B__AV;
376typedef HV *B__HV;
377typedef CV *B__CV;
378typedef GV *B__GV;
379typedef IO *B__IO;
380
381typedef MAGIC *B__MAGIC;
382
383MODULE = B PACKAGE = B PREFIX = B_
384
385PROTOTYPES: DISABLE
386
387BOOT:
4c1f658f 388{
389 HV *stash = gv_stashpvn("B", 1, TRUE);
390 AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
89ca4ac7 391 MY_CXT_INIT;
e8edd1e6 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;
059a8bb7 396 specialsv_list[4] = pWARN_ALL;
397 specialsv_list[5] = pWARN_NONE;
b326da91 398 specialsv_list[6] = pWARN_STD;
4c1f658f 399#include "defsubs.h"
400}
a8a597b2 401
3280af22 402#define B_main_cv() PL_main_cv
31d7d75a 403#define B_init_av() PL_initav
059a8bb7 404#define B_begin_av() PL_beginav_save
405#define B_end_av() PL_endav
3280af22 406#define B_main_root() PL_main_root
407#define B_main_start() PL_main_start
56eca212 408#define B_amagic_generation() PL_amagic_generation
3280af22 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
a8a597b2 413
31d7d75a 414B::AV
415B_init_av()
416
059a8bb7 417B::AV
418B_begin_av()
419
420B::AV
421B_end_av()
422
a8a597b2 423B::CV
424B_main_cv()
425
426B::OP
427B_main_root()
428
429B::OP
430B_main_start()
431
56eca212 432long
433B_amagic_generation()
434
a8a597b2 435B::AV
436B_comppadlist()
437
438B::SV
439B_sv_undef()
440
441B::SV
442B_sv_yes()
443
444B::SV
445B_sv_no()
446
447MODULE = B PACKAGE = B
448
449
450void
451walkoptree(opsv, method)
452 SV * opsv
453 char * method
cea2e8a9 454 CODE:
455 walkoptree(aTHX_ opsv, method);
a8a597b2 456
457int
458walkoptree_debug(...)
459 CODE:
89ca4ac7 460 dMY_CXT;
a8a597b2 461 RETVAL = walkoptree_debug;
462 if (items > 0 && SvTRUE(ST(1)))
463 walkoptree_debug = 1;
464 OUTPUT:
465 RETVAL
466
56431972 467#define address(sv) PTR2IV(sv)
a8a597b2 468
469IV
470address(sv)
471 SV * sv
472
473B::SV
474svref_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:
0cc1d052 481 RETVAL
482
483void
484opnumber(name)
485char * name
486CODE:
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}
a8a597b2 503
504void
505ppname(opnum)
506 int opnum
507 CODE:
508 ST(0) = sv_newmortal();
3280af22 509 if (opnum >= 0 && opnum < PL_maxo) {
a8a597b2 510 sv_setpvn(ST(0), "pp_", 3);
22c35a8c 511 sv_catpv(ST(0), PL_op_name[opnum]);
a8a597b2 512 }
513
514void
515hash(sv)
516 SV * sv
517 CODE:
518 char *s;
519 STRLEN len;
520 U32 hash = 0;
faccc32b 521 char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
a8a597b2 522 s = SvPV(sv, len);
cf86991c 523 PERL_HASH(hash, s, len);
faccc32b 524 sprintf(hexhash, "0x%"UVxf, (UV)hash);
a8a597b2 525 ST(0) = sv_2mortal(newSVpv(hexhash, 0));
526
527#define cast_I32(foo) (I32)foo
528IV
529cast_I32(i)
530 IV i
531
532void
533minus_c()
534 CODE:
3280af22 535 PL_minus_c = TRUE;
a8a597b2 536
059a8bb7 537void
538save_BEGINs()
539 CODE:
aefff11f 540 PL_savebegin = TRUE;
059a8bb7 541
a8a597b2 542SV *
543cstring(sv)
544 SV * sv
cea2e8a9 545 CODE:
546 RETVAL = cstring(aTHX_ sv);
547 OUTPUT:
548 RETVAL
a8a597b2 549
550SV *
551cchar(sv)
552 SV * sv
cea2e8a9 553 CODE:
554 RETVAL = cchar(aTHX_ sv);
555 OUTPUT:
556 RETVAL
a8a597b2 557
558void
559threadsv_names()
560 PPCODE:
4d1ff10f 561#ifdef USE_5005THREADS
a8a597b2 562 int i;
533c011a 563 STRLEN len = strlen(PL_threadsv_names);
a8a597b2 564
565 EXTEND(sp, len);
566 for (i = 0; i < len; i++)
79cb57f6 567 PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
a8a597b2 568#endif
569
570
571#define OP_next(o) o->op_next
572#define OP_sibling(o) o->op_sibling
22c35a8c 573#define OP_desc(o) PL_op_desc[o->op_type]
a8a597b2 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
580MODULE = B PACKAGE = B::OP PREFIX = OP_
581
582B::OP
583OP_next(o)
584 B::OP o
585
586B::OP
587OP_sibling(o)
588 B::OP o
589
590char *
3f872cb9 591OP_name(o)
592 B::OP o
593 CODE:
8063af02 594 RETVAL = PL_op_name[o->op_type];
595 OUTPUT:
596 RETVAL
3f872cb9 597
598
8063af02 599void
a8a597b2 600OP_ppaddr(o)
601 B::OP o
dc333d64 602 PREINIT:
603 int i;
604 SV *sv = sv_newmortal();
a8a597b2 605 CODE:
dc333d64 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;
a8a597b2 612
613char *
614OP_desc(o)
615 B::OP o
616
7934575e 617PADOFFSET
a8a597b2 618OP_targ(o)
619 B::OP o
620
621U16
622OP_type(o)
623 B::OP o
624
625U16
626OP_seq(o)
627 B::OP o
628
629U8
630OP_flags(o)
631 B::OP o
632
633U8
634OP_private(o)
635 B::OP o
636
637#define UNOP_first(o) o->op_first
638
639MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
640
641B::OP
642UNOP_first(o)
643 B::UNOP o
644
645#define BINOP_last(o) o->op_last
646
647MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
648
649B::OP
650BINOP_last(o)
651 B::BINOP o
652
653#define LOGOP_other(o) o->op_other
654
655MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
656
657B::OP
658LOGOP_other(o)
659 B::LOGOP o
660
a8a597b2 661MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
662
c03c2844 663U32
664LISTOP_children(o)
665 B::LISTOP o
666 OP * kid = NO_INIT
667 int i = NO_INIT
668 CODE:
c03c2844 669 i = 0;
670 for (kid = o->op_first; kid; kid = kid->op_sibling)
671 i++;
8063af02 672 RETVAL = i;
673 OUTPUT:
674 RETVAL
c03c2844 675
a8a597b2 676#define PMOP_pmreplroot(o) o->op_pmreplroot
677#define PMOP_pmreplstart(o) o->op_pmreplstart
678#define PMOP_pmnext(o) o->op_pmnext
aaa362c4 679#define PMOP_pmregexp(o) PM_GETRE(o)
a8a597b2 680#define PMOP_pmflags(o) o->op_pmflags
681#define PMOP_pmpermflags(o) o->op_pmpermflags
682
683MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
684
685void
686PMOP_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"),
56431972 696 PTR2IV(root));
a8a597b2 697 }
698 else {
56431972 699 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
a8a597b2 700 }
701
702B::OP
703PMOP_pmreplstart(o)
704 B::PMOP o
705
706B::PMOP
707PMOP_pmnext(o)
708 B::PMOP o
709
710U16
711PMOP_pmflags(o)
712 B::PMOP o
713
714U16
715PMOP_pmpermflags(o)
716 B::PMOP o
717
718void
719PMOP_precomp(o)
720 B::PMOP o
721 REGEXP * rx = NO_INIT
722 CODE:
723 ST(0) = sv_newmortal();
aaa362c4 724 rx = PM_GETRE(o);
a8a597b2 725 if (rx)
726 sv_setpvn(ST(0), rx->precomp, rx->prelen);
727
ac33dcd1 728#define SVOP_sv(o) cSVOPo->op_sv
729#define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
a8a597b2 730
731MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
732
a8a597b2 733B::SV
734SVOP_sv(o)
735 B::SVOP o
736
f22444f5 737B::GV
065a1863 738SVOP_gv(o)
739 B::SVOP o
740
7934575e 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)
a8a597b2 746
7934575e 747MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
748
749PADOFFSET
750PADOP_padix(o)
751 B::PADOP o
752
753B::SV
754PADOP_sv(o)
755 B::PADOP o
a8a597b2 756
757B::GV
7934575e 758PADOP_gv(o)
759 B::PADOP o
a8a597b2 760
761MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
762
763void
764PVOP_pv(o)
765 B::PVOP o
766 CODE:
767 /*
bec89253 768 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
a8a597b2 769 * whereas other PVOPs point to a null terminated string.
770 */
bec89253 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));
a8a597b2 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
789MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
790
791
792B::OP
793LOOP_redoop(o)
794 B::LOOP o
795
796B::OP
797LOOP_nextop(o)
798 B::LOOP o
799
800B::OP
801LOOP_lastop(o)
802 B::LOOP o
803
804#define COP_label(o) o->cop_label
11faa288 805#define COP_stashpv(o) CopSTASHPV(o)
806#define COP_stash(o) CopSTASH(o)
57843af0 807#define COP_file(o) CopFILE(o)
a8a597b2 808#define COP_cop_seq(o) o->cop_seq
809#define COP_arybase(o) o->cop_arybase
57843af0 810#define COP_line(o) CopLINE(o)
b295d113 811#define COP_warnings(o) o->cop_warnings
a8a597b2 812
813MODULE = B PACKAGE = B::COP PREFIX = COP_
814
815char *
816COP_label(o)
817 B::COP o
818
11faa288 819char *
820COP_stashpv(o)
821 B::COP o
822
a8a597b2 823B::HV
824COP_stash(o)
825 B::COP o
826
57843af0 827char *
828COP_file(o)
a8a597b2 829 B::COP o
830
831U32
832COP_cop_seq(o)
833 B::COP o
834
835I32
836COP_arybase(o)
837 B::COP o
838
839U16
840COP_line(o)
841 B::COP o
842
b295d113 843B::SV
844COP_warnings(o)
845 B::COP o
846
a8a597b2 847MODULE = B PACKAGE = B::SV PREFIX = Sv
848
849U32
850SvREFCNT(sv)
851 B::SV sv
852
853U32
854SvFLAGS(sv)
855 B::SV sv
856
857MODULE = B PACKAGE = B::IV PREFIX = Sv
858
859IV
860SvIV(sv)
861 B::IV sv
862
863IV
864SvIVX(sv)
865 B::IV sv
866
0ca04487 867UV
868SvUVX(sv)
869 B::IV sv
870
871
a8a597b2 872MODULE = B PACKAGE = B::IV
873
874#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
875
876int
877needs64bits(sv)
878 B::IV sv
879
880void
881packiv(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 */
42718184 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
a8a597b2 899 wp[1] = htonl(iv & 0xffffffff);
79cb57f6 900 ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
a8a597b2 901 } else {
902 U32 w = htonl((U32)SvIVX(sv));
79cb57f6 903 ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
a8a597b2 904 }
905
906MODULE = B PACKAGE = B::NV PREFIX = Sv
907
76ef7183 908NV
a8a597b2 909SvNV(sv)
910 B::NV sv
911
76ef7183 912NV
a8a597b2 913SvNVX(sv)
914 B::NV sv
915
916MODULE = B PACKAGE = B::RV PREFIX = Sv
917
918B::SV
919SvRV(sv)
920 B::RV sv
921
922MODULE = B PACKAGE = B::PV PREFIX = Sv
923
0b40bd6d 924char*
925SvPVX(sv)
926 B::PV sv
927
b326da91 928B::SV
929SvRV(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
a8a597b2 941void
942SvPV(sv)
943 B::PV sv
944 CODE:
b326da91 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 }
a8a597b2 955
445a12f6 956STRLEN
957SvLEN(sv)
958 B::PV sv
959
960STRLEN
961SvCUR(sv)
962 B::PV sv
963
a8a597b2 964MODULE = B PACKAGE = B::PVMG PREFIX = Sv
965
966void
967SvMAGIC(sv)
968 B::PVMG sv
969 MAGIC * mg = NO_INIT
970 PPCODE:
971 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
cea2e8a9 972 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
a8a597b2 973
974MODULE = B PACKAGE = B::PVMG
975
976B::HV
977SvSTASH(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
88b39979 985#define MgLENGTH(mg) mg->mg_len
a8a597b2 986
987MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
988
989B::MAGIC
990MgMOREMAGIC(mg)
991 B::MAGIC mg
992
993U16
994MgPRIVATE(mg)
995 B::MAGIC mg
996
997char
998MgTYPE(mg)
999 B::MAGIC mg
1000
1001U8
1002MgFLAGS(mg)
1003 B::MAGIC mg
1004
1005B::SV
1006MgOBJ(mg)
1007 B::MAGIC mg
b326da91 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
1018SV*
1019precomp(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
a8a597b2 1032
88b39979 1033I32
1034MgLENGTH(mg)
1035 B::MAGIC mg
1036
a8a597b2 1037void
1038MgPTR(mg)
1039 B::MAGIC mg
1040 CODE:
1041 ST(0) = sv_newmortal();
88b39979 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 }
a8a597b2 1050
1051MODULE = B PACKAGE = B::PVLV PREFIX = Lv
1052
1053U32
1054LvTARGOFF(sv)
1055 B::PVLV sv
1056
1057U32
1058LvTARGLEN(sv)
1059 B::PVLV sv
1060
1061char
1062LvTYPE(sv)
1063 B::PVLV sv
1064
1065B::SV
1066LvTARG(sv)
1067 B::PVLV sv
1068
1069MODULE = B PACKAGE = B::BM PREFIX = Bm
1070
1071I32
1072BmUSEFUL(sv)
1073 B::BM sv
1074
1075U16
1076BmPREVIOUS(sv)
1077 B::BM sv
1078
1079U8
1080BmRARE(sv)
1081 B::BM sv
1082
1083void
1084BmTABLE(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 */
79cb57f6 1091 ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
a8a597b2 1092
1093MODULE = B PACKAGE = B::GV PREFIX = Gv
1094
1095void
1096GvNAME(gv)
1097 B::GV gv
1098 CODE:
79cb57f6 1099 ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
a8a597b2 1100
87d7fd28 1101bool
1102is_empty(gv)
1103 B::GV gv
1104 CODE:
1105 RETVAL = GvGP(gv) == Null(GP*);
1106 OUTPUT:
1107 RETVAL
1108
a8a597b2 1109B::HV
1110GvSTASH(gv)
1111 B::GV gv
1112
1113B::SV
1114GvSV(gv)
1115 B::GV gv
1116
1117B::IO
1118GvIO(gv)
1119 B::GV gv
1120
1121B::CV
1122GvFORM(gv)
1123 B::GV gv
1124
1125B::AV
1126GvAV(gv)
1127 B::GV gv
1128
1129B::HV
1130GvHV(gv)
1131 B::GV gv
1132
1133B::GV
1134GvEGV(gv)
1135 B::GV gv
1136
1137B::CV
1138GvCV(gv)
1139 B::GV gv
1140
1141U32
1142GvCVGEN(gv)
1143 B::GV gv
1144
1145U16
1146GvLINE(gv)
1147 B::GV gv
1148
b195d487 1149char *
1150GvFILE(gv)
1151 B::GV gv
1152
a8a597b2 1153B::GV
1154GvFILEGV(gv)
1155 B::GV gv
1156
1157MODULE = B PACKAGE = B::GV
1158
1159U32
1160GvREFCNT(gv)
1161 B::GV gv
1162
1163U8
1164GvFLAGS(gv)
1165 B::GV gv
1166
1167MODULE = B PACKAGE = B::IO PREFIX = Io
1168
1169long
1170IoLINES(io)
1171 B::IO io
1172
1173long
1174IoPAGE(io)
1175 B::IO io
1176
1177long
1178IoPAGE_LEN(io)
1179 B::IO io
1180
1181long
1182IoLINES_LEFT(io)
1183 B::IO io
1184
1185char *
1186IoTOP_NAME(io)
1187 B::IO io
1188
1189B::GV
1190IoTOP_GV(io)
1191 B::IO io
1192
1193char *
1194IoFMT_NAME(io)
1195 B::IO io
1196
1197B::GV
1198IoFMT_GV(io)
1199 B::IO io
1200
1201char *
1202IoBOTTOM_NAME(io)
1203 B::IO io
1204
1205B::GV
1206IoBOTTOM_GV(io)
1207 B::IO io
1208
1209short
1210IoSUBPROCESS(io)
1211 B::IO io
1212
b326da91 1213bool
1214IsSTD(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
a8a597b2 1236MODULE = B PACKAGE = B::IO
1237
1238char
1239IoTYPE(io)
1240 B::IO io
1241
1242U8
1243IoFLAGS(io)
1244 B::IO io
1245
1246MODULE = B PACKAGE = B::AV PREFIX = Av
1247
1248SSize_t
1249AvFILL(av)
1250 B::AV av
1251
1252SSize_t
1253AvMAX(av)
1254 B::AV av
1255
1256#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1257
1258IV
1259AvOFF(av)
1260 B::AV av
1261
1262void
1263AvARRAY(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++)
cea2e8a9 1270 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
a8a597b2 1271 }
1272
1273MODULE = B PACKAGE = B::AV
1274
1275U8
1276AvFLAGS(av)
1277 B::AV av
1278
1279MODULE = B PACKAGE = B::CV PREFIX = Cv
1280
1281B::HV
1282CvSTASH(cv)
1283 B::CV cv
1284
1285B::OP
1286CvSTART(cv)
1287 B::CV cv
1288
1289B::OP
1290CvROOT(cv)
1291 B::CV cv
1292
1293B::GV
1294CvGV(cv)
1295 B::CV cv
1296
57843af0 1297char *
1298CvFILE(cv)
1299 B::CV cv
1300
a8a597b2 1301long
1302CvDEPTH(cv)
1303 B::CV cv
1304
1305B::AV
1306CvPADLIST(cv)
1307 B::CV cv
1308
1309B::CV
1310CvOUTSIDE(cv)
1311 B::CV cv
1312
1313void
1314CvXSUB(cv)
1315 B::CV cv
1316 CODE:
56431972 1317 ST(0) = sv_2mortal(newSViv(PTR2IV(CvXSUB(cv))));
a8a597b2 1318
1319
1320void
1321CvXSUBANY(cv)
1322 B::CV cv
1323 CODE:
b326da91 1324 ST(0) = CvCONST(cv) ?
1325 make_sv_object(aTHX_ sv_newmortal(),CvXSUBANY(cv).any_ptr) :
1326 sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
a8a597b2 1327
5cfd8ad4 1328MODULE = B PACKAGE = B::CV
1329
6aaf4108 1330U16
5cfd8ad4 1331CvFLAGS(cv)
1332 B::CV cv
1333
de3f1649 1334MODULE = B PACKAGE = B::CV PREFIX = cv_
1335
1336B::SV
1337cv_const_sv(cv)
1338 B::CV cv
1339
5cfd8ad4 1340
a8a597b2 1341MODULE = B PACKAGE = B::HV PREFIX = Hv
1342
1343STRLEN
1344HvFILL(hv)
1345 B::HV hv
1346
1347STRLEN
1348HvMAX(hv)
1349 B::HV hv
1350
1351I32
1352HvKEYS(hv)
1353 B::HV hv
1354
1355I32
1356HvRITER(hv)
1357 B::HV hv
1358
1359char *
1360HvNAME(hv)
1361 B::HV hv
1362
1363B::PMOP
1364HvPMROOT(hv)
1365 B::HV hv
1366
1367void
1368HvARRAY(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);
8063af02 1377 while ((sv = hv_iternextsv(hv, &key, &len))) {
79cb57f6 1378 PUSHs(newSVpvn(key, len));
cea2e8a9 1379 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
a8a597b2 1380 }
1381 }
Unnamed repository; edit this file to name it for gitweb.