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 | |
7d5c8305 |
719 | PADOFFSET static S_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags, HV *typestash, HV *ourstash) { |
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 | } |