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 | |
687 | #ifndef pad_add_name_sv |
688 | |
689 | #define pad_add_name_sv(NAMESV, FLAGS, TYPESTASH, OURSTASH) \ |
690 | S_pad_add_name_sv(aTHX_ NAMESV, FLAGS, TYPESTASH, OURSTASH) |
691 | |
7d5c8305 |
692 | static PADOFFSET S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash) { |
c3e72f35 |
693 | dVAR; |
694 | const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); |
695 | |
7d5c8305 |
696 | assert(flags == 0); |
697 | |
698 | ASSERT_CURPAD_ACTIVE("pad_alloc_name"); |
c3e72f35 |
699 | |
700 | if (typestash) { |
701 | assert(SvTYPE(namesv) == SVt_PVMG); |
702 | SvPAD_TYPED_on(namesv); |
703 | SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)))); |
704 | } |
705 | if (ourstash) { |
706 | SvPAD_OUR_on(namesv); |
707 | SvOURSTASH_set(namesv, ourstash); |
708 | SvREFCNT_inc_simple_void_NN(ourstash); |
709 | } |
c3e72f35 |
710 | |
711 | av_store(PL_comppad_name, offset, namesv); |
712 | return offset; |
713 | } |
714 | |
7d5c8305 |
715 | PADOFFSET static S_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags, HV *typestash, HV *ourstash) { |
716 | dVAR; |
717 | PADOFFSET offset; |
718 | SV *namesv; |
719 | |
720 | assert(flags == 0); |
721 | |
722 | namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); |
723 | |
724 | sv_setpvn(namesv, namepv, namelen); |
725 | |
726 | offset = S_pad_alloc_name(aTHX_ namesv, flags, typestash, ourstash); |
727 | |
728 | /* not yet introduced */ |
729 | COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO); |
730 | COP_SEQ_RANGE_HIGH_set(namesv, 0); |
731 | |
732 | if (!PL_min_intro_pending) |
733 | PL_min_intro_pending = offset; |
734 | PL_max_intro_pending = offset; |
735 | /* if it's not a simple scalar, replace with an AV or HV */ |
736 | assert(SvTYPE(PL_curpad[offset]) == SVt_NULL); |
737 | assert(SvREFCNT(PL_curpad[offset]) == 1); |
738 | if (namelen != 0 && *namepv == '@') |
739 | sv_upgrade(PL_curpad[offset], SVt_PVAV); |
740 | else if (namelen != 0 && *namepv == '%') |
741 | sv_upgrade(PL_curpad[offset], SVt_PVHV); |
742 | assert(SvPADMY(PL_curpad[offset])); |
743 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, |
744 | "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n", |
745 | (long)offset, SvPVX(namesv), |
746 | PTR2UV(PL_curpad[offset]))); |
747 | |
748 | return offset; |
749 | } |
750 | |
751 | static PADOFFSET S_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash) { |
752 | char *namepv; |
753 | STRLEN namelen; |
754 | assert(flags == 0); |
755 | namepv = SvPV(name, namelen); |
756 | return S_pad_add_name_pvn(aTHX_ namepv, namelen, flags, typestash, ourstash); |
757 | } |
758 | |
c3e72f35 |
759 | #endif |