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