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