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