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 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 * 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 * 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 * 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 * 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 * 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 * 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 * 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 * 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 (memCHRs("nrftaebx\\",*(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 * 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 * 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 ** 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 */ 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 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 { 1181 struct op_argcheck_aux *p = (struct op_argcheck_aux*)aux; 1182 ret = Perl_newSVpvf(aTHX_ "%" IVdf ",%" IVdf, 1183 p->params, p->opt_params); 1184 if (p->slurpy) 1185 Perl_sv_catpvf(aTHX_ ret, ",%c", p->slurpy); 1186 ret = sv_2mortal(ret); 1187 break; 1188 } 1189 1190 default: 1191 ret = sv_2mortal(newSVpvn("", 0)); 1192 } 1193 1194 ST(0) = ret; 1195 XSRETURN(1); 1196 1197 1198 # Return the contents of the op_aux array as a list of IV/GV/etc objects. 1199 # How to interpret each array element is op-dependent. The op's CV is 1200 # needed as an extra arg to allow GVs and SVs which have been moved into 1201 # the pad to be accessed okay. 1202 1203 void 1204 aux_list(o, cv) 1205 B::OP o 1206 B::CV cv 1207 PREINIT: 1208 UNOP_AUX_item *aux; 1209 PPCODE: 1210 PERL_UNUSED_VAR(cv); /* not needed on unthreaded builds */ 1211 aux = cUNOP_AUXo->op_aux; 1212 switch (o->op_type) { 1213 default: 1214 XSRETURN(0); /* by default, an empty list */ 1215 1216 case OP_ARGELEM: 1217 XPUSHs(sv_2mortal(newSViv(PTR2IV(aux)))); 1218 XSRETURN(1); 1219 break; 1220 1221 case OP_ARGCHECK: 1222 { 1223 struct op_argcheck_aux *p = (struct op_argcheck_aux*)aux; 1224 EXTEND(SP, 3); 1225 PUSHs(sv_2mortal(newSViv(p->params))); 1226 PUSHs(sv_2mortal(newSViv(p->opt_params))); 1227 PUSHs(sv_2mortal(p->slurpy 1228 ? Perl_newSVpvf(aTHX_ "%c", p->slurpy) 1229 : &PL_sv_no)); 1230 break; 1231 } 1232 1233 case OP_MULTICONCAT: 1234 { 1235 SSize_t nargs; 1236 char *p; 1237 STRLEN len; 1238 U32 utf8 = 0; 1239 SV *sv; 1240 UNOP_AUX_item *lens; 1241 1242 /* return (nargs, const string, segment len 0, 1, 2, ...) */ 1243 1244 /* if this changes, this block of code probably needs fixing */ 1245 assert(PERL_MULTICONCAT_HEADER_SIZE == 5); 1246 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize; 1247 EXTEND(SP, ((SSize_t)(2 + (nargs+1)))); 1248 PUSHs(sv_2mortal(newSViv((IV)nargs))); 1249 1250 p = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv; 1251 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize; 1252 if (!p) { 1253 p = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv; 1254 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize; 1255 utf8 = SVf_UTF8; 1256 } 1257 sv = newSVpvn(p, len); 1258 SvFLAGS(sv) |= utf8; 1259 PUSHs(sv_2mortal(sv)); 1260 1261 lens = aux + PERL_MULTICONCAT_IX_LENGTHS; 1262 nargs++; /* loop (nargs+1) times */ 1263 if (utf8) { 1264 U8 *p = (U8*)SvPVX(sv); 1265 while (nargs--) { 1266 SSize_t bytes = lens->ssize; 1267 SSize_t chars; 1268 if (bytes <= 0) 1269 chars = bytes; 1270 else { 1271 /* return char lengths rather than byte lengths */ 1272 chars = utf8_length(p, p + bytes); 1273 p += bytes; 1274 } 1275 lens++; 1276 PUSHs(sv_2mortal(newSViv(chars))); 1277 } 1278 } 1279 else { 1280 while (nargs--) { 1281 PUSHs(sv_2mortal(newSViv(lens->ssize))); 1282 lens++; 1283 } 1284 } 1285 break; 1286 } 1287 1288 case OP_MULTIDEREF: 1289 #ifdef USE_ITHREADS 1290 # define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE); 1291 #else 1292 # define ITEM_SV(item) UNOP_AUX_item_sv(item) 1293 #endif 1294 { 1295 UNOP_AUX_item *items = cUNOP_AUXo->op_aux; 1296 UV actions = items->uv; 1297 UV len = items[-1].uv; 1298 SV *sv; 1299 bool last = 0; 1300 bool is_hash = FALSE; 1301 #ifdef USE_ITHREADS 1302 PADLIST * const padlist = CvPADLIST(cv); 1303 PAD *comppad = PadlistARRAY(padlist)[1]; 1304 #endif 1305 1306 /* len should never be big enough to truncate or wrap */ 1307 assert(len <= SSize_t_MAX); 1308 EXTEND(SP, (SSize_t)len); 1309 PUSHs(sv_2mortal(newSViv(actions))); 1310 1311 while (!last) { 1312 switch (actions & MDEREF_ACTION_MASK) { 1313 1314 case MDEREF_reload: 1315 actions = (++items)->uv; 1316 PUSHs(sv_2mortal(newSVuv(actions))); 1317 continue; 1318 NOT_REACHED; /* NOTREACHED */ 1319 1320 case MDEREF_HV_padhv_helem: 1321 is_hash = TRUE; 1322 /* FALLTHROUGH */ 1323 case MDEREF_AV_padav_aelem: 1324 PUSHs(sv_2mortal(newSVuv((++items)->pad_offset))); 1325 goto do_elem; 1326 NOT_REACHED; /* NOTREACHED */ 1327 1328 case MDEREF_HV_gvhv_helem: 1329 is_hash = TRUE; 1330 /* FALLTHROUGH */ 1331 case MDEREF_AV_gvav_aelem: 1332 sv = ITEM_SV(++items); 1333 PUSHs(make_sv_object(aTHX_ sv)); 1334 goto do_elem; 1335 NOT_REACHED; /* NOTREACHED */ 1336 1337 case MDEREF_HV_gvsv_vivify_rv2hv_helem: 1338 is_hash = TRUE; 1339 /* FALLTHROUGH */ 1340 case MDEREF_AV_gvsv_vivify_rv2av_aelem: 1341 sv = ITEM_SV(++items); 1342 PUSHs(make_sv_object(aTHX_ sv)); 1343 goto do_vivify_rv2xv_elem; 1344 NOT_REACHED; /* NOTREACHED */ 1345 1346 case MDEREF_HV_padsv_vivify_rv2hv_helem: 1347 is_hash = TRUE; 1348 /* FALLTHROUGH */ 1349 case MDEREF_AV_padsv_vivify_rv2av_aelem: 1350 PUSHs(sv_2mortal(newSVuv((++items)->pad_offset))); 1351 goto do_vivify_rv2xv_elem; 1352 NOT_REACHED; /* NOTREACHED */ 1353 1354 case MDEREF_HV_pop_rv2hv_helem: 1355 case MDEREF_HV_vivify_rv2hv_helem: 1356 is_hash = TRUE; 1357 /* FALLTHROUGH */ 1358 do_vivify_rv2xv_elem: 1359 case MDEREF_AV_pop_rv2av_aelem: 1360 case MDEREF_AV_vivify_rv2av_aelem: 1361 do_elem: 1362 switch (actions & MDEREF_INDEX_MASK) { 1363 case MDEREF_INDEX_none: 1364 last = 1; 1365 break; 1366 case MDEREF_INDEX_const: 1367 if (is_hash) { 1368 sv = ITEM_SV(++items); 1369 PUSHs(make_sv_object(aTHX_ sv)); 1370 } 1371 else 1372 PUSHs(sv_2mortal(newSViv((++items)->iv))); 1373 break; 1374 case MDEREF_INDEX_padsv: 1375 PUSHs(sv_2mortal(newSVuv((++items)->pad_offset))); 1376 break; 1377 case MDEREF_INDEX_gvsv: 1378 sv = ITEM_SV(++items); 1379 PUSHs(make_sv_object(aTHX_ sv)); 1380 break; 1381 } 1382 if (actions & MDEREF_FLAG_last) 1383 last = 1; 1384 is_hash = FALSE; 1385 1386 break; 1387 } /* switch */ 1388 1389 actions >>= MDEREF_SHIFT; 1390 } /* while */ 1391 XSRETURN(len); 1392 1393 } /* OP_MULTIDEREF */ 1394 } /* switch */ 1395 1396 1397 1398 MODULE = B PACKAGE = B::SV 1399 1400 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG) 1401 1402 U32 1403 REFCNT(sv) 1404 B::SV sv 1405 ALIAS: 1406 FLAGS = 0xFFFFFFFF 1407 SvTYPE = SVTYPEMASK 1408 POK = SVf_POK 1409 ROK = SVf_ROK 1410 MAGICAL = MAGICAL_FLAG_BITS 1411 CODE: 1412 RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv); 1413 OUTPUT: 1414 RETVAL 1415 1416 void 1417 object_2svref(sv) 1418 B::SV sv 1419 PPCODE: 1420 ST(0) = sv_2mortal(newRV(sv)); 1421 XSRETURN(1); 1422 1423 MODULE = B PACKAGE = B::IV PREFIX = Sv 1424 1425 IV 1426 SvIV(sv) 1427 B::IV sv 1428 1429 MODULE = B PACKAGE = B::IV 1430 1431 #define sv_SVp 0x00000 1432 #define sv_IVp 0x10000 1433 #define sv_UVp 0x20000 1434 #define sv_STRLENp 0x30000 1435 #define sv_U32p 0x40000 1436 #define sv_U8p 0x50000 1437 #define sv_char_pp 0x60000 1438 #define sv_NVp 0x70000 1439 #define sv_char_p 0x80000 1440 #define sv_SSize_tp 0x90000 1441 #define sv_I32p 0xA0000 1442 #define sv_U16p 0xB0000 1443 1444 #define IV_ivx_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_iv) 1445 #define IV_uvx_ix sv_UVp | STRUCT_OFFSET(struct xpvuv, xuv_uv) 1446 #define NV_nvx_ix sv_NVp | STRUCT_OFFSET(struct xpvnv, xnv_u.xnv_nv) 1447 1448 #define PV_cur_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_cur) 1449 #define PV_len_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_len) 1450 1451 #define PVMG_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvmg, xmg_stash) 1452 1453 #define PVBM_useful_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_u.xivu_iv) 1454 1455 #define PVLV_targoff_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targoff) 1456 #define PVLV_targlen_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targlen) 1457 #define PVLV_targ_ix sv_SVp | STRUCT_OFFSET(struct xpvlv, xlv_targ) 1458 #define PVLV_type_ix sv_char_p | STRUCT_OFFSET(struct xpvlv, xlv_type) 1459 1460 #define PVGV_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvgv, xnv_u.xgv_stash) 1461 #define PVGV_flags_ix sv_STRLENp | STRUCT_OFFSET(struct xpvgv, xpv_cur) 1462 #define PVIO_lines_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xiv_iv) 1463 1464 #define PVIO_page_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page) 1465 #define PVIO_page_len_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page_len) 1466 #define PVIO_lines_left_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_lines_left) 1467 #define PVIO_top_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_top_name) 1468 #define PVIO_top_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_top_gv) 1469 #define PVIO_fmt_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_fmt_name) 1470 #define PVIO_fmt_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_fmt_gv) 1471 #define PVIO_bottom_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_bottom_name) 1472 #define PVIO_bottom_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_bottom_gv) 1473 #define PVIO_type_ix sv_char_p | STRUCT_OFFSET(struct xpvio, xio_type) 1474 #define PVIO_flags_ix sv_U8p | STRUCT_OFFSET(struct xpvio, xio_flags) 1475 1476 #define PVAV_max_ix sv_SSize_tp | STRUCT_OFFSET(struct xpvav, xav_max) 1477 1478 #define PVCV_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_stash) 1479 #define PVCV_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv_u.xcv_gv) 1480 #define PVCV_file_ix sv_char_pp | STRUCT_OFFSET(struct xpvcv, xcv_file) 1481 #define PVCV_outside_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_outside) 1482 #define PVCV_outside_seq_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_outside_seq) 1483 #define PVCV_flags_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_flags) 1484 1485 #define PVHV_max_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_max) 1486 #define PVHV_keys_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_keys) 1487 1488 # The type checking code in B has always been identical for all SV types, 1489 # irrespective of whether the action is actually defined on that SV. 1490 # We should fix this 1491 void 1492 IVX(sv) 1493 B::SV sv 1494 ALIAS: 1495 B::IV::IVX = IV_ivx_ix 1496 B::IV::UVX = IV_uvx_ix 1497 B::NV::NVX = NV_nvx_ix 1498 B::PV::CUR = PV_cur_ix 1499 B::PV::LEN = PV_len_ix 1500 B::PVMG::SvSTASH = PVMG_stash_ix 1501 B::PVLV::TARGOFF = PVLV_targoff_ix 1502 B::PVLV::TARGLEN = PVLV_targlen_ix 1503 B::PVLV::TARG = PVLV_targ_ix 1504 B::PVLV::TYPE = PVLV_type_ix 1505 B::GV::STASH = PVGV_stash_ix 1506 B::GV::GvFLAGS = PVGV_flags_ix 1507 B::BM::USEFUL = PVBM_useful_ix 1508 B::IO::LINES = PVIO_lines_ix 1509 B::IO::PAGE = PVIO_page_ix 1510 B::IO::PAGE_LEN = PVIO_page_len_ix 1511 B::IO::LINES_LEFT = PVIO_lines_left_ix 1512 B::IO::TOP_NAME = PVIO_top_name_ix 1513 B::IO::TOP_GV = PVIO_top_gv_ix 1514 B::IO::FMT_NAME = PVIO_fmt_name_ix 1515 B::IO::FMT_GV = PVIO_fmt_gv_ix 1516 B::IO::BOTTOM_NAME = PVIO_bottom_name_ix 1517 B::IO::BOTTOM_GV = PVIO_bottom_gv_ix 1518 B::IO::IoTYPE = PVIO_type_ix 1519 B::IO::IoFLAGS = PVIO_flags_ix 1520 B::AV::MAX = PVAV_max_ix 1521 B::CV::STASH = PVCV_stash_ix 1522 B::CV::FILE = PVCV_file_ix 1523 B::CV::OUTSIDE = PVCV_outside_ix 1524 B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix 1525 B::CV::CvFLAGS = PVCV_flags_ix 1526 B::HV::MAX = PVHV_max_ix 1527 B::HV::KEYS = PVHV_keys_ix 1528 PREINIT: 1529 char *ptr; 1530 SV *ret; 1531 PPCODE: 1532 ptr = (ix & 0xFFFF) + (char *)SvANY(sv); 1533 switch ((U8)(ix >> 16)) { 1534 case (U8)(sv_SVp >> 16): 1535 ret = make_sv_object(aTHX_ *((SV **)ptr)); 1536 break; 1537 case (U8)(sv_IVp >> 16): 1538 ret = sv_2mortal(newSViv(*((IV *)ptr))); 1539 break; 1540 case (U8)(sv_UVp >> 16): 1541 ret = sv_2mortal(newSVuv(*((UV *)ptr))); 1542 break; 1543 case (U8)(sv_STRLENp >> 16): 1544 ret = sv_2mortal(newSVuv(*((STRLEN *)ptr))); 1545 break; 1546 case (U8)(sv_U32p >> 16): 1547 ret = sv_2mortal(newSVuv(*((U32 *)ptr))); 1548 break; 1549 case (U8)(sv_U8p >> 16): 1550 ret = sv_2mortal(newSVuv(*((U8 *)ptr))); 1551 break; 1552 case (U8)(sv_char_pp >> 16): 1553 ret = sv_2mortal(newSVpv(*((char **)ptr), 0)); 1554 break; 1555 case (U8)(sv_NVp >> 16): 1556 ret = sv_2mortal(newSVnv(*((NV *)ptr))); 1557 break; 1558 case (U8)(sv_char_p >> 16): 1559 ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP); 1560 break; 1561 case (U8)(sv_SSize_tp >> 16): 1562 ret = sv_2mortal(newSViv(*((SSize_t *)ptr))); 1563 break; 1564 case (U8)(sv_I32p >> 16): 1565 ret = sv_2mortal(newSVuv(*((I32 *)ptr))); 1566 break; 1567 case (U8)(sv_U16p >> 16): 1568 ret = sv_2mortal(newSVuv(*((U16 *)ptr))); 1569 break; 1570 default: 1571 croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix); 1572 } 1573 ST(0) = ret; 1574 XSRETURN(1); 1575 1576 void 1577 packiv(sv) 1578 B::IV sv 1579 ALIAS: 1580 needs64bits = 1 1581 CODE: 1582 if (ix) { 1583 ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv)); 1584 } else if (sizeof(IV) == 8) { 1585 U32 wp[2]; 1586 const IV iv = SvIVX(sv); 1587 /* 1588 * The following way of spelling 32 is to stop compilers on 1589 * 32-bit architectures from moaning about the shift count 1590 * being >= the width of the type. Such architectures don't 1591 * reach this code anyway (unless sizeof(IV) > 8 but then 1592 * everything else breaks too so I'm not fussed at the moment). 1593 */ 1594 #ifdef UV_IS_QUAD 1595 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4)); 1596 #else 1597 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4)); 1598 #endif 1599 wp[1] = htonl(iv & 0xffffffff); 1600 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP); 1601 } else { 1602 U32 w = htonl((U32)SvIVX(sv)); 1603 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP); 1604 } 1605 1606 MODULE = B PACKAGE = B::NV PREFIX = Sv 1607 1608 NV 1609 SvNV(sv) 1610 B::NV sv 1611 1612 MODULE = B PACKAGE = B::REGEXP 1613 1614 void 1615 REGEX(sv) 1616 B::REGEXP sv 1617 ALIAS: 1618 precomp = 1 1619 qr_anoncv = 2 1620 compflags = 3 1621 PPCODE: 1622 if (ix == 1) { 1623 PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP)); 1624 } else if (ix == 2) { 1625 PUSHs(make_sv_object(aTHX_ (SV *)ReANY(sv)->qr_anoncv)); 1626 } else { 1627 dXSTARG; 1628 if (ix) 1629 PUSHu(RX_COMPFLAGS(sv)); 1630 else 1631 /* FIXME - can we code this method more efficiently? */ 1632 PUSHi(PTR2IV(sv)); 1633 } 1634 1635 MODULE = B PACKAGE = B::PV 1636 1637 void 1638 RV(sv) 1639 B::PV sv 1640 PPCODE: 1641 if (!SvROK(sv)) 1642 croak( "argument is not SvROK" ); 1643 PUSHs(make_sv_object(aTHX_ SvRV(sv))); 1644 1645 void 1646 PV(sv) 1647 B::PV sv 1648 ALIAS: 1649 PVX = 1 1650 PVBM = 2 1651 B::BM::TABLE = 3 1652 PREINIT: 1653 const char *p; 1654 STRLEN len = 0; 1655 U32 utf8 = 0; 1656 CODE: 1657 if (ix == 3) { 1658 const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm); 1659 1660 if (!mg) 1661 croak("argument to B::BM::TABLE is not a PVBM"); 1662 p = mg->mg_ptr; 1663 len = mg->mg_len; 1664 } else if (ix == 2) { 1665 /* This used to read 257. I think that that was buggy - should have 1666 been 258. (The "\0", the flags byte, and 256 for the table.) 1667 The only user of this method is B::Bytecode in B::PV::bsave. 1668 I'm guessing that nothing tested the runtime correctness of 1669 output of bytecompiled string constant arguments to index (etc). 1670 1671 Note the start pointer is and has always been SvPVX(sv), not 1672 SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and 1673 first used by the compiler in 651aa52ea1faa806. It's used to 1674 get a "complete" dump of the buffer at SvPVX(), not just the 1675 PVBM table. This permits the generated bytecode to "load" 1676 SvPVX in "one" hit. 1677 1678 5.15 and later store the BM table via MAGIC, so the compiler 1679 should handle this just fine without changes if PVBM now 1680 always returns the SvPVX() buffer. */ 1681 p = isREGEXP(sv) 1682 ? RX_WRAPPED_const((REGEXP*)sv) 1683 : SvPVX_const(sv); 1684 len = SvCUR(sv); 1685 } else if (ix) { 1686 p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv); 1687 len = strlen(p); 1688 } else if (SvPOK(sv)) { 1689 len = SvCUR(sv); 1690 p = SvPVX_const(sv); 1691 utf8 = SvUTF8(sv); 1692 } else if (isREGEXP(sv)) { 1693 len = SvCUR(sv); 1694 p = RX_WRAPPED_const((REGEXP*)sv); 1695 utf8 = SvUTF8(sv); 1696 } else { 1697 /* XXX for backward compatibility, but should fail */ 1698 /* croak( "argument is not SvPOK" ); */ 1699 p = NULL; 1700 } 1701 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8); 1702 1703 MODULE = B PACKAGE = B::PVMG 1704 1705 void 1706 MAGIC(sv) 1707 B::PVMG sv 1708 MAGIC * mg = NO_INIT 1709 PPCODE: 1710 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) 1711 XPUSHs(make_mg_object(aTHX_ mg)); 1712 1713 MODULE = B PACKAGE = B::MAGIC 1714 1715 void 1716 MOREMAGIC(mg) 1717 B::MAGIC mg 1718 ALIAS: 1719 PRIVATE = 1 1720 TYPE = 2 1721 FLAGS = 3 1722 LENGTH = 4 1723 OBJ = 5 1724 PTR = 6 1725 REGEX = 7 1726 precomp = 8 1727 PPCODE: 1728 switch (ix) { 1729 case 0: 1730 XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic) 1731 : &PL_sv_undef); 1732 break; 1733 case 1: 1734 mPUSHu(mg->mg_private); 1735 break; 1736 case 2: 1737 PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP)); 1738 break; 1739 case 3: 1740 mPUSHu(mg->mg_flags); 1741 break; 1742 case 4: 1743 mPUSHi(mg->mg_len); 1744 break; 1745 case 5: 1746 PUSHs(make_sv_object(aTHX_ mg->mg_obj)); 1747 break; 1748 case 6: 1749 if (mg->mg_ptr) { 1750 if (mg->mg_len >= 0) { 1751 PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP)); 1752 } else if (mg->mg_len == HEf_SVKEY) { 1753 PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr)); 1754 } else 1755 PUSHs(sv_newmortal()); 1756 } else 1757 PUSHs(sv_newmortal()); 1758 break; 1759 case 7: 1760 if(mg->mg_type == PERL_MAGIC_qr) { 1761 mPUSHi(PTR2IV(mg->mg_obj)); 1762 } else { 1763 croak("REGEX is only meaningful on r-magic"); 1764 } 1765 break; 1766 case 8: 1767 if (mg->mg_type == PERL_MAGIC_qr) { 1768 REGEXP *rx = (REGEXP *)mg->mg_obj; 1769 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL, 1770 rx ? RX_PRELEN(rx) : 0, SVs_TEMP)); 1771 } else { 1772 croak( "precomp is only meaningful on r-magic" ); 1773 } 1774 break; 1775 } 1776 1777 MODULE = B PACKAGE = B::BM PREFIX = Bm 1778 1779 U32 1780 BmPREVIOUS(sv) 1781 B::BM sv 1782 CODE: 1783 PERL_UNUSED_VAR(sv); 1784 RETVAL = BmPREVIOUS(sv); 1785 OUTPUT: 1786 RETVAL 1787 1788 1789 U8 1790 BmRARE(sv) 1791 B::BM sv 1792 CODE: 1793 PERL_UNUSED_VAR(sv); 1794 RETVAL = BmRARE(sv); 1795 OUTPUT: 1796 RETVAL 1797 1798 1799 MODULE = B PACKAGE = B::GV PREFIX = Gv 1800 1801 void 1802 GvNAME(gv) 1803 B::GV gv 1804 ALIAS: 1805 FILE = 1 1806 B::HV::NAME = 2 1807 CODE: 1808 ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv) 1809 : (ix == 1 ? GvFILE_HEK(gv) 1810 : HvNAME_HEK((HV *)gv)))); 1811 1812 bool 1813 is_empty(gv) 1814 B::GV gv 1815 ALIAS: 1816 isGV_with_GP = 1 1817 CODE: 1818 if (ix) { 1819 RETVAL = cBOOL(isGV_with_GP(gv)); 1820 } else { 1821 RETVAL = GvGP(gv) == Null(GP*); 1822 } 1823 OUTPUT: 1824 RETVAL 1825 1826 void* 1827 GvGP(gv) 1828 B::GV gv 1829 1830 #define GP_sv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_sv) 1831 #define GP_io_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_io) 1832 #define GP_cv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_cv) 1833 #define GP_cvgen_ix (U32p << 16) | STRUCT_OFFSET(struct gp, gp_cvgen) 1834 #define GP_refcnt_ix (U32p << 16) | STRUCT_OFFSET(struct gp, gp_refcnt) 1835 #define GP_hv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_hv) 1836 #define GP_av_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_av) 1837 #define GP_form_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_form) 1838 #define GP_egv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_egv) 1839 1840 void 1841 SV(gv) 1842 B::GV gv 1843 ALIAS: 1844 SV = GP_sv_ix 1845 IO = GP_io_ix 1846 CV = GP_cv_ix 1847 CVGEN = GP_cvgen_ix 1848 GvREFCNT = GP_refcnt_ix 1849 HV = GP_hv_ix 1850 AV = GP_av_ix 1851 FORM = GP_form_ix 1852 EGV = GP_egv_ix 1853 PREINIT: 1854 GP *gp; 1855 char *ptr; 1856 SV *ret; 1857 PPCODE: 1858 gp = GvGP(gv); 1859 if (!gp) { 1860 const GV *const gv = CvGV(cv); 1861 Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???"); 1862 } 1863 ptr = (ix & 0xFFFF) + (char *)gp; 1864 switch ((U8)(ix >> 16)) { 1865 case SVp: 1866 ret = make_sv_object(aTHX_ *((SV **)ptr)); 1867 break; 1868 case U32p: 1869 ret = sv_2mortal(newSVuv(*((U32*)ptr))); 1870 break; 1871 default: 1872 croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix); 1873 } 1874 ST(0) = ret; 1875 XSRETURN(1); 1876 1877 U32 1878 GvLINE(gv) 1879 B::GV gv 1880 1881 U32 1882 GvGPFLAGS(gv) 1883 B::GV gv 1884 1885 void 1886 FILEGV(gv) 1887 B::GV gv 1888 PPCODE: 1889 PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv))); 1890 1891 MODULE = B PACKAGE = B::IO PREFIX = Io 1892 1893 1894 bool 1895 IsSTD(io,name) 1896 B::IO io 1897 const char* name 1898 PREINIT: 1899 PerlIO* handle = 0; 1900 CODE: 1901 if( strEQ( name, "stdin" ) ) { 1902 handle = PerlIO_stdin(); 1903 } 1904 else if( strEQ( name, "stdout" ) ) { 1905 handle = PerlIO_stdout(); 1906 } 1907 else if( strEQ( name, "stderr" ) ) { 1908 handle = PerlIO_stderr(); 1909 } 1910 else { 1911 croak( "Invalid value '%s'", name ); 1912 } 1913 RETVAL = handle == IoIFP(io); 1914 OUTPUT: 1915 RETVAL 1916 1917 MODULE = B PACKAGE = B::AV PREFIX = Av 1918 1919 SSize_t 1920 AvFILL(av) 1921 B::AV av 1922 1923 void 1924 AvARRAY(av) 1925 B::AV av 1926 PPCODE: 1927 if (AvFILL(av) >= 0) { 1928 SV **svp = AvARRAY(av); 1929 I32 i; 1930 for (i = 0; i <= AvFILL(av); i++) 1931 XPUSHs(make_sv_object(aTHX_ svp[i])); 1932 } 1933 1934 void 1935 AvARRAYelt(av, idx) 1936 B::AV av 1937 int idx 1938 PPCODE: 1939 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av)) 1940 XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx]))); 1941 else 1942 XPUSHs(make_sv_object(aTHX_ NULL)); 1943 1944 1945 MODULE = B PACKAGE = B::FM PREFIX = Fm 1946 1947 IV 1948 FmLINES(format) 1949 B::FM format 1950 CODE: 1951 PERL_UNUSED_VAR(format); 1952 RETVAL = 0; 1953 OUTPUT: 1954 RETVAL 1955 1956 1957 MODULE = B PACKAGE = B::CV PREFIX = Cv 1958 1959 U32 1960 CvCONST(cv) 1961 B::CV cv 1962 1963 void 1964 CvSTART(cv) 1965 B::CV cv 1966 ALIAS: 1967 ROOT = 1 1968 PPCODE: 1969 PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL 1970 : ix ? CvROOT(cv) : CvSTART(cv))); 1971 1972 I32 1973 CvDEPTH(cv) 1974 B::CV cv 1975 1976 B::PADLIST 1977 CvPADLIST(cv) 1978 B::CV cv 1979 CODE: 1980 RETVAL = CvISXSUB(cv) ? NULL : CvPADLIST(cv); 1981 OUTPUT: 1982 RETVAL 1983 1984 SV * 1985 CvHSCXT(cv) 1986 B::CV cv 1987 CODE: 1988 RETVAL = newSVuv(CvISXSUB(cv) ? PTR2UV(CvHSCXT(cv)) : 0); 1989 OUTPUT: 1990 RETVAL 1991 1992 void 1993 CvXSUB(cv) 1994 B::CV cv 1995 ALIAS: 1996 XSUBANY = 1 1997 CODE: 1998 ST(0) = ix && CvCONST(cv) 1999 ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr) 2000 : sv_2mortal(newSViv(CvISXSUB(cv) 2001 ? (ix ? CvXSUBANY(cv).any_iv 2002 : PTR2IV(CvXSUB(cv))) 2003 : 0)); 2004 2005 void 2006 const_sv(cv) 2007 B::CV cv 2008 PPCODE: 2009 PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv))); 2010 2011 void 2012 GV(cv) 2013 B::CV cv 2014 CODE: 2015 ST(0) = make_sv_object(aTHX_ (SV*)CvGV(cv)); 2016 2017 SV * 2018 NAME_HEK(cv) 2019 B::CV cv 2020 CODE: 2021 RETVAL = CvNAMED(cv) ? newSVhek(CvNAME_HEK(cv)) : &PL_sv_undef; 2022 OUTPUT: 2023 RETVAL 2024 2025 MODULE = B PACKAGE = B::HV PREFIX = Hv 2026 2027 STRLEN 2028 HvFILL(hv) 2029 B::HV hv 2030 2031 I32 2032 HvRITER(hv) 2033 B::HV hv 2034 2035 void 2036 HvARRAY(hv) 2037 B::HV hv 2038 PPCODE: 2039 if (HvUSEDKEYS(hv) > 0) { 2040 HE *he; 2041 SSize_t extend_size; 2042 (void)hv_iterinit(hv); 2043 /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */ 2044 assert(HvUSEDKEYS(hv) <= (SSize_t_MAX >> 1)); 2045 extend_size = (SSize_t)HvUSEDKEYS(hv) * 2; 2046 EXTEND(sp, extend_size); 2047 while ((he = hv_iternext(hv))) { 2048 if (HeSVKEY(he)) { 2049 mPUSHs(HeSVKEY(he)); 2050 } else if (HeKUTF8(he)) { 2051 PUSHs(newSVpvn_flags(HeKEY(he), HeKLEN(he), SVf_UTF8|SVs_TEMP)); 2052 } else { 2053 mPUSHp(HeKEY(he), HeKLEN(he)); 2054 } 2055 PUSHs(make_sv_object(aTHX_ HeVAL(he))); 2056 } 2057 } 2058 2059 MODULE = B PACKAGE = B::HE PREFIX = He 2060 2061 void 2062 HeVAL(he) 2063 B::HE he 2064 ALIAS: 2065 SVKEY_force = 1 2066 PPCODE: 2067 PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he))); 2068 2069 U32 2070 HeHASH(he) 2071 B::HE he 2072 2073 MODULE = B PACKAGE = B::RHE 2074 2075 SV* 2076 HASH(h) 2077 B::RHE h 2078 CODE: 2079 RETVAL = newRV_noinc( (SV*)cophh_2hv(h, 0) ); 2080 OUTPUT: 2081 RETVAL 2082 2083 2084 MODULE = B PACKAGE = B::PADLIST PREFIX = Padlist 2085 2086 SSize_t 2087 PadlistMAX(padlist) 2088 B::PADLIST padlist 2089 ALIAS: B::PADNAMELIST::MAX = 0 2090 CODE: 2091 PERL_UNUSED_VAR(ix); 2092 RETVAL = PadlistMAX(padlist); 2093 OUTPUT: 2094 RETVAL 2095 2096 B::PADNAMELIST 2097 PadlistNAMES(padlist) 2098 B::PADLIST padlist 2099 2100 void 2101 PadlistARRAY(padlist) 2102 B::PADLIST padlist 2103 PPCODE: 2104 if (PadlistMAX(padlist) >= 0) { 2105 dXSTARG; 2106 PAD **padp = PadlistARRAY(padlist); 2107 SSize_t i; 2108 sv_setiv(newSVrv(TARG, PadlistNAMES(padlist) 2109 ? "B::PADNAMELIST" 2110 : "B::NULL"), 2111 PTR2IV(PadlistNAMES(padlist))); 2112 XPUSHTARG; 2113 for (i = 1; i <= PadlistMAX(padlist); i++) 2114 XPUSHs(make_sv_object(aTHX_ (SV *)padp[i])); 2115 } 2116 2117 void 2118 PadlistARRAYelt(padlist, idx) 2119 B::PADLIST padlist 2120 SSize_t idx 2121 PPCODE: 2122 if (idx < 0 || idx > PadlistMAX(padlist)) 2123 XPUSHs(make_sv_object(aTHX_ NULL)); 2124 else if (!idx) { 2125 PL_stack_sp--; 2126 PUSHMARK(PL_stack_sp-1); 2127 XS_B__PADLIST_NAMES(aTHX_ cv); 2128 return; 2129 } 2130 else 2131 XPUSHs(make_sv_object(aTHX_ 2132 (SV *)PadlistARRAY(padlist)[idx])); 2133 2134 U32 2135 PadlistREFCNT(padlist) 2136 B::PADLIST padlist 2137 CODE: 2138 PERL_UNUSED_VAR(padlist); 2139 RETVAL = PadlistREFCNT(padlist); 2140 OUTPUT: 2141 RETVAL 2142 2143 MODULE = B PACKAGE = B::PADNAMELIST PREFIX = Padnamelist 2144 2145 void 2146 PadnamelistARRAY(pnl) 2147 B::PADNAMELIST pnl 2148 PPCODE: 2149 if (PadnamelistMAX(pnl) >= 0) { 2150 PADNAME **padp = PadnamelistARRAY(pnl); 2151 SSize_t i = 0; 2152 for (; i <= PadnamelistMAX(pnl); i++) 2153 { 2154 SV *rv = sv_newmortal(); 2155 sv_setiv(newSVrv(rv,padp[i] ? "B::PADNAME" : "B::SPECIAL"), 2156 PTR2IV(padp[i])); 2157 XPUSHs(rv); 2158 } 2159 } 2160 2161 B::PADNAME 2162 PadnamelistARRAYelt(pnl, idx) 2163 B::PADNAMELIST pnl 2164 SSize_t idx 2165 CODE: 2166 if (idx < 0 || idx > PadnamelistMAX(pnl)) 2167 RETVAL = NULL; 2168 else 2169 RETVAL = PadnamelistARRAY(pnl)[idx]; 2170 OUTPUT: 2171 RETVAL 2172 2173 MODULE = B PACKAGE = B::PADNAME PREFIX = Padname 2174 2175 #define PN_type_ix \ 2176 sv_SVp | STRUCT_OFFSET(struct padname,xpadn_type_u.xpadn_typestash) 2177 #define PN_ourstash_ix \ 2178 sv_SVp | STRUCT_OFFSET(struct padname,xpadn_ourstash) 2179 #define PN_len_ix \ 2180 sv_U8p | STRUCT_OFFSET(struct padname,xpadn_len) 2181 #define PN_refcnt_ix \ 2182 sv_U32p | STRUCT_OFFSET(struct padname, xpadn_refcnt) 2183 #define PN_cop_seq_range_low_ix \ 2184 sv_U32p | STRUCT_OFFSET(struct padname, xpadn_low) 2185 #define PN_cop_seq_range_high_ix \ 2186 sv_U32p | STRUCT_OFFSET(struct padname, xpadn_high) 2187 #define PNL_refcnt_ix \ 2188 sv_U32p | STRUCT_OFFSET(struct padnamelist, xpadnl_refcnt) 2189 #define PL_id_ix \ 2190 sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_id) 2191 #define PL_outid_ix \ 2192 sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_outid) 2193 2194 2195 void 2196 PadnameTYPE(pn) 2197 B::PADNAME pn 2198 ALIAS: 2199 B::PADNAME::TYPE = PN_type_ix 2200 B::PADNAME::OURSTASH = PN_ourstash_ix 2201 B::PADNAME::LEN = PN_len_ix 2202 B::PADNAME::REFCNT = PN_refcnt_ix 2203 B::PADNAME::COP_SEQ_RANGE_LOW = PN_cop_seq_range_low_ix 2204 B::PADNAME::COP_SEQ_RANGE_HIGH = PN_cop_seq_range_high_ix 2205 B::PADNAMELIST::REFCNT = PNL_refcnt_ix 2206 B::PADLIST::id = PL_id_ix 2207 B::PADLIST::outid = PL_outid_ix 2208 PREINIT: 2209 char *ptr; 2210 SV *ret; 2211 PPCODE: 2212 ptr = (ix & 0xFFFF) + (char *)pn; 2213 switch ((U8)(ix >> 16)) { 2214 case (U8)(sv_SVp >> 16): 2215 ret = make_sv_object(aTHX_ *((SV **)ptr)); 2216 break; 2217 case (U8)(sv_U32p >> 16): 2218 ret = sv_2mortal(newSVuv(*((U32 *)ptr))); 2219 break; 2220 case (U8)(sv_U8p >> 16): 2221 ret = sv_2mortal(newSVuv(*((U8 *)ptr))); 2222 break; 2223 default: 2224 NOT_REACHED; 2225 } 2226 ST(0) = ret; 2227 XSRETURN(1); 2228 2229 SV * 2230 PadnamePV(pn) 2231 B::PADNAME pn 2232 PREINIT: 2233 dXSTARG; 2234 PPCODE: 2235 PERL_UNUSED_ARG(RETVAL); 2236 sv_setpvn(TARG, PadnamePV(pn), PadnameLEN(pn)); 2237 SvUTF8_on(TARG); 2238 XPUSHTARG; 2239 2240 BOOT: 2241 { 2242 /* Uses less memory than an ALIAS. */ 2243 GV *gv = gv_fetchpvs("B::PADNAME::TYPE", 1, SVt_PVGV); 2244 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::SvSTASH",1,SVt_PVGV),(SV *)gv); 2245 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PROTOCV",1,SVt_PVGV),(SV *)gv); 2246 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PVX",1,SVt_PVGV), 2247 (SV *)gv_fetchpvs("B::PADNAME::PV" ,1,SVt_PVGV)); 2248 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_PAD_INDEX" ,1,SVt_PVGV), 2249 (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_LOW",1, 2250 SVt_PVGV)); 2251 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_FAKELEX_FLAGS",1, 2252 SVt_PVGV), 2253 (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_HIGH" ,1, 2254 SVt_PVGV)); 2255 } 2256 2257 U32 2258 PadnameFLAGS(pn) 2259 B::PADNAME pn 2260 CODE: 2261 RETVAL = PadnameFLAGS(pn); 2262 /* backward-compatibility hack, which should be removed if the 2263 flags field becomes large enough to hold SVf_FAKE (and 2264 PADNAMEt_OUTER should be renumbered to match SVf_FAKE) */ 2265 STATIC_ASSERT_STMT(SVf_FAKE >= 1<<(sizeof(PadnameFLAGS((B__PADNAME)NULL)) * 8)); 2266 if (PadnameOUTER(pn)) 2267 RETVAL |= SVf_FAKE; 2268 OUTPUT: 2269 RETVAL 2270