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 20typedef PerlIO * InputStream; 21#else 22typedef FILE * InputStream; 23#endif 24 25 26static 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 47static 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 64static 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 83typedef struct { 84 SV * x_specialsv_list[8]; 85 int x_walkoptree_debug; /* Flag for walkoptree debug hook */ 86} my_cxt_t; 87 88START_MY_CXT 89 90#define walkoptree_debug (MY_CXT.x_walkoptree_debug) 91#define specialsv_list (MY_CXT.x_specialsv_list) 92 93 94static 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 106static SV * 107make_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 115static SV * 116get_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 146static SV * 147make_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 168static SV * 169make_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 189static SV * 190make_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 218static SV * 219make_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 233static SV * 234make_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 241static SV * 242cstring(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 324static SV * 325cchar(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 361static SV * 362walkoptree(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 408static SV ** 409oplist(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 443typedef OP *B__OP; 444typedef UNOP *B__UNOP; 445typedef BINOP *B__BINOP; 446typedef LOGOP *B__LOGOP; 447typedef LISTOP *B__LISTOP; 448typedef PMOP *B__PMOP; 449typedef SVOP *B__SVOP; 450typedef PADOP *B__PADOP; 451typedef PVOP *B__PVOP; 452typedef LOOP *B__LOOP; 453typedef COP *B__COP; 454typedef METHOP *B__METHOP; 455 456typedef SV *B__SV; 457typedef SV *B__IV; 458typedef SV *B__PV; 459typedef SV *B__NV; 460typedef SV *B__PVMG; 461typedef SV *B__REGEXP; 462typedef SV *B__PVLV; 463typedef SV *B__BM; 464typedef SV *B__RV; 465typedef SV *B__FM; 466typedef AV *B__AV; 467typedef HV *B__HV; 468typedef CV *B__CV; 469typedef GV *B__GV; 470typedef IO *B__IO; 471 472typedef MAGIC *B__MAGIC; 473typedef HE *B__HE; 474typedef struct refcounted_he *B__RHE; 475typedef PADLIST *B__PADLIST; 476typedef PADNAMELIST *B__PADNAMELIST; 477typedef PADNAME *B__PADNAME; 478 479typedef 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. */ 491static XSPROTO(intrpvar_sv_common); /* prototype to pass -Wmissing-prototypes */ 492static 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 522static 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 602MODULE = B PACKAGE = B 603 604INCLUDE: const-xs.inc 605 606PROTOTYPES: DISABLE 607 608BOOT: 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 645void 646formfeed() 647 PPCODE: 648 PUSHs(make_sv_object(aTHX_ GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)))); 649 650long 651amagic_generation() 652 CODE: 653 RETVAL = PL_amagic_generation; 654 OUTPUT: 655 RETVAL 656 657void 658comppadlist() 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 669void 670sv_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 679void 680main_root() 681 ALIAS: 682 main_start = 1 683 PPCODE: 684 PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root)); 685 686UV 687sub_generation() 688 ALIAS: 689 dowarn = 1 690 CODE: 691 RETVAL = ix ? PL_dowarn : PL_sub_generation; 692 OUTPUT: 693 RETVAL 694 695void 696walkoptree(op, method) 697 B::OP op 698 const char * method 699 CODE: 700 (void) walkoptree(aTHX_ op, method, &PL_sv_undef); 701 702int 703walkoptree_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 714IV 715address(sv) 716 SV * sv 717 718void 719svref_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 726void 727opnumber(name) 728const char * name 729CODE: 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 747void 748ppname(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 755void 756hash(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 766IV 767cast_I32(i) 768 IV i 769 770void 771minus_c() 772 ALIAS: 773 save_BEGINs = 1 774 CODE: 775 if (ix) 776 PL_savebegin = TRUE; 777 else 778 PL_minus_c = TRUE; 779 780void 781cstring(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 789void 790threadsv_names() 791 PPCODE: 792 793 794#ifdef USE_ITHREADS 795void 796CLONE(...) 797PPCODE: 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 807MODULE = 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 813void 814next(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 1139void 1140oplist(o) 1141 B::OP o 1142 PPCODE: 1143 SP = oplist(aTHX_ o, SP); 1144 1145 1146 1147MODULE = 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 1158void 1159string(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 1205void 1206aux_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 1400MODULE = B PACKAGE = B::SV PREFIX = Sv 1401 1402#define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG) 1403 1404U32 1405SvREFCNT(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 1418void 1419Svobject_2svref(sv) 1420 B::SV sv 1421 PPCODE: 1422 ST(0) = sv_2mortal(newRV(sv)); 1423 XSRETURN(1); 1424 1425bool 1426SvIsBOOL(sv) 1427 B::SV sv 1428 1429bool 1430SvTRUE(sv) 1431 B::SV sv 1432 1433bool 1434SvTRUE_nomg(sv) 1435 B::SV sv 1436 1437MODULE = B PACKAGE = B::IV PREFIX = Sv 1438 1439IV 1440SvIV(sv) 1441 B::IV sv 1442 1443MODULE = 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 1505void 1506IVX(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 1590void 1591packiv(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 1620MODULE = B PACKAGE = B::NV PREFIX = Sv 1621 1622NV 1623SvNV(sv) 1624 B::NV sv 1625 1626MODULE = B PACKAGE = B::REGEXP 1627 1628void 1629REGEX(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 1649MODULE = B PACKAGE = B::INVLIST PREFIX = Invlist 1650 1651int 1652prev_index(invlist) 1653 B::INVLIST invlist 1654 CODE: 1655 RETVAL = ((XINVLIST*) SvANY(invlist))->prev_index; 1656 OUTPUT: 1657 RETVAL 1658 1659int 1660is_offset(invlist) 1661 B::INVLIST invlist 1662 CODE: 1663 RETVAL = ((XINVLIST*) SvANY(invlist))->is_offset == TRUE ? 1 : 0; 1664 OUTPUT: 1665 RETVAL 1666 1667unsigned int 1668array_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 1680void 1681get_invlist_array(invlist) 1682 B::INVLIST invlist 1683PPCODE: 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 1714MODULE = B PACKAGE = B::PV 1715 1716void 1717RV(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 1724void 1725PV(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 1782MODULE = B PACKAGE = B::PVMG 1783 1784void 1785MAGIC(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 1792MODULE = B PACKAGE = B::MAGIC 1793 1794void 1795MOREMAGIC(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 1856MODULE = B PACKAGE = B::BM PREFIX = Bm 1857 1858U32 1859BmPREVIOUS(sv) 1860 B::BM sv 1861 CODE: 1862 PERL_UNUSED_VAR(sv); 1863 RETVAL = BmPREVIOUS(sv); 1864 OUTPUT: 1865 RETVAL 1866 1867 1868U8 1869BmRARE(sv) 1870 B::BM sv 1871 CODE: 1872 PERL_UNUSED_VAR(sv); 1873 RETVAL = BmRARE(sv); 1874 OUTPUT: 1875 RETVAL 1876 1877 1878MODULE = B PACKAGE = B::GV PREFIX = Gv 1879 1880void 1881GvNAME(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 1891bool 1892is_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 1905void* 1906GvGP(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 1919void 1920SV(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 1956U32 1957GvLINE(gv) 1958 B::GV gv 1959 1960U32 1961GvGPFLAGS(gv) 1962 B::GV gv 1963 1964void 1965FILEGV(gv) 1966 B::GV gv 1967 PPCODE: 1968 PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv))); 1969 1970MODULE = B PACKAGE = B::IO PREFIX = Io 1971 1972 1973bool 1974IsSTD(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 1996MODULE = B PACKAGE = B::AV PREFIX = Av 1997 1998SSize_t 1999AvFILL(av) 2000 B::AV av 2001 2002void 2003AvARRAY(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 2013void 2014AvARRAYelt(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 2024MODULE = B PACKAGE = B::FM PREFIX = Fm 2025 2026IV 2027FmLINES(format) 2028 B::FM format 2029 CODE: 2030 PERL_UNUSED_VAR(format); 2031 RETVAL = 0; 2032 OUTPUT: 2033 RETVAL 2034 2035 2036MODULE = B PACKAGE = B::CV PREFIX = Cv 2037 2038U32 2039CvCONST(cv) 2040 B::CV cv 2041 2042void 2043CvSTART(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 2051I32 2052CvDEPTH(cv) 2053 B::CV cv 2054 2055B::PADLIST 2056CvPADLIST(cv) 2057 B::CV cv 2058 CODE: 2059 RETVAL = CvISXSUB(cv) ? NULL : CvPADLIST(cv); 2060 OUTPUT: 2061 RETVAL 2062 2063SV * 2064CvHSCXT(cv) 2065 B::CV cv 2066 CODE: 2067 RETVAL = newSVuv(CvISXSUB(cv) ? PTR2UV(CvHSCXT(cv)) : 0); 2068 OUTPUT: 2069 RETVAL 2070 2071void 2072CvXSUB(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 2084void 2085const_sv(cv) 2086 B::CV cv 2087 PPCODE: 2088 PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv))); 2089 2090void 2091GV(cv) 2092 B::CV cv 2093 CODE: 2094 ST(0) = make_sv_object(aTHX_ (SV*)CvGV(cv)); 2095 2096SV * 2097NAME_HEK(cv) 2098 B::CV cv 2099 CODE: 2100 RETVAL = CvNAMED(cv) ? newSVhek(CvNAME_HEK(cv)) : &PL_sv_undef; 2101 OUTPUT: 2102 RETVAL 2103 2104MODULE = B PACKAGE = B::HV PREFIX = Hv 2105 2106STRLEN 2107HvFILL(hv) 2108 B::HV hv 2109 2110I32 2111HvRITER(hv) 2112 B::HV hv 2113 2114void 2115HvARRAY(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 2138MODULE = B PACKAGE = B::HE PREFIX = He 2139 2140void 2141HeVAL(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 2148U32 2149HeHASH(he) 2150 B::HE he 2151 2152MODULE = B PACKAGE = B::RHE 2153 2154SV* 2155HASH(h) 2156 B::RHE h 2157 CODE: 2158 RETVAL = newRV_noinc( (SV*)cophh_2hv(h, 0) ); 2159 OUTPUT: 2160 RETVAL 2161 2162 2163MODULE = B PACKAGE = B::PADLIST PREFIX = Padlist 2164 2165SSize_t 2166PadlistMAX(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 2175B::PADNAMELIST 2176PadlistNAMES(padlist) 2177 B::PADLIST padlist 2178 2179void 2180PadlistARRAY(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 2196void 2197PadlistARRAYelt(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 2213U32 2214PadlistREFCNT(padlist) 2215 B::PADLIST padlist 2216 CODE: 2217 PERL_UNUSED_VAR(padlist); 2218 RETVAL = PadlistREFCNT(padlist); 2219 OUTPUT: 2220 RETVAL 2221 2222MODULE = B PACKAGE = B::PADNAMELIST PREFIX = Padnamelist 2223 2224void 2225PadnamelistARRAY(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 2240B::PADNAME 2241PadnamelistARRAYelt(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 2252MODULE = 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 2275void 2276PadnameTYPE(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 2310SV * 2311PadnamePV(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 2321bool 2322PadnameIsUndef(padn) 2323 B::PADNAME padn 2324 CODE: 2325 RETVAL = padn == &PL_padname_undef; 2326 OUTPUT: 2327 RETVAL 2328 2329BOOT: 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 2346U32 2347PadnameFLAGS(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