1 /* pp_hot.c
2 *
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11 /*
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
13 * shaking the air.
14 *
15 * Awake! Awake! Fear, Fire, Foes! Awake!
16 * Fire, Foes! Awake!
17 *
18 * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
19 */
20
21 /* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
26 *
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
31 * performance.
32 */
33
34 #include "EXTERN.h"
35 #define PERL_IN_PP_HOT_C
36 #include "perl.h"
37 #include "regcomp.h"
38
39 /* Hot code. */
40
PP(pp_const)41 PP(pp_const)
42 {
43 dSP;
44 XPUSHs(cSVOP_sv);
45 RETURN;
46 }
47
PP(pp_nextstate)48 PP(pp_nextstate)
49 {
50 PL_curcop = (COP*)PL_op;
51 TAINT_NOT; /* Each statement is presumed innocent */
52 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
53 FREETMPS;
54 PERL_ASYNC_CHECK();
55 return NORMAL;
56 }
57
PP(pp_gvsv)58 PP(pp_gvsv)
59 {
60 dSP;
61 assert(SvTYPE(cGVOP_gv) == SVt_PVGV);
62 EXTEND(SP,1);
63 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
64 PUSHs(save_scalar(cGVOP_gv));
65 else
66 PUSHs(GvSVn(cGVOP_gv));
67 RETURN;
68 }
69
70
71 /* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
72
PP(pp_null)73 PP(pp_null)
74 {
75 return NORMAL;
76 }
77
78 /* This is sometimes called directly by pp_coreargs, pp_grepstart and
79 amagic_call. */
PP(pp_pushmark)80 PP(pp_pushmark)
81 {
82 PUSHMARK(PL_stack_sp);
83 return NORMAL;
84 }
85
PP(pp_stringify)86 PP(pp_stringify)
87 {
88 dSP; dTARGET;
89 SV * const sv = TOPs;
90 SETs(TARG);
91 sv_copypv(TARG, sv);
92 SvSETMAGIC(TARG);
93 /* no PUTBACK, SETs doesn't inc/dec SP */
94 return NORMAL;
95 }
96
PP(pp_gv)97 PP(pp_gv)
98 {
99 dSP;
100 /* cGVOP_gv might be a real GV or might be an RV to a CV */
101 assert(SvTYPE(cGVOP_gv) == SVt_PVGV ||
102 (SvTYPE(cGVOP_gv) <= SVt_PVMG && SvROK(cGVOP_gv) && SvTYPE(SvRV(cGVOP_gv)) == SVt_PVCV));
103 XPUSHs(MUTABLE_SV(cGVOP_gv));
104 RETURN;
105 }
106
107
108 /* also used for: pp_andassign() */
109
PP(pp_and)110 PP(pp_and)
111 {
112 PERL_ASYNC_CHECK();
113 {
114 /* SP is not used to remove a variable that is saved across the
115 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
116 register or load/store vs direct mem ops macro is introduced, this
117 should be a define block between direct PL_stack_sp and dSP operations,
118 presently, using PL_stack_sp is bias towards CISC cpus */
119 SV * const sv = *PL_stack_sp;
120 if (!SvTRUE_NN(sv))
121 return NORMAL;
122 else {
123 if (PL_op->op_type == OP_AND)
124 --PL_stack_sp;
125 return cLOGOP->op_other;
126 }
127 }
128 }
129
130 /*
131 * Mashup of simple padsv + sassign OPs
132 * Doesn't support the following lengthy and unlikely sassign case:
133 * (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV))
134 * These cases have a separate optimization, so are not handled here:
135 * (PL_op->op_private & OPpASSIGN_BACKWARDS) {or,and,dor}assign
136 */
137
PP(pp_padsv_store)138 PP(pp_padsv_store)
139 {
140 dSP;
141 OP * const op = PL_op;
142 SV** const padentry = &PAD_SVl(op->op_targ);
143 SV* targ = *padentry; /* lvalue to assign into */
144 SV* const val = TOPs; /* RHS value to assign */
145
146 /* !OPf_STACKED is not handled by this OP */
147 assert(op->op_flags & OPf_STACKED);
148
149 /* Inlined, simplified pp_padsv here */
150 if ((op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO) {
151 save_clearsv(padentry);
152 }
153
154 /* Inlined, simplified pp_sassign from here */
155 assert(TAINTING_get || !TAINT_get);
156 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
157 TAINT_NOT;
158
159 if (
160 UNLIKELY(SvTEMP(targ)) && !SvSMAGICAL(targ) && SvREFCNT(targ) == 1 &&
161 (!isGV_with_GP(targ) || SvFAKE(targ)) && ckWARN(WARN_MISC)
162 )
163 Perl_warner(aTHX_
164 packWARN(WARN_MISC), "Useless assignment to a temporary"
165 );
166 SvSetMagicSV(targ, val);
167
168 SETs(targ);
169 RETURN;
170 }
171
172 /* A mashup of simplified AELEMFAST_LEX + SASSIGN OPs */
173
PP(pp_aelemfastlex_store)174 PP(pp_aelemfastlex_store)
175 {
176 dSP;
177 OP * const op = PL_op;
178 SV* const val = TOPs; /* RHS value to assign */
179 AV * const av = MUTABLE_AV(PAD_SV(op->op_targ));
180 const I8 key = (I8)PL_op->op_private;
181 SV * targ = NULL;
182
183 /* !OPf_STACKED is not handled by this OP */
184 assert(op->op_flags & OPf_STACKED);
185
186 /* Inlined, simplified pp_aelemfast here */
187 assert(SvTYPE(av) == SVt_PVAV);
188
189 /* inlined av_fetch() for simple cases ... */
190 if (!SvRMAGICAL(av) && key >=0 && key <= AvFILLp(av)) {
191 targ = AvARRAY(av)[key];
192 }
193 /* ... else do it the hard way */
194 if (!targ) {
195 SV **svp = av_fetch(av, key, 1);
196
197 if (svp)
198 targ = *svp;
199 else
200 DIE(aTHX_ PL_no_aelem, (int)key);
201 }
202
203 /* Inlined, simplified pp_sassign from here */
204 assert(TAINTING_get || !TAINT_get);
205 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
206 TAINT_NOT;
207
208 /* This assertion is a deviation from pp_sassign, which uses an if()
209 * condition to check for "Useless assignment to a temporary" and
210 * warns if the condition is true. Here, the condition should NEVER
211 * be true when the LHS is the result of an array fetch. The
212 * assertion is here as a final check that this remains the case.
213 */
214 assert(!(SvTEMP(targ) && SvREFCNT(targ) == 1 && !SvSMAGICAL(targ)));
215
216 SvSetMagicSV(targ, val);
217
218 SETs(targ);
219 RETURN;
220 }
221
PP(pp_sassign)222 PP(pp_sassign)
223 {
224 dSP;
225 /* sassign keeps its args in the optree traditionally backwards.
226 So we pop them differently.
227 */
228 SV *left = POPs; SV *right = TOPs;
229
230 if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
231 SV * const temp = left;
232 left = right; right = temp;
233 }
234 assert(TAINTING_get || !TAINT_get);
235 if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
236 TAINT_NOT;
237 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
238 /* *foo =\&bar */
239 SV * const cv = SvRV(right);
240 const U32 cv_type = SvTYPE(cv);
241 const bool is_gv = isGV_with_GP(left);
242 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
243
244 if (!got_coderef) {
245 assert(SvROK(cv));
246 }
247
248 /* Can do the optimisation if left (LVALUE) is not a typeglob,
249 right (RVALUE) is a reference to something, and we're in void
250 context. */
251 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
252 /* Is the target symbol table currently empty? */
253 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
254 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
255 /* Good. Create a new proxy constant subroutine in the target.
256 The gv becomes a(nother) reference to the constant. */
257 SV *const value = SvRV(cv);
258
259 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
260 SvPCS_IMPORTED_on(gv);
261 SvRV_set(gv, value);
262 SvREFCNT_inc_simple_void(value);
263 SETs(left);
264 RETURN;
265 }
266 }
267
268 /* Need to fix things up. */
269 if (!is_gv) {
270 /* Need to fix GV. */
271 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
272 }
273
274 if (!got_coderef) {
275 /* We've been returned a constant rather than a full subroutine,
276 but they expect a subroutine reference to apply. */
277 if (SvROK(cv)) {
278 ENTER_with_name("sassign_coderef");
279 SvREFCNT_inc_void(SvRV(cv));
280 /* newCONSTSUB takes a reference count on the passed in SV
281 from us. We set the name to NULL, otherwise we get into
282 all sorts of fun as the reference to our new sub is
283 donated to the GV that we're about to assign to.
284 */
285 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
286 SvRV(cv))));
287 SvREFCNT_dec_NN(cv);
288 LEAVE_with_name("sassign_coderef");
289 } else {
290 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
291 is that
292 First: ops for \&{"BONK"}; return us the constant in the
293 symbol table
294 Second: ops for *{"BONK"} cause that symbol table entry
295 (and our reference to it) to be upgraded from RV
296 to typeblob)
297 Thirdly: We get here. cv is actually PVGV now, and its
298 GvCV() is actually the subroutine we're looking for
299
300 So change the reference so that it points to the subroutine
301 of that typeglob, as that's what they were after all along.
302 */
303 GV *const upgraded = MUTABLE_GV(cv);
304 CV *const source = GvCV(upgraded);
305
306 assert(source);
307 assert(CvFLAGS(source) & CVf_CONST);
308
309 SvREFCNT_inc_simple_void_NN(source);
310 SvREFCNT_dec_NN(upgraded);
311 SvRV_set(right, MUTABLE_SV(source));
312 }
313 }
314
315 }
316 if (
317 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
318 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
319 )
320 Perl_warner(aTHX_
321 packWARN(WARN_MISC), "Useless assignment to a temporary"
322 );
323 SvSetMagicSV(left, right);
324 SETs(left);
325 RETURN;
326 }
327
PP(pp_cond_expr)328 PP(pp_cond_expr)
329 {
330 dSP;
331 SV *sv;
332
333 PERL_ASYNC_CHECK();
334 sv = POPs;
335 RETURNOP(SvTRUE_NN(sv) ? cLOGOP->op_other : cLOGOP->op_next);
336 }
337
PP(pp_unstack)338 PP(pp_unstack)
339 {
340 PERL_CONTEXT *cx;
341 PERL_ASYNC_CHECK();
342 TAINT_NOT; /* Each statement is presumed innocent */
343 cx = CX_CUR();
344 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
345 FREETMPS;
346 if (!(PL_op->op_flags & OPf_SPECIAL)) {
347 assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
348 CX_LEAVE_SCOPE(cx);
349 }
350 return NORMAL;
351 }
352
353
354 /* The main body of pp_concat, not including the magic/overload and
355 * stack handling.
356 * It does targ = left . right.
357 * Moved into a separate function so that pp_multiconcat() can use it
358 * too.
359 */
360
361 PERL_STATIC_INLINE void
S_do_concat(pTHX_ SV * left,SV * right,SV * targ,U8 targmy)362 S_do_concat(pTHX_ SV *left, SV *right, SV *targ, U8 targmy)
363 {
364 bool lbyte;
365 STRLEN rlen;
366 const char *rpv = NULL;
367 bool rbyte = FALSE;
368 bool rcopied = FALSE;
369
370 if (TARG == right && right != left) { /* $r = $l.$r */
371 rpv = SvPV_nomg_const(right, rlen);
372 rbyte = !DO_UTF8(right);
373 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
374 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
375 rcopied = TRUE;
376 }
377
378 if (TARG != left) { /* not $l .= $r */
379 STRLEN llen;
380 const char* const lpv = SvPV_nomg_const(left, llen);
381 lbyte = !DO_UTF8(left);
382 sv_setpvn(TARG, lpv, llen);
383 if (!lbyte)
384 SvUTF8_on(TARG);
385 else
386 SvUTF8_off(TARG);
387 }
388 else { /* $l .= $r and left == TARG */
389 if (!SvOK(left)) {
390 if ((left == right /* $l .= $l */
391 || targmy) /* $l = $l . $r */
392 && ckWARN(WARN_UNINITIALIZED)
393 )
394 report_uninit(left);
395 SvPVCLEAR(left);
396 }
397 else {
398 SvPV_force_nomg_nolen(left);
399 }
400 lbyte = !DO_UTF8(left);
401 if (IN_BYTES)
402 SvUTF8_off(left);
403 }
404
405 if (!rcopied) {
406 rpv = SvPV_nomg_const(right, rlen);
407 rbyte = !DO_UTF8(right);
408 }
409 if (lbyte != rbyte) {
410 if (lbyte)
411 sv_utf8_upgrade_nomg(TARG);
412 else {
413 if (!rcopied)
414 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
415 sv_utf8_upgrade_nomg(right);
416 rpv = SvPV_nomg_const(right, rlen);
417 }
418 }
419 sv_catpvn_nomg(TARG, rpv, rlen);
420 SvSETMAGIC(TARG);
421 }
422
423
PP(pp_concat)424 PP(pp_concat)
425 {
426 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
427 {
428 dPOPTOPssrl;
429 S_do_concat(aTHX_ left, right, targ, PL_op->op_private & OPpTARGET_MY);
430 SETs(TARG);
431 RETURN;
432 }
433 }
434
435
436 /* pp_multiconcat()
437
438 Concatenate one or more args, possibly interleaved with constant string
439 segments. The result may be assigned to, or appended to, a variable or
440 expression.
441
442 Several op_flags and/or op_private bits indicate what the target is, and
443 whether it's appended to. Valid permutations are:
444
445 - (PADTMP) = (A.B.C....)
446 OPpTARGET_MY $lex = (A.B.C....)
447 OPpTARGET_MY,OPpLVAL_INTRO my $lex = (A.B.C....)
448 OPpTARGET_MY,OPpMULTICONCAT_APPEND $lex .= (A.B.C....)
449 OPf_STACKED expr = (A.B.C....)
450 OPf_STACKED,OPpMULTICONCAT_APPEND expr .= (A.B.C....)
451
452 Other combinations like (A.B).(C.D) are not optimised into a multiconcat
453 op, as it's too hard to get the correct ordering of ties, overload etc.
454
455 In addition:
456
457 OPpMULTICONCAT_FAKE: not a real concat, instead an optimised
458 sprintf "...%s...". Don't call '.'
459 overloading: only use '""' overloading.
460
461 OPpMULTICONCAT_STRINGIFY: the RHS was of the form
462 "...$a...$b..." rather than
463 "..." . $a . "..." . $b . "..."
464
465 An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are
466 defined with PERL_MULTICONCAT_IX_FOO constants, where:
467
468
469 FOO index description
470 -------- ----- ----------------------------------
471 NARGS 0 number of arguments
472 PLAIN_PV 1 non-utf8 constant string
473 PLAIN_LEN 2 non-utf8 constant string length
474 UTF8_PV 3 utf8 constant string
475 UTF8_LEN 4 utf8 constant string length
476 LENGTHS 5 first of nargs+1 const segment lengths
477
478 The idea is that a general string concatenation will have a fixed (known
479 at compile time) number of variable args, interspersed with constant
480 strings, e.g. "a=$a b=$b\n"
481
482 All the constant string segments "a=", " b=" and "\n" are stored as a
483 single string "a= b=\n", pointed to from the PLAIN_PV/UTF8_PV slot, along
484 with a series of segment lengths: e.g. 2,3,1. In the case where the
485 constant string is plain but has a different utf8 representation, both
486 variants are stored, and two sets of (nargs+1) segments lengths are stored
487 in the slots beginning at PERL_MULTICONCAT_IX_LENGTHS.
488
489 A segment length of -1 indicates that there is no constant string at that
490 point; this distinguishes between e.g. ($a . $b) and ($a . "" . $b), which
491 have differing overloading behaviour.
492
493 */
494
PP(pp_multiconcat)495 PP(pp_multiconcat)
496 {
497 dSP;
498 SV *targ; /* The SV to be assigned or appended to */
499 char *targ_pv; /* where within SvPVX(targ) we're writing to */
500 STRLEN targ_len; /* SvCUR(targ) */
501 SV **toparg; /* the highest arg position on the stack */
502 UNOP_AUX_item *aux; /* PL_op->op_aux buffer */
503 UNOP_AUX_item *const_lens; /* the segment length array part of aux */
504 const char *const_pv; /* the current segment of the const string buf */
505 SSize_t nargs; /* how many args were expected */
506 SSize_t stack_adj; /* how much to adjust SP on return */
507 STRLEN grow; /* final size of destination string (targ) */
508 UV targ_count; /* how many times targ has appeared on the RHS */
509 bool is_append; /* OPpMULTICONCAT_APPEND flag is set */
510 bool slow_concat; /* args too complex for quick concat */
511 U32 dst_utf8; /* the result will be utf8 (indicate this with
512 SVf_UTF8 in a U32, rather than using bool,
513 for ease of testing and setting) */
514 /* for each arg, holds the result of an SvPV() call */
515 struct multiconcat_svpv {
516 const char *pv;
517 SSize_t len;
518 }
519 *targ_chain, /* chain of slots where targ has appeared on RHS */
520 *svpv_p, /* ptr for looping through svpv_buf */
521 *svpv_base, /* first slot (may be greater than svpv_buf), */
522 *svpv_end, /* and slot after highest result so far, of: */
523 svpv_buf[PERL_MULTICONCAT_MAXARG]; /* buf for storing SvPV() results */
524
525 aux = cUNOP_AUXx(PL_op)->op_aux;
526 stack_adj = nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
527 is_append = cBOOL(PL_op->op_private & OPpMULTICONCAT_APPEND);
528
529 /* get targ from the stack or pad */
530
531 if (PL_op->op_flags & OPf_STACKED) {
532 if (is_append) {
533 /* for 'expr .= ...', expr is the bottom item on the stack */
534 targ = SP[-nargs];
535 stack_adj++;
536 }
537 else
538 /* for 'expr = ...', expr is the top item on the stack */
539 targ = POPs;
540 }
541 else {
542 SV **svp = &(PAD_SVl(PL_op->op_targ));
543 targ = *svp;
544 if (PL_op->op_private & OPpLVAL_INTRO) {
545 assert(PL_op->op_private & OPpTARGET_MY);
546 save_clearsv(svp);
547 }
548 if (!nargs)
549 /* $lex .= "const" doesn't cause anything to be pushed */
550 EXTEND(SP,1);
551 }
552
553 toparg = SP;
554 SP -= (nargs - 1);
555 grow = 1; /* allow for '\0' at minimum */
556 targ_count = 0;
557 targ_chain = NULL;
558 targ_len = 0;
559 svpv_end = svpv_buf;
560 /* only utf8 variants of the const strings? */
561 dst_utf8 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv ? 0 : SVf_UTF8;
562
563
564 /* --------------------------------------------------------------
565 * Phase 1:
566 *
567 * stringify (i.e. SvPV()) every arg and store the resultant pv/len/utf8
568 * triplets in svpv_buf[]. Also increment 'grow' by the args' lengths.
569 *
570 * utf8 is indicated by storing a negative length.
571 *
572 * Where an arg is actually targ, the stringification is deferred:
573 * the length is set to 0, and the slot is added to targ_chain.
574 *
575 * If a magic, overloaded, or otherwise weird arg is found, which
576 * might have side effects when stringified, the loop is abandoned and
577 * we goto a code block where a more basic 'emulate calling
578 * pp_cpncat() on each arg in turn' is done.
579 */
580
581 for (; SP <= toparg; SP++, svpv_end++) {
582 U32 utf8;
583 STRLEN len;
584 SV *sv;
585
586 assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
587
588 sv = *SP;
589
590 /* this if/else chain is arranged so that common/simple cases
591 * take few conditionals */
592
593 if (LIKELY((SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK)) {
594 /* common case: sv is a simple non-magical PV */
595 if (targ == sv) {
596 /* targ appears on RHS.
597 * Delay storing PV pointer; instead, add slot to targ_chain
598 * so it can be populated later, after targ has been grown and
599 * we know its final SvPVX() address.
600 */
601 targ_on_rhs:
602 svpv_end->len = 0; /* zerojng here means we can skip
603 updating later if targ_len == 0 */
604 svpv_end->pv = (char*)targ_chain;
605 targ_chain = svpv_end;
606 targ_count++;
607 continue;
608 }
609
610 len = SvCUR(sv);
611 svpv_end->pv = SvPVX(sv);
612 }
613 else if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK)))
614 /* may have side effects: tie, overload etc.
615 * Abandon 'stringify everything first' and handle
616 * args in strict order. Note that already-stringified args
617 * will be reprocessed, which is safe because the each first
618 * stringification would have been idempotent.
619 */
620 goto do_magical;
621 else if (SvNIOK(sv)) {
622 if (targ == sv)
623 goto targ_on_rhs;
624 /* stringify general valid scalar */
625 svpv_end->pv = sv_2pv_flags(sv, &len, 0);
626 }
627 else if (!SvOK(sv)) {
628 if (ckWARN(WARN_UNINITIALIZED))
629 /* an undef value in the presence of warnings may trigger
630 * side affects */
631 goto do_magical;
632 svpv_end->pv = "";
633 len = 0;
634 }
635 else
636 goto do_magical; /* something weird */
637
638 utf8 = (SvFLAGS(sv) & SVf_UTF8);
639 dst_utf8 |= utf8;
640 ASSUME(len < SSize_t_MAX);
641 svpv_end->len = utf8 ? -(SSize_t)len : (SSize_t)len;
642 grow += len;
643 }
644
645 /* --------------------------------------------------------------
646 * Phase 2:
647 *
648 * Stringify targ:
649 *
650 * if targ appears on the RHS or is appended to, force stringify it;
651 * otherwise set it to "". Then set targ_len.
652 */
653
654 if (is_append) {
655 /* abandon quick route if using targ might have side effects */
656 if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK)))
657 goto do_magical;
658
659 if (SvOK(targ)) {
660 U32 targ_utf8;
661 stringify_targ:
662 SvPV_force_nomg_nolen(targ);
663 targ_utf8 = SvFLAGS(targ) & SVf_UTF8;
664 if (UNLIKELY(dst_utf8 & ~targ_utf8)) {
665 if (LIKELY(!IN_BYTES))
666 sv_utf8_upgrade_nomg(targ);
667 }
668 else
669 dst_utf8 |= targ_utf8;
670
671 targ_len = SvCUR(targ);
672 grow += targ_len * (targ_count + is_append);
673 goto phase3;
674 }
675 else if (ckWARN(WARN_UNINITIALIZED))
676 /* warning might have side effects */
677 goto do_magical;
678 /* the undef targ will be silently SvPVCLEAR()ed below */
679 }
680 else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) {
681 /* Assigning to some weird LHS type. Don't force the LHS to be an
682 * empty string; instead, do things 'long hand' by using the
683 * overload code path, which concats to a TEMP sv and does
684 * sv_catsv() calls rather than COPY()s. This ensures that even
685 * bizarre code like this doesn't break or crash:
686 * *F = *F . *F.
687 * (which makes the 'F' typeglob an alias to the
688 * '*main::F*main::F' typeglob).
689 */
690 goto do_magical;
691 }
692 else if (targ_chain)
693 /* targ was found on RHS.
694 * Force stringify it, using the same code as the append branch
695 * above, except that we don't need the magic/overload/undef
696 * checks as these will already have been done in the phase 1
697 * loop.
698 */
699 goto stringify_targ;
700
701 /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0;
702 * those will be done later. */
703 SV_CHECK_THINKFIRST_COW_DROP(targ);
704 SvUPGRADE(targ, SVt_PV);
705 SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8);
706 SvFLAGS(targ) |= (SVf_POK|SVp_POK|dst_utf8);
707
708 phase3:
709
710 /* --------------------------------------------------------------
711 * Phase 3:
712 *
713 * UTF-8 tweaks and grow targ:
714 *
715 * Now that we know the length and utf8-ness of both the targ and
716 * args, grow targ to the size needed to accumulate all the args, based
717 * on whether targ appears on the RHS, whether we're appending, and
718 * whether any non-utf8 args expand in size if converted to utf8.
719 *
720 * For the latter, if dst_utf8 we scan non-utf8 args looking for
721 * variant chars, and adjust the svpv->len value of those args to the
722 * utf8 size and negate it to flag them. At the same time we un-negate
723 * the lens of any utf8 args since after this phase we no longer care
724 * whether an arg is utf8 or not.
725 *
726 * Finally, initialise const_lens and const_pv based on utf8ness.
727 * Note that there are 3 permutations:
728 *
729 * * If the constant string is invariant whether utf8 or not (e.g. "abc"),
730 * then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] are the same as
731 * aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] and there is one set of
732 * segment lengths.
733 *
734 * * If the string is fully utf8, e.g. "\x{100}", then
735 * aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] == (NULL,0) and there is
736 * one set of segment lengths.
737 *
738 * * If the string has different plain and utf8 representations
739 * (e.g. "\x80"), then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
740 * holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
741 * holds the utf8 rep, and there are 2 sets of segment lengths,
742 * with the utf8 set following after the plain set.
743 *
744 * On entry to this section the (pv,len) pairs in svpv_buf have the
745 * following meanings:
746 * (pv, len) a plain string
747 * (pv, -len) a utf8 string
748 * (NULL, 0) left-most targ \ linked together R-to-L
749 * (next, 0) other targ / in targ_chain
750 */
751
752 /* turn off utf8 handling if 'use bytes' is in scope */
753 if (UNLIKELY(dst_utf8 && IN_BYTES)) {
754 dst_utf8 = 0;
755 SvUTF8_off(targ);
756 /* undo all the negative lengths which flag utf8-ness */
757 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
758 SSize_t len = svpv_p->len;
759 if (len < 0)
760 svpv_p->len = -len;
761 }
762 }
763
764 /* grow += total of lengths of constant string segments */
765 {
766 SSize_t len;
767 len = aux[dst_utf8 ? PERL_MULTICONCAT_IX_UTF8_LEN
768 : PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
769 slow_concat = cBOOL(len);
770 grow += len;
771 }
772
773 const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
774
775 if (dst_utf8) {
776 const_pv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
777 if ( aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv
778 && const_pv != aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv)
779 /* separate sets of lengths for plain and utf8 */
780 const_lens += nargs + 1;
781
782 /* If the result is utf8 but some of the args aren't,
783 * calculate how much extra growth is needed for all the chars
784 * which will expand to two utf8 bytes.
785 * Also, if the growth is non-zero, negate the length to indicate
786 * that this is a variant string. Conversely, un-negate the
787 * length on utf8 args (which was only needed to flag non-utf8
788 * args in this loop */
789 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
790 SSize_t len, extra;
791
792 len = svpv_p->len;
793 if (len <= 0) {
794 svpv_p->len = -len;
795 continue;
796 }
797
798 extra = variant_under_utf8_count((U8 *) svpv_p->pv,
799 (U8 *) svpv_p->pv + len);
800 if (UNLIKELY(extra)) {
801 grow += extra;
802 /* -ve len indicates special handling */
803 svpv_p->len = -(len + extra);
804 slow_concat = TRUE;
805 }
806 }
807 }
808 else
809 const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
810
811 /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
812 * already have been dropped */
813 assert(!SvIsCOW(targ));
814 targ_pv = (SvLEN(targ) < (grow) ? sv_grow(targ,grow) : SvPVX(targ));
815
816
817 /* --------------------------------------------------------------
818 * Phase 4:
819 *
820 * Now that targ has been grown, we know the final address of the targ
821 * PVX, if needed. Preserve / move targ contents if appending or if
822 * targ appears on RHS.
823 *
824 * Also update svpv_buf slots in targ_chain.
825 *
826 * Don't bother with any of this if the target length is zero:
827 * targ_len is set to zero unless we're appending or targ appears on
828 * RHS. And even if it is, we can optimise by skipping this chunk of
829 * code for zero targ_len. In the latter case, we don't need to update
830 * the slots in targ_chain with the (zero length) target string, since
831 * we set the len in such slots to 0 earlier, and since the Copy() is
832 * skipped on zero length, it doesn't matter what svpv_p->pv contains.
833 *
834 * On entry to this section the (pv,len) pairs in svpv_buf have the
835 * following meanings:
836 * (pv, len) a pure-plain or utf8 string
837 * (pv, -(len+extra)) a plain string which will expand by 'extra'
838 * bytes when converted to utf8
839 * (NULL, 0) left-most targ \ linked together R-to-L
840 * (next, 0) other targ / in targ_chain
841 *
842 * On exit, the targ contents will have been moved to the
843 * earliest place they are needed (e.g. $x = "abc$x" will shift them
844 * 3 bytes, while $x .= ... will leave them at the beginning);
845 * and dst_pv will point to the location within SvPVX(targ) where the
846 * next arg should be copied.
847 */
848
849 svpv_base = svpv_buf;
850
851 if (targ_len) {
852 struct multiconcat_svpv *tc_stop;
853 char *targ_buf = targ_pv; /* ptr to original targ string */
854
855 assert(is_append || targ_count);
856
857 if (is_append) {
858 targ_pv += targ_len;
859 tc_stop = NULL;
860 }
861 else {
862 /* The targ appears on RHS, e.g. '$t = $a . $t . $t'.
863 * Move the current contents of targ to the first
864 * position where it's needed, and use that as the src buffer
865 * for any further uses (such as the second RHS $t above).
866 * In calculating the first position, we need to sum the
867 * lengths of all consts and args before that.
868 */
869
870 UNOP_AUX_item *lens = const_lens;
871 /* length of first const string segment */
872 STRLEN offset = lens->ssize > 0 ? lens->ssize : 0;
873
874 assert(targ_chain);
875 svpv_p = svpv_base;
876
877 for (;;) {
878 SSize_t len;
879 if (!svpv_p->pv)
880 break; /* the first targ argument */
881 /* add lengths of the next arg and const string segment */
882 len = svpv_p->len;
883 if (len < 0) /* variant args have this */
884 len = -len;
885 offset += (STRLEN)len;
886 len = (++lens)->ssize;
887 offset += (len >= 0) ? (STRLEN)len : 0;
888 if (!offset) {
889 /* all args and consts so far are empty; update
890 * the start position for the concat later */
891 svpv_base++;
892 const_lens++;
893 }
894 svpv_p++;
895 assert(svpv_p < svpv_end);
896 }
897
898 if (offset) {
899 targ_buf += offset;
900 Move(targ_pv, targ_buf, targ_len, char);
901 /* a negative length implies don't Copy(), but do increment */
902 svpv_p->len = -((SSize_t)targ_len);
903 slow_concat = TRUE;
904 }
905 else {
906 /* skip the first targ copy */
907 svpv_base++;
908 const_lens++;
909 targ_pv += targ_len;
910 }
911
912 /* Don't populate the first targ slot in the loop below; it's
913 * either not used because we advanced svpv_base beyond it, or
914 * we already stored the special -targ_len value in it
915 */
916 tc_stop = svpv_p;
917 }
918
919 /* populate slots in svpv_buf representing targ on RHS */
920 while (targ_chain != tc_stop) {
921 struct multiconcat_svpv *p = targ_chain;
922 targ_chain = (struct multiconcat_svpv *)(p->pv);
923 p->pv = targ_buf;
924 p->len = (SSize_t)targ_len;
925 }
926 }
927
928
929 /* --------------------------------------------------------------
930 * Phase 5:
931 *
932 * Append all the args in svpv_buf, plus the const strings, to targ.
933 *
934 * On entry to this section the (pv,len) pairs in svpv_buf have the
935 * following meanings:
936 * (pv, len) a pure-plain or utf8 string (which may be targ)
937 * (pv, -(len+extra)) a plain string which will expand by 'extra'
938 * bytes when converted to utf8
939 * (0, -len) left-most targ, whose content has already
940 * been copied. Just advance targ_pv by len.
941 */
942
943 /* If there are no constant strings and no special case args
944 * (svpv_p->len < 0), use a simpler, more efficient concat loop
945 */
946 if (!slow_concat) {
947 for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) {
948 SSize_t len = svpv_p->len;
949 if (!len)
950 continue;
951 Copy(svpv_p->pv, targ_pv, len, char);
952 targ_pv += len;
953 }
954 const_lens += (svpv_end - svpv_base + 1);
955 }
956 else {
957 /* Note that we iterate the loop nargs+1 times: to append nargs
958 * arguments and nargs+1 constant strings. For example, "-$a-$b-"
959 */
960 svpv_p = svpv_base;
961
962 for (;;) {
963 SSize_t len = (const_lens++)->ssize;
964
965 /* append next const string segment */
966 if (len > 0) {
967 Copy(const_pv, targ_pv, len, char);
968 targ_pv += len;
969 const_pv += len;
970 }
971
972 if (svpv_p == svpv_end)
973 break;
974
975 /* append next arg */
976 len = svpv_p->len;
977
978 if (LIKELY(len > 0)) {
979 Copy(svpv_p->pv, targ_pv, len, char);
980 targ_pv += len;
981 }
982 else if (UNLIKELY(len < 0)) {
983 /* negative length indicates two special cases */
984 const char *p = svpv_p->pv;
985 len = -len;
986 if (UNLIKELY(p)) {
987 /* copy plain-but-variant pv to a utf8 targ */
988 char * end_pv = targ_pv + len;
989 assert(dst_utf8);
990 while (targ_pv < end_pv) {
991 U8 c = (U8) *p++;
992 append_utf8_from_native_byte(c, (U8**)&targ_pv);
993 }
994 }
995 else
996 /* arg is already-copied targ */
997 targ_pv += len;
998 }
999
1000 ++svpv_p;
1001 }
1002 }
1003
1004 *targ_pv = '\0';
1005 SvCUR_set(targ, targ_pv - SvPVX(targ));
1006 assert(grow >= SvCUR(targ) + 1);
1007 assert(SvLEN(targ) >= SvCUR(targ) + 1);
1008
1009 /* --------------------------------------------------------------
1010 * Phase 6:
1011 *
1012 * return result
1013 */
1014
1015 SP -= stack_adj;
1016 SvTAINT(targ);
1017 SETTARG;
1018 RETURN;
1019
1020 /* --------------------------------------------------------------
1021 * Phase 7:
1022 *
1023 * We only get here if any of the args (or targ too in the case of
1024 * append) have something which might cause side effects, such
1025 * as magic, overload, or an undef value in the presence of warnings.
1026 * In that case, any earlier attempt to stringify the args will have
1027 * been abandoned, and we come here instead.
1028 *
1029 * Here, we concat each arg in turn the old-fashioned way: essentially
1030 * emulating pp_concat() in a loop. This means that all the weird edge
1031 * cases will be handled correctly, if not necessarily speedily.
1032 *
1033 * Note that some args may already have been stringified - those are
1034 * processed again, which is safe, since only args without side-effects
1035 * were stringified earlier.
1036 */
1037
1038 do_magical:
1039 {
1040 SSize_t i, n;
1041 SV *left = NULL;
1042 SV *right;
1043 SV* nexttarg;
1044 bool nextappend;
1045 U32 utf8 = 0;
1046 SV **svp;
1047 const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1048 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
1049 Size_t arg_count = 0; /* how many args have been processed */
1050
1051 if (!cpv) {
1052 cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1053 utf8 = SVf_UTF8;
1054 }
1055
1056 svp = toparg - nargs + 1;
1057
1058 /* iterate for:
1059 * nargs arguments,
1060 * plus possible nargs+1 consts,
1061 * plus, if appending, a final targ in an extra last iteration
1062 */
1063
1064 n = nargs *2 + 1;
1065 for (i = 0; i <= n; i++) {
1066 SSize_t len;
1067
1068 /* if necessary, stringify the final RHS result in
1069 * something like $targ .= "$a$b$c" - simulating
1070 * pp_stringify
1071 */
1072 if ( i == n
1073 && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY)
1074 && !(SvPOK(left))
1075 /* extra conditions for backwards compatibility:
1076 * probably incorrect, but keep the existing behaviour
1077 * for now. The rules are:
1078 * $x = "$ov" single arg: stringify;
1079 * $x = "$ov$y" multiple args: don't stringify,
1080 * $lex = "$ov$y$z" except TARGMY with at least 2 concats
1081 */
1082 && ( arg_count == 1
1083 || ( arg_count >= 3
1084 && !is_append
1085 && (PL_op->op_private & OPpTARGET_MY)
1086 && !(PL_op->op_private & OPpLVAL_INTRO)
1087 )
1088 )
1089 )
1090 {
1091 SV *tmp = newSV_type_mortal(SVt_PV);
1092 sv_copypv(tmp, left);
1093 SvSETMAGIC(tmp);
1094 left = tmp;
1095 }
1096
1097 /* do one extra iteration to handle $targ in $targ .= ... */
1098 if (i == n && !is_append)
1099 break;
1100
1101 /* get the next arg SV or regen the next const SV */
1102 len = lens[i >> 1].ssize;
1103 if (i == n) {
1104 /* handle the final targ .= (....) */
1105 right = left;
1106 left = targ;
1107 }
1108 else if (i & 1)
1109 right = svp[(i >> 1)];
1110 else if (len < 0)
1111 continue; /* no const in this position */
1112 else {
1113 right = newSVpvn_flags(cpv, len, (utf8 | SVs_TEMP));
1114 cpv += len;
1115 }
1116
1117 arg_count++;
1118
1119 if (arg_count <= 1) {
1120 left = right;
1121 continue; /* need at least two SVs to concat together */
1122 }
1123
1124 if (arg_count == 2 && i < n) {
1125 /* for the first concat, create a mortal acting like the
1126 * padtmp from OP_CONST. In later iterations this will
1127 * be appended to */
1128 nexttarg = sv_newmortal();
1129 nextappend = FALSE;
1130 }
1131 else {
1132 nexttarg = left;
1133 nextappend = TRUE;
1134 }
1135
1136 /* Handle possible overloading.
1137 * This is basically an unrolled
1138 * tryAMAGICbin_MG(concat_amg, AMGf_assign);
1139 * and
1140 * Perl_try_amagic_bin()
1141 * call, but using left and right rather than SP[-1], SP[0],
1142 * and not relying on OPf_STACKED implying .=
1143 */
1144
1145 if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) {
1146 SvGETMAGIC(left);
1147 if (left != right)
1148 SvGETMAGIC(right);
1149
1150 if ((SvAMAGIC(left) || SvAMAGIC(right))
1151 /* sprintf doesn't do concat overloading,
1152 * but allow for $x .= sprintf(...)
1153 */
1154 && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE)
1155 || i == n)
1156 )
1157 {
1158 SV * const tmpsv = amagic_call(left, right, concat_amg,
1159 (nextappend ? AMGf_assign: 0));
1160 if (tmpsv) {
1161 /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test
1162 * here, which isn't needed as any implicit
1163 * assign done under OPpTARGET_MY is done after
1164 * this loop */
1165 if (nextappend) {
1166 sv_setsv(left, tmpsv);
1167 SvSETMAGIC(left);
1168 }
1169 else
1170 left = tmpsv;
1171 continue;
1172 }
1173 }
1174
1175 /* if both args are the same magical value, make one a copy */
1176 if (left == right && SvGMAGICAL(left)) {
1177 SV * targetsv = right;
1178 /* Print the uninitialized warning now, so it includes the
1179 * variable name. */
1180 if (!SvOK(right)) {
1181 if (ckWARN(WARN_UNINITIALIZED))
1182 report_uninit(right);
1183 targetsv = &PL_sv_no;
1184 }
1185 left = sv_mortalcopy_flags(targetsv, 0);
1186 SvGETMAGIC(right);
1187 }
1188 }
1189
1190 /* nexttarg = left . right */
1191 S_do_concat(aTHX_ left, right, nexttarg, 0);
1192 left = nexttarg;
1193 }
1194
1195 SP = toparg - stack_adj + 1;
1196
1197 /* Return the result of all RHS concats, unless this op includes
1198 * an assign ($lex = x.y.z or expr = x.y.z), in which case copy
1199 * to target (which will be $lex or expr).
1200 * If we are appending, targ will already have been appended to in
1201 * the loop */
1202 if ( !is_append
1203 && ( (PL_op->op_flags & OPf_STACKED)
1204 || (PL_op->op_private & OPpTARGET_MY))
1205 ) {
1206 sv_setsv(targ, left);
1207 SvSETMAGIC(targ);
1208 }
1209 else
1210 targ = left;
1211 SETs(targ);
1212 RETURN;
1213 }
1214 }
1215
1216
1217 /* push the elements of av onto the stack.
1218 * Returns PL_op->op_next to allow tail-call optimisation of its callers */
1219
1220 STATIC OP*
S_pushav(pTHX_ AV * const av)1221 S_pushav(pTHX_ AV* const av)
1222 {
1223 dSP;
1224 const SSize_t maxarg = AvFILL(av) + 1;
1225 EXTEND(SP, maxarg);
1226 if (UNLIKELY(SvRMAGICAL(av))) {
1227 PADOFFSET i;
1228 for (i=0; i < (PADOFFSET)maxarg; i++) {
1229 SV ** const svp = av_fetch(av, i, FALSE);
1230 SP[i+1] = LIKELY(svp)
1231 ? *svp
1232 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1233 ? av_nonelem(av,i)
1234 : &PL_sv_undef;
1235 }
1236 }
1237 else {
1238 PADOFFSET i;
1239 for (i=0; i < (PADOFFSET)maxarg; i++) {
1240 SV *sv = AvARRAY(av)[i];
1241 SP[i+1] = LIKELY(sv)
1242 ? sv
1243 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1244 ? av_nonelem(av,i)
1245 : &PL_sv_undef;
1246 }
1247 }
1248 SP += maxarg;
1249 PUTBACK;
1250 return NORMAL;
1251 }
1252
1253
1254 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
1255
PP(pp_padrange)1256 PP(pp_padrange)
1257 {
1258 dSP;
1259 PADOFFSET base = PL_op->op_targ;
1260 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
1261 if (PL_op->op_flags & OPf_SPECIAL) {
1262 /* fake the RHS of my ($x,$y,..) = @_ */
1263 PUSHMARK(SP);
1264 (void)S_pushav(aTHX_ GvAVn(PL_defgv));
1265 SPAGAIN;
1266 }
1267
1268 /* note, this is only skipped for compile-time-known void cxt */
1269 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
1270 int i;
1271
1272 EXTEND(SP, count);
1273 PUSHMARK(SP);
1274 for (i = 0; i <count; i++)
1275 *++SP = PAD_SV(base+i);
1276 }
1277 if (PL_op->op_private & OPpLVAL_INTRO) {
1278 SV **svp = &(PAD_SVl(base));
1279 const UV payload = (UV)(
1280 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
1281 | (count << SAVE_TIGHT_SHIFT)
1282 | SAVEt_CLEARPADRANGE);
1283 int i;
1284
1285 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
1286 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
1287 == (Size_t)base);
1288 {
1289 dSS_ADD;
1290 SS_ADD_UV(payload);
1291 SS_ADD_END(1);
1292 }
1293
1294 for (i = 0; i <count; i++)
1295 SvPADSTALE_off(*svp++); /* mark lexical as active */
1296 }
1297 RETURN;
1298 }
1299
1300
PP(pp_padsv)1301 PP(pp_padsv)
1302 {
1303 dSP;
1304 EXTEND(SP, 1);
1305 {
1306 OP * const op = PL_op;
1307 /* access PL_curpad once */
1308 SV ** const padentry = &(PAD_SVl(op->op_targ));
1309 {
1310 dTARG;
1311 TARG = *padentry;
1312 PUSHs(TARG);
1313 PUTBACK; /* no pop/push after this, TOPs ok */
1314 }
1315 if (op->op_flags & OPf_MOD) {
1316 if (op->op_private & OPpLVAL_INTRO)
1317 if (!(op->op_private & OPpPAD_STATE))
1318 save_clearsv(padentry);
1319 if (op->op_private & OPpDEREF) {
1320 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
1321 than TARG reduces the scope of TARG, so it does not
1322 span the call to save_clearsv, resulting in smaller
1323 machine code. */
1324 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
1325 }
1326 }
1327 return op->op_next;
1328 }
1329 }
1330
PP(pp_readline)1331 PP(pp_readline)
1332 {
1333 dSP;
1334 /* pp_coreargs pushes a NULL to indicate no args passed to
1335 * CORE::readline() */
1336 if (TOPs) {
1337 SvGETMAGIC(TOPs);
1338 tryAMAGICunTARGETlist(iter_amg, 0);
1339 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1340 }
1341 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
1342 if (!isGV_with_GP(PL_last_in_gv)) {
1343 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
1344 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
1345 else {
1346 dSP;
1347 XPUSHs(MUTABLE_SV(PL_last_in_gv));
1348 PUTBACK;
1349 Perl_pp_rv2gv(aTHX);
1350 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1351 assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
1352 }
1353 }
1354 return do_readline();
1355 }
1356
PP(pp_eq)1357 PP(pp_eq)
1358 {
1359 dSP;
1360 SV *left, *right;
1361 U32 flags_and, flags_or;
1362
1363 tryAMAGICbin_MG(eq_amg, AMGf_numeric);
1364 right = POPs;
1365 left = TOPs;
1366 flags_and = SvFLAGS(left) & SvFLAGS(right);
1367 flags_or = SvFLAGS(left) | SvFLAGS(right);
1368
1369 SETs(boolSV(
1370 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
1371 ? (SvIVX(left) == SvIVX(right))
1372 : (flags_and & SVf_NOK)
1373 ? (SvNVX(left) == SvNVX(right))
1374 : ( do_ncmp(left, right) == 0)
1375 ));
1376 RETURN;
1377 }
1378
1379
1380 /* also used for: pp_i_preinc() */
1381
PP(pp_preinc)1382 PP(pp_preinc)
1383 {
1384 SV *sv = *PL_stack_sp;
1385
1386 if (LIKELY(((sv->sv_flags &
1387 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1388 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1389 == SVf_IOK))
1390 && SvIVX(sv) != IV_MAX)
1391 {
1392 SvIV_set(sv, SvIVX(sv) + 1);
1393 }
1394 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
1395 sv_inc(sv);
1396 SvSETMAGIC(sv);
1397 return NORMAL;
1398 }
1399
1400
1401 /* also used for: pp_i_predec() */
1402
PP(pp_predec)1403 PP(pp_predec)
1404 {
1405 SV *sv = *PL_stack_sp;
1406
1407 if (LIKELY(((sv->sv_flags &
1408 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1409 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1410 == SVf_IOK))
1411 && SvIVX(sv) != IV_MIN)
1412 {
1413 SvIV_set(sv, SvIVX(sv) - 1);
1414 }
1415 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */
1416 sv_dec(sv);
1417 SvSETMAGIC(sv);
1418 return NORMAL;
1419 }
1420
1421
1422 /* also used for: pp_orassign() */
1423
PP(pp_or)1424 PP(pp_or)
1425 {
1426 dSP;
1427 SV *sv;
1428 PERL_ASYNC_CHECK();
1429 sv = TOPs;
1430 if (SvTRUE_NN(sv))
1431 RETURN;
1432 else {
1433 if (PL_op->op_type == OP_OR)
1434 --SP;
1435 RETURNOP(cLOGOP->op_other);
1436 }
1437 }
1438
1439
1440 /* also used for: pp_dor() pp_dorassign() */
1441
PP(pp_defined)1442 PP(pp_defined)
1443 {
1444 dSP;
1445 SV* sv = TOPs;
1446 bool defined = FALSE;
1447 const int op_type = PL_op->op_type;
1448 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
1449
1450 if (is_dor) {
1451 PERL_ASYNC_CHECK();
1452 if (UNLIKELY(!sv || !SvANY(sv))) {
1453 if (op_type == OP_DOR)
1454 --SP;
1455 RETURNOP(cLOGOP->op_other);
1456 }
1457 }
1458 else {
1459 /* OP_DEFINED */
1460 if (UNLIKELY(!sv || !SvANY(sv)))
1461 RETSETNO;
1462 }
1463
1464 /* Historically what followed was a switch on SvTYPE(sv), handling SVt_PVAV,
1465 * SVt_PVCV, SVt_PVHV and "default". `defined &sub` is still valid syntax,
1466 * hence we still need the special case PVCV code. But AVs and HVs now
1467 * should never arrive here... */
1468 #ifdef DEBUGGING
1469 assert(SvTYPE(sv) != SVt_PVAV);
1470 assert(SvTYPE(sv) != SVt_PVHV);
1471 #endif
1472
1473 if (UNLIKELY(SvTYPE(sv) == SVt_PVCV)) {
1474 if (CvROOT(sv) || CvXSUB(sv))
1475 defined = TRUE;
1476 }
1477 else {
1478 SvGETMAGIC(sv);
1479 if (SvOK(sv))
1480 defined = TRUE;
1481 }
1482
1483 if (is_dor) {
1484 if(defined)
1485 RETURN;
1486 if(op_type == OP_DOR)
1487 --SP;
1488 RETURNOP(cLOGOP->op_other);
1489 }
1490 /* assuming OP_DEFINED */
1491 if(defined)
1492 RETSETYES;
1493 RETSETNO;
1494 }
1495
1496
1497
PP(pp_add)1498 PP(pp_add)
1499 {
1500 dSP; dATARGET; bool useleft; SV *svl, *svr;
1501
1502 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
1503 svr = TOPs;
1504 svl = TOPm1s;
1505
1506 #ifdef PERL_PRESERVE_IVUV
1507
1508 /* special-case some simple common cases */
1509 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1510 IV il, ir;
1511 U32 flags = (svl->sv_flags & svr->sv_flags);
1512 if (flags & SVf_IOK) {
1513 /* both args are simple IVs */
1514 UV topl, topr;
1515 il = SvIVX(svl);
1516 ir = SvIVX(svr);
1517 do_iv:
1518 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1519 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1520
1521 /* if both are in a range that can't under/overflow, do a
1522 * simple integer add: if the top of both numbers
1523 * are 00 or 11, then it's safe */
1524 if (!( ((topl+1) | (topr+1)) & 2)) {
1525 SP--;
1526 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1527 SETs(TARG);
1528 RETURN;
1529 }
1530 goto generic;
1531 }
1532 else if (flags & SVf_NOK) {
1533 /* both args are NVs */
1534 NV nl = SvNVX(svl);
1535 NV nr = SvNVX(svr);
1536
1537 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1538 /* nothing was lost by converting to IVs */
1539 goto do_iv;
1540 }
1541 SP--;
1542 TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1543 SETs(TARG);
1544 RETURN;
1545 }
1546 }
1547
1548 generic:
1549
1550 useleft = USE_LEFT(svl);
1551 /* We must see if we can perform the addition with integers if possible,
1552 as the integer code detects overflow while the NV code doesn't.
1553 If either argument hasn't had a numeric conversion yet attempt to get
1554 the IV. It's important to do this now, rather than just assuming that
1555 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1556 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1557 integer in case the second argument is IV=9223372036854775806
1558 We can (now) rely on sv_2iv to do the right thing, only setting the
1559 public IOK flag if the value in the NV (or PV) slot is truly integer.
1560
1561 A side effect is that this also aggressively prefers integer maths over
1562 fp maths for integer values.
1563
1564 How to detect overflow?
1565
1566 C 99 section 6.2.6.1 says
1567
1568 The range of nonnegative values of a signed integer type is a subrange
1569 of the corresponding unsigned integer type, and the representation of
1570 the same value in each type is the same. A computation involving
1571 unsigned operands can never overflow, because a result that cannot be
1572 represented by the resulting unsigned integer type is reduced modulo
1573 the number that is one greater than the largest value that can be
1574 represented by the resulting type.
1575
1576 (the 9th paragraph)
1577
1578 which I read as "unsigned ints wrap."
1579
1580 signed integer overflow seems to be classed as "exception condition"
1581
1582 If an exceptional condition occurs during the evaluation of an
1583 expression (that is, if the result is not mathematically defined or not
1584 in the range of representable values for its type), the behavior is
1585 undefined.
1586
1587 (6.5, the 5th paragraph)
1588
1589 I had assumed that on 2s complement machines signed arithmetic would
1590 wrap, hence coded pp_add and pp_subtract on the assumption that
1591 everything perl builds on would be happy. After much wailing and
1592 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1593 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
1594 unsigned code below is actually shorter than the old code. :-)
1595 */
1596
1597 if (SvIV_please_nomg(svr)) {
1598 /* Unless the left argument is integer in range we are going to have to
1599 use NV maths. Hence only attempt to coerce the right argument if
1600 we know the left is integer. */
1601 UV auv = 0;
1602 bool auvok = FALSE;
1603 bool a_valid = 0;
1604
1605 if (!useleft) {
1606 auv = 0;
1607 a_valid = auvok = 1;
1608 /* left operand is undef, treat as zero. + 0 is identity,
1609 Could SETi or SETu right now, but space optimise by not adding
1610 lots of code to speed up what is probably a rarish case. */
1611 } else {
1612 /* Left operand is defined, so is it IV? */
1613 if (SvIV_please_nomg(svl)) {
1614 if ((auvok = SvUOK(svl)))
1615 auv = SvUVX(svl);
1616 else {
1617 const IV aiv = SvIVX(svl);
1618 if (aiv >= 0) {
1619 auv = aiv;
1620 auvok = 1; /* Now acting as a sign flag. */
1621 } else {
1622 /* Using 0- here and later to silence bogus warning
1623 * from MS VC */
1624 auv = (UV) (0 - (UV) aiv);
1625 }
1626 }
1627 a_valid = 1;
1628 }
1629 }
1630 if (a_valid) {
1631 bool result_good = 0;
1632 UV result;
1633 UV buv;
1634 bool buvok = SvUOK(svr);
1635
1636 if (buvok)
1637 buv = SvUVX(svr);
1638 else {
1639 const IV biv = SvIVX(svr);
1640 if (biv >= 0) {
1641 buv = biv;
1642 buvok = 1;
1643 } else
1644 buv = (UV) (0 - (UV) biv);
1645 }
1646 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1647 else "IV" now, independent of how it came in.
1648 if a, b represents positive, A, B negative, a maps to -A etc
1649 a + b => (a + b)
1650 A + b => -(a - b)
1651 a + B => (a - b)
1652 A + B => -(a + b)
1653 all UV maths. negate result if A negative.
1654 add if signs same, subtract if signs differ. */
1655
1656 if (auvok ^ buvok) {
1657 /* Signs differ. */
1658 if (auv >= buv) {
1659 result = auv - buv;
1660 /* Must get smaller */
1661 if (result <= auv)
1662 result_good = 1;
1663 } else {
1664 result = buv - auv;
1665 if (result <= buv) {
1666 /* result really should be -(auv-buv). as its negation
1667 of true value, need to swap our result flag */
1668 auvok = !auvok;
1669 result_good = 1;
1670 }
1671 }
1672 } else {
1673 /* Signs same */
1674 result = auv + buv;
1675 if (result >= auv)
1676 result_good = 1;
1677 }
1678 if (result_good) {
1679 SP--;
1680 if (auvok)
1681 SETu( result );
1682 else {
1683 /* Negate result */
1684 if (result <= (UV)IV_MIN)
1685 SETi(result == (UV)IV_MIN
1686 ? IV_MIN : -(IV)result);
1687 else {
1688 /* result valid, but out of range for IV. */
1689 SETn( -(NV)result );
1690 }
1691 }
1692 RETURN;
1693 } /* Overflow, drop through to NVs. */
1694 }
1695 }
1696
1697 #else
1698 useleft = USE_LEFT(svl);
1699 #endif
1700
1701 {
1702 NV value = SvNV_nomg(svr);
1703 (void)POPs;
1704 if (!useleft) {
1705 /* left operand is undef, treat as zero. + 0.0 is identity. */
1706 SETn(value);
1707 RETURN;
1708 }
1709 SETn( value + SvNV_nomg(svl) );
1710 RETURN;
1711 }
1712 }
1713
1714
1715 /* also used for: pp_aelemfast_lex() */
1716
PP(pp_aelemfast)1717 PP(pp_aelemfast)
1718 {
1719 dSP;
1720 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
1721 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
1722 const U32 lval = PL_op->op_flags & OPf_MOD;
1723 const I8 key = (I8)PL_op->op_private;
1724 SV** svp;
1725 SV *sv;
1726
1727 assert(SvTYPE(av) == SVt_PVAV);
1728
1729 EXTEND(SP, 1);
1730
1731 /* inlined av_fetch() for simple cases ... */
1732 if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
1733 sv = AvARRAY(av)[key];
1734 if (sv) {
1735 PUSHs(sv);
1736 RETURN;
1737 } else if (!lval) {
1738 PUSHs(&PL_sv_undef);
1739 RETURN;
1740 }
1741 }
1742
1743 /* ... else do it the hard way */
1744 svp = av_fetch(av, key, lval);
1745 sv = (svp ? *svp : &PL_sv_undef);
1746
1747 if (UNLIKELY(!svp && lval))
1748 DIE(aTHX_ PL_no_aelem, (int)key);
1749
1750 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
1751 mg_get(sv);
1752 PUSHs(sv);
1753 RETURN;
1754 }
1755
PP(pp_join)1756 PP(pp_join)
1757 {
1758 dSP; dMARK; dTARGET;
1759 MARK++;
1760 do_join(TARG, *MARK, MARK, SP);
1761 SP = MARK;
1762 SETs(TARG);
1763 RETURN;
1764 }
1765
1766 /* Oversized hot code. */
1767
1768 /* also used for: pp_say() */
1769
PP(pp_print)1770 PP(pp_print)
1771 {
1772 dSP; dMARK; dORIGMARK;
1773 PerlIO *fp;
1774 MAGIC *mg;
1775 GV * const gv
1776 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1777 IO *io = GvIO(gv);
1778
1779 if (io
1780 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1781 {
1782 had_magic:
1783 if (MARK == ORIGMARK) {
1784 /* If using default handle then we need to make space to
1785 * pass object as 1st arg, so move other args up ...
1786 */
1787 MEXTEND(SP, 1);
1788 ++MARK;
1789 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1790 ++SP;
1791 }
1792 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
1793 mg,
1794 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
1795 | (PL_op->op_type == OP_SAY
1796 ? TIED_METHOD_SAY : 0)), sp - mark);
1797 }
1798 if (!io) {
1799 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
1800 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1801 goto had_magic;
1802 report_evil_fh(gv);
1803 SETERRNO(EBADF,RMS_IFI);
1804 goto just_say_no;
1805 }
1806 else if (!(fp = IoOFP(io))) {
1807 if (IoIFP(io))
1808 report_wrongway_fh(gv, '<');
1809 else
1810 report_evil_fh(gv);
1811 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1812 goto just_say_no;
1813 }
1814 else {
1815 SV * const ofs = GvSV(PL_ofsgv); /* $, */
1816 MARK++;
1817 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
1818 while (MARK <= SP) {
1819 if (!do_print(*MARK, fp))
1820 break;
1821 MARK++;
1822 if (MARK <= SP) {
1823 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
1824 if (!do_print(GvSV(PL_ofsgv), fp)) {
1825 MARK--;
1826 break;
1827 }
1828 }
1829 }
1830 }
1831 else {
1832 while (MARK <= SP) {
1833 if (!do_print(*MARK, fp))
1834 break;
1835 MARK++;
1836 }
1837 }
1838 if (MARK <= SP)
1839 goto just_say_no;
1840 else {
1841 if (PL_op->op_type == OP_SAY) {
1842 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
1843 goto just_say_no;
1844 }
1845 else if (PL_ors_sv && SvOK(PL_ors_sv))
1846 if (!do_print(PL_ors_sv, fp)) /* $\ */
1847 goto just_say_no;
1848
1849 if (IoFLAGS(io) & IOf_FLUSH)
1850 if (PerlIO_flush(fp) == EOF)
1851 goto just_say_no;
1852 }
1853 }
1854 SP = ORIGMARK;
1855 XPUSHs(&PL_sv_yes);
1856 RETURN;
1857
1858 just_say_no:
1859 SP = ORIGMARK;
1860 XPUSHs(&PL_sv_undef);
1861 RETURN;
1862 }
1863
1864
1865 /* do the common parts of pp_padhv() and pp_rv2hv()
1866 * It assumes the caller has done EXTEND(SP, 1) or equivalent.
1867 * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
1868 * 'has_targ' indicates that the op has a target - this should
1869 * be a compile-time constant so that the code can constant-folded as
1870 * appropriate
1871 * */
1872
1873 PERL_STATIC_INLINE OP*
S_padhv_rv2hv_common(pTHX_ HV * hv,U8 gimme,bool is_keys,bool has_targ)1874 S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
1875 {
1876 dSP;
1877
1878 assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
1879
1880 if (gimme == G_LIST) {
1881 hv_pushkv(hv, 3);
1882 return NORMAL;
1883 }
1884
1885 if (is_keys)
1886 /* 'keys %h' masquerading as '%h': reset iterator */
1887 (void)hv_iterinit(hv);
1888
1889 if (gimme == G_VOID)
1890 return NORMAL;
1891
1892 bool is_bool = ( PL_op->op_private & OPpTRUEBOOL
1893 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
1894 && block_gimme() == G_VOID));
1895
1896 MAGIC *is_tied_mg = SvRMAGICAL(hv)
1897 ? mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied)
1898 : NULL;
1899
1900 IV i = 0;
1901 SV *sv = NULL;
1902 if (UNLIKELY(is_tied_mg)) {
1903 if (is_keys && !is_bool) {
1904 i = 0;
1905 while (hv_iternext(hv))
1906 i++;
1907 goto push_i;
1908 }
1909 else {
1910 sv = magic_scalarpack(hv, is_tied_mg);
1911 goto push_sv;
1912 }
1913 }
1914 else {
1915 #if defined(DYNAMIC_ENV_FETCH) && defined(VMS)
1916 /* maybe nothing set up %ENV for iteration yet...
1917 do this always (not just if HvUSEDKEYS(hv) is currently 0) because
1918 we ought to give a *consistent* answer to "how many keys?"
1919 whether we ask this op in scalar context, or get the list of all
1920 keys then check its length, and whether we do either with or without
1921 an %ENV lookup first. prime_env_iter() returns quickly if nothing
1922 needs doing. */
1923 if (SvRMAGICAL((const SV *)hv)
1924 && mg_find((const SV *)hv, PERL_MAGIC_env)) {
1925 prime_env_iter();
1926 }
1927 #endif
1928 i = HvUSEDKEYS(hv);
1929 if (is_bool) {
1930 sv = i ? &PL_sv_yes : &PL_sv_zero;
1931 push_sv:
1932 PUSHs(sv);
1933 }
1934 else {
1935 push_i:
1936 if (has_targ) {
1937 dTARGET;
1938 PUSHi(i);
1939 }
1940 else
1941 if (is_keys) {
1942 /* parent op should be an unused OP_KEYS whose targ we can
1943 * use */
1944 dTARG;
1945 OP *k;
1946
1947 assert(!OpHAS_SIBLING(PL_op));
1948 k = PL_op->op_sibparent;
1949 assert(k->op_type == OP_KEYS);
1950 TARG = PAD_SV(k->op_targ);
1951 PUSHi(i);
1952 }
1953 else
1954 mPUSHi(i);
1955 }
1956 }
1957
1958 PUTBACK;
1959 return NORMAL;
1960 }
1961
1962
1963 /* This is also called directly by pp_lvavref. */
PP(pp_padav)1964 PP(pp_padav)
1965 {
1966 dSP; dTARGET;
1967 U8 gimme;
1968 assert(SvTYPE(TARG) == SVt_PVAV);
1969 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1970 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1971 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1972 EXTEND(SP, 1);
1973
1974 if (PL_op->op_flags & OPf_REF) {
1975 PUSHs(TARG);
1976 RETURN;
1977 }
1978 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1979 const I32 flags = is_lvalue_sub();
1980 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1981 if (GIMME_V == G_SCALAR)
1982 /* diag_listed_as: Can't return %s to lvalue scalar context */
1983 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
1984 PUSHs(TARG);
1985 RETURN;
1986 }
1987 }
1988
1989 gimme = GIMME_V;
1990 if (gimme == G_LIST)
1991 return S_pushav(aTHX_ (AV*)TARG);
1992
1993 if (gimme == G_SCALAR) {
1994 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
1995 if (!maxarg)
1996 PUSHs(&PL_sv_zero);
1997 else if (PL_op->op_private & OPpTRUEBOOL)
1998 PUSHs(&PL_sv_yes);
1999 else
2000 mPUSHi(maxarg);
2001 }
2002 RETURN;
2003 }
2004
2005
PP(pp_padhv)2006 PP(pp_padhv)
2007 {
2008 dSP; dTARGET;
2009 U8 gimme;
2010
2011 assert(SvTYPE(TARG) == SVt_PVHV);
2012 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
2013 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
2014 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
2015
2016 EXTEND(SP, 1);
2017
2018 if (PL_op->op_flags & OPf_REF) {
2019 PUSHs(TARG);
2020 RETURN;
2021 }
2022 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
2023 const I32 flags = is_lvalue_sub();
2024 if (flags && !(flags & OPpENTERSUB_INARGS)) {
2025 if (GIMME_V == G_SCALAR)
2026 /* diag_listed_as: Can't return %s to lvalue scalar context */
2027 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
2028 PUSHs(TARG);
2029 RETURN;
2030 }
2031 }
2032
2033 gimme = GIMME_V;
2034
2035 return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
2036 cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
2037 0 /* has_targ*/);
2038 }
2039
2040
2041 /* also used for: pp_rv2hv() */
2042 /* also called directly by pp_lvavref */
2043
PP(pp_rv2av)2044 PP(pp_rv2av)
2045 {
2046 dSP; dTOPss;
2047 const U8 gimme = GIMME_V;
2048 static const char an_array[] = "an ARRAY";
2049 static const char a_hash[] = "a HASH";
2050 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
2051 || PL_op->op_type == OP_LVAVREF;
2052 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
2053
2054 SvGETMAGIC(sv);
2055 if (SvROK(sv)) {
2056 if (UNLIKELY(SvAMAGIC(sv))) {
2057 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
2058 }
2059 sv = SvRV(sv);
2060 if (UNLIKELY(SvTYPE(sv) != type))
2061 /* diag_listed_as: Not an ARRAY reference */
2062 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
2063 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
2064 && PL_op->op_private & OPpLVAL_INTRO))
2065 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
2066 }
2067 else if (UNLIKELY(SvTYPE(sv) != type)) {
2068 GV *gv;
2069
2070 if (!isGV_with_GP(sv)) {
2071 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
2072 type, &sp);
2073 if (!gv)
2074 RETURN;
2075 }
2076 else {
2077 gv = MUTABLE_GV(sv);
2078 }
2079 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
2080 if (PL_op->op_private & OPpLVAL_INTRO)
2081 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
2082 }
2083 if (PL_op->op_flags & OPf_REF) {
2084 SETs(sv);
2085 RETURN;
2086 }
2087 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
2088 const I32 flags = is_lvalue_sub();
2089 if (flags && !(flags & OPpENTERSUB_INARGS)) {
2090 if (gimme != G_LIST)
2091 goto croak_cant_return;
2092 SETs(sv);
2093 RETURN;
2094 }
2095 }
2096
2097 if (is_pp_rv2av) {
2098 AV *const av = MUTABLE_AV(sv);
2099
2100 if (gimme == G_LIST) {
2101 SP--;
2102 PUTBACK;
2103 return S_pushav(aTHX_ av);
2104 }
2105
2106 if (gimme == G_SCALAR) {
2107 const SSize_t maxarg = AvFILL(av) + 1;
2108 if (PL_op->op_private & OPpTRUEBOOL)
2109 SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
2110 else {
2111 dTARGET;
2112 SETi(maxarg);
2113 }
2114 }
2115 }
2116 else {
2117 SP--; PUTBACK;
2118 return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
2119 cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
2120 1 /* has_targ*/);
2121 }
2122 RETURN;
2123
2124 croak_cant_return:
2125 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
2126 is_pp_rv2av ? "array" : "hash");
2127 RETURN;
2128 }
2129
2130 STATIC void
S_do_oddball(pTHX_ SV ** oddkey,SV ** firstkey)2131 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
2132 {
2133 PERL_ARGS_ASSERT_DO_ODDBALL;
2134
2135 if (*oddkey) {
2136 if (ckWARN(WARN_MISC)) {
2137 const char *err;
2138 if (oddkey == firstkey &&
2139 SvROK(*oddkey) &&
2140 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
2141 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
2142 {
2143 err = "Reference found where even-sized list expected";
2144 }
2145 else
2146 err = "Odd number of elements in hash assignment";
2147 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
2148 }
2149
2150 }
2151 }
2152
2153
2154 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
2155 * are common to both the LHS and RHS of an aassign, and replace them
2156 * with copies. All these copies are made before the actual list assign is
2157 * done.
2158 *
2159 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
2160 * element ($b) to the first LH element ($a), modifies $a; when the
2161 * second assignment is done, the second RH element now has the wrong
2162 * value. So we initially replace the RHS with ($b, mortalcopy($a)).
2163 * Note that we don't need to make a mortal copy of $b.
2164 *
2165 * The algorithm below works by, for every RHS element, mark the
2166 * corresponding LHS target element with SVf_BREAK. Then if the RHS
2167 * element is found with SVf_BREAK set, it means it would have been
2168 * modified, so make a copy.
2169 * Note that by scanning both LHS and RHS in lockstep, we avoid
2170 * unnecessary copies (like $b above) compared with a naive
2171 * "mark all LHS; copy all marked RHS; unmark all LHS".
2172 *
2173 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
2174 * it can't be common and can be skipped.
2175 *
2176 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
2177 * that we thought we didn't need to call S_aassign_copy_common(), but we
2178 * have anyway for sanity checking. If we find we need to copy, then panic.
2179 */
2180
2181 PERL_STATIC_INLINE void
S_aassign_copy_common(pTHX_ SV ** firstlelem,SV ** lastlelem,SV ** firstrelem,SV ** lastrelem,bool fake)2182 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
2183 SV **firstrelem, SV **lastrelem
2184 #ifdef DEBUGGING
2185 , bool fake
2186 #endif
2187 )
2188 {
2189 SV **relem;
2190 SV **lelem;
2191 SSize_t lcount = lastlelem - firstlelem + 1;
2192 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
2193 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
2194 bool copy_all = FALSE;
2195
2196 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
2197 assert(firstlelem < lastlelem); /* at least 2 LH elements */
2198 assert(firstrelem < lastrelem); /* at least 2 RH elements */
2199
2200
2201 lelem = firstlelem;
2202 /* we never have to copy the first RH element; it can't be corrupted
2203 * by assigning something to the corresponding first LH element.
2204 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
2205 */
2206 relem = firstrelem + 1;
2207
2208 for (; relem <= lastrelem; relem++) {
2209 SV *svr;
2210
2211 /* mark next LH element */
2212
2213 if (--lcount >= 0) {
2214 SV *svl = *lelem++;
2215
2216 if (UNLIKELY(!svl)) {/* skip AV alias marker */
2217 assert (lelem <= lastlelem);
2218 svl = *lelem++;
2219 lcount--;
2220 }
2221
2222 assert(svl);
2223 if (SvSMAGICAL(svl)) {
2224 copy_all = TRUE;
2225 }
2226 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
2227 if (!marked)
2228 return;
2229 /* this LH element will consume all further args;
2230 * no need to mark any further LH elements (if any).
2231 * But we still need to scan any remaining RHS elements;
2232 * set lcount negative to distinguish from lcount == 0,
2233 * so the loop condition continues being true
2234 */
2235 lcount = -1;
2236 lelem--; /* no need to unmark this element */
2237 }
2238 else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
2239 SvFLAGS(svl) |= SVf_BREAK;
2240 marked = TRUE;
2241 }
2242 else if (!marked) {
2243 /* don't check RH element if no SVf_BREAK flags set yet */
2244 if (!lcount)
2245 break;
2246 continue;
2247 }
2248 }
2249
2250 /* see if corresponding RH element needs copying */
2251
2252 assert(marked);
2253 svr = *relem;
2254 assert(svr);
2255
2256 if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
2257 U32 brk = (SvFLAGS(svr) & SVf_BREAK);
2258
2259 #ifdef DEBUGGING
2260 if (fake) {
2261 /* op_dump(PL_op); */
2262 Perl_croak(aTHX_
2263 "panic: aassign skipped needed copy of common RH elem %"
2264 UVuf, (UV)(relem - firstrelem));
2265 }
2266 #endif
2267
2268 TAINT_NOT; /* Each item is independent */
2269
2270 /* Dear TODO test in t/op/sort.t, I love you.
2271 (It's relying on a panic, not a "semi-panic" from newSVsv()
2272 and then an assertion failure below.) */
2273 if (UNLIKELY(SvIS_FREED(svr))) {
2274 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
2275 (void*)svr);
2276 }
2277 /* avoid break flag while copying; otherwise COW etc
2278 * disabled... */
2279 SvFLAGS(svr) &= ~SVf_BREAK;
2280 /* Not newSVsv(), as it does not allow copy-on-write,
2281 resulting in wasteful copies.
2282 Also, we use SV_NOSTEAL in case the SV is used more than
2283 once, e.g. (...) = (f())[0,0]
2284 Where the same SV appears twice on the RHS without a ref
2285 count bump. (Although I suspect that the SV won't be
2286 stealable here anyway - DAPM).
2287 */
2288 *relem = sv_mortalcopy_flags(svr,
2289 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2290 /* ... but restore afterwards in case it's needed again,
2291 * e.g. ($a,$b,$c) = (1,$a,$a)
2292 */
2293 SvFLAGS(svr) |= brk;
2294 }
2295
2296 if (!lcount)
2297 break;
2298 }
2299
2300 if (!marked)
2301 return;
2302
2303 /*unmark LHS */
2304
2305 while (lelem > firstlelem) {
2306 SV * const svl = *(--lelem);
2307 if (svl)
2308 SvFLAGS(svl) &= ~SVf_BREAK;
2309 }
2310 }
2311
2312
2313
PP(pp_aassign)2314 PP(pp_aassign)
2315 {
2316 dSP;
2317 SV **lastlelem = PL_stack_sp;
2318 SV **lastrelem = PL_stack_base + POPMARK;
2319 SV **firstrelem = PL_stack_base + POPMARK + 1;
2320 SV **firstlelem = lastrelem + 1;
2321
2322 SV **relem;
2323 SV **lelem;
2324 U8 gimme;
2325 /* PL_delaymagic is restored by JMPENV_POP on dieing, so we
2326 * only need to save locally, not on the save stack */
2327 U16 old_delaymagic = PL_delaymagic;
2328 #ifdef DEBUGGING
2329 bool fake = 0;
2330 #endif
2331
2332 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
2333
2334 /* If there's a common identifier on both sides we have to take
2335 * special care that assigning the identifier on the left doesn't
2336 * clobber a value on the right that's used later in the list.
2337 */
2338
2339 /* at least 2 LH and RH elements, or commonality isn't an issue */
2340 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2341 for (relem = firstrelem+1; relem <= lastrelem; relem++) {
2342 if (SvGMAGICAL(*relem))
2343 goto do_scan;
2344 }
2345 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2346 if (*lelem && SvSMAGICAL(*lelem))
2347 goto do_scan;
2348 }
2349 if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
2350 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
2351 /* skip the scan if all scalars have a ref count of 1 */
2352 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2353 SV *sv = *lelem;
2354 if (!sv || SvREFCNT(sv) == 1)
2355 continue;
2356 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
2357 goto do_scan;
2358 break;
2359 }
2360 }
2361 else {
2362 do_scan:
2363 S_aassign_copy_common(aTHX_
2364 firstlelem, lastlelem, firstrelem, lastrelem
2365 #ifdef DEBUGGING
2366 , fake
2367 #endif
2368 );
2369 }
2370 }
2371 }
2372 #ifdef DEBUGGING
2373 else {
2374 /* on debugging builds, do the scan even if we've concluded we
2375 * don't need to, then panic if we find commonality. Note that the
2376 * scanner assumes at least 2 elements */
2377 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2378 fake = 1;
2379 goto do_scan;
2380 }
2381 }
2382 #endif
2383
2384 gimme = GIMME_V;
2385 relem = firstrelem;
2386 lelem = firstlelem;
2387
2388 if (relem > lastrelem)
2389 goto no_relems;
2390
2391 /* first lelem loop while there are still relems */
2392 while (LIKELY(lelem <= lastlelem)) {
2393 bool alias = FALSE;
2394 SV *lsv = *lelem++;
2395
2396 TAINT_NOT; /* Each item stands on its own, taintwise. */
2397
2398 assert(relem <= lastrelem);
2399 if (UNLIKELY(!lsv)) {
2400 alias = TRUE;
2401 lsv = *lelem++;
2402 ASSUME(SvTYPE(lsv) == SVt_PVAV);
2403 }
2404
2405 switch (SvTYPE(lsv)) {
2406 case SVt_PVAV: {
2407 SV **svp;
2408 SSize_t i;
2409 SSize_t tmps_base;
2410 SSize_t nelems = lastrelem - relem + 1;
2411 AV *ary = MUTABLE_AV(lsv);
2412
2413 /* Assigning to an aggregate is tricky. First there is the
2414 * issue of commonality, e.g. @a = ($a[0]). Since the
2415 * stack isn't refcounted, clearing @a prior to storing
2416 * elements will free $a[0]. Similarly with
2417 * sub FETCH { $status[$_[1]] } @status = @tied[0,1];
2418 *
2419 * The way to avoid these issues is to make the copy of each
2420 * SV (and we normally store a *copy* in the array) *before*
2421 * clearing the array. But this has a problem in that
2422 * if the code croaks during copying, the not-yet-stored copies
2423 * could leak. One way to avoid this is to make all the copies
2424 * mortal, but that's quite expensive.
2425 *
2426 * The current solution to these issues is to use a chunk
2427 * of the tmps stack as a temporary refcounted-stack. SVs
2428 * will be put on there during processing to avoid leaks,
2429 * but will be removed again before the end of this block,
2430 * so free_tmps() is never normally called. Also, the
2431 * sv_refcnt of the SVs doesn't have to be manipulated, since
2432 * the ownership of 1 reference count is transferred directly
2433 * from the tmps stack to the AV when the SV is stored.
2434 *
2435 * We disarm slots in the temps stack by storing PL_sv_undef
2436 * there: it doesn't matter if that SV's refcount is
2437 * repeatedly decremented during a croak. But usually this is
2438 * only an interim measure. By the end of this code block
2439 * we try where possible to not leave any PL_sv_undef's on the
2440 * tmps stack e.g. by shuffling newer entries down.
2441 *
2442 * There is one case where we don't copy: non-magical
2443 * SvTEMP(sv)'s with a ref count of 1. The only owner of these
2444 * is on the tmps stack, so its safe to directly steal the SV
2445 * rather than copying. This is common in things like function
2446 * returns, map etc, which all return a list of such SVs.
2447 *
2448 * Note however something like @a = (f())[0,0], where there is
2449 * a danger of the same SV being shared: this avoided because
2450 * when the SV is stored as $a[0], its ref count gets bumped,
2451 * so the RC==1 test fails and the second element is copied
2452 * instead.
2453 *
2454 * We also use one slot in the tmps stack to hold an extra
2455 * ref to the array, to ensure it doesn't get prematurely
2456 * freed. Again, this is removed before the end of this block.
2457 *
2458 * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
2459 * @a = ($a[0]) case, but the current implementation uses the
2460 * same algorithm regardless, so ignores that flag. (It *is*
2461 * used in the hash branch below, however).
2462 */
2463
2464 /* Reserve slots for ary, plus the elems we're about to copy,
2465 * then protect ary and temporarily void the remaining slots
2466 * with &PL_sv_undef */
2467 EXTEND_MORTAL(nelems + 1);
2468 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
2469 tmps_base = PL_tmps_ix + 1;
2470 for (i = 0; i < nelems; i++)
2471 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2472 PL_tmps_ix += nelems;
2473
2474 /* Make a copy of each RHS elem and save on the tmps_stack
2475 * (or pass through where we can optimise away the copy) */
2476
2477 if (UNLIKELY(alias)) {
2478 U32 lval = (gimme == G_LIST)
2479 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
2480 for (svp = relem; svp <= lastrelem; svp++) {
2481 SV *rsv = *svp;
2482
2483 SvGETMAGIC(rsv);
2484 if (!SvROK(rsv))
2485 DIE(aTHX_ "Assigned value is not a reference");
2486 if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
2487 /* diag_listed_as: Assigned value is not %s reference */
2488 DIE(aTHX_
2489 "Assigned value is not a SCALAR reference");
2490 if (lval)
2491 *svp = rsv = sv_mortalcopy(rsv);
2492 /* XXX else check for weak refs? */
2493 rsv = SvREFCNT_inc_NN(SvRV(rsv));
2494 assert(tmps_base <= PL_tmps_max);
2495 PL_tmps_stack[tmps_base++] = rsv;
2496 }
2497 }
2498 else {
2499 for (svp = relem; svp <= lastrelem; svp++) {
2500 SV *rsv = *svp;
2501
2502 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2503 /* can skip the copy */
2504 SvREFCNT_inc_simple_void_NN(rsv);
2505 SvTEMP_off(rsv);
2506 }
2507 else {
2508 SV *nsv;
2509 /* see comment in S_aassign_copy_common about
2510 * SV_NOSTEAL */
2511 nsv = newSVsv_flags(rsv,
2512 (SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC));
2513 rsv = *svp = nsv;
2514 }
2515
2516 assert(tmps_base <= PL_tmps_max);
2517 PL_tmps_stack[tmps_base++] = rsv;
2518 }
2519 }
2520
2521 if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
2522 av_clear(ary);
2523
2524 /* store in the array, the SVs that are in the tmps stack */
2525
2526 tmps_base -= nelems;
2527
2528 if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
2529 /* for arrays we can't cheat with, use the official API */
2530 av_extend(ary, nelems - 1);
2531 for (i = 0; i < nelems; i++) {
2532 SV **svp = &(PL_tmps_stack[tmps_base + i]);
2533 SV *rsv = *svp;
2534 /* A tied store won't take ownership of rsv, so keep
2535 * the 1 refcnt on the tmps stack; otherwise disarm
2536 * the tmps stack entry */
2537 if (av_store(ary, i, rsv))
2538 *svp = &PL_sv_undef;
2539 /* av_store() may have added set magic to rsv */;
2540 SvSETMAGIC(rsv);
2541 }
2542 /* disarm ary refcount: see comments below about leak */
2543 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2544 }
2545 else {
2546 /* directly access/set the guts of the AV */
2547 SSize_t fill = nelems - 1;
2548 if (fill > AvMAX(ary))
2549 av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
2550 &AvARRAY(ary));
2551 AvFILLp(ary) = fill;
2552 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
2553 /* Quietly remove all the SVs from the tmps stack slots,
2554 * since ary has now taken ownership of the refcnt.
2555 * Also remove ary: which will now leak if we die before
2556 * the SvREFCNT_dec_NN(ary) below */
2557 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2558 Move(&PL_tmps_stack[tmps_base + nelems],
2559 &PL_tmps_stack[tmps_base - 1],
2560 PL_tmps_ix - (tmps_base + nelems) + 1,
2561 SV*);
2562 PL_tmps_ix -= (nelems + 1);
2563 }
2564
2565 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
2566 /* its assumed @ISA set magic can't die and leak ary */
2567 SvSETMAGIC(MUTABLE_SV(ary));
2568 SvREFCNT_dec_NN(ary);
2569
2570 relem = lastrelem + 1;
2571 goto no_relems;
2572 }
2573
2574 case SVt_PVHV: { /* normal hash */
2575
2576 SV **svp;
2577 bool dirty_tmps;
2578 SSize_t i;
2579 SSize_t tmps_base;
2580 SSize_t nelems = lastrelem - relem + 1;
2581 HV *hash = MUTABLE_HV(lsv);
2582
2583 if (UNLIKELY(nelems & 1)) {
2584 do_oddball(lastrelem, relem);
2585 /* we have firstlelem to reuse, it's not needed any more */
2586 *++lastrelem = &PL_sv_undef;
2587 nelems++;
2588 }
2589
2590 /* See the SVt_PVAV branch above for a long description of
2591 * how the following all works. The main difference for hashes
2592 * is that we treat keys and values separately (and have
2593 * separate loops for them): as for arrays, values are always
2594 * copied (except for the SvTEMP optimisation), since they
2595 * need to be stored in the hash; while keys are only
2596 * processed where they might get prematurely freed or
2597 * whatever. */
2598
2599 /* tmps stack slots:
2600 * * reserve a slot for the hash keepalive;
2601 * * reserve slots for the hash values we're about to copy;
2602 * * preallocate for the keys we'll possibly copy or refcount bump
2603 * later;
2604 * then protect hash and temporarily void the remaining
2605 * value slots with &PL_sv_undef */
2606 EXTEND_MORTAL(nelems + 1);
2607
2608 /* convert to number of key/value pairs */
2609 nelems >>= 1;
2610
2611 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
2612 tmps_base = PL_tmps_ix + 1;
2613 for (i = 0; i < nelems; i++)
2614 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2615 PL_tmps_ix += nelems;
2616
2617 /* Make a copy of each RHS hash value and save on the tmps_stack
2618 * (or pass through where we can optimise away the copy) */
2619
2620 for (svp = relem + 1; svp <= lastrelem; svp += 2) {
2621 SV *rsv = *svp;
2622
2623 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2624 /* can skip the copy */
2625 SvREFCNT_inc_simple_void_NN(rsv);
2626 SvTEMP_off(rsv);
2627 }
2628 else {
2629 SV *nsv;
2630 /* see comment in S_aassign_copy_common about
2631 * SV_NOSTEAL */
2632 nsv = newSVsv_flags(rsv,
2633 (SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC));
2634 rsv = *svp = nsv;
2635 }
2636
2637 assert(tmps_base <= PL_tmps_max);
2638 PL_tmps_stack[tmps_base++] = rsv;
2639 }
2640 tmps_base -= nelems;
2641
2642
2643 /* possibly protect keys */
2644
2645 if (UNLIKELY(gimme == G_LIST)) {
2646 /* handle e.g.
2647 * @a = ((%h = ($$r, 1)), $r = "x");
2648 * $_++ for %h = (1,2,3,4);
2649 */
2650 EXTEND_MORTAL(nelems);
2651 for (svp = relem; svp <= lastrelem; svp += 2)
2652 *svp = sv_mortalcopy_flags(*svp,
2653 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2654 }
2655 else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
2656 /* for possible commonality, e.g.
2657 * %h = ($h{a},1)
2658 * avoid premature freeing RHS keys by mortalising
2659 * them.
2660 * For a magic element, make a copy so that its magic is
2661 * called *before* the hash is emptied (which may affect
2662 * a tied value for example).
2663 * In theory we should check for magic keys in all
2664 * cases, not just under OPpASSIGN_COMMON_AGG, but in
2665 * practice, !OPpASSIGN_COMMON_AGG implies only
2666 * constants or padtmps on the RHS.
2667 */
2668 EXTEND_MORTAL(nelems);
2669 for (svp = relem; svp <= lastrelem; svp += 2) {
2670 SV *rsv = *svp;
2671 if (UNLIKELY(SvGMAGICAL(rsv))) {
2672 SSize_t n;
2673 *svp = sv_mortalcopy_flags(*svp,
2674 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2675 /* allow other branch to continue pushing
2676 * onto tmps stack without checking each time */
2677 n = (lastrelem - relem) >> 1;
2678 EXTEND_MORTAL(n);
2679 }
2680 else
2681 PL_tmps_stack[++PL_tmps_ix] =
2682 SvREFCNT_inc_simple_NN(rsv);
2683 }
2684 }
2685
2686 if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
2687 hv_clear(hash);
2688
2689 /* "nelems" was converted to the number of pairs earlier. */
2690 if (nelems > PERL_HASH_DEFAULT_HvMAX) {
2691 hv_ksplit(hash, nelems);
2692 }
2693
2694 /* now assign the keys and values to the hash */
2695
2696 dirty_tmps = FALSE;
2697
2698 if (UNLIKELY(gimme == G_LIST)) {
2699 /* @a = (%h = (...)) etc */
2700 SV **svp;
2701 SV **topelem = relem;
2702
2703 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2704 SV *key = *svp++;
2705 SV *val = *svp;
2706 /* remove duplicates from list we return */
2707 if (!hv_exists_ent(hash, key, 0)) {
2708 /* copy key back: possibly to an earlier
2709 * stack location if we encountered dups earlier,
2710 * The values will be updated later
2711 */
2712 *topelem = key;
2713 topelem += 2;
2714 }
2715 /* A tied store won't take ownership of val, so keep
2716 * the 1 refcnt on the tmps stack; otherwise disarm
2717 * the tmps stack entry */
2718 if (hv_store_ent(hash, key, val, 0))
2719 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2720 else
2721 dirty_tmps = TRUE;
2722 /* hv_store_ent() may have added set magic to val */;
2723 SvSETMAGIC(val);
2724 }
2725 if (topelem < svp) {
2726 /* at this point we have removed the duplicate key/value
2727 * pairs from the stack, but the remaining values may be
2728 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
2729 * the (a 2), but the stack now probably contains
2730 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
2731 * obliterates the earlier key. So refresh all values. */
2732 lastrelem = topelem - 1;
2733 while (relem < lastrelem) {
2734 HE *he;
2735 he = hv_fetch_ent(hash, *relem++, 0, 0);
2736 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
2737 }
2738 }
2739 }
2740 else {
2741 SV **svp;
2742 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2743 SV *key = *svp++;
2744 SV *val = *svp;
2745 if (hv_store_ent(hash, key, val, 0))
2746 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2747 else
2748 dirty_tmps = TRUE;
2749 /* hv_store_ent() may have added set magic to val */;
2750 SvSETMAGIC(val);
2751 }
2752 }
2753
2754 if (dirty_tmps) {
2755 /* there are still some 'live' recounts on the tmps stack
2756 * - usually caused by storing into a tied hash. So let
2757 * free_tmps() do the proper but slow job later.
2758 * Just disarm hash refcount: see comments below about leak
2759 */
2760 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2761 }
2762 else {
2763 /* Quietly remove all the SVs from the tmps stack slots,
2764 * since hash has now taken ownership of the refcnt.
2765 * Also remove hash: which will now leak if we die before
2766 * the SvREFCNT_dec_NN(hash) below */
2767 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2768 Move(&PL_tmps_stack[tmps_base + nelems],
2769 &PL_tmps_stack[tmps_base - 1],
2770 PL_tmps_ix - (tmps_base + nelems) + 1,
2771 SV*);
2772 PL_tmps_ix -= (nelems + 1);
2773 }
2774
2775 SvREFCNT_dec_NN(hash);
2776
2777 relem = lastrelem + 1;
2778 goto no_relems;
2779 }
2780
2781 default:
2782 if (!SvIMMORTAL(lsv)) {
2783 SV *ref;
2784
2785 if (UNLIKELY(
2786 SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
2787 (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
2788 ))
2789 Perl_warner(aTHX_
2790 packWARN(WARN_MISC),
2791 "Useless assignment to a temporary"
2792 );
2793
2794 /* avoid freeing $$lsv if it might be needed for further
2795 * elements, e.g. ($ref, $foo) = (1, $$ref) */
2796 if ( SvROK(lsv)
2797 && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
2798 && lelem <= lastlelem
2799 ) {
2800 SSize_t ix;
2801 SvREFCNT_inc_simple_void_NN(ref);
2802 /* an unrolled sv_2mortal */
2803 ix = ++PL_tmps_ix;
2804 if (UNLIKELY(ix >= PL_tmps_max))
2805 /* speculatively grow enough to cover other
2806 * possible refs */
2807 (void)tmps_grow_p(ix + (lastlelem - lelem));
2808 PL_tmps_stack[ix] = ref;
2809 }
2810
2811 sv_setsv(lsv, *relem);
2812 *relem = lsv;
2813 SvSETMAGIC(lsv);
2814 }
2815 if (++relem > lastrelem)
2816 goto no_relems;
2817 break;
2818 } /* switch */
2819 } /* while */
2820
2821
2822 no_relems:
2823
2824 /* simplified lelem loop for when there are no relems left */
2825 while (LIKELY(lelem <= lastlelem)) {
2826 SV *lsv = *lelem++;
2827
2828 TAINT_NOT; /* Each item stands on its own, taintwise. */
2829
2830 if (UNLIKELY(!lsv)) {
2831 lsv = *lelem++;
2832 ASSUME(SvTYPE(lsv) == SVt_PVAV);
2833 }
2834
2835 switch (SvTYPE(lsv)) {
2836 case SVt_PVAV:
2837 if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
2838 av_clear((AV*)lsv);
2839 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
2840 SvSETMAGIC(lsv);
2841 }
2842 break;
2843
2844 case SVt_PVHV:
2845 if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
2846 hv_clear((HV*)lsv);
2847 break;
2848
2849 default:
2850 if (!SvIMMORTAL(lsv)) {
2851 sv_set_undef(lsv);
2852 SvSETMAGIC(lsv);
2853 }
2854 *relem++ = lsv;
2855 break;
2856 } /* switch */
2857 } /* while */
2858
2859 TAINT_NOT; /* result of list assign isn't tainted */
2860
2861 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
2862 /* Will be used to set PL_tainting below */
2863 Uid_t tmp_uid = PerlProc_getuid();
2864 Uid_t tmp_euid = PerlProc_geteuid();
2865 Gid_t tmp_gid = PerlProc_getgid();
2866 Gid_t tmp_egid = PerlProc_getegid();
2867
2868 /* XXX $> et al currently silently ignore failures */
2869 if (PL_delaymagic & DM_UID) {
2870 #ifdef HAS_SETRESUID
2871 PERL_UNUSED_RESULT(
2872 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2873 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
2874 (Uid_t)-1));
2875 #elif defined(HAS_SETREUID)
2876 PERL_UNUSED_RESULT(
2877 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2878 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
2879 #else
2880 # ifdef HAS_SETRUID
2881 if ((PL_delaymagic & DM_UID) == DM_RUID) {
2882 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
2883 PL_delaymagic &= ~DM_RUID;
2884 }
2885 # endif /* HAS_SETRUID */
2886 # ifdef HAS_SETEUID
2887 if ((PL_delaymagic & DM_UID) == DM_EUID) {
2888 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
2889 PL_delaymagic &= ~DM_EUID;
2890 }
2891 # endif /* HAS_SETEUID */
2892 if (PL_delaymagic & DM_UID) {
2893 if (PL_delaymagic_uid != PL_delaymagic_euid)
2894 DIE(aTHX_ "No setreuid available");
2895 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
2896 }
2897 #endif /* HAS_SETRESUID */
2898
2899 tmp_uid = PerlProc_getuid();
2900 tmp_euid = PerlProc_geteuid();
2901 }
2902 /* XXX $> et al currently silently ignore failures */
2903 if (PL_delaymagic & DM_GID) {
2904 #ifdef HAS_SETRESGID
2905 PERL_UNUSED_RESULT(
2906 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2907 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
2908 (Gid_t)-1));
2909 #elif defined(HAS_SETREGID)
2910 PERL_UNUSED_RESULT(
2911 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2912 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
2913 #else
2914 # ifdef HAS_SETRGID
2915 if ((PL_delaymagic & DM_GID) == DM_RGID) {
2916 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
2917 PL_delaymagic &= ~DM_RGID;
2918 }
2919 # endif /* HAS_SETRGID */
2920 # ifdef HAS_SETEGID
2921 if ((PL_delaymagic & DM_GID) == DM_EGID) {
2922 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
2923 PL_delaymagic &= ~DM_EGID;
2924 }
2925 # endif /* HAS_SETEGID */
2926 if (PL_delaymagic & DM_GID) {
2927 if (PL_delaymagic_gid != PL_delaymagic_egid)
2928 DIE(aTHX_ "No setregid available");
2929 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
2930 }
2931 #endif /* HAS_SETRESGID */
2932
2933 tmp_gid = PerlProc_getgid();
2934 tmp_egid = PerlProc_getegid();
2935 }
2936 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
2937 #ifdef NO_TAINT_SUPPORT
2938 PERL_UNUSED_VAR(tmp_uid);
2939 PERL_UNUSED_VAR(tmp_euid);
2940 PERL_UNUSED_VAR(tmp_gid);
2941 PERL_UNUSED_VAR(tmp_egid);
2942 #endif
2943 }
2944 PL_delaymagic = old_delaymagic;
2945
2946 if (gimme == G_VOID)
2947 SP = firstrelem - 1;
2948 else if (gimme == G_SCALAR) {
2949 SP = firstrelem;
2950 EXTEND(SP,1);
2951 if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
2952 SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
2953 else {
2954 dTARGET;
2955 SETi(firstlelem - firstrelem);
2956 }
2957 }
2958 else
2959 SP = relem - 1;
2960
2961 RETURN;
2962 }
2963
PP(pp_qr)2964 PP(pp_qr)
2965 {
2966 dSP;
2967 PMOP * const pm = cPMOP;
2968 REGEXP * rx = PM_GETRE(pm);
2969 regexp *prog = ReANY(rx);
2970 SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
2971 SV * const rv = newSV_type_mortal(SVt_IV);
2972 CV **cvp;
2973 CV *cv;
2974
2975 SvUPGRADE(rv, SVt_IV);
2976 /* For a subroutine describing itself as "This is a hacky workaround" I'm
2977 loathe to use it here, but it seems to be the right fix. Or close.
2978 The key part appears to be that it's essential for pp_qr to return a new
2979 object (SV), which implies that there needs to be an effective way to
2980 generate a new SV from the existing SV that is pre-compiled in the
2981 optree. */
2982 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
2983 SvROK_on(rv);
2984
2985 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
2986 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
2987 *cvp = cv_clone(cv);
2988 SvREFCNT_dec_NN(cv);
2989 }
2990
2991 if (pkg) {
2992 HV *const stash = gv_stashsv(pkg, GV_ADD);
2993 SvREFCNT_dec_NN(pkg);
2994 (void)sv_bless(rv, stash);
2995 }
2996
2997 if (UNLIKELY(RXp_ISTAINTED(prog))) {
2998 SvTAINTED_on(rv);
2999 SvTAINTED_on(SvRV(rv));
3000 }
3001 XPUSHs(rv);
3002 RETURN;
3003 }
3004
3005 STATIC bool
S_are_we_in_Debug_EXECUTE_r(pTHX)3006 S_are_we_in_Debug_EXECUTE_r(pTHX)
3007 {
3008 /* Given a 'use re' is in effect, does it ask for outputting execution
3009 * debug info?
3010 *
3011 * This is separated from the sole place it's called, an inline function,
3012 * because it is the large-ish slow portion of the function */
3013
3014 DECLARE_AND_GET_RE_DEBUG_FLAGS_NON_REGEX;
3015
3016 return cBOOL(RE_DEBUG_FLAG(RE_DEBUG_EXECUTE_MASK));
3017 }
3018
3019 PERL_STATIC_INLINE bool
S_should_we_output_Debug_r(pTHX_ regexp * prog)3020 S_should_we_output_Debug_r(pTHX_ regexp *prog)
3021 {
3022 PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R;
3023
3024 /* pp_match can output regex debugging info. This function returns a
3025 * boolean as to whether or not it should.
3026 *
3027 * Under -Dr, it should. Any reasonable compiler will optimize this bit of
3028 * code away on non-debugging builds. */
3029 if (UNLIKELY(DEBUG_r_TEST)) {
3030 return TRUE;
3031 }
3032
3033 /* If the regex engine is using the non-debugging execution routine, then
3034 * no debugging should be output. Same if the field is NULL that pluggable
3035 * engines are not supposed to fill. */
3036 if ( LIKELY(prog->engine->exec == &Perl_regexec_flags)
3037 || UNLIKELY(prog->engine->op_comp == NULL))
3038 {
3039 return FALSE;
3040 }
3041
3042 /* Otherwise have to check */
3043 return S_are_we_in_Debug_EXECUTE_r(aTHX);
3044 }
3045
PP(pp_match)3046 PP(pp_match)
3047 {
3048 dSP; dTARG;
3049 PMOP *pm = cPMOP;
3050 PMOP *dynpm = pm;
3051 const char *s;
3052 const char *strend;
3053 SSize_t curpos = 0; /* initial pos() or current $+[0] */
3054 I32 global;
3055 U8 r_flags = 0;
3056 const char *truebase; /* Start of string */
3057 REGEXP *rx = PM_GETRE(pm);
3058 regexp *prog = ReANY(rx);
3059 bool rxtainted;
3060 const U8 gimme = GIMME_V;
3061 STRLEN len;
3062 const I32 oldsave = PL_savestack_ix;
3063 I32 had_zerolen = 0;
3064 MAGIC *mg = NULL;
3065
3066 if (PL_op->op_flags & OPf_STACKED)
3067 TARG = POPs;
3068 else {
3069 if (ARGTARG)
3070 GETTARGET;
3071 else {
3072 TARG = DEFSV;
3073 }
3074 EXTEND(SP,1);
3075 }
3076
3077 PUTBACK; /* EVAL blocks need stack_sp. */
3078 /* Skip get-magic if this is a qr// clone, because regcomp has
3079 already done it. */
3080 truebase = prog->mother_re
3081 ? SvPV_nomg_const(TARG, len)
3082 : SvPV_const(TARG, len);
3083 if (!truebase)
3084 DIE(aTHX_ "panic: pp_match");
3085 strend = truebase + len;
3086 rxtainted = (RXp_ISTAINTED(prog) ||
3087 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
3088 TAINT_NOT;
3089
3090 /* We need to know this in case we fail out early - pos() must be reset */
3091 global = dynpm->op_pmflags & PMf_GLOBAL;
3092
3093 /* PMdf_USED is set after a ?? matches once */
3094 if (
3095 #ifdef USE_ITHREADS
3096 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
3097 #else
3098 pm->op_pmflags & PMf_USED
3099 #endif
3100 ) {
3101 if (UNLIKELY(should_we_output_Debug_r(prog))) {
3102 PerlIO_printf(Perl_debug_log, "?? already matched once");
3103 }
3104 goto nope;
3105 }
3106
3107 /* handle the empty pattern */
3108 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
3109 if (PL_curpm == PL_reg_curpm) {
3110 if (PL_curpm_under) {
3111 if (PL_curpm_under == PL_reg_curpm) {
3112 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
3113 } else {
3114 pm = PL_curpm_under;
3115 }
3116 }
3117 } else {
3118 pm = PL_curpm;
3119 }
3120 rx = PM_GETRE(pm);
3121 prog = ReANY(rx);
3122 }
3123
3124 if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
3125 if (UNLIKELY(should_we_output_Debug_r(prog))) {
3126 PerlIO_printf(Perl_debug_log,
3127 "String shorter than min possible regex match (%zd < %zd)\n",
3128 len, RXp_MINLEN(prog));
3129 }
3130 goto nope;
3131 }
3132
3133 /* get pos() if //g */
3134 if (global) {
3135 mg = mg_find_mglob(TARG);
3136 if (mg && mg->mg_len >= 0) {
3137 curpos = MgBYTEPOS(mg, TARG, truebase, len);
3138 /* last time pos() was set, it was zero-length match */
3139 if (mg->mg_flags & MGf_MINMATCH)
3140 had_zerolen = 1;
3141 }
3142 }
3143
3144 #ifdef PERL_SAWAMPERSAND
3145 if ( RXp_NPARENS(prog)
3146 || PL_sawampersand
3147 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
3148 || (dynpm->op_pmflags & PMf_KEEPCOPY)
3149 )
3150 #endif
3151 {
3152 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
3153 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
3154 * only on the first iteration. Therefore we need to copy $' as well
3155 * as $&, to make the rest of the string available for captures in
3156 * subsequent iterations */
3157 if (! (global && gimme == G_LIST))
3158 r_flags |= REXEC_COPY_SKIP_POST;
3159 };
3160 #ifdef PERL_SAWAMPERSAND
3161 if (dynpm->op_pmflags & PMf_KEEPCOPY)
3162 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
3163 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
3164 #endif
3165
3166 s = truebase;
3167
3168 play_it_again:
3169 if (global)
3170 s = truebase + curpos;
3171
3172 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
3173 had_zerolen, TARG, NULL, r_flags))
3174 goto nope;
3175
3176 PL_curpm = pm;
3177 if (dynpm->op_pmflags & PMf_ONCE)
3178 #ifdef USE_ITHREADS
3179 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
3180 #else
3181 dynpm->op_pmflags |= PMf_USED;
3182 #endif
3183
3184 if (rxtainted)
3185 RXp_MATCH_TAINTED_on(prog);
3186 TAINT_IF(RXp_MATCH_TAINTED(prog));
3187
3188 /* update pos */
3189
3190 if (global && (gimme != G_LIST || (dynpm->op_pmflags & PMf_CONTINUE))) {
3191 if (!mg)
3192 mg = sv_magicext_mglob(TARG);
3193 MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS_END(prog,0));
3194 if (RXp_ZERO_LEN(prog))
3195 mg->mg_flags |= MGf_MINMATCH;
3196 else
3197 mg->mg_flags &= ~MGf_MINMATCH;
3198 }
3199
3200 if ((!RXp_NPARENS(prog) && !global) || gimme != G_LIST) {
3201 LEAVE_SCOPE(oldsave);
3202 RETPUSHYES;
3203 }
3204
3205 /* push captures on stack */
3206
3207 {
3208 const I32 logical_nparens = RXp_LOGICAL_NPARENS(prog);
3209 /* This following statement is *devious* code. If we are in a global
3210 match and the pattern has no parens in it we should return $&
3211 (offset pair 0). So we set logical_paren to 1 when we should return
3212 $&, otherwise we set it to 0.
3213
3214 This allows us to simply add logical_nparens to logical_paren to
3215 compute the number of elements we are going to return.
3216
3217 In the loop intit we "not" it with: logical_paren = !logical_paren
3218 which results in it being 0 inside the loop when we want to return
3219 $&, and results in it being 1 when we want to return the parens.
3220 Thus we either loop over 1..logical_nparens, or just over 0.
3221
3222 This is an elegant way to do this code wise, but is super devious
3223 and potentially confusing. When I first saw this logic I thought
3224 "WTF?". But it makes sense after you poke it a while.
3225
3226 Frankly I probably would have done it differently, but it works so
3227 I am leaving it. - Yves */
3228 I32 logical_paren = (global && !logical_nparens) ? 1 : 0;
3229 I32 *l2p = RXp_LOGICAL_TO_PARNO(prog);
3230 /* this is used to step through the physical parens associated
3231 * with a given logical paren. */
3232 I32 *p2l_next = RXp_PARNO_TO_LOGICAL_NEXT(prog);
3233
3234 SPAGAIN; /* EVAL blocks could move the stack. */
3235 EXTEND(SP, logical_nparens + logical_paren); /* devious code ... */
3236 EXTEND_MORTAL(logical_nparens + logical_paren); /* ... see above */
3237
3238 /* loop over the logical parens in the pattern. This may not
3239 correspond to the actual paren checked, as branch reset may
3240 mean that there is more than one paren "behind" the logical
3241 parens. Eg, in /(?|(a)|(b))/ there are two parens, but one
3242 logical paren. */
3243 for (logical_paren = !logical_paren;
3244 logical_paren <= logical_nparens;
3245 logical_paren++)
3246 {
3247 /* now convert the logical_paren to the physical parens which
3248 are "behind" it. If branch reset was not used then
3249 physical_paren and logical_paren are the same as each other
3250 and we will only perform one iteration of the loop */
3251 I32 phys_paren = l2p ? l2p[logical_paren] : logical_paren;
3252 SSize_t offs_start, offs_end;
3253 /* We check the loop invariants below and break out of the loop
3254 explicitly if our checks fail, so we use while (1) here to
3255 avoid double testing a conditional. */
3256 while (1) {
3257 /* Check end offset first, as the start might be >=0 even
3258 though the end is -1, so testing the end first helps
3259 use avoid the start check. Really we should be able to
3260 get away with ONLY testing the end, but testing both
3261 doesn't hurt much and preserves sanity. */
3262 if (((offs_end = RXp_OFFS_END(prog, phys_paren)) != -1) &&
3263 ((offs_start = RXp_OFFS_START(prog, phys_paren)) != -1))
3264 {
3265 const SSize_t len = offs_end - offs_start;
3266 const char * const s = offs_start + truebase;
3267 if ( UNLIKELY( len < 0 || len > strend - s) ) {
3268 DIE(aTHX_ "panic: pp_match start/end pointers, paren=%" I32df ", "
3269 "start=%zd, end=%zd, s=%p, strend=%p, len=%zd",
3270 phys_paren, offs_start, offs_end, s, strend, len);
3271 }
3272 PUSHs(newSVpvn_flags(s, len,
3273 (DO_UTF8(TARG))
3274 ? SVf_UTF8|SVs_TEMP
3275 : SVs_TEMP)
3276 );
3277 break;
3278 } else if (!p2l_next || !(phys_paren = p2l_next[phys_paren])) {
3279 /* Either logical_paren and phys_paren are the same and
3280 we won't have a p2l_next, or they aren't the same (and
3281 we do have a p2l_next) but we have exhausted the list
3282 of physical parens associated with this logical paren.
3283 Either way we are done, and we can push undef and break
3284 out of the loop. */
3285 PUSHs(sv_newmortal());
3286 break;
3287 }
3288 }
3289 }
3290 if (global) {
3291 curpos = (UV)RXp_OFFS_END(prog,0);
3292 had_zerolen = RXp_ZERO_LEN(prog);
3293 PUTBACK; /* EVAL blocks may use stack */
3294 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
3295 goto play_it_again;
3296 }
3297 LEAVE_SCOPE(oldsave);
3298 RETURN;
3299 }
3300 NOT_REACHED; /* NOTREACHED */
3301
3302 nope:
3303 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
3304 if (!mg)
3305 mg = mg_find_mglob(TARG);
3306 if (mg)
3307 mg->mg_len = -1;
3308 }
3309 LEAVE_SCOPE(oldsave);
3310 if (gimme == G_LIST)
3311 RETURN;
3312 RETPUSHNO;
3313 }
3314
3315 OP *
Perl_do_readline(pTHX)3316 Perl_do_readline(pTHX)
3317 {
3318 dSP; dTARGETSTACKED;
3319 SV *sv;
3320 STRLEN tmplen = 0;
3321 STRLEN offset;
3322 PerlIO *fp;
3323 IO * const io = GvIO(PL_last_in_gv);
3324 const I32 type = PL_op->op_type;
3325 const U8 gimme = GIMME_V;
3326
3327 if (io) {
3328 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
3329 if (mg) {
3330 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
3331 if (gimme == G_SCALAR) {
3332 SPAGAIN;
3333 SvSetSV_nosteal(TARG, TOPs);
3334 SETTARG;
3335 }
3336 return NORMAL;
3337 }
3338 }
3339 fp = NULL;
3340 if (io) {
3341 fp = IoIFP(io);
3342 if (!fp) {
3343 if (IoFLAGS(io) & IOf_ARGV) {
3344 if (IoFLAGS(io) & IOf_START) {
3345 IoLINES(io) = 0;
3346 if (av_count(GvAVn(PL_last_in_gv)) == 0) {
3347 IoFLAGS(io) &= ~IOf_START;
3348 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
3349 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
3350 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3351 SvSETMAGIC(GvSV(PL_last_in_gv));
3352 fp = IoIFP(io);
3353 goto have_fp;
3354 }
3355 }
3356 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3357 if (!fp) { /* Note: fp != IoIFP(io) */
3358 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
3359 }
3360 }
3361 else if (type == OP_GLOB)
3362 fp = Perl_start_glob(aTHX_ POPs, io);
3363 }
3364 else if (type == OP_GLOB)
3365 SP--;
3366 else if (IoTYPE(io) == IoTYPE_WRONLY) {
3367 report_wrongway_fh(PL_last_in_gv, '>');
3368 }
3369 }
3370 if (!fp) {
3371 if ((!io || !(IoFLAGS(io) & IOf_START))
3372 && ckWARN(WARN_CLOSED)
3373 && type != OP_GLOB)
3374 {
3375 report_evil_fh(PL_last_in_gv);
3376 }
3377 if (gimme == G_SCALAR) {
3378 /* undef TARG, and push that undefined value */
3379 if (type != OP_RCATLINE) {
3380 sv_set_undef(TARG);
3381 }
3382 PUSHTARG;
3383 }
3384 RETURN;
3385 }
3386 have_fp:
3387 if (gimme == G_SCALAR) {
3388 sv = TARG;
3389 if (type == OP_RCATLINE && SvGMAGICAL(sv))
3390 mg_get(sv);
3391 if (SvROK(sv)) {
3392 if (type == OP_RCATLINE)
3393 SvPV_force_nomg_nolen(sv);
3394 else
3395 sv_unref(sv);
3396 }
3397 else if (isGV_with_GP(sv)) {
3398 SvPV_force_nomg_nolen(sv);
3399 }
3400 SvUPGRADE(sv, SVt_PV);
3401 tmplen = SvLEN(sv); /* remember if already alloced */
3402 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
3403 /* try short-buffering it. Please update t/op/readline.t
3404 * if you change the growth length.
3405 */
3406 Sv_Grow(sv, 80);
3407 }
3408 offset = 0;
3409 if (type == OP_RCATLINE && SvOK(sv)) {
3410 if (!SvPOK(sv)) {
3411 SvPV_force_nomg_nolen(sv);
3412 }
3413 offset = SvCUR(sv);
3414 }
3415 }
3416 else {
3417 sv = sv_2mortal(newSV(80));
3418 offset = 0;
3419 }
3420
3421 /* This should not be marked tainted if the fp is marked clean */
3422 #define MAYBE_TAINT_LINE(io, sv) \
3423 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
3424 TAINT; \
3425 SvTAINTED_on(sv); \
3426 }
3427
3428 /* delay EOF state for a snarfed empty file */
3429 #define SNARF_EOF(gimme,rs,io,sv) \
3430 (gimme != G_SCALAR || SvCUR(sv) \
3431 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
3432
3433 for (;;) {
3434 PUTBACK;
3435 if (!sv_gets(sv, fp, offset)
3436 && (type == OP_GLOB
3437 || SNARF_EOF(gimme, PL_rs, io, sv)
3438 || PerlIO_error(fp)))
3439 {
3440 if (IoFLAGS(io) & IOf_ARGV) {
3441 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3442 if (fp) {
3443 continue;
3444 }
3445 (void)do_close(PL_last_in_gv, FALSE);
3446 }
3447 else if (type == OP_GLOB) {
3448 /* clear any errors here so we only fail on the pclose()
3449 failing, which should only happen on the child
3450 failing
3451 */
3452 PerlIO_clearerr(fp);
3453 if (!do_close(PL_last_in_gv, FALSE)) {
3454 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
3455 "glob failed (child exited with status %d%s)",
3456 (int)(STATUS_CURRENT >> 8),
3457 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
3458 }
3459 }
3460 if (gimme == G_SCALAR) {
3461 if (type != OP_RCATLINE) {
3462 SV_CHECK_THINKFIRST_COW_DROP(TARG);
3463 SvOK_off(TARG);
3464 }
3465 SPAGAIN;
3466 PUSHTARG;
3467 }
3468 MAYBE_TAINT_LINE(io, sv);
3469 RETURN;
3470 }
3471 MAYBE_TAINT_LINE(io, sv);
3472 IoLINES(io)++;
3473 IoFLAGS(io) |= IOf_NOLINE;
3474 SvSETMAGIC(sv);
3475 SPAGAIN;
3476 XPUSHs(sv);
3477 if (type == OP_GLOB) {
3478 const char *t1;
3479 Stat_t statbuf;
3480
3481 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
3482 char * const tmps = SvEND(sv) - 1;
3483 if (*tmps == *SvPVX_const(PL_rs)) {
3484 *tmps = '\0';
3485 SvCUR_set(sv, SvCUR(sv) - 1);
3486 }
3487 }
3488 for (t1 = SvPVX_const(sv); *t1; t1++)
3489 #ifdef __VMS
3490 if (memCHRs("*%?", *t1))
3491 #else
3492 if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1))
3493 #endif
3494 break;
3495 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
3496 (void)POPs; /* Unmatched wildcard? Chuck it... */
3497 continue;
3498 }
3499 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
3500 if (ckWARN(WARN_UTF8)) {
3501 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
3502 const STRLEN len = SvCUR(sv) - offset;
3503 const U8 *f;
3504
3505 if (!is_utf8_string_loc(s, len, &f))
3506 /* Emulate :encoding(utf8) warning in the same case. */
3507 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3508 "utf8 \"\\x%02X\" does not map to Unicode",
3509 f < (U8*)SvEND(sv) ? *f : 0);
3510 }
3511 }
3512 if (gimme == G_LIST) {
3513 if (SvLEN(sv) - SvCUR(sv) > 20) {
3514 SvPV_shrink_to_cur(sv);
3515 }
3516 sv = sv_2mortal(newSV(80));
3517 continue;
3518 }
3519 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
3520 /* try to reclaim a bit of scalar space (only on 1st alloc) */
3521 const STRLEN new_len
3522 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
3523 SvPV_renew(sv, new_len);
3524 }
3525 RETURN;
3526 }
3527 }
3528
PP(pp_helem)3529 PP(pp_helem)
3530 {
3531 dSP;
3532 HE* he;
3533 SV **svp;
3534 SV * const keysv = POPs;
3535 HV * const hv = MUTABLE_HV(POPs);
3536 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3537 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3538 SV *sv;
3539 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3540 bool preeminent = TRUE;
3541
3542 if (SvTYPE(hv) != SVt_PVHV)
3543 RETPUSHUNDEF;
3544
3545 if (localizing) {
3546 MAGIC *mg;
3547 HV *stash;
3548
3549 /* Try to preserve the existence of a tied hash
3550 * element by using EXISTS and DELETE if possible.
3551 * Fall back to FETCH and STORE otherwise. */
3552 if (SvCANEXISTDELETE(hv))
3553 preeminent = hv_exists_ent(hv, keysv, 0);
3554 }
3555
3556 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3557 svp = he ? &HeVAL(he) : NULL;
3558 if (lval) {
3559 if (!svp || !*svp || *svp == &PL_sv_undef) {
3560 SV* lv;
3561 SV* key2;
3562 if (!defer) {
3563 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3564 }
3565 lv = newSV_type_mortal(SVt_PVLV);
3566 LvTYPE(lv) = 'y';
3567 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
3568 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
3569 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3570 LvTARGLEN(lv) = 1;
3571 PUSHs(lv);
3572 RETURN;
3573 }
3574 if (localizing) {
3575 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
3576 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
3577 else if (preeminent)
3578 save_helem_flags(hv, keysv, svp,
3579 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
3580 else
3581 SAVEHDELETE(hv, keysv);
3582 }
3583 else if (PL_op->op_private & OPpDEREF) {
3584 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3585 RETURN;
3586 }
3587 }
3588 sv = (svp && *svp ? *svp : &PL_sv_undef);
3589 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
3590 * was to make C<local $tied{foo} = $tied{foo}> possible.
3591 * However, it seems no longer to be needed for that purpose, and
3592 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
3593 * would loop endlessly since the pos magic is getting set on the
3594 * mortal copy and lost. However, the copy has the effect of
3595 * triggering the get magic, and losing it altogether made things like
3596 * c<$tied{foo};> in void context no longer do get magic, which some
3597 * code relied on. Also, delayed triggering of magic on @+ and friends
3598 * meant the original regex may be out of scope by now. So as a
3599 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
3600 * being called too many times). */
3601 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
3602 mg_get(sv);
3603 PUSHs(sv);
3604 RETURN;
3605 }
3606
3607
3608 /* a stripped-down version of Perl_softref2xv() for use by
3609 * pp_multideref(), which doesn't use PL_op->op_flags */
3610
3611 STATIC GV *
S_softref2xv_lite(pTHX_ SV * const sv,const char * const what,const svtype type)3612 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
3613 const svtype type)
3614 {
3615 if (PL_op->op_private & HINT_STRICT_REFS) {
3616 if (SvOK(sv))
3617 Perl_die(aTHX_ PL_no_symref_sv, sv,
3618 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
3619 else
3620 Perl_die(aTHX_ PL_no_usym, what);
3621 }
3622 if (!SvOK(sv))
3623 Perl_die(aTHX_ PL_no_usym, what);
3624 return gv_fetchsv_nomg(sv, GV_ADD, type);
3625 }
3626
3627
3628 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
3629 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
3630 *
3631 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
3632 * Each of these either contains a set of actions, or an argument, such as
3633 * an IV to use as an array index, or a lexical var to retrieve.
3634 * Several actions are stored per UV; we keep shifting new actions off the
3635 * one UV, and only reload when it becomes zero.
3636 */
3637
PP(pp_multideref)3638 PP(pp_multideref)
3639 {
3640 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
3641 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
3642 UV actions = items->uv;
3643
3644 assert(actions);
3645 /* this tells find_uninit_var() where we're up to */
3646 PL_multideref_pc = items;
3647
3648 while (1) {
3649 /* there are three main classes of action; the first retrieves
3650 * the initial AV or HV from a variable or the stack; the second
3651 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
3652 * the third an unrolled (/DREFHV, rv2hv, helem).
3653 */
3654 switch (actions & MDEREF_ACTION_MASK) {
3655
3656 case MDEREF_reload:
3657 actions = (++items)->uv;
3658 continue;
3659
3660 case MDEREF_AV_padav_aelem: /* $lex[...] */
3661 sv = PAD_SVl((++items)->pad_offset);
3662 goto do_AV_aelem;
3663
3664 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
3665 sv = UNOP_AUX_item_sv(++items);
3666 assert(isGV_with_GP(sv));
3667 sv = (SV*)GvAVn((GV*)sv);
3668 goto do_AV_aelem;
3669
3670 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
3671 {
3672 dSP;
3673 sv = POPs;
3674 PUTBACK;
3675 goto do_AV_rv2av_aelem;
3676 }
3677
3678 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
3679 sv = UNOP_AUX_item_sv(++items);
3680 assert(isGV_with_GP(sv));
3681 sv = GvSVn((GV*)sv);
3682 goto do_AV_vivify_rv2av_aelem;
3683
3684 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
3685 sv = PAD_SVl((++items)->pad_offset);
3686 /* FALLTHROUGH */
3687
3688 do_AV_vivify_rv2av_aelem:
3689 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
3690 /* this is the OPpDEREF action normally found at the end of
3691 * ops like aelem, helem, rv2sv */
3692 sv = vivify_ref(sv, OPpDEREF_AV);
3693 /* FALLTHROUGH */
3694
3695 do_AV_rv2av_aelem:
3696 /* this is basically a copy of pp_rv2av when it just has the
3697 * sKR/1 flags */
3698 SvGETMAGIC(sv);
3699 if (LIKELY(SvROK(sv))) {
3700 if (UNLIKELY(SvAMAGIC(sv))) {
3701 sv = amagic_deref_call(sv, to_av_amg);
3702 }
3703 sv = SvRV(sv);
3704 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
3705 DIE(aTHX_ "Not an ARRAY reference");
3706 }
3707 else if (SvTYPE(sv) != SVt_PVAV) {
3708 if (!isGV_with_GP(sv))
3709 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
3710 sv = MUTABLE_SV(GvAVn((GV*)sv));
3711 }
3712 /* FALLTHROUGH */
3713
3714 do_AV_aelem:
3715 {
3716 /* retrieve the key; this may be either a lexical or package
3717 * var (whose index/ptr is stored as an item) or a signed
3718 * integer constant stored as an item.
3719 */
3720 SV *elemsv;
3721 IV elem = 0; /* to shut up stupid compiler warnings */
3722
3723
3724 assert(SvTYPE(sv) == SVt_PVAV);
3725
3726 switch (actions & MDEREF_INDEX_MASK) {
3727 case MDEREF_INDEX_none:
3728 goto finish;
3729 case MDEREF_INDEX_const:
3730 elem = (++items)->iv;
3731 break;
3732 case MDEREF_INDEX_padsv:
3733 elemsv = PAD_SVl((++items)->pad_offset);
3734 goto check_elem;
3735 case MDEREF_INDEX_gvsv:
3736 elemsv = UNOP_AUX_item_sv(++items);
3737 assert(isGV_with_GP(elemsv));
3738 elemsv = GvSVn((GV*)elemsv);
3739 check_elem:
3740 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
3741 && ckWARN(WARN_MISC)))
3742 Perl_warner(aTHX_ packWARN(WARN_MISC),
3743 "Use of reference \"%" SVf "\" as array index",
3744 SVfARG(elemsv));
3745 /* the only time that S_find_uninit_var() needs this
3746 * is to determine which index value triggered the
3747 * undef warning. So just update it here. Note that
3748 * since we don't save and restore this var (e.g. for
3749 * tie or overload execution), its value will be
3750 * meaningless apart from just here */
3751 PL_multideref_pc = items;
3752 elem = SvIV(elemsv);
3753 break;
3754 }
3755
3756
3757 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
3758
3759 if (!(actions & MDEREF_FLAG_last)) {
3760 SV** svp = av_fetch((AV*)sv, elem, 1);
3761 if (!svp || ! (sv=*svp))
3762 DIE(aTHX_ PL_no_aelem, elem);
3763 break;
3764 }
3765
3766 if (PL_op->op_private &
3767 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3768 {
3769 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3770 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
3771 }
3772 else {
3773 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3774 sv = av_delete((AV*)sv, elem, discard);
3775 if (discard)
3776 return NORMAL;
3777 if (!sv)
3778 sv = &PL_sv_undef;
3779 }
3780 }
3781 else {
3782 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3783 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3784 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3785 bool preeminent = TRUE;
3786 AV *const av = (AV*)sv;
3787 SV** svp;
3788
3789 if (UNLIKELY(localizing)) {
3790 MAGIC *mg;
3791 HV *stash;
3792
3793 /* Try to preserve the existence of a tied array
3794 * element by using EXISTS and DELETE if possible.
3795 * Fall back to FETCH and STORE otherwise. */
3796 if (SvCANEXISTDELETE(av))
3797 preeminent = av_exists(av, elem);
3798 }
3799
3800 svp = av_fetch(av, elem, lval && !defer);
3801
3802 if (lval) {
3803 if (!svp || !(sv = *svp)) {
3804 IV len;
3805 if (!defer)
3806 DIE(aTHX_ PL_no_aelem, elem);
3807 len = av_top_index(av);
3808 /* Resolve a negative index that falls within
3809 * the array. Leave it negative it if falls
3810 * outside the array. */
3811 if (elem < 0 && len + elem >= 0)
3812 elem = len + elem;
3813 if (elem >= 0 && elem <= len)
3814 /* Falls within the array. */
3815 sv = av_nonelem(av,elem);
3816 else
3817 /* Falls outside the array. If it is neg-
3818 ative, magic_setdefelem will use the
3819 index for error reporting. */
3820 sv = sv_2mortal(newSVavdefelem(av,elem,1));
3821 }
3822 else {
3823 if (UNLIKELY(localizing)) {
3824 if (preeminent) {
3825 save_aelem(av, elem, svp);
3826 sv = *svp; /* may have changed */
3827 }
3828 else
3829 SAVEADELETE(av, elem);
3830 }
3831 }
3832 }
3833 else {
3834 sv = (svp ? *svp : &PL_sv_undef);
3835 /* see note in pp_helem() */
3836 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
3837 mg_get(sv);
3838 }
3839 }
3840
3841 }
3842 finish:
3843 {
3844 dSP;
3845 XPUSHs(sv);
3846 RETURN;
3847 }
3848 /* NOTREACHED */
3849
3850
3851
3852
3853 case MDEREF_HV_padhv_helem: /* $lex{...} */
3854 sv = PAD_SVl((++items)->pad_offset);
3855 goto do_HV_helem;
3856
3857 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
3858 sv = UNOP_AUX_item_sv(++items);
3859 assert(isGV_with_GP(sv));
3860 sv = (SV*)GvHVn((GV*)sv);
3861 goto do_HV_helem;
3862
3863 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
3864 {
3865 dSP;
3866 sv = POPs;
3867 PUTBACK;
3868 goto do_HV_rv2hv_helem;
3869 }
3870
3871 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
3872 sv = UNOP_AUX_item_sv(++items);
3873 assert(isGV_with_GP(sv));
3874 sv = GvSVn((GV*)sv);
3875 goto do_HV_vivify_rv2hv_helem;
3876
3877 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
3878 sv = PAD_SVl((++items)->pad_offset);
3879 /* FALLTHROUGH */
3880
3881 do_HV_vivify_rv2hv_helem:
3882 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
3883 /* this is the OPpDEREF action normally found at the end of
3884 * ops like aelem, helem, rv2sv */
3885 sv = vivify_ref(sv, OPpDEREF_HV);
3886 /* FALLTHROUGH */
3887
3888 do_HV_rv2hv_helem:
3889 /* this is basically a copy of pp_rv2hv when it just has the
3890 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
3891
3892 SvGETMAGIC(sv);
3893 if (LIKELY(SvROK(sv))) {
3894 if (UNLIKELY(SvAMAGIC(sv))) {
3895 sv = amagic_deref_call(sv, to_hv_amg);
3896 }
3897 sv = SvRV(sv);
3898 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
3899 DIE(aTHX_ "Not a HASH reference");
3900 }
3901 else if (SvTYPE(sv) != SVt_PVHV) {
3902 if (!isGV_with_GP(sv))
3903 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
3904 sv = MUTABLE_SV(GvHVn((GV*)sv));
3905 }
3906 /* FALLTHROUGH */
3907
3908 do_HV_helem:
3909 {
3910 /* retrieve the key; this may be either a lexical / package
3911 * var or a string constant, whose index/ptr is stored as an
3912 * item
3913 */
3914 SV *keysv = NULL; /* to shut up stupid compiler warnings */
3915
3916 assert(SvTYPE(sv) == SVt_PVHV);
3917
3918 switch (actions & MDEREF_INDEX_MASK) {
3919 case MDEREF_INDEX_none:
3920 goto finish;
3921
3922 case MDEREF_INDEX_const:
3923 keysv = UNOP_AUX_item_sv(++items);
3924 break;
3925
3926 case MDEREF_INDEX_padsv:
3927 keysv = PAD_SVl((++items)->pad_offset);
3928 break;
3929
3930 case MDEREF_INDEX_gvsv:
3931 keysv = UNOP_AUX_item_sv(++items);
3932 keysv = GvSVn((GV*)keysv);
3933 break;
3934 }
3935
3936 /* see comment above about setting this var */
3937 PL_multideref_pc = items;
3938
3939
3940 /* ensure that candidate CONSTs have been HEKified */
3941 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
3942 || SvTYPE(keysv) >= SVt_PVMG
3943 || !SvOK(keysv)
3944 || SvROK(keysv)
3945 || SvIsCOW_shared_hash(keysv));
3946
3947 /* this is basically a copy of pp_helem with OPpDEREF skipped */
3948
3949 if (!(actions & MDEREF_FLAG_last)) {
3950 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
3951 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
3952 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3953 break;
3954 }
3955
3956 if (PL_op->op_private &
3957 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3958 {
3959 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3960 sv = hv_exists_ent((HV*)sv, keysv, 0)
3961 ? &PL_sv_yes : &PL_sv_no;
3962 }
3963 else {
3964 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3965 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
3966 if (discard)
3967 return NORMAL;
3968 if (!sv)
3969 sv = &PL_sv_undef;
3970 }
3971 }
3972 else {
3973 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3974 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3975 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3976 bool preeminent = TRUE;
3977 SV **svp;
3978 HV * const hv = (HV*)sv;
3979 HE* he;
3980
3981 if (UNLIKELY(localizing)) {
3982 MAGIC *mg;
3983 HV *stash;
3984
3985 /* Try to preserve the existence of a tied hash
3986 * element by using EXISTS and DELETE if possible.
3987 * Fall back to FETCH and STORE otherwise. */
3988 if (SvCANEXISTDELETE(hv))
3989 preeminent = hv_exists_ent(hv, keysv, 0);
3990 }
3991
3992 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3993 svp = he ? &HeVAL(he) : NULL;
3994
3995
3996 if (lval) {
3997 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
3998 SV* lv;
3999 SV* key2;
4000 if (!defer)
4001 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4002 lv = newSV_type_mortal(SVt_PVLV);
4003 LvTYPE(lv) = 'y';
4004 sv_magic(lv, key2 = newSVsv(keysv),
4005 PERL_MAGIC_defelem, NULL, 0);
4006 /* sv_magic() increments refcount */
4007 SvREFCNT_dec_NN(key2);
4008 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
4009 LvTARGLEN(lv) = 1;
4010 sv = lv;
4011 }
4012 else {
4013 if (localizing) {
4014 if (HvNAME_get(hv) && isGV_or_RVCV(sv))
4015 save_gp(MUTABLE_GV(sv),
4016 !(PL_op->op_flags & OPf_SPECIAL));
4017 else if (preeminent) {
4018 save_helem_flags(hv, keysv, svp,
4019 (PL_op->op_flags & OPf_SPECIAL)
4020 ? 0 : SAVEf_SETMAGIC);
4021 sv = *svp; /* may have changed */
4022 }
4023 else
4024 SAVEHDELETE(hv, keysv);
4025 }
4026 }
4027 }
4028 else {
4029 sv = (svp && *svp ? *svp : &PL_sv_undef);
4030 /* see note in pp_helem() */
4031 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
4032 mg_get(sv);
4033 }
4034 }
4035 goto finish;
4036 }
4037
4038 } /* switch */
4039
4040 actions >>= MDEREF_SHIFT;
4041 } /* while */
4042 /* NOTREACHED */
4043 }
4044
4045
PP(pp_iter)4046 PP(pp_iter)
4047 {
4048 PERL_CONTEXT *cx = CX_CUR();
4049 SV **itersvp = CxITERVAR(cx);
4050 const U8 type = CxTYPE(cx);
4051
4052 /* Classic "for" syntax iterates one-at-a-time.
4053 Many-at-a-time for loops are only for lexicals declared as part of the
4054 for loop, and rely on all the lexicals being in adjacent pad slots.
4055
4056 Curiously, even if the iterator variable is a lexical, the pad offset is
4057 stored in the targ slot of the ENTERITER op, meaning that targ of this OP
4058 has always been zero. Hence we can use this op's targ to hold "how many"
4059 for many-at-a-time. We actually store C<how_many - 1>, so that for the
4060 case of one-at-a-time we have zero (as before), as this makes all the
4061 logic of the for loop below much simpler, with all the other
4062 one-at-a-time cases just falling out of this "naturally". */
4063 PADOFFSET how_many = PL_op->op_targ;
4064 PADOFFSET i = 0;
4065
4066 assert(itersvp);
4067
4068 for (; i <= how_many; ++i ) {
4069 SV *oldsv;
4070 SV *sv;
4071 AV *av;
4072 IV ix;
4073 IV inc;
4074
4075 switch (type) {
4076
4077 case CXt_LOOP_LAZYSV: /* string increment */
4078 {
4079 SV* cur = cx->blk_loop.state_u.lazysv.cur;
4080 SV *end = cx->blk_loop.state_u.lazysv.end;
4081 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
4082 It has SvPVX of "" and SvCUR of 0, which is what we want. */
4083 STRLEN maxlen = 0;
4084 const char *max = SvPV_const(end, maxlen);
4085 bool pad_it = FALSE;
4086 if (DO_UTF8(end) && IN_UNI_8_BIT)
4087 maxlen = sv_len_utf8_nomg(end);
4088 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen)) {
4089 if (LIKELY(!i)) {
4090 goto retno;
4091 }
4092 /* We are looping n-at-a-time and the range isn't a multiple
4093 of n, so we fill the rest of the lexicals with undef.
4094 This only happens on the last iteration of the loop, and
4095 we will have already set up the "terminate next time"
4096 condition earlier in this for loop for this call of the
4097 ITER op when we set up the lexical corresponding to the
4098 last value in the range. Hence we don't goto retno (yet),
4099 and just below we don't repeat the setup for "terminate
4100 next time". */
4101 pad_it = TRUE;
4102 }
4103
4104 oldsv = *itersvp;
4105 /* NB: on the first iteration, oldsv will have a ref count of at
4106 * least 2 (one extra from blk_loop.itersave), so the GV or pad
4107 * slot will get localised; on subsequent iterations the RC==1
4108 * optimisation may kick in and the SV will be reused. */
4109 if (UNLIKELY(pad_it)) {
4110 *itersvp = &PL_sv_undef;
4111 SvREFCNT_dec(oldsv);
4112 }
4113 else if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
4114 /* safe to reuse old SV */
4115 sv_setsv(oldsv, cur);
4116 }
4117 else {
4118 /* we need a fresh SV every time so that loop body sees a
4119 * completely new SV for closures/references to work as
4120 * they used to */
4121 *itersvp = newSVsv(cur);
4122 SvREFCNT_dec(oldsv);
4123 }
4124
4125 if (UNLIKELY(pad_it)) {
4126 /* We're "beyond the end" of the iterator here, filling the
4127 extra lexicals with undef, so we mustn't do anything
4128 (further) to the iterator itself at this point.
4129 (Observe how the other two blocks modify the iterator's
4130 value) */
4131 }
4132 else if (strEQ(SvPVX_const(cur), max))
4133 sv_setiv(cur, 0); /* terminate next time */
4134 else
4135 sv_inc(cur);
4136 break;
4137 }
4138
4139 case CXt_LOOP_LAZYIV: /* integer increment */
4140 {
4141 IV cur = cx->blk_loop.state_u.lazyiv.cur;
4142 bool pad_it = FALSE;
4143 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end)) {
4144 if (LIKELY(!i)) {
4145 goto retno;
4146 }
4147 pad_it = TRUE;
4148 }
4149
4150 oldsv = *itersvp;
4151 /* see NB comment above */
4152 if (UNLIKELY(pad_it)) {
4153 *itersvp = &PL_sv_undef;
4154 SvREFCNT_dec(oldsv);
4155 }
4156 else if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
4157 /* safe to reuse old SV */
4158
4159 if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
4160 == SVt_IV) {
4161 /* Cheap SvIOK_only().
4162 * Assert that flags which SvIOK_only() would test or
4163 * clear can't be set, because we're SVt_IV */
4164 assert(!(SvFLAGS(oldsv) &
4165 (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
4166 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
4167 /* SvIV_set() where sv_any points to head */
4168 oldsv->sv_u.svu_iv = cur;
4169
4170 }
4171 else
4172 sv_setiv(oldsv, cur);
4173 }
4174 else {
4175 /* we need a fresh SV every time so that loop body sees a
4176 * completely new SV for closures/references to work as they
4177 * used to */
4178 *itersvp = newSViv(cur);
4179 SvREFCNT_dec(oldsv);
4180 }
4181
4182 if (UNLIKELY(pad_it)) {
4183 /* We're good (see "We are looping n-at-a-time" comment
4184 above). */
4185 }
4186 else if (UNLIKELY(cur == IV_MAX)) {
4187 /* Handle end of range at IV_MAX */
4188 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
4189 } else
4190 ++cx->blk_loop.state_u.lazyiv.cur;
4191 break;
4192 }
4193
4194 case CXt_LOOP_LIST: /* for (1,2,3) */
4195
4196 assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
4197 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
4198 ix = (cx->blk_loop.state_u.stack.ix += inc);
4199 if (UNLIKELY(inc > 0
4200 ? ix > cx->blk_oldsp
4201 : ix <= cx->blk_loop.state_u.stack.basesp)
4202 ) {
4203 if (LIKELY(!i)) {
4204 goto retno;
4205 }
4206
4207 sv = &PL_sv_undef;
4208 }
4209 else {
4210 sv = PL_stack_base[ix];
4211 }
4212
4213 av = NULL;
4214 goto loop_ary_common;
4215
4216 case CXt_LOOP_ARY: /* for (@ary) */
4217
4218 av = cx->blk_loop.state_u.ary.ary;
4219 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
4220 ix = (cx->blk_loop.state_u.ary.ix += inc);
4221 if (UNLIKELY(inc > 0
4222 ? ix > AvFILL(av)
4223 : ix < 0)
4224 ) {
4225 if (LIKELY(!i)) {
4226 goto retno;
4227 }
4228
4229 sv = &PL_sv_undef;
4230 } else if (UNLIKELY(SvRMAGICAL(av))) {
4231 SV * const * const svp = av_fetch(av, ix, FALSE);
4232 sv = svp ? *svp : NULL;
4233 }
4234 else {
4235 sv = AvARRAY(av)[ix];
4236 }
4237
4238 loop_ary_common:
4239
4240 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
4241 SvSetMagicSV(*itersvp, sv);
4242 break;
4243 }
4244
4245 if (LIKELY(sv)) {
4246 if (UNLIKELY(SvIS_FREED(sv))) {
4247 *itersvp = NULL;
4248 Perl_croak(aTHX_ "Use of freed value in iteration");
4249 }
4250 if (SvPADTMP(sv)) {
4251 sv = newSVsv(sv);
4252 }
4253 else {
4254 SvTEMP_off(sv);
4255 SvREFCNT_inc_simple_void_NN(sv);
4256 }
4257 }
4258 else if (av) {
4259 sv = newSVavdefelem(av, ix, 0);
4260 }
4261 else
4262 sv = &PL_sv_undef;
4263
4264 oldsv = *itersvp;
4265 *itersvp = sv;
4266 SvREFCNT_dec(oldsv);
4267 break;
4268
4269 default:
4270 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
4271 }
4272
4273 /* Only relevant for a many-at-a-time loop: */
4274 ++itersvp;
4275 }
4276
4277 /* Try to bypass pushing &PL_sv_yes and calling pp_and(); instead
4278 * jump straight to the AND op's op_other */
4279 assert(PL_op->op_next->op_type == OP_AND);
4280 if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
4281 return cLOGOPx(PL_op->op_next)->op_other;
4282 }
4283 else {
4284 /* An XS module has replaced the op_ppaddr, so fall back to the slow,
4285 * obvious way. */
4286 /* pp_enteriter should have pre-extended the stack */
4287 EXTEND_SKIP(PL_stack_sp, 1);
4288 *++PL_stack_sp = &PL_sv_yes;
4289 return PL_op->op_next;
4290 }
4291
4292 retno:
4293 /* Try to bypass pushing &PL_sv_no and calling pp_and(); instead
4294 * jump straight to the AND op's op_next */
4295 assert(PL_op->op_next->op_type == OP_AND);
4296 /* pp_enteriter should have pre-extended the stack */
4297 EXTEND_SKIP(PL_stack_sp, 1);
4298 /* we only need this for the rare case where the OP_AND isn't
4299 * in void context, e.g. $x = do { for (..) {...} };
4300 * (or for when an XS module has replaced the op_ppaddr)
4301 * but it's cheaper to just push it rather than testing first
4302 */
4303 *++PL_stack_sp = &PL_sv_no;
4304 if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
4305 return PL_op->op_next->op_next;
4306 }
4307 else {
4308 /* An XS module has replaced the op_ppaddr, so fall back to the slow,
4309 * obvious way. */
4310 return PL_op->op_next;
4311 }
4312 }
4313
4314
4315 /*
4316 A description of how taint works in pattern matching and substitution.
4317
4318 This is all conditional on NO_TAINT_SUPPORT remaining undefined (the default).
4319 Under NO_TAINT_SUPPORT, taint-related operations should become no-ops.
4320
4321 While the pattern is being assembled/concatenated and then compiled,
4322 PL_tainted will get set (via TAINT_set) if any component of the pattern
4323 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
4324 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
4325 TAINT_get). It will also be set if any component of the pattern matches
4326 based on locale-dependent behavior.
4327
4328 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
4329 the pattern is marked as tainted. This means that subsequent usage, such
4330 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
4331 on the new pattern too.
4332
4333 RXf_TAINTED_SEEN is used post-execution by the get magic code
4334 of $1 et al to indicate whether the returned value should be tainted.
4335 It is the responsibility of the caller of the pattern (i.e. pp_match,
4336 pp_subst etc) to set this flag for any other circumstances where $1 needs
4337 to be tainted.
4338
4339 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
4340
4341 There are three possible sources of taint
4342 * the source string
4343 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
4344 * the replacement string (or expression under /e)
4345
4346 There are four destinations of taint and they are affected by the sources
4347 according to the rules below:
4348
4349 * the return value (not including /r):
4350 tainted by the source string and pattern, but only for the
4351 number-of-iterations case; boolean returns aren't tainted;
4352 * the modified string (or modified copy under /r):
4353 tainted by the source string, pattern, and replacement strings;
4354 * $1 et al:
4355 tainted by the pattern, and under 'use re "taint"', by the source
4356 string too;
4357 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
4358 should always be unset before executing subsequent code.
4359
4360 The overall action of pp_subst is:
4361
4362 * at the start, set bits in rxtainted indicating the taint status of
4363 the various sources.
4364
4365 * After each pattern execution, update the SUBST_TAINT_PAT bit in
4366 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
4367 pattern has subsequently become tainted via locale ops.
4368
4369 * If control is being passed to pp_substcont to execute a /e block,
4370 save rxtainted in the CXt_SUBST block, for future use by
4371 pp_substcont.
4372
4373 * Whenever control is being returned to perl code (either by falling
4374 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
4375 use the flag bits in rxtainted to make all the appropriate types of
4376 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
4377 et al will appear tainted.
4378
4379 pp_match is just a simpler version of the above.
4380
4381 */
4382
PP(pp_subst)4383 PP(pp_subst)
4384 {
4385 dSP; dTARG;
4386 PMOP *pm = cPMOP;
4387 PMOP *rpm = pm;
4388 char *s;
4389 char *strend;
4390 const char *c;
4391 STRLEN clen;
4392 SSize_t iters = 0;
4393 SSize_t maxiters;
4394 bool once;
4395 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
4396 See "how taint works" above */
4397 char *orig;
4398 U8 r_flags;
4399 REGEXP *rx = PM_GETRE(pm);
4400 regexp *prog = ReANY(rx);
4401 STRLEN len;
4402 int force_on_match = 0;
4403 const I32 oldsave = PL_savestack_ix;
4404 bool doutf8 = FALSE; /* whether replacement is in utf8 */
4405 #ifdef PERL_ANY_COW
4406 bool was_cow;
4407 #endif
4408 SV *nsv = NULL;
4409 /* known replacement string? */
4410 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
4411
4412 PERL_ASYNC_CHECK();
4413
4414 if (PL_op->op_flags & OPf_STACKED)
4415 TARG = POPs;
4416 else {
4417 if (ARGTARG)
4418 GETTARGET;
4419 else {
4420 TARG = DEFSV;
4421 }
4422 EXTEND(SP,1);
4423 }
4424
4425 SvGETMAGIC(TARG); /* must come before cow check */
4426 #ifdef PERL_ANY_COW
4427 /* note that a string might get converted to COW during matching */
4428 was_cow = cBOOL(SvIsCOW(TARG));
4429 #endif
4430 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4431 #ifndef PERL_ANY_COW
4432 if (SvIsCOW(TARG))
4433 sv_force_normal_flags(TARG,0);
4434 #endif
4435 if ((SvREADONLY(TARG)
4436 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
4437 || SvTYPE(TARG) > SVt_PVLV)
4438 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
4439 Perl_croak_no_modify();
4440 }
4441 PUTBACK;
4442
4443 orig = SvPV_nomg(TARG, len);
4444 /* note we don't (yet) force the var into being a string; if we fail
4445 * to match, we leave as-is; on successful match however, we *will*
4446 * coerce into a string, then repeat the match */
4447 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
4448 force_on_match = 1;
4449
4450 /* only replace once? */
4451 once = !(rpm->op_pmflags & PMf_GLOBAL);
4452
4453 /* See "how taint works" above */
4454 if (TAINTING_get) {
4455 rxtainted = (
4456 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
4457 | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
4458 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
4459 | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4460 || (PL_op->op_private & OPpTRUEBOOL)) ? SUBST_TAINT_BOOLRET : 0));
4461 TAINT_NOT;
4462 }
4463
4464 force_it:
4465 if (!pm || !orig)
4466 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
4467
4468 strend = orig + len;
4469 /* We can match twice at each position, once with zero-length,
4470 * second time with non-zero.
4471 * Don't handle utf8 specially; we can use length-in-bytes as an
4472 * upper bound on length-in-characters, and avoid the cpu-cost of
4473 * computing a tighter bound. */
4474 maxiters = 2 * len + 10;
4475
4476 /* handle the empty pattern */
4477 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
4478 if (PL_curpm == PL_reg_curpm) {
4479 if (PL_curpm_under) {
4480 if (PL_curpm_under == PL_reg_curpm) {
4481 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
4482 } else {
4483 pm = PL_curpm_under;
4484 }
4485 }
4486 } else {
4487 pm = PL_curpm;
4488 }
4489 rx = PM_GETRE(pm);
4490 prog = ReANY(rx);
4491 }
4492
4493 #ifdef PERL_SAWAMPERSAND
4494 r_flags = ( RXp_NPARENS(prog)
4495 || PL_sawampersand
4496 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
4497 || (rpm->op_pmflags & PMf_KEEPCOPY)
4498 )
4499 ? REXEC_COPY_STR
4500 : 0;
4501 #else
4502 r_flags = REXEC_COPY_STR;
4503 #endif
4504
4505 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
4506 {
4507 SPAGAIN;
4508 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
4509 LEAVE_SCOPE(oldsave);
4510 RETURN;
4511 }
4512 PL_curpm = pm;
4513
4514 /* known replacement string? */
4515 if (dstr) {
4516 /* replacement needing upgrading? */
4517 if (DO_UTF8(TARG) && !doutf8) {
4518 nsv = sv_newmortal();
4519 SvSetSV(nsv, dstr);
4520 sv_utf8_upgrade(nsv);
4521 c = SvPV_const(nsv, clen);
4522 doutf8 = TRUE;
4523 }
4524 else {
4525 c = SvPV_const(dstr, clen);
4526 doutf8 = DO_UTF8(dstr);
4527 }
4528
4529 if (UNLIKELY(TAINT_get))
4530 rxtainted |= SUBST_TAINT_REPL;
4531 }
4532 else {
4533 c = NULL;
4534 doutf8 = FALSE;
4535 }
4536
4537 /* can do inplace substitution? */
4538 if (c
4539 #ifdef PERL_ANY_COW
4540 && !was_cow
4541 #endif
4542 && (I32)clen <= RXp_MINLENRET(prog)
4543 && ( once
4544 || !(r_flags & REXEC_COPY_STR)
4545 || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
4546 )
4547 && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
4548 && (!doutf8 || SvUTF8(TARG))
4549 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4550 {
4551
4552 #ifdef PERL_ANY_COW
4553 /* string might have got converted to COW since we set was_cow */
4554 if (SvIsCOW(TARG)) {
4555 if (!force_on_match)
4556 goto have_a_cow;
4557 assert(SvVOK(TARG));
4558 }
4559 #endif
4560 if (force_on_match) {
4561 /* redo the first match, this time with the orig var
4562 * forced into being a string */
4563 force_on_match = 0;
4564 orig = SvPV_force_nomg(TARG, len);
4565 goto force_it;
4566 }
4567
4568 if (once) {
4569 char *d, *m;
4570 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4571 rxtainted |= SUBST_TAINT_PAT;
4572 m = orig + RXp_OFFS_START(prog,0);
4573 d = orig + RXp_OFFS_END(prog,0);
4574 s = orig;
4575 if (m - s > strend - d) { /* faster to shorten from end */
4576 I32 i;
4577 if (clen) {
4578 Copy(c, m, clen, char);
4579 m += clen;
4580 }
4581 i = strend - d;
4582 if (i > 0) {
4583 Move(d, m, i, char);
4584 m += i;
4585 }
4586 *m = '\0';
4587 SvCUR_set(TARG, m - s);
4588 }
4589 else { /* faster from front */
4590 I32 i = m - s;
4591 d -= clen;
4592 if (i > 0)
4593 Move(s, d - i, i, char);
4594 sv_chop(TARG, d-i);
4595 if (clen)
4596 Copy(c, d, clen, char);
4597 }
4598 SPAGAIN;
4599 PUSHs(&PL_sv_yes);
4600 }
4601 else {
4602 char *d, *m;
4603 d = s = RXp_OFFS_START(prog,0) + orig;
4604 do {
4605 I32 i;
4606 if (UNLIKELY(iters++ > maxiters))
4607 DIE(aTHX_ "Substitution loop");
4608 /* run time pattern taint, eg locale */
4609 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4610 rxtainted |= SUBST_TAINT_PAT;
4611 m = RXp_OFFS_START(prog,0) + orig;
4612 if ((i = m - s)) {
4613 if (s != d)
4614 Move(s, d, i, char);
4615 d += i;
4616 }
4617 if (clen) {
4618 Copy(c, d, clen, char);
4619 d += clen;
4620 }
4621 s = RXp_OFFS_END(prog,0) + orig;
4622 } while (CALLREGEXEC(rx, s, strend, orig,
4623 s == m, /* don't match same null twice */
4624 TARG, NULL,
4625 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4626 if (s != d) {
4627 I32 i = strend - s;
4628 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
4629 Move(s, d, i+1, char); /* include the NUL */
4630 }
4631 SPAGAIN;
4632 assert(iters);
4633 if (PL_op->op_private & OPpTRUEBOOL)
4634 PUSHs(&PL_sv_yes);
4635 else
4636 mPUSHi(iters);
4637 }
4638 }
4639 else {
4640 bool first;
4641 char *m;
4642 SV *repl;
4643 if (force_on_match) {
4644 /* redo the first match, this time with the orig var
4645 * forced into being a string */
4646 force_on_match = 0;
4647 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4648 /* I feel that it should be possible to avoid this mortal copy
4649 given that the code below copies into a new destination.
4650 However, I suspect it isn't worth the complexity of
4651 unravelling the C<goto force_it> for the small number of
4652 cases where it would be viable to drop into the copy code. */
4653 TARG = sv_2mortal(newSVsv(TARG));
4654 }
4655 orig = SvPV_force_nomg(TARG, len);
4656 goto force_it;
4657 }
4658 #ifdef PERL_ANY_COW
4659 have_a_cow:
4660 #endif
4661 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4662 rxtainted |= SUBST_TAINT_PAT;
4663 repl = dstr;
4664 s = RXp_OFFS_START(prog,0) + orig;
4665 dstr = newSVpvn_flags(orig, s-orig,
4666 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
4667 if (!c) {
4668 PERL_CONTEXT *cx;
4669 SPAGAIN;
4670 m = orig;
4671 /* note that a whole bunch of local vars are saved here for
4672 * use by pp_substcont: here's a list of them in case you're
4673 * searching for places in this sub that uses a particular var:
4674 * iters maxiters r_flags oldsave rxtainted orig dstr targ
4675 * s m strend rx once */
4676 CX_PUSHSUBST(cx);
4677 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
4678 }
4679 first = TRUE;
4680 do {
4681 if (UNLIKELY(iters++ > maxiters))
4682 DIE(aTHX_ "Substitution loop");
4683 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4684 rxtainted |= SUBST_TAINT_PAT;
4685 if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
4686 char *old_s = s;
4687 char *old_orig = orig;
4688 assert(RXp_SUBOFFSET(prog) == 0);
4689
4690 orig = RXp_SUBBEG(prog);
4691 s = orig + (old_s - old_orig);
4692 strend = s + (strend - old_s);
4693 }
4694 m = RXp_OFFS_START(prog,0) + orig;
4695 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
4696 s = RXp_OFFS_END(prog,0) + orig;
4697 if (first) {
4698 /* replacement already stringified */
4699 if (clen)
4700 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
4701 first = FALSE;
4702 }
4703 else {
4704 sv_catsv(dstr, repl);
4705 }
4706 if (once)
4707 break;
4708 } while (CALLREGEXEC(rx, s, strend, orig,
4709 s == m, /* Yields minend of 0 or 1 */
4710 TARG, NULL,
4711 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4712 assert(strend >= s);
4713 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
4714
4715 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4716 /* From here on down we're using the copy, and leaving the original
4717 untouched. */
4718 TARG = dstr;
4719 SPAGAIN;
4720 PUSHs(dstr);
4721 } else {
4722 #ifdef PERL_ANY_COW
4723 /* The match may make the string COW. If so, brilliant, because
4724 that's just saved us one malloc, copy and free - the regexp has
4725 donated the old buffer, and we malloc an entirely new one, rather
4726 than the regexp malloc()ing a buffer and copying our original,
4727 only for us to throw it away here during the substitution. */
4728 if (SvIsCOW(TARG)) {
4729 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
4730 } else
4731 #endif
4732 {
4733 SvPV_free(TARG);
4734 }
4735 SvPV_set(TARG, SvPVX(dstr));
4736 SvCUR_set(TARG, SvCUR(dstr));
4737 SvLEN_set(TARG, SvLEN(dstr));
4738 SvFLAGS(TARG) |= SvUTF8(dstr);
4739 SvPV_set(dstr, NULL);
4740
4741 SPAGAIN;
4742 if (PL_op->op_private & OPpTRUEBOOL)
4743 PUSHs(&PL_sv_yes);
4744 else
4745 mPUSHi(iters);
4746 }
4747 }
4748
4749 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4750 (void)SvPOK_only_UTF8(TARG);
4751 }
4752
4753 /* See "how taint works" above */
4754 if (TAINTING_get) {
4755 if ((rxtainted & SUBST_TAINT_PAT) ||
4756 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
4757 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
4758 )
4759 (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
4760
4761 if (!(rxtainted & SUBST_TAINT_BOOLRET)
4762 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
4763 )
4764 SvTAINTED_on(TOPs); /* taint return value */
4765 else
4766 SvTAINTED_off(TOPs); /* may have got tainted earlier */
4767
4768 /* needed for mg_set below */
4769 TAINT_set(
4770 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
4771 );
4772 SvTAINT(TARG);
4773 }
4774 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
4775 TAINT_NOT;
4776 LEAVE_SCOPE(oldsave);
4777 RETURN;
4778 }
4779
PP(pp_grepwhile)4780 PP(pp_grepwhile)
4781 {
4782 /* Understanding the stack during a grep.
4783 *
4784 * 'grep expr, args' is implemented in the form of
4785 * grepstart;
4786 * do {
4787 * expr;
4788 * grepwhile;
4789 * } while (args);
4790 *
4791 * The stack examples below are in the form of 'perl -Ds' output,
4792 * where any stack element indexed by PL_markstack_ptr[i] has a star
4793 * just to the right of it. In addition, the corresponding i value
4794 * is displayed under the indexed stack element.
4795 *
4796 * On entry to grepwhile, the stack looks like this:
4797 *
4798 * => * M1..Mn X1 * X2..Xn C * R1..Rn BOOL
4799 * [-2] [-1] [0]
4800 *
4801 * where:
4802 * M1..Mn Accumulated args which have been matched so far.
4803 * X1..Xn Random discardable elements from previous iterations.
4804 * C The current (just processed) arg, still aliased to $_.
4805 * R1..Rn The args remaining to be processed.
4806 * BOOL the result of the just-executed grep expression.
4807 *
4808 * Note that it is easiest to think of the top two stack marks as both
4809 * being one too high, and so it would make more sense to have had the
4810 * marks like this:
4811 *
4812 * => * M1..Mn * X1..Xn * C R1..Rn BOOL
4813 * [-2] [-1] [0]
4814 *
4815 * where the stack is divided neatly into 3 groups:
4816 * - matched,
4817 * - discarded,
4818 * - being, or yet to be, processed.
4819 * But off-by-one is the way it is currently, and it works as long as
4820 * we keep it consistent and bear it in mind.
4821 *
4822 * pp_grepwhile() does the following:
4823 *
4824 * - for a match, replace the X1 pointer with a pointer to C and bump
4825 * PL_markstack_ptr[-1]
4826 * - if more args to process, bump PL_markstack_ptr[0] and update the
4827 * $_ alias, else
4828 * - remove top 3 MARKs and return M1..Mn, or a scalar,
4829 * or void as appropriate.
4830 *
4831 */
4832
4833 dSP;
4834 dPOPss;
4835
4836 if (SvTRUE_NN(sv))
4837 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
4838 ++*PL_markstack_ptr;
4839 FREETMPS;
4840 LEAVE_with_name("grep_item"); /* exit inner scope */
4841
4842 /* All done yet? */
4843 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
4844 I32 items;
4845 const U8 gimme = GIMME_V;
4846
4847 LEAVE_with_name("grep"); /* exit outer scope */
4848 (void)POPMARK; /* pop src */
4849 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
4850 (void)POPMARK; /* pop dst */
4851 SP = PL_stack_base + POPMARK; /* pop original mark */
4852 if (gimme == G_SCALAR) {
4853 if (PL_op->op_private & OPpTRUEBOOL)
4854 PUSHs(items ? &PL_sv_yes : &PL_sv_zero);
4855 else {
4856 dTARGET;
4857 PUSHi(items);
4858 }
4859 }
4860 else if (gimme == G_LIST)
4861 SP += items;
4862 RETURN;
4863 }
4864 else {
4865 SV *src;
4866
4867 ENTER_with_name("grep_item"); /* enter inner scope */
4868 SAVEVPTR(PL_curpm);
4869
4870 src = PL_stack_base[TOPMARK];
4871 if (SvPADTMP(src)) {
4872 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
4873 PL_tmps_floor++;
4874 }
4875 SvTEMP_off(src);
4876 DEFSV_set(src);
4877
4878 RETURNOP(cLOGOP->op_other);
4879 }
4880 }
4881
4882 /* leave_adjust_stacks():
4883 *
4884 * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
4885 * positioning them at to_sp+1 onwards, and do the equivalent of a
4886 * FREEMPS and TAINT_NOT.
4887 *
4888 * Not intended to be called in void context.
4889 *
4890 * When leaving a sub, eval, do{} or other scope, the things that need
4891 * doing to process the return args are:
4892 * * in scalar context, only return the last arg (or PL_sv_undef if none);
4893 * * for the types of return that return copies of their args (such
4894 * as rvalue sub return), make a mortal copy of every return arg,
4895 * except where we can optimise the copy away without it being
4896 * semantically visible;
4897 * * make sure that the arg isn't prematurely freed; in the case of an
4898 * arg not copied, this may involve mortalising it. For example, in
4899 * C<sub f { my $x = ...; $x }>, $x would be freed when we do
4900 * CX_LEAVE_SCOPE(cx) unless it's protected or copied.
4901 *
4902 * What condition to use when deciding whether to pass the arg through
4903 * or make a copy, is determined by the 'pass' arg; its valid values are:
4904 * 0: rvalue sub/eval exit
4905 * 1: other rvalue scope exit
4906 * 2: :lvalue sub exit in rvalue context
4907 * 3: :lvalue sub exit in lvalue context and other lvalue scope exits
4908 *
4909 * There is a big issue with doing a FREETMPS. We would like to free any
4910 * temps created by the last statement which the sub executed, rather than
4911 * leaving them for the caller. In a situation where a sub call isn't
4912 * soon followed by a nextstate (e.g. nested recursive calls, a la
4913 * fibonacci()), temps can accumulate, causing memory and performance
4914 * issues.
4915 *
4916 * On the other hand, we don't want to free any TEMPs which are keeping
4917 * alive any return args that we skipped copying; nor do we wish to undo
4918 * any mortalising done here.
4919 *
4920 * The solution is to split the temps stack frame into two, with a cut
4921 * point delineating the two halves. We arrange that by the end of this
4922 * function, all the temps stack frame entries we wish to keep are in the
4923 * range PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
4924 * the range tmps_base .. PL_tmps_ix. During the course of this
4925 * function, tmps_base starts off as PL_tmps_floor+1, then increases
4926 * whenever we find or create a temp that we know should be kept. In
4927 * general the stuff above tmps_base is undecided until we reach the end,
4928 * and we may need a sort stage for that.
4929 *
4930 * To determine whether a TEMP is keeping a return arg alive, every
4931 * arg that is kept rather than copied and which has the SvTEMP flag
4932 * set, has the flag temporarily unset, to mark it. At the end we scan
4933 * the temps stack frame above the cut for entries without SvTEMP and
4934 * keep them, while turning SvTEMP on again. Note that if we die before
4935 * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
4936 * those SVs may be slightly less efficient.
4937 *
4938 * In practice various optimisations for some common cases mean we can
4939 * avoid most of the scanning and swapping about with the temps stack.
4940 */
4941
4942 void
Perl_leave_adjust_stacks(pTHX_ SV ** from_sp,SV ** to_sp,U8 gimme,int pass)4943 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
4944 {
4945 dSP;
4946 SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
4947 SSize_t nargs;
4948
4949 PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
4950
4951 TAINT_NOT;
4952
4953 if (gimme == G_LIST) {
4954 nargs = SP - from_sp;
4955 from_sp++;
4956 }
4957 else {
4958 assert(gimme == G_SCALAR);
4959 if (UNLIKELY(from_sp >= SP)) {
4960 /* no return args */
4961 assert(from_sp == SP);
4962 EXTEND(SP, 1);
4963 *++SP = &PL_sv_undef;
4964 }
4965 from_sp = SP;
4966 nargs = 1;
4967 }
4968
4969 /* common code for G_SCALAR and G_LIST */
4970
4971 tmps_base = PL_tmps_floor + 1;
4972
4973 assert(nargs >= 0);
4974 if (nargs) {
4975 /* pointer version of tmps_base. Not safe across temp stack
4976 * reallocs. */
4977 SV **tmps_basep;
4978
4979 EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
4980 tmps_basep = PL_tmps_stack + tmps_base;
4981
4982 /* process each return arg */
4983
4984 do {
4985 SV *sv = *from_sp++;
4986
4987 assert(PL_tmps_ix + nargs < PL_tmps_max);
4988 #ifdef DEBUGGING
4989 /* PADTMPs with container set magic shouldn't appear in the
4990 * wild. This assert is more important for pp_leavesublv(),
4991 * but by testing for it here, we're more likely to catch
4992 * bad cases (what with :lvalue subs not being widely
4993 * deployed). The two issues are that for something like
4994 * sub :lvalue { $tied{foo} }
4995 * or
4996 * sub :lvalue { substr($foo,1,2) }
4997 * pp_leavesublv() will croak if the sub returns a PADTMP,
4998 * and currently functions like pp_substr() return a mortal
4999 * rather than using their PADTMP when returning a PVLV.
5000 * This is because the PVLV will hold a ref to $foo,
5001 * so $foo would get delayed in being freed while
5002 * the PADTMP SV remained in the PAD.
5003 * So if this assert fails it means either:
5004 * 1) there is pp code similar to pp_substr that is
5005 * returning a PADTMP instead of a mortal, and probably
5006 * needs fixing, or
5007 * 2) pp_leavesublv is making unwarranted assumptions
5008 * about always croaking on a PADTMP
5009 */
5010 if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
5011 MAGIC *mg;
5012 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
5013 assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
5014 }
5015 }
5016 #endif
5017
5018 if (
5019 pass == 0 ? (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
5020 : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
5021 : pass == 2 ? (!SvPADTMP(sv))
5022 : 1)
5023 {
5024 /* pass through: skip copy for logic or optimisation
5025 * reasons; instead mortalise it, except that ... */
5026 *++to_sp = sv;
5027
5028 if (SvTEMP(sv)) {
5029 /* ... since this SV is an SvTEMP , we don't need to
5030 * re-mortalise it; instead we just need to ensure
5031 * that its existing entry in the temps stack frame
5032 * ends up below the cut and so avoids being freed
5033 * this time round. We mark it as needing to be kept
5034 * by temporarily unsetting SvTEMP; then at the end,
5035 * we shuffle any !SvTEMP entries on the tmps stack
5036 * back below the cut.
5037 * However, there's a significant chance that there's
5038 * a 1:1 correspondence between the first few (or all)
5039 * elements in the return args stack frame and those
5040 * in the temps stack frame; e,g.:
5041 * sub f { ....; map {...} .... },
5042 * or if we're exiting multiple scopes and one of the
5043 * inner scopes has already made mortal copies of each
5044 * return arg.
5045 *
5046 * If so, this arg sv will correspond to the next item
5047 * on the tmps stack above the cut, and so can be kept
5048 * merely by moving the cut boundary up one, rather
5049 * than messing with SvTEMP. If all args are 1:1 then
5050 * we can avoid the sorting stage below completely.
5051 *
5052 * If there are no items above the cut on the tmps
5053 * stack, then the SvTEMP must comne from an item
5054 * below the cut, so there's nothing to do.
5055 */
5056 if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
5057 if (sv == *tmps_basep)
5058 tmps_basep++;
5059 else
5060 SvTEMP_off(sv);
5061 }
5062 }
5063 else if (!SvPADTMP(sv)) {
5064 /* mortalise arg to avoid it being freed during save
5065 * stack unwinding. Pad tmps don't need mortalising as
5066 * they're never freed. This is the equivalent of
5067 * sv_2mortal(SvREFCNT_inc(sv)), except that:
5068 * * it assumes that the temps stack has already been
5069 * extended;
5070 * * it puts the new item at the cut rather than at
5071 * ++PL_tmps_ix, moving the previous occupant there
5072 * instead.
5073 */
5074 if (!SvIMMORTAL(sv)) {
5075 SvREFCNT_inc_simple_void_NN(sv);
5076 SvTEMP_on(sv);
5077 /* Note that if there's nothing above the cut,
5078 * this copies the garbage one slot above
5079 * PL_tmps_ix onto itself. This is harmless (the
5080 * stack's already been extended), but might in
5081 * theory trigger warnings from tools like ASan
5082 */
5083 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
5084 *tmps_basep++ = sv;
5085 }
5086 }
5087 }
5088 else {
5089 /* Make a mortal copy of the SV.
5090 * The following code is the equivalent of sv_mortalcopy()
5091 * except that:
5092 * * it assumes the temps stack has already been extended;
5093 * * it optimises the copying for some simple SV types;
5094 * * it puts the new item at the cut rather than at
5095 * ++PL_tmps_ix, moving the previous occupant there
5096 * instead.
5097 */
5098 SV *newsv = newSV_type(SVt_NULL);
5099
5100 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
5101 /* put it on the tmps stack early so it gets freed if we die */
5102 *tmps_basep++ = newsv;
5103 *++to_sp = newsv;
5104
5105 if (SvTYPE(sv) <= SVt_IV) {
5106 /* arg must be one of undef, IV/UV, or RV: skip
5107 * sv_setsv_flags() and do the copy directly */
5108 U32 dstflags;
5109 U32 srcflags = SvFLAGS(sv);
5110
5111 assert(!SvGMAGICAL(sv));
5112 if (srcflags & (SVf_IOK|SVf_ROK)) {
5113 SET_SVANY_FOR_BODYLESS_IV(newsv);
5114
5115 if (srcflags & SVf_ROK) {
5116 newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
5117 /* SV type plus flags */
5118 dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
5119 }
5120 else {
5121 /* both src and dst are <= SVt_IV, so sv_any
5122 * points to the head; so access the heads
5123 * directly rather than going via sv_any.
5124 */
5125 assert( &(sv->sv_u.svu_iv)
5126 == &(((XPVIV*) SvANY(sv))->xiv_iv));
5127 assert( &(newsv->sv_u.svu_iv)
5128 == &(((XPVIV*) SvANY(newsv))->xiv_iv));
5129 newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
5130 /* SV type plus flags */
5131 dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
5132 |(srcflags & SVf_IVisUV));
5133 }
5134 }
5135 else {
5136 assert(!(srcflags & SVf_OK));
5137 dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
5138 }
5139 SvFLAGS(newsv) = dstflags;
5140
5141 }
5142 else {
5143 /* do the full sv_setsv() */
5144 SSize_t old_base;
5145
5146 SvTEMP_on(newsv);
5147 old_base = tmps_basep - PL_tmps_stack;
5148 SvGETMAGIC(sv);
5149 sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
5150 /* the mg_get or sv_setsv might have created new temps
5151 * or realloced the tmps stack; regrow and reload */
5152 EXTEND_MORTAL(nargs);
5153 tmps_basep = PL_tmps_stack + old_base;
5154 TAINT_NOT; /* Each item is independent */
5155 }
5156
5157 }
5158 } while (--nargs);
5159
5160 /* If there are any temps left above the cut, we need to sort
5161 * them into those to keep and those to free. The only ones to
5162 * keep are those for which we've temporarily unset SvTEMP.
5163 * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
5164 * swapping pairs as necessary. Stop when we meet in the middle.
5165 */
5166 {
5167 SV **top = PL_tmps_stack + PL_tmps_ix;
5168 while (tmps_basep <= top) {
5169 SV *sv = *top;
5170 if (SvTEMP(sv))
5171 top--;
5172 else {
5173 SvTEMP_on(sv);
5174 *top = *tmps_basep;
5175 *tmps_basep = sv;
5176 tmps_basep++;
5177 }
5178 }
5179 }
5180
5181 tmps_base = tmps_basep - PL_tmps_stack;
5182 }
5183
5184 PL_stack_sp = to_sp;
5185
5186 /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
5187 while (PL_tmps_ix >= tmps_base) {
5188 SV* const sv = PL_tmps_stack[PL_tmps_ix--];
5189 #ifdef PERL_POISON
5190 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
5191 #endif
5192 if (LIKELY(sv)) {
5193 SvTEMP_off(sv);
5194 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
5195 }
5196 }
5197 }
5198
5199
5200 /* also tail-called by pp_return */
5201
PP(pp_leavesub)5202 PP(pp_leavesub)
5203 {
5204 U8 gimme;
5205 PERL_CONTEXT *cx;
5206 SV **oldsp;
5207 OP *retop;
5208
5209 cx = CX_CUR();
5210 assert(CxTYPE(cx) == CXt_SUB);
5211
5212 if (CxMULTICALL(cx)) {
5213 /* entry zero of a stack is always PL_sv_undef, which
5214 * simplifies converting a '()' return into undef in scalar context */
5215 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
5216 return 0;
5217 }
5218
5219 gimme = cx->blk_gimme;
5220 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
5221
5222 if (gimme == G_VOID)
5223 PL_stack_sp = oldsp;
5224 else
5225 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
5226
5227 CX_LEAVE_SCOPE(cx);
5228 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
5229 cx_popblock(cx);
5230 retop = cx->blk_sub.retop;
5231 CX_POP(cx);
5232
5233 return retop;
5234 }
5235
5236
5237 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
5238 * forces an abandon */
5239
5240 void
Perl_clear_defarray(pTHX_ AV * av,bool abandon)5241 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
5242 {
5243 PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
5244
5245 if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))) {
5246 av_clear(av);
5247 AvREIFY_only(av);
5248 }
5249 else {
5250 const SSize_t size = AvFILLp(av) + 1;
5251 /* The ternary gives consistency with av_extend() */
5252 AV *newav = newAV_alloc_x(size < PERL_ARRAY_NEW_MIN_KEY ?
5253 PERL_ARRAY_NEW_MIN_KEY : size);
5254 AvREIFY_only(newav);
5255 PAD_SVl(0) = MUTABLE_SV(newav);
5256 SvREFCNT_dec_NN(av);
5257 }
5258 }
5259
5260
PP(pp_entersub)5261 PP(pp_entersub)
5262 {
5263 dSP; dPOPss;
5264 GV *gv;
5265 CV *cv;
5266 PERL_CONTEXT *cx;
5267 I32 old_savestack_ix;
5268
5269 if (UNLIKELY(!sv))
5270 goto do_die;
5271
5272 /* Locate the CV to call:
5273 * - most common case: RV->CV: f(), $ref->():
5274 * note that if a sub is compiled before its caller is compiled,
5275 * the stash entry will be a ref to a CV, rather than being a GV.
5276 * - second most common case: CV: $ref->method()
5277 */
5278
5279 /* a non-magic-RV -> CV ? */
5280 if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
5281 cv = MUTABLE_CV(SvRV(sv));
5282 if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
5283 goto do_ref;
5284 }
5285 else
5286 cv = MUTABLE_CV(sv);
5287
5288 /* a CV ? */
5289 if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
5290 /* handle all the weird cases */
5291 switch (SvTYPE(sv)) {
5292 case SVt_PVLV:
5293 if (!isGV_with_GP(sv))
5294 goto do_default;
5295 /* FALLTHROUGH */
5296 case SVt_PVGV:
5297 cv = GvCVu((const GV *)sv);
5298 if (UNLIKELY(!cv)) {
5299 HV *stash;
5300 cv = sv_2cv(sv, &stash, &gv, 0);
5301 if (!cv) {
5302 old_savestack_ix = PL_savestack_ix;
5303 goto try_autoload;
5304 }
5305 }
5306 break;
5307
5308 default:
5309 do_default:
5310 SvGETMAGIC(sv);
5311 if (SvROK(sv)) {
5312 do_ref:
5313 if (UNLIKELY(SvAMAGIC(sv))) {
5314 sv = amagic_deref_call(sv, to_cv_amg);
5315 /* Don't SPAGAIN here. */
5316 }
5317 }
5318 else {
5319 const char *sym;
5320 STRLEN len;
5321 if (UNLIKELY(!SvOK(sv)))
5322 DIE(aTHX_ PL_no_usym, "a subroutine");
5323
5324 sym = SvPV_nomg_const(sv, len);
5325 if (PL_op->op_private & HINT_STRICT_REFS)
5326 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
5327 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
5328 break;
5329 }
5330 cv = MUTABLE_CV(SvRV(sv));
5331 if (LIKELY(SvTYPE(cv) == SVt_PVCV))
5332 break;
5333 /* FALLTHROUGH */
5334 case SVt_PVHV:
5335 case SVt_PVAV:
5336 do_die:
5337 DIE(aTHX_ "Not a CODE reference");
5338 }
5339 }
5340
5341 /* At this point we want to save PL_savestack_ix, either by doing a
5342 * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
5343 * CV we will be using (so we don't know whether its XS, so we can't
5344 * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
5345 * the save stack. So remember where we are currently on the save
5346 * stack, and later update the CX or scopestack entry accordingly. */
5347 old_savestack_ix = PL_savestack_ix;
5348
5349 /* these two fields are in a union. If they ever become separate,
5350 * we have to test for both of them being null below */
5351 assert(cv);
5352 assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
5353 while (UNLIKELY(!CvROOT(cv))) {
5354 GV* autogv;
5355 SV* sub_name;
5356
5357 /* anonymous or undef'd function leaves us no recourse */
5358 if (CvLEXICAL(cv) && CvHASGV(cv))
5359 DIE(aTHX_ "Undefined subroutine &%" SVf " called",
5360 SVfARG(cv_name(cv, NULL, 0)));
5361 if (CvANON(cv) || !CvHASGV(cv)) {
5362 DIE(aTHX_ "Undefined subroutine called");
5363 }
5364
5365 /* autoloaded stub? */
5366 if (cv != GvCV(gv = CvGV(cv))) {
5367 cv = GvCV(gv);
5368 }
5369 /* should call AUTOLOAD now? */
5370 else {
5371 try_autoload:
5372 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
5373 (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
5374 |(PL_op->op_flags & OPf_REF
5375 ? GV_AUTOLOAD_ISMETHOD
5376 : 0));
5377 cv = autogv ? GvCV(autogv) : NULL;
5378 }
5379 if (!cv) {
5380 sub_name = sv_newmortal();
5381 gv_efullname3(sub_name, gv, NULL);
5382 DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name));
5383 }
5384 }
5385
5386 /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */
5387 if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE))
5388 DIE(aTHX_ "Closure prototype called");
5389
5390 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
5391 && !CvNODEBUG(cv)))
5392 {
5393 Perl_get_db_sub(aTHX_ &sv, cv);
5394 if (CvISXSUB(cv))
5395 PL_curcopdb = PL_curcop;
5396 if (CvLVALUE(cv)) {
5397 /* check for lsub that handles lvalue subroutines */
5398 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
5399 /* if lsub not found then fall back to DB::sub */
5400 if (!cv) cv = GvCV(PL_DBsub);
5401 } else {
5402 cv = GvCV(PL_DBsub);
5403 }
5404
5405 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
5406 DIE(aTHX_ "No DB::sub routine defined");
5407 }
5408
5409 if (!(CvISXSUB(cv))) {
5410 /* This path taken at least 75% of the time */
5411 dMARK;
5412 PADLIST *padlist;
5413 I32 depth;
5414 bool hasargs;
5415 U8 gimme;
5416
5417 /* keep PADTMP args alive throughout the call (we need to do this
5418 * because @_ isn't refcounted). Note that we create the mortals
5419 * in the caller's tmps frame, so they won't be freed until after
5420 * we return from the sub.
5421 */
5422 {
5423 SV **svp = MARK;
5424 while (svp < SP) {
5425 SV *sv = *++svp;
5426 if (!sv)
5427 continue;
5428 if (SvPADTMP(sv))
5429 *svp = sv = sv_mortalcopy(sv);
5430 SvTEMP_off(sv);
5431 }
5432 }
5433
5434 gimme = GIMME_V;
5435 cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
5436 hasargs = cBOOL(PL_op->op_flags & OPf_STACKED);
5437 cx_pushsub(cx, cv, PL_op->op_next, hasargs);
5438
5439 padlist = CvPADLIST(cv);
5440 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
5441 pad_push(padlist, depth);
5442 PAD_SET_CUR_NOSAVE(padlist, depth);
5443 if (LIKELY(hasargs)) {
5444 AV *const av = MUTABLE_AV(PAD_SVl(0));
5445 SSize_t items;
5446 AV **defavp;
5447
5448 defavp = &GvAV(PL_defgv);
5449 cx->blk_sub.savearray = *defavp;
5450 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
5451
5452 /* it's the responsibility of whoever leaves a sub to ensure
5453 * that a clean, empty AV is left in pad[0]. This is normally
5454 * done by cx_popsub() */
5455 assert(!AvREAL(av) && AvFILLp(av) == -1);
5456
5457 items = SP - MARK;
5458 if (UNLIKELY(items - 1 > AvMAX(av))) {
5459 SV **ary = AvALLOC(av);
5460 Renew(ary, items, SV*);
5461 AvMAX(av) = items - 1;
5462 AvALLOC(av) = ary;
5463 AvARRAY(av) = ary;
5464 }
5465
5466 if (items)
5467 Copy(MARK+1,AvARRAY(av),items,SV*);
5468 AvFILLp(av) = items - 1;
5469 }
5470 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
5471 !CvLVALUE(cv)))
5472 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
5473 SVfARG(cv_name(cv, NULL, 0)));
5474 /* warning must come *after* we fully set up the context
5475 * stuff so that __WARN__ handlers can safely dounwind()
5476 * if they want to
5477 */
5478 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
5479 && ckWARN(WARN_RECURSION)
5480 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
5481 sub_crush_depth(cv);
5482 RETURNOP(CvSTART(cv));
5483 }
5484 else {
5485 SSize_t markix = TOPMARK;
5486 bool is_scalar;
5487
5488 ENTER;
5489 /* pretend we did the ENTER earlier */
5490 PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
5491
5492 SAVETMPS;
5493 PUTBACK;
5494
5495 if (UNLIKELY(((PL_op->op_private
5496 & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
5497 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
5498 !CvLVALUE(cv)))
5499 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
5500 SVfARG(cv_name(cv, NULL, 0)));
5501
5502 if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) {
5503 /* Need to copy @_ to stack. Alternative may be to
5504 * switch stack to @_, and copy return values
5505 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
5506 AV * const av = GvAV(PL_defgv);
5507 const SSize_t items = AvFILL(av) + 1;
5508
5509 if (items) {
5510 SSize_t i = 0;
5511 const bool m = cBOOL(SvRMAGICAL(av));
5512 /* Mark is at the end of the stack. */
5513 EXTEND(SP, items);
5514 for (; i < items; ++i)
5515 {
5516 SV *sv;
5517 if (m) {
5518 SV ** const svp = av_fetch(av, i, 0);
5519 sv = svp ? *svp : NULL;
5520 }
5521 else sv = AvARRAY(av)[i];
5522 if (sv) SP[i+1] = sv;
5523 else {
5524 SP[i+1] = av_nonelem(av, i);
5525 }
5526 }
5527 SP += items;
5528 PUTBACK ;
5529 }
5530 }
5531 else {
5532 SV **mark = PL_stack_base + markix;
5533 SSize_t items = SP - mark;
5534 while (items--) {
5535 mark++;
5536 if (*mark && SvPADTMP(*mark)) {
5537 *mark = sv_mortalcopy(*mark);
5538 }
5539 }
5540 }
5541 /* We assume first XSUB in &DB::sub is the called one. */
5542 if (UNLIKELY(PL_curcopdb)) {
5543 SAVEVPTR(PL_curcop);
5544 PL_curcop = PL_curcopdb;
5545 PL_curcopdb = NULL;
5546 }
5547 /* Do we need to open block here? XXXX */
5548
5549 /* calculate gimme here as PL_op might get changed and then not
5550 * restored until the LEAVE further down */
5551 is_scalar = (GIMME_V == G_SCALAR);
5552
5553 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
5554 assert(CvXSUB(cv));
5555 CvXSUB(cv)(aTHX_ cv);
5556
5557 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5558 /* This duplicates the check done in runops_debug(), but provides more
5559 * information in the common case of the fault being with an XSUB.
5560 *
5561 * It should also catch an XSUB pushing more than it extends
5562 * in scalar context.
5563 */
5564 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
5565 Perl_croak_nocontext(
5566 "panic: XSUB %s::%s (%s) failed to extend arg stack: "
5567 "base=%p, sp=%p, hwm=%p\n",
5568 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)), CvFILE(cv),
5569 PL_stack_base, PL_stack_sp,
5570 PL_stack_base + PL_curstackinfo->si_stack_hwm);
5571 #endif
5572 /* Enforce some sanity in scalar context. */
5573 if (is_scalar) {
5574 SV **svp = PL_stack_base + markix + 1;
5575 if (svp != PL_stack_sp) {
5576 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
5577 PL_stack_sp = svp;
5578 }
5579 }
5580 LEAVE;
5581 return NORMAL;
5582 }
5583 }
5584
5585 void
Perl_sub_crush_depth(pTHX_ CV * cv)5586 Perl_sub_crush_depth(pTHX_ CV *cv)
5587 {
5588 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
5589
5590 if (CvANON(cv))
5591 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
5592 else {
5593 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"",
5594 SVfARG(cv_name(cv,NULL,0)));
5595 }
5596 }
5597
5598
5599
5600 /* like croak, but report in context of caller */
5601
5602 void
Perl_croak_caller(const char * pat,...)5603 Perl_croak_caller(const char *pat, ...)
5604 {
5605 dTHX;
5606 va_list args;
5607 const PERL_CONTEXT *cx = caller_cx(0, NULL);
5608
5609 /* make error appear at call site */
5610 assert(cx);
5611 PL_curcop = cx->blk_oldcop;
5612
5613 va_start(args, pat);
5614 vcroak(pat, &args);
5615 NOT_REACHED; /* NOTREACHED */
5616 va_end(args);
5617 }
5618
5619
PP(pp_aelem)5620 PP(pp_aelem)
5621 {
5622 dSP;
5623 SV** svp;
5624 SV* const elemsv = POPs;
5625 IV elem = SvIV(elemsv);
5626 AV *const av = MUTABLE_AV(POPs);
5627 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
5628 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
5629 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5630 bool preeminent = TRUE;
5631 SV *sv;
5632
5633 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
5634 Perl_warner(aTHX_ packWARN(WARN_MISC),
5635 "Use of reference \"%" SVf "\" as array index",
5636 SVfARG(elemsv));
5637 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
5638 RETPUSHUNDEF;
5639
5640 if (UNLIKELY(localizing)) {
5641 MAGIC *mg;
5642 HV *stash;
5643
5644 /* Try to preserve the existence of a tied array
5645 * element by using EXISTS and DELETE if possible.
5646 * Fall back to FETCH and STORE otherwise. */
5647 if (SvCANEXISTDELETE(av))
5648 preeminent = av_exists(av, elem);
5649 }
5650
5651 svp = av_fetch(av, elem, lval && !defer);
5652 if (lval) {
5653 #ifdef PERL_MALLOC_WRAP
5654 if (SvUOK(elemsv)) {
5655 const UV uv = SvUV(elemsv);
5656 elem = uv > IV_MAX ? IV_MAX : uv;
5657 }
5658 else if (SvNOK(elemsv))
5659 elem = (IV)SvNV(elemsv);
5660 if (elem > 0) {
5661 MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend");
5662 }
5663 #endif
5664 if (!svp || !*svp) {
5665 IV len;
5666 if (!defer)
5667 DIE(aTHX_ PL_no_aelem, elem);
5668 len = av_top_index(av);
5669 /* Resolve a negative index that falls within the array. Leave
5670 it negative it if falls outside the array. */
5671 if (elem < 0 && len + elem >= 0)
5672 elem = len + elem;
5673 if (elem >= 0 && elem <= len)
5674 /* Falls within the array. */
5675 PUSHs(av_nonelem(av,elem));
5676 else
5677 /* Falls outside the array. If it is negative,
5678 magic_setdefelem will use the index for error reporting.
5679 */
5680 mPUSHs(newSVavdefelem(av, elem, 1));
5681 RETURN;
5682 }
5683 if (UNLIKELY(localizing)) {
5684 if (preeminent)
5685 save_aelem(av, elem, svp);
5686 else
5687 SAVEADELETE(av, elem);
5688 }
5689 else if (PL_op->op_private & OPpDEREF) {
5690 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
5691 RETURN;
5692 }
5693 }
5694 sv = (svp ? *svp : &PL_sv_undef);
5695 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
5696 mg_get(sv);
5697 PUSHs(sv);
5698 RETURN;
5699 }
5700
5701 SV*
Perl_vivify_ref(pTHX_ SV * sv,U32 to_what)5702 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
5703 {
5704 PERL_ARGS_ASSERT_VIVIFY_REF;
5705
5706 SvGETMAGIC(sv);
5707 if (!SvOK(sv)) {
5708 if (SvREADONLY(sv))
5709 Perl_croak_no_modify();
5710 prepare_SV_for_RV(sv);
5711 switch (to_what) {
5712 case OPpDEREF_SV:
5713 SvRV_set(sv, newSV_type(SVt_NULL));
5714 break;
5715 case OPpDEREF_AV:
5716 SvRV_set(sv, MUTABLE_SV(newAV()));
5717 break;
5718 case OPpDEREF_HV:
5719 SvRV_set(sv, MUTABLE_SV(newHV()));
5720 break;
5721 }
5722 SvROK_on(sv);
5723 SvSETMAGIC(sv);
5724 SvGETMAGIC(sv);
5725 }
5726 if (SvGMAGICAL(sv)) {
5727 /* copy the sv without magic to prevent magic from being
5728 executed twice */
5729 SV* msv = sv_newmortal();
5730 sv_setsv_nomg(msv, sv);
5731 return msv;
5732 }
5733 return sv;
5734 }
5735
5736 PERL_STATIC_INLINE HV *
S_opmethod_stash(pTHX_ SV * meth)5737 S_opmethod_stash(pTHX_ SV* meth)
5738 {
5739 SV* ob;
5740 HV* stash;
5741
5742 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
5743 ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a "
5744 "package or object reference", SVfARG(meth)),
5745 (SV *)NULL)
5746 : *(PL_stack_base + TOPMARK + 1);
5747
5748 PERL_ARGS_ASSERT_OPMETHOD_STASH;
5749
5750 if (UNLIKELY(!sv))
5751 undefined:
5752 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value",
5753 SVfARG(meth));
5754
5755 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
5756 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
5757 stash = gv_stashsv(sv, GV_CACHE_ONLY);
5758 if (stash) return stash;
5759 }
5760
5761 if (SvROK(sv))
5762 ob = MUTABLE_SV(SvRV(sv));
5763 else if (!SvOK(sv)) goto undefined;
5764 else if (isGV_with_GP(sv)) {
5765 if (!GvIO(sv))
5766 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
5767 "without a package or object reference",
5768 SVfARG(meth));
5769 ob = sv;
5770 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
5771 assert(!LvTARGLEN(ob));
5772 ob = LvTARG(ob);
5773 assert(ob);
5774 }
5775 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
5776 }
5777 else {
5778 /* this isn't a reference */
5779 GV* iogv;
5780 STRLEN packlen;
5781 const char * const packname = SvPV_nomg_const(sv, packlen);
5782 const U32 packname_utf8 = SvUTF8(sv);
5783 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
5784 if (stash) return stash;
5785
5786 if (!(iogv = gv_fetchpvn_flags(
5787 packname, packlen, packname_utf8, SVt_PVIO
5788 )) ||
5789 !(ob=MUTABLE_SV(GvIO(iogv))))
5790 {
5791 /* this isn't the name of a filehandle either */
5792 if (!packlen)
5793 {
5794 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
5795 "without a package or object reference",
5796 SVfARG(meth));
5797 }
5798 /* assume it's a package name */
5799 stash = gv_stashpvn(packname, packlen, packname_utf8);
5800 if (stash) return stash;
5801 else return MUTABLE_HV(sv);
5802 }
5803 /* it _is_ a filehandle name -- replace with a reference */
5804 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
5805 }
5806
5807 /* if we got here, ob should be an object or a glob */
5808 if (!ob || !(SvOBJECT(ob)
5809 || (isGV_with_GP(ob)
5810 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
5811 && SvOBJECT(ob))))
5812 {
5813 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference",
5814 SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES)
5815 ? newSVpvs_flags("DOES", SVs_TEMP)
5816 : meth));
5817 }
5818
5819 return SvSTASH(ob);
5820 }
5821
PP(pp_method)5822 PP(pp_method)
5823 {
5824 dSP;
5825 GV* gv;
5826 HV* stash;
5827 SV* const meth = TOPs;
5828
5829 if (SvROK(meth)) {
5830 SV* const rmeth = SvRV(meth);
5831 if (SvTYPE(rmeth) == SVt_PVCV) {
5832 SETs(rmeth);
5833 RETURN;
5834 }
5835 }
5836
5837 stash = opmethod_stash(meth);
5838
5839 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
5840 assert(gv);
5841
5842 SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5843 RETURN;
5844 }
5845
5846 #define METHOD_CHECK_CACHE(stash,cache,meth) \
5847 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
5848 if (he) { \
5849 gv = MUTABLE_GV(HeVAL(he)); \
5850 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
5851 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
5852 { \
5853 XPUSHs(MUTABLE_SV(GvCV(gv))); \
5854 RETURN; \
5855 } \
5856 } \
5857
PP(pp_method_named)5858 PP(pp_method_named)
5859 {
5860 dSP;
5861 GV* gv;
5862 SV* const meth = cMETHOP_meth;
5863 HV* const stash = opmethod_stash(meth);
5864
5865 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
5866 METHOD_CHECK_CACHE(stash, stash, meth);
5867 }
5868
5869 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
5870 assert(gv);
5871
5872 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5873 RETURN;
5874 }
5875
PP(pp_method_super)5876 PP(pp_method_super)
5877 {
5878 dSP;
5879 GV* gv;
5880 HV* cache;
5881 SV* const meth = cMETHOP_meth;
5882 HV* const stash = CopSTASH(PL_curcop);
5883 /* Actually, SUPER doesn't need real object's (or class') stash at all,
5884 * as it uses CopSTASH. However, we must ensure that object(class) is
5885 * correct (this check is done by S_opmethod_stash) */
5886 opmethod_stash(meth);
5887
5888 if ((cache = HvMROMETA(stash)->super)) {
5889 METHOD_CHECK_CACHE(stash, cache, meth);
5890 }
5891
5892 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
5893 assert(gv);
5894
5895 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5896 RETURN;
5897 }
5898
PP(pp_method_redir)5899 PP(pp_method_redir)
5900 {
5901 dSP;
5902 GV* gv;
5903 SV* const meth = cMETHOP_meth;
5904 HV* stash = gv_stashsv(cMETHOP_rclass, 0);
5905 opmethod_stash(meth); /* not used but needed for error checks */
5906
5907 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
5908 else stash = MUTABLE_HV(cMETHOP_rclass);
5909
5910 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
5911 assert(gv);
5912
5913 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5914 RETURN;
5915 }
5916
PP(pp_method_redir_super)5917 PP(pp_method_redir_super)
5918 {
5919 dSP;
5920 GV* gv;
5921 HV* cache;
5922 SV* const meth = cMETHOP_meth;
5923 HV* stash = gv_stashsv(cMETHOP_rclass, 0);
5924 opmethod_stash(meth); /* not used but needed for error checks */
5925
5926 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOP_rclass);
5927 else if ((cache = HvMROMETA(stash)->super)) {
5928 METHOD_CHECK_CACHE(stash, cache, meth);
5929 }
5930
5931 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
5932 assert(gv);
5933
5934 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5935 RETURN;
5936 }
5937
5938 /*
5939 * ex: set ts=8 sts=4 sw=4 et:
5940 */
5941