| Commit | Line | Data |
|---|
| c311cef3 |
1 | /* |
| 2 | * This code was copied from perl/pad.c and perl/op.c and subsequently |
| 3 | * butchered by Lukas Mai (2012). |
| 4 | */ |
| 5 | /* vi: set ft=c inde=: */ |
| 6 | |
| 7 | #define COP_SEQ_RANGE_LOW_set(SV, VAL) \ |
| 9cb05a12 |
8 | STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } STMT_END |
| c311cef3 |
9 | #define COP_SEQ_RANGE_HIGH_set(SV, VAL) \ |
| 9cb05a12 |
10 | STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END |
| c311cef3 |
11 | |
| 12 | static void S_pad_block_start(pTHX_ int full) { |
| 13 | dVAR; |
| 14 | ASSERT_CURPAD_ACTIVE("pad_block_start"); |
| 15 | SAVEI32(PL_comppad_name_floor); |
| 16 | PL_comppad_name_floor = AvFILLp(PL_comppad_name); |
| 17 | if (full) |
| 18 | PL_comppad_name_fill = PL_comppad_name_floor; |
| 19 | if (PL_comppad_name_floor < 0) |
| 20 | PL_comppad_name_floor = 0; |
| 21 | SAVEI32(PL_min_intro_pending); |
| 22 | SAVEI32(PL_max_intro_pending); |
| 23 | PL_min_intro_pending = 0; |
| 24 | SAVEI32(PL_comppad_name_fill); |
| 25 | SAVEI32(PL_padix_floor); |
| 26 | PL_padix_floor = PL_padix; |
| 27 | PL_pad_reset_pending = FALSE; |
| 28 | } |
| 29 | |
| 30 | static int S_block_start(pTHX_ int full) { |
| 31 | dVAR; |
| 32 | const int retval = PL_savestack_ix; |
| 33 | |
| 311ced6f |
34 | S_pad_block_start(aTHX_ full); |
| c311cef3 |
35 | SAVEHINTS(); |
| 36 | PL_hints &= ~HINT_BLOCK_SCOPE; |
| 37 | SAVECOMPILEWARNINGS(); |
| 38 | PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); |
| 39 | |
| 40 | CALL_BLOCK_HOOKS(bhk_start, full); |
| 41 | |
| 42 | return retval; |
| 43 | } |
| 44 | |
| 45 | /* Check for in place reverse and sort assignments like "@a = reverse @a" |
| 46 | and modify the optree to make them work inplace */ |
| 47 | |
| 48 | static void S_inplace_aassign(pTHX_ OP *o) { |
| 49 | OP *modop, *modop_pushmark; |
| 50 | OP *oright; |
| 51 | OP *oleft, *oleft_pushmark; |
| 52 | |
| 53 | assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID); |
| 54 | |
| 55 | assert(cUNOPo->op_first->op_type == OP_NULL); |
| 56 | modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first; |
| 57 | assert(modop_pushmark->op_type == OP_PUSHMARK); |
| 58 | modop = modop_pushmark->op_sibling; |
| 59 | |
| 60 | if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) |
| 61 | return; |
| 62 | |
| 63 | /* no other operation except sort/reverse */ |
| 64 | if (modop->op_sibling) |
| 65 | return; |
| 66 | |
| 67 | assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); |
| 68 | if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return; |
| 69 | |
| 70 | if (modop->op_flags & OPf_STACKED) { |
| 71 | /* skip sort subroutine/block */ |
| 72 | assert(oright->op_type == OP_NULL); |
| 73 | oright = oright->op_sibling; |
| 74 | } |
| 75 | |
| 76 | assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL); |
| 77 | oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first; |
| 78 | assert(oleft_pushmark->op_type == OP_PUSHMARK); |
| 79 | oleft = oleft_pushmark->op_sibling; |
| 80 | |
| 81 | /* Check the lhs is an array */ |
| 82 | if (!oleft || |
| 83 | (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) |
| 84 | || oleft->op_sibling |
| 85 | || (oleft->op_private & OPpLVAL_INTRO) |
| 86 | ) |
| 87 | return; |
| 88 | |
| 89 | /* Only one thing on the rhs */ |
| 90 | if (oright->op_sibling) |
| 91 | return; |
| 92 | |
| 93 | /* check the array is the same on both sides */ |
| 94 | if (oleft->op_type == OP_RV2AV) { |
| 95 | if (oright->op_type != OP_RV2AV |
| 96 | || !cUNOPx(oright)->op_first |
| 97 | || cUNOPx(oright)->op_first->op_type != OP_GV |
| 98 | || cUNOPx(oleft )->op_first->op_type != OP_GV |
| 99 | || cGVOPx_gv(cUNOPx(oleft)->op_first) != |
| 100 | cGVOPx_gv(cUNOPx(oright)->op_first) |
| 101 | ) |
| 102 | return; |
| 103 | } |
| 104 | else if (oright->op_type != OP_PADAV |
| 105 | || oright->op_targ != oleft->op_targ |
| 106 | ) |
| 107 | return; |
| 108 | |
| 109 | /* This actually is an inplace assignment */ |
| 110 | |
| 111 | modop->op_private |= OPpSORT_INPLACE; |
| 112 | |
| 113 | /* transfer MODishness etc from LHS arg to RHS arg */ |
| 114 | oright->op_flags = oleft->op_flags; |
| 115 | |
| 116 | /* remove the aassign op and the lhs */ |
| 117 | op_null(o); |
| 118 | op_null(oleft_pushmark); |
| 119 | if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first) |
| 120 | op_null(cUNOPx(oleft)->op_first); |
| 121 | op_null(oleft); |
| 122 | } |
| 123 | |
| 124 | static OP *S_scalarvoid(pTHX_ OP *); |
| 125 | |
| 126 | static OP *S_scalar(pTHX_ OP *o) { |
| 127 | dVAR; |
| 128 | OP *kid; |
| 129 | |
| 130 | /* assumes no premature commitment */ |
| 131 | if (!o || (PL_parser && PL_parser->error_count) |
| 132 | || (o->op_flags & OPf_WANT) |
| 133 | || o->op_type == OP_RETURN) |
| 134 | { |
| 135 | return o; |
| 136 | } |
| 137 | |
| 138 | o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; |
| 139 | |
| 140 | switch (o->op_type) { |
| 141 | case OP_REPEAT: |
| 311ced6f |
142 | S_scalar(aTHX_ cBINOPo->op_first); |
| c311cef3 |
143 | break; |
| 144 | case OP_OR: |
| 145 | case OP_AND: |
| 146 | case OP_COND_EXPR: |
| 147 | for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) |
| 311ced6f |
148 | S_scalar(aTHX_ kid); |
| c311cef3 |
149 | break; |
| 150 | /* FALL THROUGH */ |
| 151 | case OP_SPLIT: |
| 152 | case OP_MATCH: |
| 153 | case OP_QR: |
| 154 | case OP_SUBST: |
| 155 | case OP_NULL: |
| 156 | default: |
| 157 | if (o->op_flags & OPf_KIDS) { |
| 158 | for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) |
| 311ced6f |
159 | S_scalar(aTHX_ kid); |
| c311cef3 |
160 | } |
| 161 | break; |
| 162 | case OP_LEAVE: |
| 163 | case OP_LEAVETRY: |
| 164 | kid = cLISTOPo->op_first; |
| 311ced6f |
165 | S_scalar(aTHX_ kid); |
| c311cef3 |
166 | kid = kid->op_sibling; |
| 167 | do_kids: |
| 168 | while (kid) { |
| 169 | OP *sib = kid->op_sibling; |
| 170 | if (sib && kid->op_type != OP_LEAVEWHEN) |
| 311ced6f |
171 | S_scalarvoid(aTHX_ kid); |
| c311cef3 |
172 | else |
| 311ced6f |
173 | S_scalar(aTHX_ kid); |
| c311cef3 |
174 | kid = sib; |
| 175 | } |
| 176 | PL_curcop = &PL_compiling; |
| 177 | break; |
| 178 | case OP_SCOPE: |
| 179 | case OP_LINESEQ: |
| 180 | case OP_LIST: |
| 181 | kid = cLISTOPo->op_first; |
| 182 | goto do_kids; |
| 183 | case OP_SORT: |
| 184 | Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); |
| 185 | break; |
| 186 | } |
| 187 | return o; |
| 188 | } |
| 189 | |
| 190 | static OP *S_scalarkids(pTHX_ OP *o) { |
| 191 | if (o && o->op_flags & OPf_KIDS) { |
| 192 | OP *kid; |
| 193 | for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) |
| 311ced6f |
194 | S_scalar(aTHX_ kid); |
| c311cef3 |
195 | } |
| 196 | return o; |
| 197 | } |
| 198 | |
| 199 | static OP *S_scalarvoid(pTHX_ OP *o) { |
| 200 | dVAR; |
| 201 | OP *kid; |
| 202 | const char *useless = NULL; |
| 203 | U32 useless_is_utf8 = 0; |
| 204 | SV *sv; |
| 205 | U8 want; |
| 206 | |
| 207 | PERL_ARGS_ASSERT_SCALARVOID; |
| 208 | |
| 209 | if ( |
| 210 | o->op_type == OP_NEXTSTATE || |
| 211 | o->op_type == OP_DBSTATE || ( |
| 212 | o->op_type == OP_NULL && ( |
| 213 | o->op_targ == OP_NEXTSTATE || |
| 214 | o->op_targ == OP_DBSTATE |
| 215 | ) |
| 216 | ) |
| 217 | ) { |
| 218 | PL_curcop = (COP*)o; /* for warning below */ |
| 219 | } |
| 220 | |
| 221 | /* assumes no premature commitment */ |
| 222 | want = o->op_flags & OPf_WANT; |
| 223 | if ( |
| 224 | (want && want != OPf_WANT_SCALAR) || |
| 225 | (PL_parser && PL_parser->error_count) || |
| 226 | o->op_type == OP_RETURN || |
| 227 | o->op_type == OP_REQUIRE || |
| 228 | o->op_type == OP_LEAVEWHEN |
| 229 | ) { |
| 230 | return o; |
| 231 | } |
| 232 | |
| 233 | if ( |
| 234 | (o->op_private & OPpTARGET_MY) && |
| 235 | (PL_opargs[o->op_type] & OA_TARGLEX) |
| 236 | /* OPp share the meaning */ |
| 237 | ) { |
| 311ced6f |
238 | return S_scalar(aTHX_ o); /* As if inside SASSIGN */ |
| c311cef3 |
239 | } |
| 240 | |
| 241 | o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; |
| 242 | |
| 243 | switch (o->op_type) { |
| 244 | default: |
| 245 | if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) |
| 246 | break; |
| 247 | /* FALL THROUGH */ |
| 248 | case OP_REPEAT: |
| 249 | if (o->op_flags & OPf_STACKED) |
| 250 | break; |
| 251 | goto func_ops; |
| 252 | case OP_SUBSTR: |
| 253 | if (o->op_private == 4) |
| 254 | break; |
| 255 | /* FALL THROUGH */ |
| 256 | case OP_GVSV: |
| 257 | case OP_WANTARRAY: |
| 258 | case OP_GV: |
| 259 | case OP_SMARTMATCH: |
| 260 | case OP_PADSV: |
| 261 | case OP_PADAV: |
| 262 | case OP_PADHV: |
| 263 | case OP_PADANY: |
| 264 | case OP_AV2ARYLEN: |
| 265 | case OP_REF: |
| 266 | case OP_REFGEN: |
| 267 | case OP_SREFGEN: |
| 268 | case OP_DEFINED: |
| 269 | case OP_HEX: |
| 270 | case OP_OCT: |
| 271 | case OP_LENGTH: |
| 272 | case OP_VEC: |
| 273 | case OP_INDEX: |
| 274 | case OP_RINDEX: |
| 275 | case OP_SPRINTF: |
| 276 | case OP_AELEM: |
| 277 | case OP_AELEMFAST: |
| c3e72f35 |
278 | IF_HAVE_PERL_5_16(case OP_AELEMFAST_LEX:, ) |
| c311cef3 |
279 | case OP_ASLICE: |
| 280 | case OP_HELEM: |
| 281 | case OP_HSLICE: |
| 282 | case OP_UNPACK: |
| 283 | case OP_PACK: |
| 284 | case OP_JOIN: |
| 285 | case OP_LSLICE: |
| 286 | case OP_ANONLIST: |
| 287 | case OP_ANONHASH: |
| 288 | case OP_SORT: |
| 289 | case OP_REVERSE: |
| 290 | case OP_RANGE: |
| 291 | case OP_FLIP: |
| 292 | case OP_FLOP: |
| 293 | case OP_CALLER: |
| 294 | case OP_FILENO: |
| 295 | case OP_EOF: |
| 296 | case OP_TELL: |
| 297 | case OP_GETSOCKNAME: |
| 298 | case OP_GETPEERNAME: |
| 299 | case OP_READLINK: |
| 300 | case OP_TELLDIR: |
| 301 | case OP_GETPPID: |
| 302 | case OP_GETPGRP: |
| 303 | case OP_GETPRIORITY: |
| 304 | case OP_TIME: |
| 305 | case OP_TMS: |
| 306 | case OP_LOCALTIME: |
| 307 | case OP_GMTIME: |
| 308 | case OP_GHBYNAME: |
| 309 | case OP_GHBYADDR: |
| 310 | case OP_GHOSTENT: |
| 311 | case OP_GNBYNAME: |
| 312 | case OP_GNBYADDR: |
| 313 | case OP_GNETENT: |
| 314 | case OP_GPBYNAME: |
| 315 | case OP_GPBYNUMBER: |
| 316 | case OP_GPROTOENT: |
| 317 | case OP_GSBYNAME: |
| 318 | case OP_GSBYPORT: |
| 319 | case OP_GSERVENT: |
| 320 | case OP_GPWNAM: |
| 321 | case OP_GPWUID: |
| 322 | case OP_GGRNAM: |
| 323 | case OP_GGRGID: |
| 324 | case OP_GETLOGIN: |
| 325 | case OP_PROTOTYPE: |
| c3e72f35 |
326 | IF_HAVE_PERL_5_16(case OP_RUNCV:, ) |
| c311cef3 |
327 | func_ops: |
| 328 | if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) |
| 329 | /* Otherwise it's "Useless use of grep iterator" */ |
| 330 | useless = OP_DESC(o); |
| 331 | break; |
| 332 | |
| 333 | case OP_SPLIT: |
| 334 | kid = cLISTOPo->op_first; |
| 335 | if (kid && kid->op_type == OP_PUSHRE |
| 336 | #ifdef USE_ITHREADS |
| 337 | && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff) |
| 338 | #else |
| 339 | && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv) |
| 340 | #endif |
| 341 | useless = OP_DESC(o); |
| 342 | break; |
| 343 | |
| 344 | case OP_NOT: |
| 345 | kid = cUNOPo->op_first; |
| 346 | if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && |
| 347 | kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) { |
| 348 | goto func_ops; |
| 349 | } |
| 350 | useless = "negative pattern binding (!~)"; |
| 351 | break; |
| 352 | |
| 353 | case OP_SUBST: |
| 354 | if (cPMOPo->op_pmflags & PMf_NONDESTRUCT) |
| 355 | useless = "non-destructive substitution (s///r)"; |
| 356 | break; |
| 357 | |
| 358 | case OP_TRANSR: |
| 359 | useless = "non-destructive transliteration (tr///r)"; |
| 360 | break; |
| 361 | |
| 362 | case OP_RV2GV: |
| 363 | case OP_RV2SV: |
| 364 | case OP_RV2AV: |
| 365 | case OP_RV2HV: |
| 366 | if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && |
| 367 | (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) |
| 368 | useless = "a variable"; |
| 369 | break; |
| 370 | |
| 371 | case OP_CONST: |
| 372 | sv = cSVOPo_sv; |
| 373 | if (cSVOPo->op_private & OPpCONST_STRICT) { |
| 374 | //no_bareword_allowed(o); |
| 375 | *((int *)NULL) += 1; |
| 376 | } else { |
| 377 | if (ckWARN(WARN_VOID)) { |
| 378 | /* don't warn on optimised away booleans, eg |
| 379 | * use constant Foo, 5; Foo || print; */ |
| 380 | if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) |
| 381 | useless = NULL; |
| 382 | /* the constants 0 and 1 are permitted as they are |
| 383 | conventionally used as dummies in constructs like |
| 384 | 1 while some_condition_with_side_effects; */ |
| 385 | else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) |
| 386 | useless = NULL; |
| 387 | else if (SvPOK(sv)) { |
| 388 | /* perl4's way of mixing documentation and code |
| 389 | (before the invention of POD) was based on a |
| 390 | trick to mix nroff and perl code. The trick was |
| 391 | built upon these three nroff macros being used in |
| 392 | void context. The pink camel has the details in |
| 393 | the script wrapman near page 319. */ |
| 394 | const char * const maybe_macro = SvPVX_const(sv); |
| 395 | if (strnEQ(maybe_macro, "di", 2) || |
| 396 | strnEQ(maybe_macro, "ds", 2) || |
| 397 | strnEQ(maybe_macro, "ig", 2)) |
| 398 | useless = NULL; |
| 399 | else { |
| 400 | SV * const dsv = newSVpvs(""); |
| 401 | SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ |
| 402 | "a constant (%s)", |
| 403 | pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL, |
| 404 | PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT ))); |
| 405 | SvREFCNT_dec(dsv); |
| 406 | useless = SvPV_nolen(msv); |
| 407 | useless_is_utf8 = SvUTF8(msv); |
| 408 | } |
| 409 | } |
| 410 | else if (SvOK(sv)) { |
| 411 | SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ |
| 412 | "a constant (%"SVf")", sv)); |
| 413 | useless = SvPV_nolen(msv); |
| 414 | } |
| 415 | else |
| 416 | useless = "a constant (undef)"; |
| 417 | } |
| 418 | } |
| 419 | op_null(o); /* don't execute or even remember it */ |
| 420 | break; |
| 421 | |
| 422 | case OP_POSTINC: |
| 423 | o->op_type = OP_PREINC; /* pre-increment is faster */ |
| 424 | o->op_ppaddr = PL_ppaddr[OP_PREINC]; |
| 425 | break; |
| 426 | |
| 427 | case OP_POSTDEC: |
| 428 | o->op_type = OP_PREDEC; /* pre-decrement is faster */ |
| 429 | o->op_ppaddr = PL_ppaddr[OP_PREDEC]; |
| 430 | break; |
| 431 | |
| 432 | case OP_I_POSTINC: |
| 433 | o->op_type = OP_I_PREINC; /* pre-increment is faster */ |
| 434 | o->op_ppaddr = PL_ppaddr[OP_I_PREINC]; |
| 435 | break; |
| 436 | |
| 437 | case OP_I_POSTDEC: |
| 438 | o->op_type = OP_I_PREDEC; /* pre-decrement is faster */ |
| 439 | o->op_ppaddr = PL_ppaddr[OP_I_PREDEC]; |
| 440 | break; |
| 441 | |
| 442 | case OP_SASSIGN: { |
| 443 | OP *rv2gv; |
| 444 | UNOP *refgen, *rv2cv; |
| 445 | LISTOP *exlist; |
| 446 | |
| 447 | if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2) |
| 448 | break; |
| 449 | |
| 450 | rv2gv = ((BINOP *)o)->op_last; |
| 451 | if (!rv2gv || rv2gv->op_type != OP_RV2GV) |
| 452 | break; |
| 453 | |
| 454 | refgen = (UNOP *)((BINOP *)o)->op_first; |
| 455 | |
| 456 | if (!refgen || refgen->op_type != OP_REFGEN) |
| 457 | break; |
| 458 | |
| 459 | exlist = (LISTOP *)refgen->op_first; |
| 460 | if (!exlist || exlist->op_type != OP_NULL |
| 461 | || exlist->op_targ != OP_LIST) |
| 462 | break; |
| 463 | |
| 464 | if (exlist->op_first->op_type != OP_PUSHMARK) |
| 465 | break; |
| 466 | |
| 467 | rv2cv = (UNOP*)exlist->op_last; |
| 468 | |
| 469 | if (rv2cv->op_type != OP_RV2CV) |
| 470 | break; |
| 471 | |
| 472 | assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0); |
| 473 | assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0); |
| 474 | assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0); |
| 475 | |
| 476 | o->op_private |= OPpASSIGN_CV_TO_GV; |
| 477 | rv2gv->op_private |= OPpDONT_INIT_GV; |
| 478 | rv2cv->op_private |= OPpMAY_RETURN_CONSTANT; |
| 479 | |
| 480 | break; |
| 481 | } |
| 482 | |
| 483 | case OP_AASSIGN: { |
| 311ced6f |
484 | S_inplace_aassign(aTHX_ o); |
| c311cef3 |
485 | break; |
| 486 | } |
| 487 | |
| 488 | case OP_OR: |
| 489 | case OP_AND: |
| 490 | kid = cLOGOPo->op_first; |
| 491 | if (kid->op_type == OP_NOT |
| 492 | && (kid->op_flags & OPf_KIDS) |
| 493 | && !PL_madskills) { |
| 494 | if (o->op_type == OP_AND) { |
| 495 | o->op_type = OP_OR; |
| 496 | o->op_ppaddr = PL_ppaddr[OP_OR]; |
| 497 | } else { |
| 498 | o->op_type = OP_AND; |
| 499 | o->op_ppaddr = PL_ppaddr[OP_AND]; |
| 500 | } |
| 501 | op_null(kid); |
| 502 | } |
| 503 | |
| 504 | case OP_DOR: |
| 505 | case OP_COND_EXPR: |
| 506 | case OP_ENTERGIVEN: |
| 507 | case OP_ENTERWHEN: |
| 508 | for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) |
| 311ced6f |
509 | S_scalarvoid(aTHX_ kid); |
| c311cef3 |
510 | break; |
| 511 | |
| 512 | case OP_NULL: |
| 513 | if (o->op_flags & OPf_STACKED) |
| 514 | break; |
| 515 | /* FALL THROUGH */ |
| 516 | case OP_NEXTSTATE: |
| 517 | case OP_DBSTATE: |
| 518 | case OP_ENTERTRY: |
| 519 | case OP_ENTER: |
| 520 | if (!(o->op_flags & OPf_KIDS)) |
| 521 | break; |
| 522 | /* FALL THROUGH */ |
| 523 | case OP_SCOPE: |
| 524 | case OP_LEAVE: |
| 525 | case OP_LEAVETRY: |
| 526 | case OP_LEAVELOOP: |
| 527 | case OP_LINESEQ: |
| 528 | case OP_LIST: |
| 529 | case OP_LEAVEGIVEN: |
| 530 | case OP_LEAVEWHEN: |
| 531 | for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) |
| 311ced6f |
532 | S_scalarvoid(aTHX_ kid); |
| c311cef3 |
533 | break; |
| 534 | case OP_ENTEREVAL: |
| 311ced6f |
535 | S_scalarkids(aTHX_ o); |
| c311cef3 |
536 | break; |
| 537 | case OP_SCALAR: |
| 311ced6f |
538 | return S_scalar(aTHX_ o); |
| c311cef3 |
539 | } |
| 540 | if (useless) |
| 541 | Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context", |
| 542 | newSVpvn_flags(useless, strlen(useless), |
| 543 | SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 ))); |
| 544 | return o; |
| 545 | } |
| 546 | |
| 547 | static OP *S_scalarseq(pTHX_ OP *o) { |
| 548 | dVAR; |
| 549 | if (o) { |
| 550 | const OPCODE type = o->op_type; |
| 551 | |
| 552 | if (type == OP_LINESEQ || type == OP_SCOPE || |
| 553 | type == OP_LEAVE || type == OP_LEAVETRY) |
| 554 | { |
| 555 | OP *kid; |
| 556 | for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { |
| 557 | if (kid->op_sibling) { |
| 311ced6f |
558 | S_scalarvoid(aTHX_ kid); |
| c311cef3 |
559 | } |
| 560 | } |
| 561 | PL_curcop = &PL_compiling; |
| 562 | } |
| 563 | o->op_flags &= ~OPf_PARENS; |
| 564 | if (PL_hints & HINT_BLOCK_SCOPE) |
| 565 | o->op_flags |= OPf_PARENS; |
| 566 | } |
| 567 | else |
| 568 | o = newOP(OP_STUB, 0); |
| 569 | return o; |
| 570 | } |
| 571 | |
| 572 | static void S_pad_leavemy(pTHX) { |
| 573 | dVAR; |
| 574 | I32 off; |
| 575 | SV * const * const svp = AvARRAY(PL_comppad_name); |
| 576 | |
| 577 | PL_pad_reset_pending = FALSE; |
| 578 | |
| 579 | ASSERT_CURPAD_ACTIVE("pad_leavemy"); |
| 580 | if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) { |
| 581 | for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { |
| 582 | const SV * const sv = svp[off]; |
| 583 | if (sv && sv != &PL_sv_undef && !SvFAKE(sv)) |
| 584 | Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), |
| 585 | "%"SVf" never introduced", |
| 586 | SVfARG(sv)); |
| 587 | } |
| 588 | } |
| 589 | /* "Deintroduce" my variables that are leaving with this scope. */ |
| 590 | for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) { |
| 591 | const SV * const sv = svp[off]; |
| 592 | if (sv && sv != &PL_sv_undef && !SvFAKE(sv) |
| 593 | && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) |
| 594 | { |
| 595 | COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); |
| 596 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
| 597 | "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", |
| 598 | (long)off, SvPVX_const(sv), |
| 599 | (unsigned long)COP_SEQ_RANGE_LOW(sv), |
| 600 | (unsigned long)COP_SEQ_RANGE_HIGH(sv)) |
| 601 | ); |
| 602 | } |
| 603 | } |
| 604 | PL_cop_seqmax++; |
| 605 | if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ |
| 606 | PL_cop_seqmax++; |
| 607 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
| 608 | "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax)); |
| 609 | } |
| 610 | |
| 611 | static OP *S_block_end(pTHX_ I32 floor, OP *seq) { |
| 612 | dVAR; |
| 613 | const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; |
| 311ced6f |
614 | OP *retval = S_scalarseq(aTHX_ seq); |
| c311cef3 |
615 | |
| 616 | CALL_BLOCK_HOOKS(bhk_pre_end, &retval); |
| 617 | |
| 618 | LEAVE_SCOPE(floor); |
| 619 | CopHINTS_set(&PL_compiling, PL_hints); |
| 620 | if (needblockscope) |
| 621 | PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ |
| 311ced6f |
622 | S_pad_leavemy(aTHX); |
| c311cef3 |
623 | |
| 624 | CALL_BLOCK_HOOKS(bhk_post_end, &retval); |
| 625 | |
| 626 | return retval; |
| 627 | } |
| c3e72f35 |
628 | |
| 629 | |
| 630 | #ifndef pad_alloc |
| 631 | |
| 632 | #define pad_alloc(OPTYPE, TMPTYPE) \ |
| 633 | S_pad_alloc(aTHX_ OPTYPE, TMPTYPE) |
| 634 | |
| 635 | static PADOFFSET S_pad_alloc(pTHX_ I32 optype, U32 tmptype) { |
| 636 | dVAR; |
| 637 | SV *sv; |
| 638 | I32 retval; |
| 639 | |
| 640 | PERL_UNUSED_ARG(optype); |
| 641 | ASSERT_CURPAD_ACTIVE("pad_alloc"); |
| 642 | |
| 643 | if (AvARRAY(PL_comppad) != PL_curpad) |
| 644 | Perl_croak(aTHX_ "panic: pad_alloc"); |
| 645 | PL_pad_reset_pending = FALSE; |
| 646 | if (tmptype & SVs_PADMY) { |
| 647 | sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); |
| 648 | retval = AvFILLp(PL_comppad); |
| 649 | } |
| 650 | else { |
| 651 | SV * const * const names = AvARRAY(PL_comppad_name); |
| 652 | const SSize_t names_fill = AvFILLp(PL_comppad_name); |
| 653 | for (;;) { |
| 654 | /* |
| 655 | * "foreach" index vars temporarily become aliases to non-"my" |
| 656 | * values. Thus we must skip, not just pad values that are |
| 657 | * marked as current pad values, but also those with names. |
| 658 | */ |
| 659 | /* HVDS why copy to sv here? we don't seem to use it */ |
| 660 | if (++PL_padix <= names_fill && |
| 661 | (sv = names[PL_padix]) && sv != &PL_sv_undef) |
| 662 | continue; |
| 663 | sv = *av_fetch(PL_comppad, PL_padix, TRUE); |
| 664 | if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) && |
| 665 | !IS_PADGV(sv) && !IS_PADCONST(sv)) |
| 666 | break; |
| 667 | } |
| 668 | retval = PL_padix; |
| 669 | } |
| 670 | SvFLAGS(sv) |= tmptype; |
| 671 | PL_curpad = AvARRAY(PL_comppad); |
| 672 | |
| 673 | DEBUG_X(PerlIO_printf(Perl_debug_log, |
| 674 | "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n", |
| 675 | PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval, |
| 676 | PL_op_name[optype])); |
| 677 | #ifdef DEBUG_LEAKING_SCALARS |
| 678 | sv->sv_debug_optype = optype; |
| 679 | sv->sv_debug_inpad = 1; |
| 680 | #endif |
| 681 | return (PADOFFSET)retval; |
| 682 | } |
| 683 | |
| 684 | #endif |
| 685 | |
| 686 | |
| e158cf8f |
687 | #ifndef pad_add_name_pvs |
| 688 | #define pad_add_name_pvs(NAME, FLAGS, TYPESTASH, OURSTASH) S_pad_add_name_pvn(aTHX_ "" NAME "", sizeof NAME - 1, FLAGS, TYPESTASH, OURSTASH) |
| 689 | #endif |
| 690 | |
| c3e72f35 |
691 | #ifndef pad_add_name_sv |
| 692 | |
| 693 | #define pad_add_name_sv(NAMESV, FLAGS, TYPESTASH, OURSTASH) \ |
| 694 | S_pad_add_name_sv(aTHX_ NAMESV, FLAGS, TYPESTASH, OURSTASH) |
| 695 | |
| 7d5c8305 |
696 | static PADOFFSET S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash) { |
| c3e72f35 |
697 | dVAR; |
| 698 | const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); |
| 699 | |
| 7d5c8305 |
700 | assert(flags == 0); |
| 701 | |
| 702 | ASSERT_CURPAD_ACTIVE("pad_alloc_name"); |
| c3e72f35 |
703 | |
| 704 | if (typestash) { |
| 705 | assert(SvTYPE(namesv) == SVt_PVMG); |
| 706 | SvPAD_TYPED_on(namesv); |
| 707 | SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)))); |
| 708 | } |
| 709 | if (ourstash) { |
| 710 | SvPAD_OUR_on(namesv); |
| 711 | SvOURSTASH_set(namesv, ourstash); |
| 712 | SvREFCNT_inc_simple_void_NN(ourstash); |
| 713 | } |
| c3e72f35 |
714 | |
| 715 | av_store(PL_comppad_name, offset, namesv); |
| 716 | return offset; |
| 717 | } |
| 718 | |
| 723c2956 |
719 | static PADOFFSET S_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags, HV *typestash, HV *ourstash) { |
| 7d5c8305 |
720 | dVAR; |
| 721 | PADOFFSET offset; |
| 722 | SV *namesv; |
| 723 | |
| 724 | assert(flags == 0); |
| 725 | |
| 726 | namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); |
| 727 | |
| 728 | sv_setpvn(namesv, namepv, namelen); |
| 729 | |
| 730 | offset = S_pad_alloc_name(aTHX_ namesv, flags, typestash, ourstash); |
| 731 | |
| 732 | /* not yet introduced */ |
| 733 | COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO); |
| 734 | COP_SEQ_RANGE_HIGH_set(namesv, 0); |
| 735 | |
| 736 | if (!PL_min_intro_pending) |
| 737 | PL_min_intro_pending = offset; |
| 738 | PL_max_intro_pending = offset; |
| 739 | /* if it's not a simple scalar, replace with an AV or HV */ |
| 740 | assert(SvTYPE(PL_curpad[offset]) == SVt_NULL); |
| 741 | assert(SvREFCNT(PL_curpad[offset]) == 1); |
| 742 | if (namelen != 0 && *namepv == '@') |
| 743 | sv_upgrade(PL_curpad[offset], SVt_PVAV); |
| 744 | else if (namelen != 0 && *namepv == '%') |
| 745 | sv_upgrade(PL_curpad[offset], SVt_PVHV); |
| 746 | assert(SvPADMY(PL_curpad[offset])); |
| 747 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
| 748 | "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n", |
| 749 | (long)offset, SvPVX(namesv), |
| 750 | PTR2UV(PL_curpad[offset]))); |
| 751 | |
| 752 | return offset; |
| 753 | } |
| 754 | |
| 755 | static PADOFFSET S_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash) { |
| 756 | char *namepv; |
| 757 | STRLEN namelen; |
| 758 | assert(flags == 0); |
| 759 | namepv = SvPV(name, namelen); |
| 760 | return S_pad_add_name_pvn(aTHX_ namepv, namelen, flags, typestash, ourstash); |
| 761 | } |
| 762 | |
| c3e72f35 |
763 | #endif |
| 63915d26 |
764 | |
| 765 | #ifndef pad_findmy_sv |
| 766 | |
| 767 | #define pad_findmy_sv(SV, FLAGS) \ |
| 768 | S_pad_findmy(aTHX_ SvPV_nolen(SV), FLAGS) |
| 769 | |
| 770 | #define PARENT_PAD_INDEX_set(SV, VAL) \ |
| 771 | STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } STMT_END |
| 772 | #define PARENT_FAKELEX_FLAGS_set(SV, VAL) \ |
| 773 | STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END |
| 774 | |
| 775 | static PADOFFSET S_pad_findlex(pTHX_ const char *name, const CV *cv, U32 seq, int warn, SV **out_capture, SV **out_name_sv, int *out_flags) { |
| 776 | #define CvCOMPILED(CV) CvROOT(CV) |
| 777 | #define CvLATE(CV) (CvANON(CV) || SvTYPE(CV) == SVt_PVFM) |
| 778 | dVAR; |
| 779 | I32 offset, new_offset; |
| 780 | SV *new_capture; |
| 781 | SV **new_capturep; |
| 782 | const AV *const padlist = CvPADLIST(cv); |
| 783 | |
| 784 | *out_flags = 0; |
| 785 | |
| 786 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
| 787 | "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n", |
| 788 | PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" )); |
| 789 | |
| 790 | /* first, search this pad */ |
| 791 | |
| 792 | if (padlist) { /* not an undef CV */ |
| 793 | I32 fake_offset = 0; |
| 794 | const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]); |
| 795 | SV * const * const name_svp = AvARRAY(nameav); |
| 796 | |
| 797 | for (offset = AvFILLp(nameav); offset > 0; offset--) { |
| 798 | const SV * const namesv = name_svp[offset]; |
| 799 | if (namesv && namesv != &PL_sv_undef |
| 800 | && strEQ(SvPVX_const(namesv), name)) |
| 801 | { |
| 802 | if (SvFAKE(namesv)) { |
| 803 | fake_offset = offset; /* in case we don't find a real one */ |
| 804 | continue; |
| 805 | } |
| 806 | /* is seq within the range _LOW to _HIGH ? |
| 807 | * This is complicated by the fact that PL_cop_seqmax |
| 808 | * may have wrapped around at some point */ |
| 809 | if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO) |
| 810 | continue; /* not yet introduced */ |
| 811 | |
| 812 | if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) { |
| 813 | /* in compiling scope */ |
| 814 | if ( |
| 815 | (seq > COP_SEQ_RANGE_LOW(namesv)) |
| 816 | ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1)) |
| 817 | : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1)) |
| 818 | ) |
| 819 | break; |
| 820 | } |
| 821 | else if ( |
| 822 | (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv)) |
| 823 | ? |
| 824 | ( seq > COP_SEQ_RANGE_LOW(namesv) |
| 825 | || seq <= COP_SEQ_RANGE_HIGH(namesv)) |
| 826 | |
| 827 | : ( seq > COP_SEQ_RANGE_LOW(namesv) |
| 828 | && seq <= COP_SEQ_RANGE_HIGH(namesv)) |
| 829 | ) |
| 830 | break; |
| 831 | } |
| 832 | } |
| 833 | |
| 834 | if (offset > 0 || fake_offset > 0 ) { /* a match! */ |
| 835 | if (offset > 0) { /* not fake */ |
| 836 | fake_offset = 0; |
| 837 | *out_name_sv = name_svp[offset]; /* return the namesv */ |
| 838 | |
| 839 | /* set PAD_FAKELEX_MULTI if this lex can have multiple |
| 840 | * instances. For now, we just test !CvUNIQUE(cv), but |
| 841 | * ideally, we should detect my's declared within loops |
| 842 | * etc - this would allow a wider range of 'not stayed |
| 843 | * shared' warnings. We also treated already-compiled |
| 844 | * lexes as not multi as viewed from evals. */ |
| 845 | |
| 846 | *out_flags = CvANON(cv) ? |
| 847 | PAD_FAKELEX_ANON : |
| 848 | (!CvUNIQUE(cv) && ! CvCOMPILED(cv)) |
| 849 | ? PAD_FAKELEX_MULTI : 0; |
| 850 | |
| 851 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
| 852 | "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n", |
| 853 | PTR2UV(cv), (long)offset, |
| 854 | (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv), |
| 855 | (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv))); |
| 856 | } |
| 857 | else { /* fake match */ |
| 858 | offset = fake_offset; |
| 859 | *out_name_sv = name_svp[offset]; /* return the namesv */ |
| 860 | *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv); |
| 861 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
| 862 | "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n", |
| 863 | PTR2UV(cv), (long)offset, (unsigned long)*out_flags, |
| 864 | (unsigned long) PARENT_PAD_INDEX(*out_name_sv) |
| 865 | )); |
| 866 | } |
| 867 | |
| 868 | /* return the lex? */ |
| 869 | |
| 870 | if (out_capture) { |
| 871 | |
| 872 | /* our ? */ |
| 873 | if (SvPAD_OUR(*out_name_sv)) { |
| 874 | *out_capture = NULL; |
| 875 | return offset; |
| 876 | } |
| 877 | |
| 878 | /* trying to capture from an anon prototype? */ |
| 879 | if (CvCOMPILED(cv) |
| 880 | ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv) |
| 881 | : *out_flags & PAD_FAKELEX_ANON) |
| 882 | { |
| 883 | if (warn) |
| 884 | Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), |
| 885 | "Variable \"%s\" is not available", name); |
| 886 | *out_capture = NULL; |
| 887 | } |
| 888 | |
| 889 | /* real value */ |
| 890 | else { |
| 891 | int newwarn = warn; |
| 892 | if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI) |
| 893 | && !SvPAD_STATE(name_svp[offset]) |
| 894 | && warn && ckWARN(WARN_CLOSURE)) { |
| 895 | newwarn = 0; |
| 896 | Perl_warner(aTHX_ packWARN(WARN_CLOSURE), |
| 897 | "Variable \"%s\" will not stay shared", name); |
| 898 | } |
| 899 | |
| 900 | if (fake_offset && CvANON(cv) |
| 901 | && CvCLONE(cv) &&!CvCLONED(cv)) |
| 902 | { |
| 903 | SV *n; |
| 904 | /* not yet caught - look further up */ |
| 905 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
| 906 | "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n", |
| 907 | PTR2UV(cv))); |
| 908 | n = *out_name_sv; |
| 909 | (void)S_pad_findlex(aTHX_ name, CvOUTSIDE(cv), |
| 910 | CvOUTSIDE_SEQ(cv), |
| 911 | newwarn, out_capture, out_name_sv, out_flags); |
| 912 | *out_name_sv = n; |
| 913 | return offset; |
| 914 | } |
| 915 | |
| 916 | *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[ |
| 917 | CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset]; |
| 918 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
| 919 | "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n", |
| 920 | PTR2UV(cv), PTR2UV(*out_capture))); |
| 921 | |
| 922 | if (SvPADSTALE(*out_capture) |
| 923 | && !SvPAD_STATE(name_svp[offset])) |
| 924 | { |
| 925 | Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), |
| 926 | "Variable \"%s\" is not available", name); |
| 927 | *out_capture = NULL; |
| 928 | } |
| 929 | } |
| 930 | if (!*out_capture) { |
| 931 | if (*name == '@') |
| 932 | *out_capture = sv_2mortal(MUTABLE_SV(newAV())); |
| 933 | else if (*name == '%') |
| 934 | *out_capture = sv_2mortal(MUTABLE_SV(newHV())); |
| 935 | else |
| 936 | *out_capture = sv_newmortal(); |
| 937 | } |
| 938 | } |
| 939 | |
| 940 | return offset; |
| 941 | } |
| 942 | } |
| 943 | |
| 944 | /* it's not in this pad - try above */ |
| 945 | |
| 946 | if (!CvOUTSIDE(cv)) |
| 947 | return NOT_IN_PAD; |
| 948 | |
| 949 | /* out_capture non-null means caller wants us to capture lex; in |
| 950 | * addition we capture ourselves unless it's an ANON/format */ |
| 951 | new_capturep = out_capture ? out_capture : |
| 952 | CvLATE(cv) ? NULL : &new_capture; |
| 953 | |
| 954 | offset = S_pad_findlex(aTHX_ name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1, |
| 955 | new_capturep, out_name_sv, out_flags); |
| 956 | if ((PADOFFSET)offset == NOT_IN_PAD) |
| 957 | return NOT_IN_PAD; |
| 958 | |
| 959 | /* found in an outer CV. Add appropriate fake entry to this pad */ |
| 960 | |
| 961 | /* don't add new fake entries (via eval) to CVs that we have already |
| 962 | * finished compiling, or to undef CVs */ |
| 963 | if (CvCOMPILED(cv) || !padlist) |
| 964 | return 0; /* this dummy (and invalid) value isnt used by the caller */ |
| 965 | |
| 966 | { |
| 967 | /* This relies on sv_setsv_flags() upgrading the destination to the same |
| 968 | type as the source, independent of the flags set, and on it being |
| 969 | "good" and only copying flag bits and pointers that it understands. |
| 970 | */ |
| 971 | SV *new_namesv = newSVsv(*out_name_sv); |
| 972 | AV * const ocomppad_name = PL_comppad_name; |
| 973 | PAD * const ocomppad = PL_comppad; |
| 974 | PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]); |
| 975 | PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]); |
| 976 | PL_curpad = AvARRAY(PL_comppad); |
| 977 | |
| 978 | new_offset |
| 979 | = pad_add_name_sv(new_namesv, |
| 980 | 0, |
| 981 | SvPAD_TYPED(*out_name_sv) |
| 982 | ? SvSTASH(*out_name_sv) : NULL, |
| 983 | SvOURSTASH(*out_name_sv) |
| 984 | ); |
| 985 | |
| 986 | SvFAKE_on(new_namesv); |
| 987 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
| 988 | "Pad addname: %ld \"%.*s\" FAKE\n", |
| 989 | (long)new_offset, |
| 990 | (int) SvCUR(new_namesv), SvPVX(new_namesv))); |
| 991 | PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags); |
| 992 | |
| 993 | PARENT_PAD_INDEX_set(new_namesv, 0); |
| 994 | if (SvPAD_OUR(new_namesv)) { |
| 995 | NOOP; /* do nothing */ |
| 996 | } |
| 997 | else if (CvLATE(cv)) { |
| 998 | /* delayed creation - just note the offset within parent pad */ |
| 999 | PARENT_PAD_INDEX_set(new_namesv, offset); |
| 1000 | CvCLONE_on(cv); |
| 1001 | } |
| 1002 | else { |
| 1003 | /* immediate creation - capture outer value right now */ |
| 1004 | av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep)); |
| 1005 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
| 1006 | "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n", |
| 1007 | PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset)); |
| 1008 | } |
| 1009 | *out_name_sv = new_namesv; |
| 1010 | *out_flags = PARENT_FAKELEX_FLAGS(new_namesv); |
| 1011 | |
| 1012 | PL_comppad_name = ocomppad_name; |
| 1013 | PL_comppad = ocomppad; |
| 1014 | PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL; |
| 1015 | } |
| 1016 | return new_offset; |
| 1017 | #undef CvLATE |
| 1018 | #undef CvCOMPILED |
| 1019 | } |
| 1020 | |
| 1021 | static PADOFFSET S_pad_findmy(pTHX_ const char *name, U32 flags) { |
| 1022 | dVAR; |
| 1023 | SV *out_sv; |
| 1024 | int out_flags; |
| 1025 | I32 offset; |
| 1026 | const AV *nameav; |
| 1027 | SV **name_svp; |
| 1028 | |
| 1029 | offset = S_pad_findlex(aTHX_ name, PL_compcv, PL_cop_seqmax, 1, |
| 1030 | NULL, &out_sv, &out_flags); |
| 1031 | if ((PADOFFSET)offset != NOT_IN_PAD) |
| 1032 | return offset; |
| 1033 | |
| 1034 | /* look for an our that's being introduced; this allows |
| 1035 | * our $foo = 0 unless defined $foo; |
| 1036 | * to not give a warning. (Yes, this is a hack) */ |
| 1037 | |
| 1038 | nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]); |
| 1039 | name_svp = AvARRAY(nameav); |
| 1040 | for (offset = AvFILLp(nameav); offset > 0; offset--) { |
| 1041 | const SV * const namesv = name_svp[offset]; |
| 1042 | if (namesv && namesv != &PL_sv_undef |
| 1043 | && !SvFAKE(namesv) |
| 1044 | && (SvPAD_OUR(namesv)) |
| 1045 | && strEQ(SvPVX_const(namesv), name) |
| 1046 | && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO |
| 1047 | ) |
| 1048 | return offset; |
| 1049 | } |
| 1050 | return NOT_IN_PAD; |
| 1051 | } |
| 1052 | |
| 1053 | #endif |
| e158cf8f |
1054 | |
| 51a483f8 |
1055 | #ifndef pad_findmy_pvs |
| 1056 | #define pad_findmy_pvs(S, FLAGS) S_pad_findmy(aTHX_ "" S "", FLAGS) |
| 1057 | #endif |
| 1058 | |
| 1059 | static OP *S_newDEFSVOP(pTHX) { |
| 1060 | dVAR; |
| 1061 | const PADOFFSET offset = pad_findmy_pvs("$_", 0); |
| 1062 | if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { |
| 1063 | return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); |
| 1064 | } |
| 1065 | else { |
| 1066 | OP * const o = newOP(OP_PADSV, 0); |
| 1067 | o->op_targ = offset; |
| 1068 | return o; |
| 1069 | } |
| 1070 | } |
| 1071 | |
| e158cf8f |
1072 | static U32 S_intro_my(pTHX) { |
| 1073 | dVAR; |
| 1074 | SV **svp; |
| 1075 | I32 i; |
| 1076 | U32 seq; |
| 1077 | |
| 1078 | ASSERT_CURPAD_ACTIVE("intro_my"); |
| 1079 | if (!PL_min_intro_pending) |
| 1080 | return PL_cop_seqmax; |
| 1081 | |
| 1082 | svp = AvARRAY(PL_comppad_name); |
| 1083 | for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) { |
| 1084 | SV *const sv = svp[i]; |
| 1085 | |
| 1086 | if (sv && sv != &PL_sv_undef && !SvFAKE(sv) |
| 1087 | && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO) |
| 1088 | { |
| 1089 | COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */ |
| 1090 | COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax); |
| 1091 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
| 1092 | "Pad intromy: %ld \"%s\", (%lu,%lu)\n", |
| 1093 | (long)i, SvPVX_const(sv), |
| 1094 | (unsigned long)COP_SEQ_RANGE_LOW(sv), |
| 1095 | (unsigned long)COP_SEQ_RANGE_HIGH(sv)) |
| 1096 | ); |
| 1097 | } |
| 1098 | } |
| 1099 | seq = PL_cop_seqmax; |
| 1100 | PL_cop_seqmax++; |
| 1101 | if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ |
| 1102 | PL_cop_seqmax++; |
| 1103 | PL_min_intro_pending = 0; |
| 1104 | PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */ |
| 1105 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
| 1106 | "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax))); |
| 1107 | |
| 1108 | return seq; |
| 1109 | } |
projects / p5sagit/Function-Parameters.git / blame