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 #define PERL_EXT
12 #include "EXTERN.h"
13 #include "perl.h"
14 #include "XSUB.h"
15
16 /* #include "invlist_inline.h" */
17 #define FROM_INTERNAL_SIZE(x) ((x)/ sizeof(UV))
18
19 #ifdef PerlIO
20 typedef PerlIO * InputStream;
21 #else
22 typedef FILE * InputStream;
23 #endif
24
25
26 static const char* const svclassnames[] = {
27 "B::NULL",
28 "B::IV",
29 "B::NV",
30 "B::PV",
31 "B::INVLIST",
32 "B::PVIV",
33 "B::PVNV",
34 "B::PVMG",
35 "B::REGEXP",
36 "B::GV",
37 "B::PVLV",
38 "B::AV",
39 "B::HV",
40 "B::CV",
41 "B::FM",
42 "B::IO",
43 };
44
45
46 static const char* const opclassnames[] = {
47 "B::NULL",
48 "B::OP",
49 "B::UNOP",
50 "B::BINOP",
51 "B::LOGOP",
52 "B::LISTOP",
53 "B::PMOP",
54 "B::SVOP",
55 "B::PADOP",
56 "B::PVOP",
57 "B::LOOP",
58 "B::COP",
59 "B::METHOP",
60 "B::UNOP_AUX"
61 };
62
63 static const size_t opsizes[] = {
64 0,
65 sizeof(OP),
66 sizeof(UNOP),
67 sizeof(BINOP),
68 sizeof(LOGOP),
69 sizeof(LISTOP),
70 sizeof(PMOP),
71 sizeof(SVOP),
72 sizeof(PADOP),
73 sizeof(PVOP),
74 sizeof(LOOP),
75 sizeof(COP),
76 sizeof(METHOP),
77 sizeof(UNOP_AUX),
78 };
79
80 #define MY_CXT_KEY "B::_guts" XS_VERSION
81
82 typedef struct {
83 SV * x_specialsv_list[8];
84 int x_walkoptree_debug; /* Flag for walkoptree debug hook */
85 } my_cxt_t;
86
87 START_MY_CXT
88
89 #define walkoptree_debug (MY_CXT.x_walkoptree_debug)
90 #define specialsv_list (MY_CXT.x_specialsv_list)
91
92
B_init_my_cxt(pTHX_ my_cxt_t * cxt)93 static void B_init_my_cxt(pTHX_ my_cxt_t * cxt) {
94 cxt->x_specialsv_list[0] = Nullsv;
95 cxt->x_specialsv_list[1] = &PL_sv_undef;
96 cxt->x_specialsv_list[2] = &PL_sv_yes;
97 cxt->x_specialsv_list[3] = &PL_sv_no;
98 cxt->x_specialsv_list[4] = (SV *) pWARN_ALL;
99 cxt->x_specialsv_list[5] = (SV *) pWARN_NONE;
100 cxt->x_specialsv_list[6] = (SV *) pWARN_STD;
101 cxt->x_specialsv_list[7] = &PL_sv_zero;
102 }
103
104
105 static SV *
make_op_object(pTHX_ const OP * o)106 make_op_object(pTHX_ const OP *o)
107 {
108 SV *opsv = sv_newmortal();
109 sv_setiv(newSVrv(opsv, opclassnames[op_class(o)]), PTR2IV(o));
110 return opsv;
111 }
112
113
114 static SV *
get_overlay_object(pTHX_ const OP * o,const char * const name,U32 namelen)115 get_overlay_object(pTHX_ const OP *o, const char * const name, U32 namelen)
116 {
117 HE *he;
118 SV **svp;
119 SV *key;
120 SV *sv =get_sv("B::overlay", 0);
121 if (!sv || !SvROK(sv))
122 return NULL;
123 sv = SvRV(sv);
124 if (SvTYPE(sv) != SVt_PVHV)
125 return NULL;
126 key = newSViv(PTR2IV(o));
127 he = hv_fetch_ent((HV*)sv, key, 0, 0);
128 SvREFCNT_dec(key);
129 if (!he)
130 return NULL;
131 sv = HeVAL(he);
132 if (!sv || !SvROK(sv))
133 return NULL;
134 sv = SvRV(sv);
135 if (SvTYPE(sv) != SVt_PVHV)
136 return NULL;
137 svp = hv_fetch((HV*)sv, name, namelen, 0);
138 if (!svp)
139 return NULL;
140 sv = *svp;
141 return sv;
142 }
143
144
145 static SV *
make_sv_object(pTHX_ SV * sv)146 make_sv_object(pTHX_ SV *sv)
147 {
148 SV *const arg = sv_newmortal();
149 const char *type = 0;
150 IV iv;
151 dMY_CXT;
152
153 for (iv = 0; iv < (IV)(sizeof(specialsv_list)/sizeof(SV*)); iv++) {
154 if (sv == specialsv_list[iv]) {
155 type = "B::SPECIAL";
156 break;
157 }
158 }
159 if (!type) {
160 type = svclassnames[SvTYPE(sv)];
161 iv = PTR2IV(sv);
162 }
163 sv_setiv(newSVrv(arg, type), iv);
164 return arg;
165 }
166
167 static SV *
make_temp_object(pTHX_ SV * temp)168 make_temp_object(pTHX_ SV *temp)
169 {
170 SV *target;
171 SV *arg = sv_newmortal();
172 const char *const type = svclassnames[SvTYPE(temp)];
173 const IV iv = PTR2IV(temp);
174
175 target = newSVrv(arg, type);
176 sv_setiv(target, iv);
177
178 /* Need to keep our "temp" around as long as the target exists.
179 Simplest way seems to be to hang it from magic, and let that clear
180 it up. No vtable, so won't actually get in the way of anything. */
181 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
182 /* magic object has had its reference count increased, so we must drop
183 our reference. */
184 SvREFCNT_dec(temp);
185 return arg;
186 }
187
188 static SV *
make_warnings_object(pTHX_ const COP * const cop)189 make_warnings_object(pTHX_ const COP *const cop)
190 {
191 const STRLEN *const warnings = cop->cop_warnings;
192 const char *type = 0;
193 dMY_CXT;
194 IV iv = sizeof(specialsv_list)/sizeof(SV*);
195
196 /* Counting down is deliberate. Before the split between make_sv_object
197 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
198 were both 0, so you could never get a B::SPECIAL for pWARN_STD */
199
200 while (iv--) {
201 if ((SV*)warnings == specialsv_list[iv]) {
202 type = "B::SPECIAL";
203 break;
204 }
205 }
206 if (type) {
207 SV *arg = sv_newmortal();
208 sv_setiv(newSVrv(arg, type), iv);
209 return arg;
210 } else {
211 /* B assumes that warnings are a regular SV. Seems easier to keep it
212 happy by making them into a regular SV. */
213 return make_temp_object(aTHX_ newSVpvn((char *)(warnings + 1), *warnings));
214 }
215 }
216
217 static SV *
make_cop_io_object(pTHX_ COP * cop)218 make_cop_io_object(pTHX_ COP *cop)
219 {
220 SV *const value = newSV(0);
221
222 Perl_emulate_cop_io(aTHX_ cop, value);
223
224 if(SvOK(value)) {
225 return make_sv_object(aTHX_ value);
226 } else {
227 SvREFCNT_dec(value);
228 return make_sv_object(aTHX_ NULL);
229 }
230 }
231
232 static SV *
make_mg_object(pTHX_ MAGIC * mg)233 make_mg_object(pTHX_ MAGIC *mg)
234 {
235 SV *arg = sv_newmortal();
236 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
237 return arg;
238 }
239
240 static SV *
cstring(pTHX_ SV * sv,bool perlstyle)241 cstring(pTHX_ SV *sv, bool perlstyle)
242 {
243 SV *sstr;
244
245 if (!SvOK(sv))
246 return newSVpvs_flags("0", SVs_TEMP);
247
248 sstr = newSVpvs_flags("\"", SVs_TEMP);
249
250 if (perlstyle && SvUTF8(sv)) {
251 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
252 const STRLEN len = SvCUR(sv);
253 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
254 while (*s)
255 {
256 if (*s == '"')
257 sv_catpvs(sstr, "\\\"");
258 else if (*s == '$')
259 sv_catpvs(sstr, "\\$");
260 else if (*s == '@')
261 sv_catpvs(sstr, "\\@");
262 else if (*s == '\\')
263 {
264 if (memCHRs("nrftaebx\\",*(s+1)))
265 sv_catpvn(sstr, s++, 2);
266 else
267 sv_catpvs(sstr, "\\\\");
268 }
269 else /* should always be printable */
270 sv_catpvn(sstr, s, 1);
271 ++s;
272 }
273 }
274 else
275 {
276 /* XXX Optimise? */
277 STRLEN len;
278 const char *s = SvPV(sv, len);
279 for (; len; len--, s++)
280 {
281 /* At least try a little for readability */
282 if (*s == '"')
283 sv_catpvs(sstr, "\\\"");
284 else if (*s == '\\')
285 sv_catpvs(sstr, "\\\\");
286 /* trigraphs - bleagh */
287 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
288 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?');
289 }
290 else if (perlstyle && *s == '$')
291 sv_catpvs(sstr, "\\$");
292 else if (perlstyle && *s == '@')
293 sv_catpvs(sstr, "\\@");
294 else if (isPRINT(*s))
295 sv_catpvn(sstr, s, 1);
296 else if (*s == '\n')
297 sv_catpvs(sstr, "\\n");
298 else if (*s == '\r')
299 sv_catpvs(sstr, "\\r");
300 else if (*s == '\t')
301 sv_catpvs(sstr, "\\t");
302 else if (*s == '\a')
303 sv_catpvs(sstr, "\\a");
304 else if (*s == '\b')
305 sv_catpvs(sstr, "\\b");
306 else if (*s == '\f')
307 sv_catpvs(sstr, "\\f");
308 else if (!perlstyle && *s == '\v')
309 sv_catpvs(sstr, "\\v");
310 else
311 {
312 /* Don't want promotion of a signed -1 char in sprintf args */
313 const unsigned char c = (unsigned char) *s;
314 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
315 }
316 /* XXX Add line breaks if string is long */
317 }
318 }
319 sv_catpvs(sstr, "\"");
320 return sstr;
321 }
322
323 static SV *
cchar(pTHX_ SV * sv)324 cchar(pTHX_ SV *sv)
325 {
326 SV *sstr = newSVpvs_flags("'", SVs_TEMP);
327 const char *s = SvPV_nolen(sv);
328 /* Don't want promotion of a signed -1 char in sprintf args */
329 const unsigned char c = (unsigned char) *s;
330
331 if (c == '\'')
332 sv_catpvs(sstr, "\\'");
333 else if (c == '\\')
334 sv_catpvs(sstr, "\\\\");
335 else if (isPRINT(c))
336 sv_catpvn(sstr, s, 1);
337 else if (c == '\n')
338 sv_catpvs(sstr, "\\n");
339 else if (c == '\r')
340 sv_catpvs(sstr, "\\r");
341 else if (c == '\t')
342 sv_catpvs(sstr, "\\t");
343 else if (c == '\a')
344 sv_catpvs(sstr, "\\a");
345 else if (c == '\b')
346 sv_catpvs(sstr, "\\b");
347 else if (c == '\f')
348 sv_catpvs(sstr, "\\f");
349 else if (c == '\v')
350 sv_catpvs(sstr, "\\v");
351 else
352 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
353 sv_catpvs(sstr, "'");
354 return sstr;
355 }
356
357 #define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart
358 #define PMOP_pmreplroot(o) o->op_pmreplrootu.op_pmreplroot
359
360 static SV *
walkoptree(pTHX_ OP * o,const char * method,SV * ref)361 walkoptree(pTHX_ OP *o, const char *method, SV *ref)
362 {
363 dSP;
364 OP *kid;
365 SV *object;
366 const char *const classname = opclassnames[op_class(o)];
367 dMY_CXT;
368
369 /* Check that no-one has changed our reference, or is holding a reference
370 to it. */
371 if (SvREFCNT(ref) == 1 && SvROK(ref) && SvTYPE(ref) == SVt_RV
372 && (object = SvRV(ref)) && SvREFCNT(object) == 1
373 && SvTYPE(object) == SVt_PVMG && SvIOK_only(object)
374 && !SvMAGICAL(object) && !SvMAGIC(object) && SvSTASH(object)) {
375 /* Looks good, so rebless it for the class we need: */
376 sv_bless(ref, gv_stashpv(classname, GV_ADD));
377 } else {
378 /* Need to make a new one. */
379 ref = sv_newmortal();
380 object = newSVrv(ref, classname);
381 }
382 sv_setiv(object, PTR2IV(o));
383
384 if (walkoptree_debug) {
385 PUSHMARK(sp);
386 XPUSHs(ref);
387 PUTBACK;
388 perl_call_method("walkoptree_debug", G_DISCARD);
389 }
390 PUSHMARK(sp);
391 XPUSHs(ref);
392 PUTBACK;
393 perl_call_method(method, G_DISCARD);
394 if (o && (o->op_flags & OPf_KIDS)) {
395 for (kid = ((UNOP*)o)->op_first; kid; kid = OpSIBLING(kid)) {
396 ref = walkoptree(aTHX_ kid, method, ref);
397 }
398 }
399 if (o && (op_class(o) == OPclass_PMOP) && o->op_type != OP_SPLIT
400 && (kid = PMOP_pmreplroot(cPMOPo)))
401 {
402 ref = walkoptree(aTHX_ kid, method, ref);
403 }
404 return ref;
405 }
406
407 static SV **
oplist(pTHX_ OP * o,SV ** SP)408 oplist(pTHX_ OP *o, SV **SP)
409 {
410 for(; o; o = o->op_next) {
411 if (o->op_opt == 0)
412 break;
413 o->op_opt = 0;
414 XPUSHs(make_op_object(aTHX_ o));
415 switch (o->op_type) {
416 case OP_SUBST:
417 SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP);
418 continue;
419 case OP_SORT:
420 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
421 OP *kid = OpSIBLING(cLISTOPo->op_first); /* pass pushmark */
422 kid = kUNOP->op_first; /* pass rv2gv */
423 kid = kUNOP->op_first; /* pass leave */
424 SP = oplist(aTHX_ kid->op_next, SP);
425 }
426 continue;
427 }
428 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
429 case OA_LOGOP:
430 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
431 break;
432 case OA_LOOP:
433 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
434 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
435 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
436 break;
437 }
438 }
439 return SP;
440 }
441
442 typedef OP *B__OP;
443 typedef UNOP *B__UNOP;
444 typedef BINOP *B__BINOP;
445 typedef LOGOP *B__LOGOP;
446 typedef LISTOP *B__LISTOP;
447 typedef PMOP *B__PMOP;
448 typedef SVOP *B__SVOP;
449 typedef PADOP *B__PADOP;
450 typedef PVOP *B__PVOP;
451 typedef LOOP *B__LOOP;
452 typedef COP *B__COP;
453 typedef METHOP *B__METHOP;
454
455 typedef SV *B__SV;
456 typedef SV *B__IV;
457 typedef SV *B__PV;
458 typedef SV *B__NV;
459 typedef SV *B__PVMG;
460 typedef SV *B__REGEXP;
461 typedef SV *B__PVLV;
462 typedef SV *B__BM;
463 typedef SV *B__RV;
464 typedef SV *B__FM;
465 typedef AV *B__AV;
466 typedef HV *B__HV;
467 typedef CV *B__CV;
468 typedef GV *B__GV;
469 typedef IO *B__IO;
470
471 typedef MAGIC *B__MAGIC;
472 typedef HE *B__HE;
473 typedef struct refcounted_he *B__RHE;
474 typedef PADLIST *B__PADLIST;
475 typedef PADNAMELIST *B__PADNAMELIST;
476 typedef PADNAME *B__PADNAME;
477
478 typedef INVLIST *B__INVLIST;
479
480 #ifdef MULTIPLICITY
481 # define ASSIGN_COMMON_ALIAS(prefix, var) \
482 STMT_START { XSANY.any_i32 = STRUCT_OFFSET(struct interpreter, prefix##var); } STMT_END
483 #else
484 # define ASSIGN_COMMON_ALIAS(prefix, var) \
485 STMT_START { XSANY.any_ptr = (void *)&PL_##var; } STMT_END
486 #endif
487
488 /* This needs to be ALIASed in a custom way, hence can't easily be defined as
489 a regular XSUB. */
490 static XSPROTO(intrpvar_sv_common); /* prototype to pass -Wmissing-prototypes */
XSPROTO(intrpvar_sv_common)491 static XSPROTO(intrpvar_sv_common)
492 {
493 dXSARGS;
494 SV *ret;
495 if (items != 0)
496 croak_xs_usage(cv, "");
497 #ifdef MULTIPLICITY
498 ret = *(SV **)(XSANY.any_i32 + (char *)my_perl);
499 #else
500 ret = *(SV **)(XSANY.any_ptr);
501 #endif
502 ST(0) = make_sv_object(aTHX_ ret);
503 XSRETURN(1);
504 }
505
506
507
508 #define SVp 0x0
509 #define U32p 0x1
510 #define line_tp 0x2
511 #define OPp 0x3
512 #define PADOFFSETp 0x4
513 #define U8p 0x5
514 #define IVp 0x6
515 #define char_pp 0x7
516 /* Keep this last: */
517 #define op_offset_special 0x8
518
519 /* table that drives most of the B::*OP methods */
520
521 static const struct OP_methods {
522 const char *name;
523 U8 namelen;
524 U8 type; /* if op_offset_special, access is handled on a case-by-case basis */
525 U16 offset;
526 } op_methods[] = {
527 { STR_WITH_LEN("next"), OPp, STRUCT_OFFSET(struct op, op_next), },/* 0*/
528 { STR_WITH_LEN("sibling"), op_offset_special, 0, },/* 1*/
529 { STR_WITH_LEN("targ"), PADOFFSETp, STRUCT_OFFSET(struct op, op_targ), },/* 2*/
530 { STR_WITH_LEN("flags"), U8p, STRUCT_OFFSET(struct op, op_flags), },/* 3*/
531 { STR_WITH_LEN("private"), U8p, STRUCT_OFFSET(struct op, op_private), },/* 4*/
532 { STR_WITH_LEN("first"), OPp, STRUCT_OFFSET(struct unop, op_first), },/* 5*/
533 { STR_WITH_LEN("last"), OPp, STRUCT_OFFSET(struct binop, op_last), },/* 6*/
534 { STR_WITH_LEN("other"), OPp, STRUCT_OFFSET(struct logop, op_other), },/* 7*/
535 { STR_WITH_LEN("pmreplstart"), op_offset_special, 0, },/* 8*/
536 { STR_WITH_LEN("redoop"), OPp, STRUCT_OFFSET(struct loop, op_redoop), },/* 9*/
537 { STR_WITH_LEN("nextop"), OPp, STRUCT_OFFSET(struct loop, op_nextop), },/*10*/
538 { STR_WITH_LEN("lastop"), OPp, STRUCT_OFFSET(struct loop, op_lastop), },/*11*/
539 { STR_WITH_LEN("pmflags"), U32p, STRUCT_OFFSET(struct pmop, op_pmflags),},/*12*/
540 { STR_WITH_LEN("code_list"),OPp, STRUCT_OFFSET(struct pmop, op_code_list),},/*13*/
541 { STR_WITH_LEN("sv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*14*/
542 { STR_WITH_LEN("gv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*15*/
543 { STR_WITH_LEN("padix"), PADOFFSETp,STRUCT_OFFSET(struct padop, op_padix),},/*16*/
544 { STR_WITH_LEN("cop_seq"), U32p, STRUCT_OFFSET(struct cop, cop_seq), },/*17*/
545 { STR_WITH_LEN("line"), line_tp, STRUCT_OFFSET(struct cop, cop_line), },/*18*/
546 { STR_WITH_LEN("hints"), U32p, STRUCT_OFFSET(struct cop, cop_hints), },/*19*/
547 #ifdef USE_ITHREADS
548 { STR_WITH_LEN("pmoffset"),IVp, STRUCT_OFFSET(struct pmop, op_pmoffset),},/*20*/
549 { STR_WITH_LEN("filegv"), op_offset_special, 0, },/*21*/
550 { STR_WITH_LEN("file"), char_pp, STRUCT_OFFSET(struct cop, cop_file), },/*22*/
551 { STR_WITH_LEN("stash"), op_offset_special, 0, },/*23*/
552 { STR_WITH_LEN("stashpv"), op_offset_special, 0, },/*24*/
553 { STR_WITH_LEN("stashoff"),PADOFFSETp,STRUCT_OFFSET(struct cop,cop_stashoff),},/*25*/
554 #else
555 { STR_WITH_LEN("pmoffset"),op_offset_special, 0, },/*20*/
556 { STR_WITH_LEN("filegv"), SVp, STRUCT_OFFSET(struct cop, cop_filegv),},/*21*/
557 { STR_WITH_LEN("file"), op_offset_special, 0, },/*22*/
558 { STR_WITH_LEN("stash"), SVp, STRUCT_OFFSET(struct cop, cop_stash), },/*23*/
559 { STR_WITH_LEN("stashpv"), op_offset_special, 0, },/*24*/
560 { STR_WITH_LEN("stashoff"),op_offset_special, 0, },/*25*/
561 #endif
562 { STR_WITH_LEN("size"), op_offset_special, 0, },/*26*/
563 { STR_WITH_LEN("name"), op_offset_special, 0, },/*27*/
564 { STR_WITH_LEN("desc"), op_offset_special, 0, },/*28*/
565 { STR_WITH_LEN("ppaddr"), op_offset_special, 0, },/*29*/
566 { STR_WITH_LEN("type"), op_offset_special, 0, },/*30*/
567 { STR_WITH_LEN("opt"), op_offset_special, 0, },/*31*/
568 { STR_WITH_LEN("spare"), op_offset_special, 0, },/*32*/
569 { STR_WITH_LEN("children"),op_offset_special, 0, },/*33*/
570 { STR_WITH_LEN("pmreplroot"), op_offset_special, 0, },/*34*/
571 { STR_WITH_LEN("pmstashpv"), op_offset_special, 0, },/*35*/
572 { STR_WITH_LEN("pmstash"), op_offset_special, 0, },/*36*/
573 { STR_WITH_LEN("precomp"), op_offset_special, 0, },/*37*/
574 { STR_WITH_LEN("reflags"), op_offset_special, 0, },/*38*/
575 { STR_WITH_LEN("sv"), op_offset_special, 0, },/*39*/
576 { STR_WITH_LEN("gv"), op_offset_special, 0, },/*40*/
577 { STR_WITH_LEN("pv"), op_offset_special, 0, },/*41*/
578 { STR_WITH_LEN("label"), op_offset_special, 0, },/*42*/
579 { STR_WITH_LEN("arybase"), op_offset_special, 0, },/*43*/
580 { STR_WITH_LEN("warnings"),op_offset_special, 0, },/*44*/
581 { STR_WITH_LEN("io"), op_offset_special, 0, },/*45*/
582 { STR_WITH_LEN("hints_hash"),op_offset_special, 0, },/*46*/
583 { STR_WITH_LEN("slabbed"), op_offset_special, 0, },/*47*/
584 { STR_WITH_LEN("savefree"),op_offset_special, 0, },/*48*/
585 { STR_WITH_LEN("static"), op_offset_special, 0, },/*49*/
586 { STR_WITH_LEN("folded"), op_offset_special, 0, },/*50*/
587 { STR_WITH_LEN("moresib"), op_offset_special, 0, },/*51*/
588 { STR_WITH_LEN("parent"), op_offset_special, 0, },/*52*/
589 { STR_WITH_LEN("first"), op_offset_special, 0, },/*53*/
590 { STR_WITH_LEN("meth_sv"), op_offset_special, 0, },/*54*/
591 { STR_WITH_LEN("pmregexp"),op_offset_special, 0, },/*55*/
592 # ifdef USE_ITHREADS
593 { STR_WITH_LEN("rclass"), op_offset_special, 0, },/*56*/
594 # else
595 { STR_WITH_LEN("rclass"), op_offset_special, 0, },/*56*/
596 # endif
597 };
598
599 #include "const-c.inc"
600
601 MODULE = B PACKAGE = B
602
603 INCLUDE: const-xs.inc
604
605 PROTOTYPES: DISABLE
606
607 BOOT:
608 {
609 CV *cv;
610 const char *file = __FILE__;
611 SV *sv;
612 MY_CXT_INIT;
613 B_init_my_cxt(aTHX_ &(MY_CXT));
614 cv = newXS("B::init_av", intrpvar_sv_common, file);
615 ASSIGN_COMMON_ALIAS(I, initav);
616 cv = newXS("B::check_av", intrpvar_sv_common, file);
617 ASSIGN_COMMON_ALIAS(I, checkav_save);
618 cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
619 ASSIGN_COMMON_ALIAS(I, unitcheckav_save);
620 cv = newXS("B::begin_av", intrpvar_sv_common, file);
621 ASSIGN_COMMON_ALIAS(I, beginav_save);
622 cv = newXS("B::end_av", intrpvar_sv_common, file);
623 ASSIGN_COMMON_ALIAS(I, endav);
624 cv = newXS("B::main_cv", intrpvar_sv_common, file);
625 ASSIGN_COMMON_ALIAS(I, main_cv);
626 cv = newXS("B::inc_gv", intrpvar_sv_common, file);
627 ASSIGN_COMMON_ALIAS(I, incgv);
628 cv = newXS("B::defstash", intrpvar_sv_common, file);
629 ASSIGN_COMMON_ALIAS(I, defstash);
630 cv = newXS("B::curstash", intrpvar_sv_common, file);
631 ASSIGN_COMMON_ALIAS(I, curstash);
632 #ifdef USE_ITHREADS
633 cv = newXS("B::regex_padav", intrpvar_sv_common, file);
634 ASSIGN_COMMON_ALIAS(I, regex_padav);
635 #endif
636 cv = newXS("B::warnhook", intrpvar_sv_common, file);
637 ASSIGN_COMMON_ALIAS(I, warnhook);
638 cv = newXS("B::diehook", intrpvar_sv_common, file);
639 ASSIGN_COMMON_ALIAS(I, diehook);
640 sv = get_sv("B::OP::does_parent", GV_ADDMULTI);
641 sv_setbool(sv, TRUE);
642 }
643
644 void
645 formfeed()
646 PPCODE:
647 PUSHs(make_sv_object(aTHX_ GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV))));
648
649 long
650 amagic_generation()
651 CODE:
652 RETVAL = PL_amagic_generation;
653 OUTPUT:
654 RETVAL
655
656 void
657 comppadlist()
658 PREINIT:
659 PADLIST *padlist = CvPADLIST(PL_main_cv ? PL_main_cv : PL_compcv);
660 PPCODE:
661 {
662 SV * const rv = sv_newmortal();
663 sv_setiv(newSVrv(rv, padlist ? "B::PADLIST" : "B::NULL"),
664 PTR2IV(padlist));
665 PUSHs(rv);
666 }
667
668 void
669 sv_undef()
670 ALIAS:
671 sv_no = 1
672 sv_yes = 2
673 PPCODE:
674 PUSHs(make_sv_object(aTHX_ ix > 1 ? &PL_sv_yes
675 : ix < 1 ? &PL_sv_undef
676 : &PL_sv_no));
677
678 void
679 main_root()
680 ALIAS:
681 main_start = 1
682 PPCODE:
683 PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root));
684
685 UV
686 sub_generation()
687 ALIAS:
688 dowarn = 1
689 CODE:
690 RETVAL = ix ? PL_dowarn : PL_sub_generation;
691 OUTPUT:
692 RETVAL
693
694 void
695 walkoptree(op, method)
696 B::OP op
697 const char * method
698 CODE:
699 (void) walkoptree(aTHX_ op, method, &PL_sv_undef);
700
701 int
702 walkoptree_debug(...)
703 CODE:
704 dMY_CXT;
705 RETVAL = walkoptree_debug;
706 if (items > 0 && SvTRUE(ST(1)))
707 walkoptree_debug = 1;
708 OUTPUT:
709 RETVAL
710
711 #define address(sv) PTR2IV(sv)
712
713 IV
714 address(sv)
715 SV * sv
716
717 void
718 svref_2object(sv)
719 SV * sv
720 PPCODE:
721 if (!SvROK(sv))
722 croak("argument is not a reference");
723 PUSHs(make_sv_object(aTHX_ SvRV(sv)));
724
725 void
opnumber(name)726 opnumber(name)
727 const char * name
728 CODE:
729 {
730 int i;
731 IV result = -1;
732 ST(0) = sv_newmortal();
733 if (strBEGINs(name,"pp_"))
734 name += 3;
735 for (i = 0; i < PL_maxo; i++)
736 {
737 if (strEQ(name, PL_op_name[i]))
738 {
739 result = i;
740 break;
741 }
742 }
743 sv_setiv(ST(0),result);
744 }
745
746 void
747 ppname(opnum)
748 int opnum
749 CODE:
750 ST(0) = sv_newmortal();
751 if (opnum >= 0 && opnum < PL_maxo)
752 Perl_sv_setpvf(aTHX_ ST(0), "pp_%s", PL_op_name[opnum]);
753
754 void
755 hash(sv)
756 SV * sv
757 CODE:
758 STRLEN len;
759 U32 hash = 0;
760 const char *s = SvPVbyte(sv, len);
761 PERL_HASH(hash, s, len);
762 ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%" UVxf, (UV)hash));
763
764 #define cast_I32(foo) (I32)foo
765 IV
766 cast_I32(i)
767 IV i
768
769 void
770 minus_c()
771 ALIAS:
772 save_BEGINs = 1
773 CODE:
774 if (ix)
775 PL_savebegin = TRUE;
776 else
777 PL_minus_c = TRUE;
778
779 void
780 cstring(sv)
781 SV * sv
782 ALIAS:
783 perlstring = 1
784 cchar = 2
785 PPCODE:
786 PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, (bool)ix));
787
788 void
789 threadsv_names()
790 PPCODE:
791
792
793 #ifdef USE_ITHREADS
794 void
795 CLONE(...)
796 PPCODE:
797 PUTBACK; /* some vars go out of scope now in machine code */
798 {
799 MY_CXT_CLONE;
800 B_init_my_cxt(aTHX_ &(MY_CXT));
801 }
802 return; /* dont execute another implied XSPP PUTBACK */
803
804 #endif
805
806 MODULE = B PACKAGE = B::OP
807
808
809 # The type checking code in B has always been identical for all OP types,
810 # irrespective of whether the action is actually defined on that OP.
811 # We should fix this
812 void
813 next(o)
814 B::OP o
815 ALIAS:
816 B::OP::next = 0
817 B::OP::sibling = 1
818 B::OP::targ = 2
819 B::OP::flags = 3
820 B::OP::private = 4
821 B::UNOP::first = 5
822 B::BINOP::last = 6
823 B::LOGOP::other = 7
824 B::PMOP::pmreplstart = 8
825 B::LOOP::redoop = 9
826 B::LOOP::nextop = 10
827 B::LOOP::lastop = 11
828 B::PMOP::pmflags = 12
829 B::PMOP::code_list = 13
830 B::SVOP::sv = 14
831 B::SVOP::gv = 15
832 B::PADOP::padix = 16
833 B::COP::cop_seq = 17
834 B::COP::line = 18
835 B::COP::hints = 19
836 B::PMOP::pmoffset = 20
837 B::COP::filegv = 21
838 B::COP::file = 22
839 B::COP::stash = 23
840 B::COP::stashpv = 24
841 B::COP::stashoff = 25
842 B::OP::size = 26
843 B::OP::name = 27
844 B::OP::desc = 28
845 B::OP::ppaddr = 29
846 B::OP::type = 30
847 B::OP::opt = 31
848 B::OP::spare = 32
849 B::LISTOP::children = 33
850 B::PMOP::pmreplroot = 34
851 B::PMOP::pmstashpv = 35
852 B::PMOP::pmstash = 36
853 B::PMOP::precomp = 37
854 B::PMOP::reflags = 38
855 B::PADOP::sv = 39
856 B::PADOP::gv = 40
857 B::PVOP::pv = 41
858 B::COP::label = 42
859 B::COP::arybase = 43
860 B::COP::warnings = 44
861 B::COP::io = 45
862 B::COP::hints_hash = 46
863 B::OP::slabbed = 47
864 B::OP::savefree = 48
865 B::OP::static = 49
866 B::OP::folded = 50
867 B::OP::moresib = 51
868 B::OP::parent = 52
869 B::METHOP::first = 53
870 B::METHOP::meth_sv = 54
871 B::PMOP::pmregexp = 55
872 B::METHOP::rclass = 56
873 PREINIT:
874 SV *ret;
875 PPCODE:
876 if (ix < 0 || (U32)ix >= C_ARRAY_LENGTH(op_methods))
877 croak("Illegal alias %d for B::*OP::next", (int)ix);
878 ret = get_overlay_object(aTHX_ o,
879 op_methods[ix].name, op_methods[ix].namelen);
880 if (ret) {
881 ST(0) = ret;
882 XSRETURN(1);
883 }
884
885 /* handle non-direct field access */
886
887 if (op_methods[ix].type == op_offset_special)
888 switch (ix) {
889 case 1: /* B::OP::op_sibling */
890 ret = make_op_object(aTHX_ OpSIBLING(o));
891 break;
892
893 case 8: /* B::PMOP::pmreplstart */
894 ret = make_op_object(aTHX_
895 cPMOPo->op_type == OP_SUBST
896 ? cPMOPo->op_pmstashstartu.op_pmreplstart
897 : NULL
898 );
899 break;
900 #ifdef USE_ITHREADS
901 case 21: /* B::COP::filegv */
902 ret = make_sv_object(aTHX_ (SV *)CopFILEGV((COP*)o));
903 break;
904 #endif
905 #ifndef USE_ITHREADS
906 case 22: /* B::COP::file */
907 ret = sv_2mortal(newSVpv(CopFILE((COP*)o), 0));
908 break;
909 #endif
910 #ifdef USE_ITHREADS
911 case 23: /* B::COP::stash */
912 ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o));
913 break;
914 #endif
915 case 24: /* B::COP::stashpv */
916 ret = sv_2mortal(CopSTASH((COP*)o)
917 && SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV
918 ? newSVhek(HvNAME_HEK(CopSTASH((COP*)o)))
919 : &PL_sv_undef);
920 break;
921 case 26: /* B::OP::size */
922 ret = sv_2mortal(newSVuv((UV)(opsizes[op_class(o)])));
923 break;
924 case 27: /* B::OP::name */
925 case 28: /* B::OP::desc */
926 ret = sv_2mortal(newSVpv(
927 (char *)(ix == 28 ? OP_DESC(o) : OP_NAME(o)), 0));
928 break;
929 case 29: /* B::OP::ppaddr */
930 {
931 int i;
932 ret = sv_2mortal(Perl_newSVpvf(aTHX_ "PL_ppaddr[OP_%s]",
933 PL_op_name[o->op_type]));
934 for (i=13; (STRLEN)i < SvCUR(ret); ++i)
935 SvPVX(ret)[i] = toUPPER(SvPVX(ret)[i]);
936 }
937 break;
938 case 30: /* B::OP::type */
939 case 31: /* B::OP::opt */
940 case 32: /* B::OP::spare */
941 case 47: /* B::OP::slabbed */
942 case 48: /* B::OP::savefree */
943 case 49: /* B::OP::static */
944 case 50: /* B::OP::folded */
945 case 51: /* B::OP::moresib */
946 /* These are all bitfields, so we can't take their addresses */
947 ret = sv_2mortal(newSVuv((UV)(
948 ix == 30 ? o->op_type
949 : ix == 31 ? o->op_opt
950 : ix == 47 ? o->op_slabbed
951 : ix == 48 ? o->op_savefree
952 : ix == 49 ? o->op_static
953 : ix == 50 ? o->op_folded
954 : ix == 51 ? o->op_moresib
955 : o->op_spare)));
956 break;
957 case 33: /* B::LISTOP::children */
958 {
959 OP *kid;
960 UV i = 0;
961 for (kid = ((LISTOP*)o)->op_first; kid; kid = OpSIBLING(kid))
962 i++;
963 ret = sv_2mortal(newSVuv(i));
964 }
965 break;
966 case 34: /* B::PMOP::pmreplroot */
967 if (cPMOPo->op_type == OP_SPLIT) {
968 ret = sv_newmortal();
969 #ifndef USE_ITHREADS
970 if (o->op_private & OPpSPLIT_LEX)
971 #endif
972 sv_setiv(ret, cPMOPo->op_pmreplrootu.op_pmtargetoff);
973 #ifndef USE_ITHREADS
974 else {
975 GV *const target = cPMOPo->op_pmreplrootu.op_pmtargetgv;
976 sv_setiv(newSVrv(ret, target ?
977 svclassnames[SvTYPE((SV*)target)] : "B::SV"),
978 PTR2IV(target));
979 }
980 #endif
981 }
982 else {
983 OP *const root = cPMOPo->op_pmreplrootu.op_pmreplroot;
984 ret = make_op_object(aTHX_ root);
985 }
986 break;
987 #ifdef USE_ITHREADS
988 case 35: /* B::PMOP::pmstashpv */
989 ret = sv_2mortal(newSVpv(PmopSTASHPV(cPMOPo),0));
990 break;
991 #else
992 case 36: /* B::PMOP::pmstash */
993 ret = make_sv_object(aTHX_ (SV *) PmopSTASH(cPMOPo));
994 break;
995 #endif
996 case 37: /* B::PMOP::precomp */
997 case 38: /* B::PMOP::reflags */
998 {
999 REGEXP *rx = PM_GETRE(cPMOPo);
1000 ret = sv_newmortal();
1001 if (rx) {
1002 if (ix==38) {
1003 sv_setuv(ret, RX_EXTFLAGS(rx));
1004 }
1005 else {
1006 sv_setpvn(ret, RX_PRECOMP(rx), RX_PRELEN(rx));
1007 if (RX_UTF8(rx))
1008 SvUTF8_on(ret);
1009 }
1010 }
1011 }
1012 break;
1013 case 39: /* B::PADOP::sv */
1014 case 40: /* B::PADOP::gv */
1015 /* PADOPs should only be created on threaded builds.
1016 * They don't have an sv or gv field, just an op_padix
1017 * field. Leave it to the caller to retrieve padix
1018 * and look up th value in the pad. Don't do it here,
1019 * becuase PL_curpad is the pad of the caller, not the
1020 * pad of the sub the op is part of */
1021 ret = make_sv_object(aTHX_ NULL);
1022 break;
1023 case 41: /* B::PVOP::pv */
1024 /* OP_TRANS uses op_pv to point to a OPtrans_map struct,
1025 * whereas other PVOPs point to a null terminated string.
1026 * For trans, for now just return the whole struct as a
1027 * string and let the caller unpack() it */
1028 if ( cPVOPo->op_type == OP_TRANS
1029 || cPVOPo->op_type == OP_TRANSR)
1030 {
1031 const OPtrans_map *const tbl = (OPtrans_map*)cPVOPo->op_pv;
1032 ret = newSVpvn_flags(cPVOPo->op_pv,
1033 (char*)(&tbl->map[tbl->size + 1])
1034 - (char*)tbl,
1035 SVs_TEMP);
1036 }
1037 else
1038 ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP);
1039 break;
1040 case 42: /* B::COP::label */
1041 ret = sv_2mortal(newSVpv(CopLABEL(cCOPo),0));
1042 break;
1043 case 43: /* B::COP::arybase */
1044 ret = sv_2mortal(newSVuv(0));
1045 break;
1046 case 44: /* B::COP::warnings */
1047 ret = make_warnings_object(aTHX_ cCOPo);
1048 break;
1049 case 45: /* B::COP::io */
1050 ret = make_cop_io_object(aTHX_ cCOPo);
1051 break;
1052 case 46: /* B::COP::hints_hash */
1053 ret = sv_newmortal();
1054 sv_setiv(newSVrv(ret, "B::RHE"),
1055 PTR2IV(CopHINTHASH_get(cCOPo)));
1056 break;
1057 case 52: /* B::OP::parent */
1058 #ifdef PERL_OP_PARENT
1059 ret = make_op_object(aTHX_ op_parent(o));
1060 #else
1061 ret = make_op_object(aTHX_ NULL);
1062 #endif
1063 break;
1064 case 53: /* B::METHOP::first */
1065 /* METHOP struct has an op_first/op_meth_sv union
1066 * as its first extra field. How to interpret the
1067 * union depends on the op type. For the purposes of
1068 * B, we treat it as a struct with both fields present,
1069 * where one of the fields always happens to be null
1070 * (i.e. we return NULL in preference to croaking with
1071 * 'method not implemented').
1072 */
1073 ret = make_op_object(aTHX_
1074 o->op_type == OP_METHOD
1075 ? cMETHOPx(o)->op_u.op_first : NULL);
1076 break;
1077 case 54: /* B::METHOP::meth_sv */
1078 /* see comment above about METHOP */
1079 ret = make_sv_object(aTHX_
1080 o->op_type == OP_METHOD
1081 ? NULL : cMETHOPx(o)->op_u.op_meth_sv);
1082 break;
1083 case 55: /* B::PMOP::pmregexp */
1084 ret = make_sv_object(aTHX_ (SV *)PM_GETRE(cPMOPo));
1085 break;
1086 case 56: /* B::METHOP::rclass */
1087 #ifdef USE_ITHREADS
1088 ret = sv_2mortal(newSVuv(
1089 (o->op_type == OP_METHOD_REDIR ||
1090 o->op_type == OP_METHOD_REDIR_SUPER) ?
1091 cMETHOPx(o)->op_rclass_targ : 0
1092 ));
1093 #else
1094 ret = make_sv_object(aTHX_
1095 (o->op_type == OP_METHOD_REDIR ||
1096 o->op_type == OP_METHOD_REDIR_SUPER) ?
1097 cMETHOPx(o)->op_rclass_sv : NULL
1098 );
1099 #endif
1100 break;
1101 default:
1102 croak("method %s not implemented", op_methods[ix].name);
1103 } else {
1104 /* do a direct structure offset lookup */
1105 const char *const ptr = (char *)o + op_methods[ix].offset;
1106 switch (op_methods[ix].type) {
1107 case OPp:
1108 ret = make_op_object(aTHX_ *((OP **)ptr));
1109 break;
1110 case PADOFFSETp:
1111 ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
1112 break;
1113 case U8p:
1114 ret = sv_2mortal(newSVuv(*((U8*)ptr)));
1115 break;
1116 case U32p:
1117 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1118 break;
1119 case SVp:
1120 ret = make_sv_object(aTHX_ *((SV **)ptr));
1121 break;
1122 case line_tp:
1123 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1124 break;
1125 case IVp:
1126 ret = sv_2mortal(newSViv(*((IV*)ptr)));
1127 break;
1128 case char_pp:
1129 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1130 break;
1131 default:
1132 croak("Illegal type 0x%x for B::*OP::%s",
1133 (unsigned)op_methods[ix].type, op_methods[ix].name);
1134 }
1135 }
1136 ST(0) = ret;
1137 XSRETURN(1);
1138
1139
1140 void
1141 oplist(o)
1142 B::OP o
1143 PPCODE:
1144 SP = oplist(aTHX_ o, SP);
1145
1146
1147
1148 MODULE = B PACKAGE = B::UNOP_AUX
1149
1150 # UNOP_AUX class ops are like UNOPs except that they have an extra
1151 # op_aux pointer that points to an array of UNOP_AUX_item unions.
1152 # Element -1 of the array contains the length
1153
1154
1155 # return a string representation of op_aux where possible The op's CV is
1156 # needed as an extra arg to allow GVs and SVs moved into the pad to be
1157 # accessed okay.
1158
1159 void
1160 string(o, cv)
1161 B::OP o
1162 B::CV cv
1163 PREINIT:
1164 SV *ret;
1165 UNOP_AUX_item *aux;
1166 PPCODE:
1167 aux = cUNOP_AUXo->op_aux;
1168 switch (o->op_type) {
1169 case OP_MULTICONCAT:
1170 ret = multiconcat_stringify(o);
1171 break;
1172
1173 case OP_MULTIDEREF:
1174 ret = multideref_stringify(o, cv);
1175 break;
1176
1177 case OP_ARGELEM:
1178 ret = sv_2mortal(Perl_newSVpvf(aTHX_ "%" IVdf,
1179 PTR2IV(aux)));
1180 break;
1181
1182 case OP_ARGCHECK:
1183 {
1184 struct op_argcheck_aux *p = (struct op_argcheck_aux*)aux;
1185 ret = Perl_newSVpvf(aTHX_ "%" IVdf ",%" IVdf,
1186 p->params, p->opt_params);
1187 if (p->slurpy)
1188 Perl_sv_catpvf(aTHX_ ret, ",%c", p->slurpy);
1189 ret = sv_2mortal(ret);
1190 break;
1191 }
1192
1193 default:
1194 ret = sv_2mortal(newSVpvn("", 0));
1195 }
1196
1197 ST(0) = ret;
1198 XSRETURN(1);
1199
1200
1201 # Return the contents of the op_aux array as a list of IV/GV/etc objects.
1202 # How to interpret each array element is op-dependent. The op's CV is
1203 # needed as an extra arg to allow GVs and SVs which have been moved into
1204 # the pad to be accessed okay.
1205
1206 void
1207 aux_list(o, cv)
1208 B::OP o
1209 B::CV cv
1210 PREINIT:
1211 UNOP_AUX_item *aux;
1212 PPCODE:
1213 PERL_UNUSED_VAR(cv); /* not needed on unthreaded builds */
1214 aux = cUNOP_AUXo->op_aux;
1215 switch (o->op_type) {
1216 default:
1217 XSRETURN(0); /* by default, an empty list */
1218
1219 case OP_ARGELEM:
1220 XPUSHs(sv_2mortal(newSViv(PTR2IV(aux))));
1221 XSRETURN(1);
1222 break;
1223
1224 case OP_ARGCHECK:
1225 {
1226 struct op_argcheck_aux *p = (struct op_argcheck_aux*)aux;
1227 EXTEND(SP, 3);
1228 PUSHs(sv_2mortal(newSViv(p->params)));
1229 PUSHs(sv_2mortal(newSViv(p->opt_params)));
1230 PUSHs(sv_2mortal(p->slurpy
1231 ? Perl_newSVpvf(aTHX_ "%c", p->slurpy)
1232 : &PL_sv_no));
1233 break;
1234 }
1235
1236 case OP_MULTICONCAT:
1237 {
1238 SSize_t nargs;
1239 char *p;
1240 STRLEN len;
1241 U32 utf8 = 0;
1242 SV *sv;
1243 UNOP_AUX_item *lens;
1244
1245 /* return (nargs, const string, segment len 0, 1, 2, ...) */
1246
1247 /* if this changes, this block of code probably needs fixing */
1248 assert(PERL_MULTICONCAT_HEADER_SIZE == 5);
1249 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
1250 EXTEND(SP, ((SSize_t)(2 + (nargs+1))));
1251 PUSHs(sv_2mortal(newSViv((IV)nargs)));
1252
1253 p = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1254 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
1255 if (!p) {
1256 p = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1257 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
1258 utf8 = SVf_UTF8;
1259 }
1260 sv = newSVpvn(p, len);
1261 SvFLAGS(sv) |= utf8;
1262 PUSHs(sv_2mortal(sv));
1263
1264 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
1265 nargs++; /* loop (nargs+1) times */
1266 if (utf8) {
1267 U8 *p = (U8*)SvPVX(sv);
1268 while (nargs--) {
1269 SSize_t bytes = lens->ssize;
1270 SSize_t chars;
1271 if (bytes <= 0)
1272 chars = bytes;
1273 else {
1274 /* return char lengths rather than byte lengths */
1275 chars = utf8_length(p, p + bytes);
1276 p += bytes;
1277 }
1278 lens++;
1279 PUSHs(sv_2mortal(newSViv(chars)));
1280 }
1281 }
1282 else {
1283 while (nargs--) {
1284 PUSHs(sv_2mortal(newSViv(lens->ssize)));
1285 lens++;
1286 }
1287 }
1288 break;
1289 }
1290
1291 case OP_MULTIDEREF:
1292 #ifdef USE_ITHREADS
1293 # define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE);
1294 #else
1295 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
1296 #endif
1297 {
1298 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1299 UV actions = items->uv;
1300 UV len = items[-1].uv;
1301 SV *sv;
1302 bool last = 0;
1303 bool is_hash = FALSE;
1304 #ifdef USE_ITHREADS
1305 PADLIST * const padlist = CvPADLIST(cv);
1306 PAD *comppad = PadlistARRAY(padlist)[1];
1307 #endif
1308
1309 /* len should never be big enough to truncate or wrap */
1310 assert(len <= SSize_t_MAX);
1311 EXTEND(SP, (SSize_t)len);
1312 PUSHs(sv_2mortal(newSViv(actions)));
1313
1314 while (!last) {
1315 switch (actions & MDEREF_ACTION_MASK) {
1316
1317 case MDEREF_reload:
1318 actions = (++items)->uv;
1319 PUSHs(sv_2mortal(newSVuv(actions)));
1320 continue;
1321 NOT_REACHED; /* NOTREACHED */
1322
1323 case MDEREF_HV_padhv_helem:
1324 is_hash = TRUE;
1325 /* FALLTHROUGH */
1326 case MDEREF_AV_padav_aelem:
1327 PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
1328 goto do_elem;
1329 NOT_REACHED; /* NOTREACHED */
1330
1331 case MDEREF_HV_gvhv_helem:
1332 is_hash = TRUE;
1333 /* FALLTHROUGH */
1334 case MDEREF_AV_gvav_aelem:
1335 sv = ITEM_SV(++items);
1336 PUSHs(make_sv_object(aTHX_ sv));
1337 goto do_elem;
1338 NOT_REACHED; /* NOTREACHED */
1339
1340 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1341 is_hash = TRUE;
1342 /* FALLTHROUGH */
1343 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1344 sv = ITEM_SV(++items);
1345 PUSHs(make_sv_object(aTHX_ sv));
1346 goto do_vivify_rv2xv_elem;
1347 NOT_REACHED; /* NOTREACHED */
1348
1349 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1350 is_hash = TRUE;
1351 /* FALLTHROUGH */
1352 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1353 PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
1354 goto do_vivify_rv2xv_elem;
1355 NOT_REACHED; /* NOTREACHED */
1356
1357 case MDEREF_HV_pop_rv2hv_helem:
1358 case MDEREF_HV_vivify_rv2hv_helem:
1359 is_hash = TRUE;
1360 /* FALLTHROUGH */
1361 do_vivify_rv2xv_elem:
1362 case MDEREF_AV_pop_rv2av_aelem:
1363 case MDEREF_AV_vivify_rv2av_aelem:
1364 do_elem:
1365 switch (actions & MDEREF_INDEX_MASK) {
1366 case MDEREF_INDEX_none:
1367 last = 1;
1368 break;
1369 case MDEREF_INDEX_const:
1370 if (is_hash) {
1371 sv = ITEM_SV(++items);
1372 PUSHs(make_sv_object(aTHX_ sv));
1373 }
1374 else
1375 PUSHs(sv_2mortal(newSViv((++items)->iv)));
1376 break;
1377 case MDEREF_INDEX_padsv:
1378 PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
1379 break;
1380 case MDEREF_INDEX_gvsv:
1381 sv = ITEM_SV(++items);
1382 PUSHs(make_sv_object(aTHX_ sv));
1383 break;
1384 }
1385 if (actions & MDEREF_FLAG_last)
1386 last = 1;
1387 is_hash = FALSE;
1388
1389 break;
1390 } /* switch */
1391
1392 actions >>= MDEREF_SHIFT;
1393 } /* while */
1394 XSRETURN(len);
1395
1396 } /* OP_MULTIDEREF */
1397 } /* switch */
1398
1399
1400
1401 MODULE = B PACKAGE = B::SV
1402
1403 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1404
1405 U32
1406 REFCNT(sv)
1407 B::SV sv
1408 ALIAS:
1409 FLAGS = 0xFFFFFFFF
1410 SvTYPE = SVTYPEMASK
1411 POK = SVf_POK
1412 ROK = SVf_ROK
1413 MAGICAL = MAGICAL_FLAG_BITS
1414 CODE:
1415 RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1416 OUTPUT:
1417 RETVAL
1418
1419 void
1420 object_2svref(sv)
1421 B::SV sv
1422 PPCODE:
1423 ST(0) = sv_2mortal(newRV(sv));
1424 XSRETURN(1);
1425
1426 MODULE = B PACKAGE = B::IV PREFIX = Sv
1427
1428 IV
1429 SvIV(sv)
1430 B::IV sv
1431
1432 MODULE = B PACKAGE = B::IV
1433
1434 #define sv_SVp 0x00000
1435 #define sv_IVp 0x10000
1436 #define sv_UVp 0x20000
1437 #define sv_STRLENp 0x30000
1438 #define sv_U32p 0x40000
1439 #define sv_U8p 0x50000
1440 #define sv_char_pp 0x60000
1441 #define sv_NVp 0x70000
1442 #define sv_char_p 0x80000
1443 #define sv_SSize_tp 0x90000
1444 #define sv_I32p 0xA0000
1445 #define sv_U16p 0xB0000
1446
1447 #define IV_ivx_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_iv)
1448 #define IV_uvx_ix sv_UVp | STRUCT_OFFSET(struct xpvuv, xuv_uv)
1449 #define NV_nvx_ix sv_NVp | STRUCT_OFFSET(struct xpvnv, xnv_u.xnv_nv)
1450
1451 #define PV_cur_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_cur)
1452 #define PV_len_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_len)
1453
1454 #define PVMG_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvmg, xmg_stash)
1455
1456 #define PVBM_useful_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_u.xivu_iv)
1457
1458 #define PVLV_targoff_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targoff)
1459 #define PVLV_targlen_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targlen)
1460 #define PVLV_targ_ix sv_SVp | STRUCT_OFFSET(struct xpvlv, xlv_targ)
1461 #define PVLV_type_ix sv_char_p | STRUCT_OFFSET(struct xpvlv, xlv_type)
1462
1463 #define PVGV_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvgv, xnv_u.xgv_stash)
1464 #define PVGV_flags_ix sv_STRLENp | STRUCT_OFFSET(struct xpvgv, xpv_cur)
1465 #define PVIO_lines_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xiv_iv)
1466
1467 #define PVIO_page_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page)
1468 #define PVIO_page_len_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page_len)
1469 #define PVIO_lines_left_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_lines_left)
1470 #define PVIO_top_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_top_name)
1471 #define PVIO_top_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_top_gv)
1472 #define PVIO_fmt_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_fmt_name)
1473 #define PVIO_fmt_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_fmt_gv)
1474 #define PVIO_bottom_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_bottom_name)
1475 #define PVIO_bottom_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_bottom_gv)
1476 #define PVIO_type_ix sv_char_p | STRUCT_OFFSET(struct xpvio, xio_type)
1477 #define PVIO_flags_ix sv_U8p | STRUCT_OFFSET(struct xpvio, xio_flags)
1478
1479 #define PVAV_max_ix sv_SSize_tp | STRUCT_OFFSET(struct xpvav, xav_max)
1480
1481 #define PVCV_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_stash)
1482 #define PVCV_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv_u.xcv_gv)
1483 #define PVCV_file_ix sv_char_pp | STRUCT_OFFSET(struct xpvcv, xcv_file)
1484 #define PVCV_outside_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_outside)
1485 #define PVCV_outside_seq_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_outside_seq)
1486 #define PVCV_flags_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_flags)
1487
1488 #define PVHV_max_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_max)
1489 #define PVHV_keys_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_keys)
1490
1491 # The type checking code in B has always been identical for all SV types,
1492 # irrespective of whether the action is actually defined on that SV.
1493 # We should fix this
1494 void
1495 IVX(sv)
1496 B::SV sv
1497 ALIAS:
1498 B::IV::IVX = IV_ivx_ix
1499 B::IV::UVX = IV_uvx_ix
1500 B::NV::NVX = NV_nvx_ix
1501 B::PV::CUR = PV_cur_ix
1502 B::PV::LEN = PV_len_ix
1503 B::PVMG::SvSTASH = PVMG_stash_ix
1504 B::PVLV::TARGOFF = PVLV_targoff_ix
1505 B::PVLV::TARGLEN = PVLV_targlen_ix
1506 B::PVLV::TARG = PVLV_targ_ix
1507 B::PVLV::TYPE = PVLV_type_ix
1508 B::GV::STASH = PVGV_stash_ix
1509 B::GV::GvFLAGS = PVGV_flags_ix
1510 B::BM::USEFUL = PVBM_useful_ix
1511 B::IO::LINES = PVIO_lines_ix
1512 B::IO::PAGE = PVIO_page_ix
1513 B::IO::PAGE_LEN = PVIO_page_len_ix
1514 B::IO::LINES_LEFT = PVIO_lines_left_ix
1515 B::IO::TOP_NAME = PVIO_top_name_ix
1516 B::IO::TOP_GV = PVIO_top_gv_ix
1517 B::IO::FMT_NAME = PVIO_fmt_name_ix
1518 B::IO::FMT_GV = PVIO_fmt_gv_ix
1519 B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1520 B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1521 B::IO::IoTYPE = PVIO_type_ix
1522 B::IO::IoFLAGS = PVIO_flags_ix
1523 B::AV::MAX = PVAV_max_ix
1524 B::CV::STASH = PVCV_stash_ix
1525 B::CV::FILE = PVCV_file_ix
1526 B::CV::OUTSIDE = PVCV_outside_ix
1527 B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1528 B::CV::CvFLAGS = PVCV_flags_ix
1529 B::HV::MAX = PVHV_max_ix
1530 B::HV::KEYS = PVHV_keys_ix
1531 PREINIT:
1532 char *ptr;
1533 SV *ret;
1534 PPCODE:
1535 ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1536 switch ((U8)(ix >> 16)) {
1537 case (U8)(sv_SVp >> 16):
1538 ret = make_sv_object(aTHX_ *((SV **)ptr));
1539 break;
1540 case (U8)(sv_IVp >> 16):
1541 ret = sv_2mortal(newSViv(*((IV *)ptr)));
1542 break;
1543 case (U8)(sv_UVp >> 16):
1544 ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1545 break;
1546 case (U8)(sv_STRLENp >> 16):
1547 ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1548 break;
1549 case (U8)(sv_U32p >> 16):
1550 ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1551 break;
1552 case (U8)(sv_U8p >> 16):
1553 ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1554 break;
1555 case (U8)(sv_char_pp >> 16):
1556 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1557 break;
1558 case (U8)(sv_NVp >> 16):
1559 ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1560 break;
1561 case (U8)(sv_char_p >> 16):
1562 ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1563 break;
1564 case (U8)(sv_SSize_tp >> 16):
1565 ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1566 break;
1567 case (U8)(sv_I32p >> 16):
1568 ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1569 break;
1570 case (U8)(sv_U16p >> 16):
1571 ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1572 break;
1573 default:
1574 croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
1575 }
1576 ST(0) = ret;
1577 XSRETURN(1);
1578
1579 void
1580 packiv(sv)
1581 B::IV sv
1582 ALIAS:
1583 needs64bits = 1
1584 CODE:
1585 if (ix) {
1586 ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1587 } else if (sizeof(IV) == 8) {
1588 U32 wp[2];
1589 const IV iv = SvIVX(sv);
1590 /*
1591 * The following way of spelling 32 is to stop compilers on
1592 * 32-bit architectures from moaning about the shift count
1593 * being >= the width of the type. Such architectures don't
1594 * reach this code anyway (unless sizeof(IV) > 8 but then
1595 * everything else breaks too so I'm not fussed at the moment).
1596 */
1597 #ifdef UV_IS_QUAD
1598 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1599 #else
1600 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1601 #endif
1602 wp[1] = htonl(iv & 0xffffffff);
1603 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1604 } else {
1605 U32 w = htonl((U32)SvIVX(sv));
1606 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1607 }
1608
1609 MODULE = B PACKAGE = B::NV PREFIX = Sv
1610
1611 NV
1612 SvNV(sv)
1613 B::NV sv
1614
1615 MODULE = B PACKAGE = B::REGEXP
1616
1617 void
1618 REGEX(sv)
1619 B::REGEXP sv
1620 ALIAS:
1621 precomp = 1
1622 qr_anoncv = 2
1623 compflags = 3
1624 PPCODE:
1625 if (ix == 1) {
1626 PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1627 } else if (ix == 2) {
1628 PUSHs(make_sv_object(aTHX_ (SV *)ReANY(sv)->qr_anoncv));
1629 } else {
1630 dXSTARG;
1631 if (ix)
1632 PUSHu(RX_COMPFLAGS(sv));
1633 else
1634 /* FIXME - can we code this method more efficiently? */
1635 PUSHi(PTR2IV(sv));
1636 }
1637
1638 MODULE = B PACKAGE = B::INVLIST PREFIX = Invlist
1639
1640 int
1641 prev_index(invlist)
1642 B::INVLIST invlist
1643 CODE:
1644 RETVAL = ((XINVLIST*) SvANY(invlist))->prev_index;
1645 OUTPUT:
1646 RETVAL
1647
1648 int
1649 is_offset(invlist)
1650 B::INVLIST invlist
1651 CODE:
1652 RETVAL = ((XINVLIST*) SvANY(invlist))->is_offset == TRUE ? 1 : 0;
1653 OUTPUT:
1654 RETVAL
1655
1656 unsigned int
array_len(invlist)1657 array_len(invlist)
1658 B::INVLIST invlist
1659 CODE:
1660 {
1661 if (SvCUR(invlist) > 0)
1662 RETVAL = FROM_INTERNAL_SIZE(SvCUR(invlist)); /* - ((XINVLIST*) SvANY(invlist))->is_offset; */ /* <- for iteration */
1663 else
1664 RETVAL = 0;
1665 }
1666 OUTPUT:
1667 RETVAL
1668
1669 void
get_invlist_array(invlist)1670 get_invlist_array(invlist)
1671 B::INVLIST invlist
1672 PPCODE:
1673 {
1674 /* should use invlist_is_iterating but not public for now */
1675 bool is_iterating = ( (XINVLIST*) SvANY(invlist) )->iterator < (STRLEN) UV_MAX;
1676
1677 if (is_iterating) {
1678 croak( "Can't access inversion list: in middle of iterating" );
1679 }
1680
1681 {
1682 UV pos;
1683 UV len;
1684
1685 len = 0;
1686 /* should use _invlist_len (or not) */
1687 if (SvCUR(invlist) > 0)
1688 len = FROM_INTERNAL_SIZE(SvCUR(invlist)); /* - ((XINVLIST*) SvANY(invlist))->is_offset; */ /* <- for iteration */
1689
1690 if ( len > 0 ) {
1691 UV *array = (UV*) SvPVX( invlist ); /* invlist_array */
1692
1693 EXTEND(SP, (int) len);
1694
1695 for ( pos = 0; pos < len; ++pos ) {
1696 PUSHs( sv_2mortal( newSVuv(array[pos]) ) );
1697 }
1698 }
1699 }
1700
1701 }
1702
1703 MODULE = B PACKAGE = B::PV
1704
1705 void
1706 RV(sv)
1707 B::PV sv
1708 PPCODE:
1709 if (!SvROK(sv))
1710 croak( "argument is not SvROK" );
1711 PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1712
1713 void
1714 PV(sv)
1715 B::PV sv
1716 ALIAS:
1717 PVX = 1
1718 PVBM = 2
1719 B::BM::TABLE = 3
1720 PREINIT:
1721 const char *p;
1722 STRLEN len = 0;
1723 U32 utf8 = 0;
1724 CODE:
1725 if (ix == 3) {
1726 const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm);
1727
1728 if (!mg)
1729 croak("argument to B::BM::TABLE is not a PVBM");
1730 p = mg->mg_ptr;
1731 len = mg->mg_len;
1732 } else if (ix == 2) {
1733 /* This used to read 257. I think that that was buggy - should have
1734 been 258. (The "\0", the flags byte, and 256 for the table.)
1735 The only user of this method is B::Bytecode in B::PV::bsave.
1736 I'm guessing that nothing tested the runtime correctness of
1737 output of bytecompiled string constant arguments to index (etc).
1738
1739 Note the start pointer is and has always been SvPVX(sv), not
1740 SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1741 first used by the compiler in 651aa52ea1faa806. It's used to
1742 get a "complete" dump of the buffer at SvPVX(), not just the
1743 PVBM table. This permits the generated bytecode to "load"
1744 SvPVX in "one" hit.
1745
1746 5.15 and later store the BM table via MAGIC, so the compiler
1747 should handle this just fine without changes if PVBM now
1748 always returns the SvPVX() buffer. */
1749 p = isREGEXP(sv)
1750 ? RX_WRAPPED_const((REGEXP*)sv)
1751 : SvPVX_const(sv);
1752 len = SvCUR(sv);
1753 } else if (ix) {
1754 p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv);
1755 len = strlen(p);
1756 } else if (SvPOK(sv)) {
1757 len = SvCUR(sv);
1758 p = SvPVX_const(sv);
1759 utf8 = SvUTF8(sv);
1760 } else if (isREGEXP(sv)) {
1761 len = SvCUR(sv);
1762 p = RX_WRAPPED_const((REGEXP*)sv);
1763 utf8 = SvUTF8(sv);
1764 } else {
1765 /* XXX for backward compatibility, but should fail */
1766 /* croak( "argument is not SvPOK" ); */
1767 p = NULL;
1768 }
1769 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
1770
1771 MODULE = B PACKAGE = B::PVMG
1772
1773 void
1774 MAGIC(sv)
1775 B::PVMG sv
1776 MAGIC * mg = NO_INIT
1777 PPCODE:
1778 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1779 XPUSHs(make_mg_object(aTHX_ mg));
1780
1781 MODULE = B PACKAGE = B::MAGIC
1782
1783 void
1784 MOREMAGIC(mg)
1785 B::MAGIC mg
1786 ALIAS:
1787 PRIVATE = 1
1788 TYPE = 2
1789 FLAGS = 3
1790 LENGTH = 4
1791 OBJ = 5
1792 PTR = 6
1793 REGEX = 7
1794 precomp = 8
1795 PPCODE:
1796 switch (ix) {
1797 case 0:
1798 XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1799 : &PL_sv_undef);
1800 break;
1801 case 1:
1802 mPUSHu(mg->mg_private);
1803 break;
1804 case 2:
1805 PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1806 break;
1807 case 3:
1808 mPUSHu(mg->mg_flags);
1809 break;
1810 case 4:
1811 mPUSHi(mg->mg_len);
1812 break;
1813 case 5:
1814 PUSHs(make_sv_object(aTHX_ mg->mg_obj));
1815 break;
1816 case 6:
1817 if (mg->mg_ptr) {
1818 if (mg->mg_len >= 0) {
1819 PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
1820 } else if (mg->mg_len == HEf_SVKEY) {
1821 PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
1822 } else
1823 PUSHs(sv_newmortal());
1824 } else
1825 PUSHs(sv_newmortal());
1826 break;
1827 case 7:
1828 if(mg->mg_type == PERL_MAGIC_qr) {
1829 mPUSHi(PTR2IV(mg->mg_obj));
1830 } else {
1831 croak("REGEX is only meaningful on r-magic");
1832 }
1833 break;
1834 case 8:
1835 if (mg->mg_type == PERL_MAGIC_qr) {
1836 REGEXP *rx = (REGEXP *)mg->mg_obj;
1837 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1838 rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
1839 } else {
1840 croak( "precomp is only meaningful on r-magic" );
1841 }
1842 break;
1843 }
1844
1845 MODULE = B PACKAGE = B::BM PREFIX = Bm
1846
1847 U32
1848 BmPREVIOUS(sv)
1849 B::BM sv
1850 CODE:
1851 PERL_UNUSED_VAR(sv);
1852 RETVAL = BmPREVIOUS(sv);
1853 OUTPUT:
1854 RETVAL
1855
1856
1857 U8
1858 BmRARE(sv)
1859 B::BM sv
1860 CODE:
1861 PERL_UNUSED_VAR(sv);
1862 RETVAL = BmRARE(sv);
1863 OUTPUT:
1864 RETVAL
1865
1866
1867 MODULE = B PACKAGE = B::GV PREFIX = Gv
1868
1869 void
1870 GvNAME(gv)
1871 B::GV gv
1872 ALIAS:
1873 FILE = 1
1874 B::HV::NAME = 2
1875 CODE:
1876 ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1877 : (ix == 1 ? GvFILE_HEK(gv)
1878 : HvNAME_HEK((HV *)gv))));
1879
1880 bool
1881 is_empty(gv)
1882 B::GV gv
1883 ALIAS:
1884 isGV_with_GP = 1
1885 CODE:
1886 if (ix) {
1887 RETVAL = cBOOL(isGV_with_GP(gv));
1888 } else {
1889 RETVAL = GvGP(gv) == Null(GP*);
1890 }
1891 OUTPUT:
1892 RETVAL
1893
1894 void*
1895 GvGP(gv)
1896 B::GV gv
1897
1898 #define GP_sv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_sv)
1899 #define GP_io_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_io)
1900 #define GP_cv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_cv)
1901 #define GP_cvgen_ix (U32p << 16) | STRUCT_OFFSET(struct gp, gp_cvgen)
1902 #define GP_refcnt_ix (U32p << 16) | STRUCT_OFFSET(struct gp, gp_refcnt)
1903 #define GP_hv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_hv)
1904 #define GP_av_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_av)
1905 #define GP_form_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_form)
1906 #define GP_egv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_egv)
1907
1908 void
1909 SV(gv)
1910 B::GV gv
1911 ALIAS:
1912 SV = GP_sv_ix
1913 IO = GP_io_ix
1914 CV = GP_cv_ix
1915 CVGEN = GP_cvgen_ix
1916 GvREFCNT = GP_refcnt_ix
1917 HV = GP_hv_ix
1918 AV = GP_av_ix
1919 FORM = GP_form_ix
1920 EGV = GP_egv_ix
1921 PREINIT:
1922 GP *gp;
1923 char *ptr;
1924 SV *ret;
1925 PPCODE:
1926 gp = GvGP(gv);
1927 if (!gp) {
1928 const GV *const gv = CvGV(cv);
1929 Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1930 }
1931 ptr = (ix & 0xFFFF) + (char *)gp;
1932 switch ((U8)(ix >> 16)) {
1933 case SVp:
1934 ret = make_sv_object(aTHX_ *((SV **)ptr));
1935 break;
1936 case U32p:
1937 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1938 break;
1939 default:
1940 croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
1941 }
1942 ST(0) = ret;
1943 XSRETURN(1);
1944
1945 U32
1946 GvLINE(gv)
1947 B::GV gv
1948
1949 U32
1950 GvGPFLAGS(gv)
1951 B::GV gv
1952
1953 void
1954 FILEGV(gv)
1955 B::GV gv
1956 PPCODE:
1957 PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
1958
1959 MODULE = B PACKAGE = B::IO PREFIX = Io
1960
1961
1962 bool
1963 IsSTD(io,name)
1964 B::IO io
1965 const char* name
1966 PREINIT:
1967 PerlIO* handle = 0;
1968 CODE:
1969 if( strEQ( name, "stdin" ) ) {
1970 handle = PerlIO_stdin();
1971 }
1972 else if( strEQ( name, "stdout" ) ) {
1973 handle = PerlIO_stdout();
1974 }
1975 else if( strEQ( name, "stderr" ) ) {
1976 handle = PerlIO_stderr();
1977 }
1978 else {
1979 croak( "Invalid value '%s'", name );
1980 }
1981 RETVAL = handle == IoIFP(io);
1982 OUTPUT:
1983 RETVAL
1984
1985 MODULE = B PACKAGE = B::AV PREFIX = Av
1986
1987 SSize_t
1988 AvFILL(av)
1989 B::AV av
1990
1991 void
1992 AvARRAY(av)
1993 B::AV av
1994 PPCODE:
1995 if (AvFILL(av) >= 0) {
1996 SV **svp = AvARRAY(av);
1997 I32 i;
1998 for (i = 0; i <= AvFILL(av); i++)
1999 XPUSHs(make_sv_object(aTHX_ svp[i]));
2000 }
2001
2002 void
2003 AvARRAYelt(av, idx)
2004 B::AV av
2005 int idx
2006 PPCODE:
2007 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
2008 XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
2009 else
2010 XPUSHs(make_sv_object(aTHX_ NULL));
2011
2012
2013 MODULE = B PACKAGE = B::FM PREFIX = Fm
2014
2015 IV
2016 FmLINES(format)
2017 B::FM format
2018 CODE:
2019 PERL_UNUSED_VAR(format);
2020 RETVAL = 0;
2021 OUTPUT:
2022 RETVAL
2023
2024
2025 MODULE = B PACKAGE = B::CV PREFIX = Cv
2026
2027 U32
2028 CvCONST(cv)
2029 B::CV cv
2030
2031 void
2032 CvSTART(cv)
2033 B::CV cv
2034 ALIAS:
2035 ROOT = 1
2036 PPCODE:
2037 PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
2038 : ix ? CvROOT(cv) : CvSTART(cv)));
2039
2040 I32
2041 CvDEPTH(cv)
2042 B::CV cv
2043
2044 B::PADLIST
2045 CvPADLIST(cv)
2046 B::CV cv
2047 CODE:
2048 RETVAL = CvISXSUB(cv) ? NULL : CvPADLIST(cv);
2049 OUTPUT:
2050 RETVAL
2051
2052 SV *
2053 CvHSCXT(cv)
2054 B::CV cv
2055 CODE:
2056 RETVAL = newSVuv(CvISXSUB(cv) ? PTR2UV(CvHSCXT(cv)) : 0);
2057 OUTPUT:
2058 RETVAL
2059
2060 void
2061 CvXSUB(cv)
2062 B::CV cv
2063 ALIAS:
2064 XSUBANY = 1
2065 CODE:
2066 ST(0) = ix && CvCONST(cv)
2067 ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
2068 : sv_2mortal(newSViv(CvISXSUB(cv)
2069 ? (ix ? CvXSUBANY(cv).any_iv
2070 : PTR2IV(CvXSUB(cv)))
2071 : 0));
2072
2073 void
2074 const_sv(cv)
2075 B::CV cv
2076 PPCODE:
2077 PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
2078
2079 void
2080 GV(cv)
2081 B::CV cv
2082 CODE:
2083 ST(0) = make_sv_object(aTHX_ (SV*)CvGV(cv));
2084
2085 SV *
2086 NAME_HEK(cv)
2087 B::CV cv
2088 CODE:
2089 RETVAL = CvNAMED(cv) ? newSVhek(CvNAME_HEK(cv)) : &PL_sv_undef;
2090 OUTPUT:
2091 RETVAL
2092
2093 MODULE = B PACKAGE = B::HV PREFIX = Hv
2094
2095 STRLEN
2096 HvFILL(hv)
2097 B::HV hv
2098
2099 I32
2100 HvRITER(hv)
2101 B::HV hv
2102
2103 void
2104 HvARRAY(hv)
2105 B::HV hv
2106 PPCODE:
2107 if (HvUSEDKEYS(hv) > 0) {
2108 HE *he;
2109 SSize_t extend_size;
2110 (void)hv_iterinit(hv);
2111 /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */
2112 assert(HvUSEDKEYS(hv) <= (SSize_t_MAX >> 1));
2113 extend_size = (SSize_t)HvUSEDKEYS(hv) * 2;
2114 EXTEND(sp, extend_size);
2115 while ((he = hv_iternext(hv))) {
2116 if (HeSVKEY(he)) {
2117 mPUSHs(HeSVKEY(he));
2118 } else if (HeKUTF8(he)) {
2119 PUSHs(newSVpvn_flags(HeKEY(he), HeKLEN(he), SVf_UTF8|SVs_TEMP));
2120 } else {
2121 mPUSHp(HeKEY(he), HeKLEN(he));
2122 }
2123 PUSHs(make_sv_object(aTHX_ HeVAL(he)));
2124 }
2125 }
2126
2127 MODULE = B PACKAGE = B::HE PREFIX = He
2128
2129 void
2130 HeVAL(he)
2131 B::HE he
2132 ALIAS:
2133 SVKEY_force = 1
2134 PPCODE:
2135 PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
2136
2137 U32
2138 HeHASH(he)
2139 B::HE he
2140
2141 MODULE = B PACKAGE = B::RHE
2142
2143 SV*
2144 HASH(h)
2145 B::RHE h
2146 CODE:
2147 RETVAL = newRV_noinc( (SV*)cophh_2hv(h, 0) );
2148 OUTPUT:
2149 RETVAL
2150
2151
2152 MODULE = B PACKAGE = B::PADLIST PREFIX = Padlist
2153
2154 SSize_t
2155 PadlistMAX(padlist)
2156 B::PADLIST padlist
2157 ALIAS: B::PADNAMELIST::MAX = 0
2158 CODE:
2159 PERL_UNUSED_VAR(ix);
2160 RETVAL = PadlistMAX(padlist);
2161 OUTPUT:
2162 RETVAL
2163
2164 B::PADNAMELIST
2165 PadlistNAMES(padlist)
2166 B::PADLIST padlist
2167
2168 void
2169 PadlistARRAY(padlist)
2170 B::PADLIST padlist
2171 PPCODE:
2172 if (PadlistMAX(padlist) >= 0) {
2173 dXSTARG;
2174 PAD **padp = PadlistARRAY(padlist);
2175 SSize_t i;
2176 sv_setiv(newSVrv(TARG, PadlistNAMES(padlist)
2177 ? "B::PADNAMELIST"
2178 : "B::NULL"),
2179 PTR2IV(PadlistNAMES(padlist)));
2180 XPUSHTARG;
2181 for (i = 1; i <= PadlistMAX(padlist); i++)
2182 XPUSHs(make_sv_object(aTHX_ (SV *)padp[i]));
2183 }
2184
2185 void
2186 PadlistARRAYelt(padlist, idx)
2187 B::PADLIST padlist
2188 SSize_t idx
2189 PPCODE:
2190 if (idx < 0 || idx > PadlistMAX(padlist))
2191 XPUSHs(make_sv_object(aTHX_ NULL));
2192 else if (!idx) {
2193 PL_stack_sp--;
2194 PUSHMARK(PL_stack_sp-1);
2195 XS_B__PADLIST_NAMES(aTHX_ cv);
2196 return;
2197 }
2198 else
2199 XPUSHs(make_sv_object(aTHX_
2200 (SV *)PadlistARRAY(padlist)[idx]));
2201
2202 U32
2203 PadlistREFCNT(padlist)
2204 B::PADLIST padlist
2205 CODE:
2206 PERL_UNUSED_VAR(padlist);
2207 RETVAL = PadlistREFCNT(padlist);
2208 OUTPUT:
2209 RETVAL
2210
2211 MODULE = B PACKAGE = B::PADNAMELIST PREFIX = Padnamelist
2212
2213 void
2214 PadnamelistARRAY(pnl)
2215 B::PADNAMELIST pnl
2216 PPCODE:
2217 if (PadnamelistMAX(pnl) >= 0) {
2218 PADNAME **padp = PadnamelistARRAY(pnl);
2219 SSize_t i = 0;
2220 for (; i <= PadnamelistMAX(pnl); i++)
2221 {
2222 SV *rv = sv_newmortal();
2223 sv_setiv(newSVrv(rv,padp[i] ? "B::PADNAME" : "B::SPECIAL"),
2224 PTR2IV(padp[i]));
2225 XPUSHs(rv);
2226 }
2227 }
2228
2229 B::PADNAME
2230 PadnamelistARRAYelt(pnl, idx)
2231 B::PADNAMELIST pnl
2232 SSize_t idx
2233 CODE:
2234 if (idx < 0 || idx > PadnamelistMAX(pnl))
2235 RETVAL = NULL;
2236 else
2237 RETVAL = PadnamelistARRAY(pnl)[idx];
2238 OUTPUT:
2239 RETVAL
2240
2241 MODULE = B PACKAGE = B::PADNAME PREFIX = Padname
2242
2243 #define PN_type_ix \
2244 sv_SVp | STRUCT_OFFSET(struct padname,xpadn_type_u.xpadn_typestash)
2245 #define PN_ourstash_ix \
2246 sv_SVp | STRUCT_OFFSET(struct padname,xpadn_ourstash)
2247 #define PN_len_ix \
2248 sv_U8p | STRUCT_OFFSET(struct padname,xpadn_len)
2249 #define PN_refcnt_ix \
2250 sv_U32p | STRUCT_OFFSET(struct padname, xpadn_refcnt)
2251 #define PN_cop_seq_range_low_ix \
2252 sv_U32p | STRUCT_OFFSET(struct padname, xpadn_low)
2253 #define PN_cop_seq_range_high_ix \
2254 sv_U32p | STRUCT_OFFSET(struct padname, xpadn_high)
2255 #define PNL_refcnt_ix \
2256 sv_U32p | STRUCT_OFFSET(struct padnamelist, xpadnl_refcnt)
2257 #define PL_id_ix \
2258 sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_id)
2259 #define PL_outid_ix \
2260 sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_outid)
2261
2262
2263 void
2264 PadnameTYPE(pn)
2265 B::PADNAME pn
2266 ALIAS:
2267 B::PADNAME::TYPE = PN_type_ix
2268 B::PADNAME::OURSTASH = PN_ourstash_ix
2269 B::PADNAME::LEN = PN_len_ix
2270 B::PADNAME::REFCNT = PN_refcnt_ix
2271 B::PADNAME::COP_SEQ_RANGE_LOW = PN_cop_seq_range_low_ix
2272 B::PADNAME::COP_SEQ_RANGE_HIGH = PN_cop_seq_range_high_ix
2273 B::PADNAMELIST::REFCNT = PNL_refcnt_ix
2274 B::PADLIST::id = PL_id_ix
2275 B::PADLIST::outid = PL_outid_ix
2276 PREINIT:
2277 char *ptr;
2278 SV *ret = NULL;
2279 PPCODE:
2280 ptr = (ix & 0xFFFF) + (char *)pn;
2281 switch ((U8)(ix >> 16)) {
2282 case (U8)(sv_SVp >> 16):
2283 ret = make_sv_object(aTHX_ *((SV **)ptr));
2284 break;
2285 case (U8)(sv_U32p >> 16):
2286 ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
2287 break;
2288 case (U8)(sv_U8p >> 16):
2289 ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
2290 break;
2291 default:
2292 NOT_REACHED;
2293 }
2294 ST(0) = ret;
2295 XSRETURN(1);
2296
2297 SV *
2298 PadnamePV(pn)
2299 B::PADNAME pn
2300 PREINIT:
2301 dXSTARG;
2302 PPCODE:
2303 PERL_UNUSED_ARG(RETVAL);
2304 sv_setpvn(TARG, PadnamePV(pn), PadnameLEN(pn));
2305 SvUTF8_on(TARG);
2306 XPUSHTARG;
2307
2308 BOOT:
2309 {
2310 /* Uses less memory than an ALIAS. */
2311 GV *gv = gv_fetchpvs("B::PADNAME::TYPE", 1, SVt_PVGV);
2312 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::SvSTASH",1,SVt_PVGV),(SV *)gv);
2313 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PROTOCV",1,SVt_PVGV),(SV *)gv);
2314 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PVX",1,SVt_PVGV),
2315 (SV *)gv_fetchpvs("B::PADNAME::PV" ,1,SVt_PVGV));
2316 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_PAD_INDEX" ,1,SVt_PVGV),
2317 (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_LOW",1,
2318 SVt_PVGV));
2319 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_FAKELEX_FLAGS",1,
2320 SVt_PVGV),
2321 (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_HIGH" ,1,
2322 SVt_PVGV));
2323 }
2324
2325 U32
2326 PadnameFLAGS(pn)
2327 B::PADNAME pn
2328 CODE:
2329 RETVAL = PadnameFLAGS(pn);
2330 /* backward-compatibility hack, which should be removed if the
2331 flags field becomes large enough to hold SVf_FAKE (and
2332 PADNAMEt_OUTER should be renumbered to match SVf_FAKE) */
2333 STATIC_ASSERT_STMT(SVf_FAKE >= 1<<(sizeof(PadnameFLAGS((B__PADNAME)NULL)) * 8));
2334 if (PadnameOUTER(pn))
2335 RETVAL |= SVf_FAKE;
2336 OUTPUT:
2337 RETVAL
2338