This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl5337delta: note that stadtx was removed
[perl5.git] / pp_hot.c
CommitLineData
a0d0e21e
LW
1/* pp_hot.c
2 *
1129b882
NC
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
a0d0e21e
LW
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 *
4ac71550
TC
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"]
a0d0e21e
LW
19 */
20
166f8a29
DM
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
a0d0e21e 34#include "EXTERN.h"
864dbfa3 35#define PERL_IN_PP_HOT_C
a0d0e21e 36#include "perl.h"
e0be7821 37#include "regcomp.h"
a0d0e21e
LW
38
39/* Hot code. */
40
41PP(pp_const)
42{
39644a26 43 dSP;
996c9baa 44 XPUSHs(cSVOP_sv);
a0d0e21e
LW
45 RETURN;
46}
47
48PP(pp_nextstate)
49{
533c011a 50 PL_curcop = (COP*)PL_op;
a0d0e21e 51 TAINT_NOT; /* Each statement is presumed innocent */
4ebe6e95 52 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
a0d0e21e 53 FREETMPS;
f410a211 54 PERL_ASYNC_CHECK();
a0d0e21e
LW
55 return NORMAL;
56}
57
58PP(pp_gvsv)
59{
39644a26 60 dSP;
924508f0 61 EXTEND(SP,1);
5d9574c1 62 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
1604cfb0 63 PUSHs(save_scalar(cGVOP_gv));
a0d0e21e 64 else
1604cfb0 65 PUSHs(GvSVn(cGVOP_gv));
a0d0e21e
LW
66 RETURN;
67}
68
b1c05ba5
DM
69
70/* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
71
a0d0e21e
LW
72PP(pp_null)
73{
74 return NORMAL;
75}
76
3dd9d4e4
FC
77/* This is sometimes called directly by pp_coreargs, pp_grepstart and
78 amagic_call. */
a0d0e21e
LW
79PP(pp_pushmark)
80{
3280af22 81 PUSHMARK(PL_stack_sp);
a0d0e21e
LW
82 return NORMAL;
83}
84
85PP(pp_stringify)
86{
20b7effb 87 dSP; dTARGET;
4cc783ef
DD
88 SV * const sv = TOPs;
89 SETs(TARG);
90 sv_copypv(TARG, sv);
91 SvSETMAGIC(TARG);
92 /* no PUTBACK, SETs doesn't inc/dec SP */
93 return NORMAL;
a0d0e21e
LW
94}
95
96PP(pp_gv)
97{
20b7effb 98 dSP;
ad64d0ec 99 XPUSHs(MUTABLE_SV(cGVOP_gv));
a0d0e21e
LW
100 RETURN;
101}
102
b1c05ba5
DM
103
104/* also used for: pp_andassign() */
105
a0d0e21e
LW
106PP(pp_and)
107{
f410a211 108 PERL_ASYNC_CHECK();
4cc783ef 109 {
1604cfb0
MS
110 /* SP is not used to remove a variable that is saved across the
111 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
112 register or load/store vs direct mem ops macro is introduced, this
113 should be a define block between direct PL_stack_sp and dSP operations,
114 presently, using PL_stack_sp is bias towards CISC cpus */
115 SV * const sv = *PL_stack_sp;
116 if (!SvTRUE_NN(sv))
117 return NORMAL;
118 else {
119 if (PL_op->op_type == OP_AND)
120 --PL_stack_sp;
121 return cLOGOP->op_other;
122 }
a0d0e21e
LW
123 }
124}
125
126PP(pp_sassign)
127{
20b7effb 128 dSP;
3e75a3c4
RU
129 /* sassign keeps its args in the optree traditionally backwards.
130 So we pop them differently.
131 */
132 SV *left = POPs; SV *right = TOPs;
748a9306 133
354eabfa 134 if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
1604cfb0
MS
135 SV * const temp = left;
136 left = right; right = temp;
a0d0e21e 137 }
d48c660d
DM
138 assert(TAINTING_get || !TAINT_get);
139 if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
1604cfb0 140 TAINT_NOT;
5d9574c1
DM
141 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
142 /* *foo =\&bar */
1604cfb0
MS
143 SV * const cv = SvRV(right);
144 const U32 cv_type = SvTYPE(cv);
145 const bool is_gv = isGV_with_GP(left);
146 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
147
148 if (!got_coderef) {
149 assert(SvROK(cv));
150 }
151
152 /* Can do the optimisation if left (LVALUE) is not a typeglob,
153 right (RVALUE) is a reference to something, and we're in void
154 context. */
155 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
156 /* Is the target symbol table currently empty? */
157 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
158 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
159 /* Good. Create a new proxy constant subroutine in the target.
160 The gv becomes a(nother) reference to the constant. */
161 SV *const value = SvRV(cv);
162
163 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
164 SvPCS_IMPORTED_on(gv);
165 SvRV_set(gv, value);
166 SvREFCNT_inc_simple_void(value);
167 SETs(left);
168 RETURN;
169 }
170 }
171
172 /* Need to fix things up. */
173 if (!is_gv) {
174 /* Need to fix GV. */
175 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
176 }
177
178 if (!got_coderef) {
179 /* We've been returned a constant rather than a full subroutine,
180 but they expect a subroutine reference to apply. */
181 if (SvROK(cv)) {
182 ENTER_with_name("sassign_coderef");
183 SvREFCNT_inc_void(SvRV(cv));
184 /* newCONSTSUB takes a reference count on the passed in SV
185 from us. We set the name to NULL, otherwise we get into
186 all sorts of fun as the reference to our new sub is
187 donated to the GV that we're about to assign to.
188 */
189 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
190 SvRV(cv))));
191 SvREFCNT_dec_NN(cv);
192 LEAVE_with_name("sassign_coderef");
193 } else {
194 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
195 is that
196 First: ops for \&{"BONK"}; return us the constant in the
197 symbol table
198 Second: ops for *{"BONK"} cause that symbol table entry
199 (and our reference to it) to be upgraded from RV
200 to typeblob)
201 Thirdly: We get here. cv is actually PVGV now, and its
202 GvCV() is actually the subroutine we're looking for
203
204 So change the reference so that it points to the subroutine
205 of that typeglob, as that's what they were after all along.
206 */
207 GV *const upgraded = MUTABLE_GV(cv);
208 CV *const source = GvCV(upgraded);
209
210 assert(source);
211 assert(CvFLAGS(source) & CVf_CONST);
212
213 SvREFCNT_inc_simple_void_NN(source);
214 SvREFCNT_dec_NN(upgraded);
215 SvRV_set(right, MUTABLE_SV(source));
216 }
217 }
53a42478 218
e26df76a 219 }
8fe85e3f 220 if (
5d9574c1 221 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
3e75a3c4 222 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
8fe85e3f 223 )
1604cfb0
MS
224 Perl_warner(aTHX_
225 packWARN(WARN_MISC), "Useless assignment to a temporary"
226 );
3e75a3c4
RU
227 SvSetMagicSV(left, right);
228 SETs(left);
a0d0e21e
LW
229 RETURN;
230}
231
232PP(pp_cond_expr)
233{
20b7effb 234 dSP;
f4c975aa
DM
235 SV *sv;
236
f410a211 237 PERL_ASYNC_CHECK();
f4c975aa
DM
238 sv = POPs;
239 RETURNOP(SvTRUE_NN(sv) ? cLOGOP->op_other : cLOGOP->op_next);
a0d0e21e
LW
240}
241
242PP(pp_unstack)
243{
f5319de9 244 PERL_CONTEXT *cx;
8f3964af 245 PERL_ASYNC_CHECK();
a0d0e21e 246 TAINT_NOT; /* Each statement is presumed innocent */
4ebe6e95 247 cx = CX_CUR();
f5319de9 248 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
a0d0e21e 249 FREETMPS;
eae48c89 250 if (!(PL_op->op_flags & OPf_SPECIAL)) {
93661e56 251 assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
1604cfb0 252 CX_LEAVE_SCOPE(cx);
eae48c89 253 }
a0d0e21e
LW
254 return NORMAL;
255}
256
16fe3f8a
DM
257
258/* The main body of pp_concat, not including the magic/overload and
259 * stack handling.
260 * It does targ = left . right.
261 * Moved into a separate function so that pp_multiconcat() can use it
262 * too.
263 */
264
265PERL_STATIC_INLINE void
266S_do_concat(pTHX_ SV *left, SV *right, SV *targ, U8 targmy)
a0d0e21e 267{
8d6d96c1
HS
268 bool lbyte;
269 STRLEN rlen;
d4c19fe8 270 const char *rpv = NULL;
a6b599c7 271 bool rbyte = FALSE;
a9c4fd4e 272 bool rcopied = FALSE;
8d6d96c1 273
6f1401dc 274 if (TARG == right && right != left) { /* $r = $l.$r */
1604cfb0
MS
275 rpv = SvPV_nomg_const(right, rlen);
276 rbyte = !DO_UTF8(right);
277 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
278 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
279 rcopied = TRUE;
8d6d96c1 280 }
7889fe52 281
89734059 282 if (TARG != left) { /* not $l .= $r */
a9c4fd4e 283 STRLEN llen;
6f1401dc 284 const char* const lpv = SvPV_nomg_const(left, llen);
1604cfb0
MS
285 lbyte = !DO_UTF8(left);
286 sv_setpvn(TARG, lpv, llen);
287 if (!lbyte)
288 SvUTF8_on(TARG);
289 else
290 SvUTF8_off(TARG);
8d6d96c1 291 }
18ea7bf2 292 else { /* $l .= $r and left == TARG */
1604cfb0 293 if (!SvOK(left)) {
51f69a24 294 if ((left == right /* $l .= $l */
16fe3f8a 295 || targmy) /* $l = $l . $r */
51f69a24
AC
296 && ckWARN(WARN_UNINITIALIZED)
297 )
298 report_uninit(left);
adf14ec6 299 SvPVCLEAR(left);
1604cfb0 300 }
18ea7bf2
SM
301 else {
302 SvPV_force_nomg_nolen(left);
303 }
1604cfb0
MS
304 lbyte = !DO_UTF8(left);
305 if (IN_BYTES)
306 SvUTF8_off(left);
8d6d96c1 307 }
a12c0f56 308
c75ab21a 309 if (!rcopied) {
1604cfb0
MS
310 rpv = SvPV_nomg_const(right, rlen);
311 rbyte = !DO_UTF8(right);
c75ab21a 312 }
8d6d96c1 313 if (lbyte != rbyte) {
1604cfb0
MS
314 if (lbyte)
315 sv_utf8_upgrade_nomg(TARG);
316 else {
317 if (!rcopied)
318 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
319 sv_utf8_upgrade_nomg(right);
320 rpv = SvPV_nomg_const(right, rlen);
321 }
a0d0e21e 322 }
8d6d96c1 323 sv_catpvn_nomg(TARG, rpv, rlen);
16fe3f8a
DM
324 SvSETMAGIC(TARG);
325}
326
43ebc500 327
16fe3f8a
DM
328PP(pp_concat)
329{
330 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
331 {
332 dPOPTOPssrl;
333 S_do_concat(aTHX_ left, right, targ, PL_op->op_private & OPpTARGET_MY);
334 SETs(TARG);
a0d0e21e 335 RETURN;
748a9306 336 }
a0d0e21e
LW
337}
338
e839e6ed
DM
339
340/* pp_multiconcat()
341
342Concatenate one or more args, possibly interleaved with constant string
343segments. The result may be assigned to, or appended to, a variable or
344expression.
345
346Several op_flags and/or op_private bits indicate what the target is, and
347whether it's appended to. Valid permutations are:
348
349 - (PADTMP) = (A.B.C....)
350 OPpTARGET_MY $lex = (A.B.C....)
351 OPpTARGET_MY,OPpLVAL_INTRO my $lex = (A.B.C....)
352 OPpTARGET_MY,OPpMULTICONCAT_APPEND $lex .= (A.B.C....)
353 OPf_STACKED expr = (A.B.C....)
354 OPf_STACKED,OPpMULTICONCAT_APPEND expr .= (A.B.C....)
355
356Other combinations like (A.B).(C.D) are not optimised into a multiconcat
357op, as it's too hard to get the correct ordering of ties, overload etc.
358
359In addition:
360
361 OPpMULTICONCAT_FAKE: not a real concat, instead an optimised
362 sprintf "...%s...". Don't call '.'
363 overloading: only use '""' overloading.
364
55b62dee
DM
365 OPpMULTICONCAT_STRINGIFY: the RHS was of the form
366 "...$a...$b..." rather than
e839e6ed
DM
367 "..." . $a . "..." . $b . "..."
368
369An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are
370defined with PERL_MULTICONCAT_IX_FOO constants, where:
371
372
373 FOO index description
374 -------- ----- ----------------------------------
375 NARGS 0 number of arguments
376 PLAIN_PV 1 non-utf8 constant string
377 PLAIN_LEN 2 non-utf8 constant string length
378 UTF8_PV 3 utf8 constant string
379 UTF8_LEN 4 utf8 constant string length
380 LENGTHS 5 first of nargs+1 const segment lengths
381
382The idea is that a general string concatenation will have a fixed (known
383at compile time) number of variable args, interspersed with constant
384strings, e.g. "a=$a b=$b\n"
385
386All the constant string segments "a=", " b=" and "\n" are stored as a
387single string "a= b=\n", pointed to from the PLAIN_PV/UTF8_PV slot, along
388with a series of segment lengths: e.g. 2,3,1. In the case where the
389constant string is plain but has a different utf8 representation, both
390variants are stored, and two sets of (nargs+1) segments lengths are stored
391in the slots beginning at PERL_MULTICONCAT_IX_LENGTHS.
392
393A segment length of -1 indicates that there is no constant string at that
394point; this distinguishes between e.g. ($a . $b) and ($a . "" . $b), which
395have differing overloading behaviour.
396
397*/
398
399PP(pp_multiconcat)
400{
401 dSP;
402 SV *targ; /* The SV to be assigned or appended to */
057ba76a 403 char *targ_pv; /* where within SvPVX(targ) we're writing to */
e839e6ed
DM
404 STRLEN targ_len; /* SvCUR(targ) */
405 SV **toparg; /* the highest arg position on the stack */
406 UNOP_AUX_item *aux; /* PL_op->op_aux buffer */
407 UNOP_AUX_item *const_lens; /* the segment length array part of aux */
408 const char *const_pv; /* the current segment of the const string buf */
ca84e88e
DM
409 SSize_t nargs; /* how many args were expected */
410 SSize_t stack_adj; /* how much to adjust SP on return */
057ba76a 411 STRLEN grow; /* final size of destination string (targ) */
e839e6ed
DM
412 UV targ_count; /* how many times targ has appeared on the RHS */
413 bool is_append; /* OPpMULTICONCAT_APPEND flag is set */
414 bool slow_concat; /* args too complex for quick concat */
415 U32 dst_utf8; /* the result will be utf8 (indicate this with
416 SVf_UTF8 in a U32, rather than using bool,
417 for ease of testing and setting) */
418 /* for each arg, holds the result of an SvPV() call */
419 struct multiconcat_svpv {
d966075e 420 const char *pv;
e839e6ed
DM
421 SSize_t len;
422 }
423 *targ_chain, /* chain of slots where targ has appeared on RHS */
424 *svpv_p, /* ptr for looping through svpv_buf */
425 *svpv_base, /* first slot (may be greater than svpv_buf), */
426 *svpv_end, /* and slot after highest result so far, of: */
427 svpv_buf[PERL_MULTICONCAT_MAXARG]; /* buf for storing SvPV() results */
428
429 aux = cUNOP_AUXx(PL_op)->op_aux;
ca84e88e 430 stack_adj = nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
e839e6ed
DM
431 is_append = cBOOL(PL_op->op_private & OPpMULTICONCAT_APPEND);
432
433 /* get targ from the stack or pad */
434
435 if (PL_op->op_flags & OPf_STACKED) {
436 if (is_append) {
437 /* for 'expr .= ...', expr is the bottom item on the stack */
438 targ = SP[-nargs];
439 stack_adj++;
440 }
441 else
442 /* for 'expr = ...', expr is the top item on the stack */
443 targ = POPs;
444 }
445 else {
446 SV **svp = &(PAD_SVl(PL_op->op_targ));
447 targ = *svp;
448 if (PL_op->op_private & OPpLVAL_INTRO) {
449 assert(PL_op->op_private & OPpTARGET_MY);
450 save_clearsv(svp);
451 }
452 if (!nargs)
453 /* $lex .= "const" doesn't cause anything to be pushed */
454 EXTEND(SP,1);
455 }
456
457 toparg = SP;
458 SP -= (nargs - 1);
e839e6ed
DM
459 grow = 1; /* allow for '\0' at minimum */
460 targ_count = 0;
461 targ_chain = NULL;
462 targ_len = 0;
463 svpv_end = svpv_buf;
464 /* only utf8 variants of the const strings? */
465 dst_utf8 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv ? 0 : SVf_UTF8;
466
467
468 /* --------------------------------------------------------------
469 * Phase 1:
470 *
471 * stringify (i.e. SvPV()) every arg and store the resultant pv/len/utf8
472 * triplets in svpv_buf[]. Also increment 'grow' by the args' lengths.
473 *
474 * utf8 is indicated by storing a negative length.
475 *
476 * Where an arg is actually targ, the stringification is deferred:
477 * the length is set to 0, and the slot is added to targ_chain.
478 *
af390142
DM
479 * If a magic, overloaded, or otherwise weird arg is found, which
480 * might have side effects when stringified, the loop is abandoned and
481 * we goto a code block where a more basic 'emulate calling
482 * pp_cpncat() on each arg in turn' is done.
e839e6ed
DM
483 */
484
485 for (; SP <= toparg; SP++, svpv_end++) {
e839e6ed
DM
486 U32 utf8;
487 STRLEN len;
488 SV *sv;
489
490 assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
491
492 sv = *SP;
e839e6ed
DM
493
494 /* this if/else chain is arranged so that common/simple cases
495 * take few conditionals */
496
af390142
DM
497 if (LIKELY((SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK)) {
498 /* common case: sv is a simple non-magical PV */
499 if (targ == sv) {
500 /* targ appears on RHS.
501 * Delay storing PV pointer; instead, add slot to targ_chain
502 * so it can be populated later, after targ has been grown and
503 * we know its final SvPVX() address.
504 */
505 targ_on_rhs:
506 svpv_end->len = 0; /* zerojng here means we can skip
507 updating later if targ_len == 0 */
508 svpv_end->pv = (char*)targ_chain;
509 targ_chain = svpv_end;
510 targ_count++;
511 continue;
512 }
513
e839e6ed 514 len = SvCUR(sv);
af390142 515 svpv_end->pv = SvPVX(sv);
e839e6ed 516 }
af390142
DM
517 else if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK)))
518 /* may have side effects: tie, overload etc.
519 * Abandon 'stringify everything first' and handle
520 * args in strict order. Note that already-stringified args
521 * will be reprocessed, which is safe because the each first
522 * stringification would have been idempotent.
e839e6ed 523 */
af390142
DM
524 goto do_magical;
525 else if (SvNIOK(sv)) {
526 if (targ == sv)
527 goto targ_on_rhs;
528 /* stringify general valid scalar */
e839e6ed
DM
529 svpv_end->pv = sv_2pv_flags(sv, &len, 0);
530 }
af390142
DM
531 else if (!SvOK(sv)) {
532 if (ckWARN(WARN_UNINITIALIZED))
533 /* an undef value in the presence of warnings may trigger
534 * side affects */
535 goto do_magical;
d966075e 536 svpv_end->pv = "";
af390142
DM
537 len = 0;
538 }
539 else
540 goto do_magical; /* something weird */
e839e6ed
DM
541
542 utf8 = (SvFLAGS(sv) & SVf_UTF8);
543 dst_utf8 |= utf8;
544 ASSUME(len < SSize_t_MAX);
545 svpv_end->len = utf8 ? -(SSize_t)len : (SSize_t)len;
546 grow += len;
547 }
548
549 /* --------------------------------------------------------------
550 * Phase 2:
551 *
552 * Stringify targ:
553 *
554 * if targ appears on the RHS or is appended to, force stringify it;
555 * otherwise set it to "". Then set targ_len.
556 */
557
558 if (is_append) {
af390142
DM
559 /* abandon quick route if using targ might have side effects */
560 if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK)))
561 goto do_magical;
e839e6ed
DM
562
563 if (SvOK(targ)) {
564 U32 targ_utf8;
565 stringify_targ:
566 SvPV_force_nomg_nolen(targ);
567 targ_utf8 = SvFLAGS(targ) & SVf_UTF8;
568 if (UNLIKELY(dst_utf8 & ~targ_utf8)) {
569 if (LIKELY(!IN_BYTES))
570 sv_utf8_upgrade_nomg(targ);
571 }
572 else
573 dst_utf8 |= targ_utf8;
574
575 targ_len = SvCUR(targ);
576 grow += targ_len * (targ_count + is_append);
577 goto phase3;
578 }
af390142
DM
579 else if (ckWARN(WARN_UNINITIALIZED))
580 /* warning might have side effects */
581 goto do_magical;
582 /* the undef targ will be silently SvPVCLEAR()ed below */
e839e6ed
DM
583 }
584 else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) {
585 /* Assigning to some weird LHS type. Don't force the LHS to be an
586 * empty string; instead, do things 'long hand' by using the
587 * overload code path, which concats to a TEMP sv and does
588 * sv_catsv() calls rather than COPY()s. This ensures that even
589 * bizarre code like this doesn't break or crash:
590 * *F = *F . *F.
591 * (which makes the 'F' typeglob an alias to the
592 * '*main::F*main::F' typeglob).
593 */
af390142 594 goto do_magical;
e839e6ed 595 }
af390142 596 else if (targ_chain)
e839e6ed 597 /* targ was found on RHS.
af390142
DM
598 * Force stringify it, using the same code as the append branch
599 * above, except that we don't need the magic/overload/undef
600 * checks as these will already have been done in the phase 1
601 * loop.
e839e6ed 602 */
e839e6ed 603 goto stringify_targ;
e839e6ed
DM
604
605 /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0;
606 * those will be done later. */
e839e6ed
DM
607 SV_CHECK_THINKFIRST_COW_DROP(targ);
608 SvUPGRADE(targ, SVt_PV);
609 SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8);
610 SvFLAGS(targ) |= (SVf_POK|SVp_POK|dst_utf8);
611
612 phase3:
613
614 /* --------------------------------------------------------------
615 * Phase 3:
616 *
057ba76a 617 * UTF-8 tweaks and grow targ:
e839e6ed
DM
618 *
619 * Now that we know the length and utf8-ness of both the targ and
057ba76a 620 * args, grow targ to the size needed to accumulate all the args, based
e839e6ed
DM
621 * on whether targ appears on the RHS, whether we're appending, and
622 * whether any non-utf8 args expand in size if converted to utf8.
623 *
624 * For the latter, if dst_utf8 we scan non-utf8 args looking for
625 * variant chars, and adjust the svpv->len value of those args to the
626 * utf8 size and negate it to flag them. At the same time we un-negate
627 * the lens of any utf8 args since after this phase we no longer care
628 * whether an arg is utf8 or not.
629 *
630 * Finally, initialise const_lens and const_pv based on utf8ness.
631 * Note that there are 3 permutations:
632 *
633 * * If the constant string is invariant whether utf8 or not (e.g. "abc"),
634 * then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] are the same as
635 * aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] and there is one set of
636 * segment lengths.
637 *
638 * * If the string is fully utf8, e.g. "\x{100}", then
639 * aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] == (NULL,0) and there is
640 * one set of segment lengths.
641 *
642 * * If the string has different plain and utf8 representations
a3815e44 643 * (e.g. "\x80"), then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
e839e6ed
DM
644 * holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
645 * holds the utf8 rep, and there are 2 sets of segment lengths,
646 * with the utf8 set following after the plain set.
647 *
648 * On entry to this section the (pv,len) pairs in svpv_buf have the
649 * following meanings:
650 * (pv, len) a plain string
651 * (pv, -len) a utf8 string
652 * (NULL, 0) left-most targ \ linked together R-to-L
653 * (next, 0) other targ / in targ_chain
654 */
655
656 /* turn off utf8 handling if 'use bytes' is in scope */
657 if (UNLIKELY(dst_utf8 && IN_BYTES)) {
658 dst_utf8 = 0;
057ba76a 659 SvUTF8_off(targ);
e839e6ed
DM
660 /* undo all the negative lengths which flag utf8-ness */
661 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
662 SSize_t len = svpv_p->len;
663 if (len < 0)
664 svpv_p->len = -len;
665 }
666 }
667
668 /* grow += total of lengths of constant string segments */
669 {
670 SSize_t len;
671 len = aux[dst_utf8 ? PERL_MULTICONCAT_IX_UTF8_LEN
b5bf9f73 672 : PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
e839e6ed
DM
673 slow_concat = cBOOL(len);
674 grow += len;
675 }
676
677 const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
678
679 if (dst_utf8) {
680 const_pv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
681 if ( aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv
682 && const_pv != aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv)
683 /* separate sets of lengths for plain and utf8 */
684 const_lens += nargs + 1;
685
686 /* If the result is utf8 but some of the args aren't,
687 * calculate how much extra growth is needed for all the chars
688 * which will expand to two utf8 bytes.
689 * Also, if the growth is non-zero, negate the length to indicate
a3815e44 690 * that this is a variant string. Conversely, un-negate the
e839e6ed
DM
691 * length on utf8 args (which was only needed to flag non-utf8
692 * args in this loop */
693 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
7d5ed5d0 694 SSize_t len, extra;
e839e6ed
DM
695
696 len = svpv_p->len;
697 if (len <= 0) {
698 svpv_p->len = -len;
699 continue;
700 }
701
7d5ed5d0
KW
702 extra = variant_under_utf8_count((U8 *) svpv_p->pv,
703 (U8 *) svpv_p->pv + len);
e839e6ed
DM
704 if (UNLIKELY(extra)) {
705 grow += extra;
706 /* -ve len indicates special handling */
707 svpv_p->len = -(len + extra);
708 slow_concat = TRUE;
709 }
710 }
711 }
712 else
713 const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
714
715 /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
716 * already have been dropped */
057ba76a
DM
717 assert(!SvIsCOW(targ));
718 targ_pv = (SvLEN(targ) < (grow) ? sv_grow(targ,grow) : SvPVX(targ));
e839e6ed
DM
719
720
721 /* --------------------------------------------------------------
722 * Phase 4:
723 *
057ba76a
DM
724 * Now that targ has been grown, we know the final address of the targ
725 * PVX, if needed. Preserve / move targ contents if appending or if
726 * targ appears on RHS.
e839e6ed
DM
727 *
728 * Also update svpv_buf slots in targ_chain.
729 *
730 * Don't bother with any of this if the target length is zero:
731 * targ_len is set to zero unless we're appending or targ appears on
732 * RHS. And even if it is, we can optimise by skipping this chunk of
733 * code for zero targ_len. In the latter case, we don't need to update
734 * the slots in targ_chain with the (zero length) target string, since
735 * we set the len in such slots to 0 earlier, and since the Copy() is
736 * skipped on zero length, it doesn't matter what svpv_p->pv contains.
737 *
738 * On entry to this section the (pv,len) pairs in svpv_buf have the
739 * following meanings:
740 * (pv, len) a pure-plain or utf8 string
741 * (pv, -(len+extra)) a plain string which will expand by 'extra'
742 * bytes when converted to utf8
743 * (NULL, 0) left-most targ \ linked together R-to-L
744 * (next, 0) other targ / in targ_chain
745 *
746 * On exit, the targ contents will have been moved to the
747 * earliest place they are needed (e.g. $x = "abc$x" will shift them
748 * 3 bytes, while $x .= ... will leave them at the beginning);
057ba76a 749 * and dst_pv will point to the location within SvPVX(targ) where the
e839e6ed
DM
750 * next arg should be copied.
751 */
752
753 svpv_base = svpv_buf;
754
755 if (targ_len) {
756 struct multiconcat_svpv *tc_stop;
057ba76a 757 char *targ_buf = targ_pv; /* ptr to original targ string */
e839e6ed 758
e839e6ed
DM
759 assert(is_append || targ_count);
760
761 if (is_append) {
057ba76a 762 targ_pv += targ_len;
e839e6ed
DM
763 tc_stop = NULL;
764 }
765 else {
766 /* The targ appears on RHS, e.g. '$t = $a . $t . $t'.
767 * Move the current contents of targ to the first
768 * position where it's needed, and use that as the src buffer
769 * for any further uses (such as the second RHS $t above).
770 * In calculating the first position, we need to sum the
771 * lengths of all consts and args before that.
772 */
773
774 UNOP_AUX_item *lens = const_lens;
775 /* length of first const string segment */
b5bf9f73 776 STRLEN offset = lens->ssize > 0 ? lens->ssize : 0;
e839e6ed
DM
777
778 assert(targ_chain);
779 svpv_p = svpv_base;
780
781 for (;;) {
782 SSize_t len;
783 if (!svpv_p->pv)
784 break; /* the first targ argument */
785 /* add lengths of the next arg and const string segment */
786 len = svpv_p->len;
787 if (len < 0) /* variant args have this */
788 len = -len;
789 offset += (STRLEN)len;
b5bf9f73 790 len = (++lens)->ssize;
e839e6ed
DM
791 offset += (len >= 0) ? (STRLEN)len : 0;
792 if (!offset) {
793 /* all args and consts so far are empty; update
794 * the start position for the concat later */
795 svpv_base++;
796 const_lens++;
797 }
798 svpv_p++;
799 assert(svpv_p < svpv_end);
800 }
801
802 if (offset) {
057ba76a
DM
803 targ_buf += offset;
804 Move(targ_pv, targ_buf, targ_len, char);
e839e6ed 805 /* a negative length implies don't Copy(), but do increment */
90b21a3e 806 svpv_p->len = -((SSize_t)targ_len);
e839e6ed
DM
807 slow_concat = TRUE;
808 }
809 else {
810 /* skip the first targ copy */
811 svpv_base++;
812 const_lens++;
057ba76a 813 targ_pv += targ_len;
e839e6ed
DM
814 }
815
816 /* Don't populate the first targ slot in the loop below; it's
817 * either not used because we advanced svpv_base beyond it, or
818 * we already stored the special -targ_len value in it
819 */
820 tc_stop = svpv_p;
821 }
822
823 /* populate slots in svpv_buf representing targ on RHS */
824 while (targ_chain != tc_stop) {
825 struct multiconcat_svpv *p = targ_chain;
826 targ_chain = (struct multiconcat_svpv *)(p->pv);
057ba76a 827 p->pv = targ_buf;
e839e6ed
DM
828 p->len = (SSize_t)targ_len;
829 }
830 }
831
832
833 /* --------------------------------------------------------------
834 * Phase 5:
835 *
057ba76a 836 * Append all the args in svpv_buf, plus the const strings, to targ.
e839e6ed
DM
837 *
838 * On entry to this section the (pv,len) pairs in svpv_buf have the
839 * following meanings:
840 * (pv, len) a pure-plain or utf8 string (which may be targ)
841 * (pv, -(len+extra)) a plain string which will expand by 'extra'
842 * bytes when converted to utf8
843 * (0, -len) left-most targ, whose content has already
057ba76a 844 * been copied. Just advance targ_pv by len.
e839e6ed
DM
845 */
846
847 /* If there are no constant strings and no special case args
848 * (svpv_p->len < 0), use a simpler, more efficient concat loop
849 */
850 if (!slow_concat) {
851 for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) {
852 SSize_t len = svpv_p->len;
853 if (!len)
854 continue;
057ba76a
DM
855 Copy(svpv_p->pv, targ_pv, len, char);
856 targ_pv += len;
e839e6ed
DM
857 }
858 const_lens += (svpv_end - svpv_base + 1);
859 }
860 else {
861 /* Note that we iterate the loop nargs+1 times: to append nargs
862 * arguments and nargs+1 constant strings. For example, "-$a-$b-"
863 */
864 svpv_p = svpv_base - 1;
865
866 for (;;) {
b5bf9f73 867 SSize_t len = (const_lens++)->ssize;
e839e6ed
DM
868
869 /* append next const string segment */
870 if (len > 0) {
057ba76a
DM
871 Copy(const_pv, targ_pv, len, char);
872 targ_pv += len;
e839e6ed
DM
873 const_pv += len;
874 }
875
876 if (++svpv_p == svpv_end)
877 break;
878
879 /* append next arg */
880 len = svpv_p->len;
881
882 if (LIKELY(len > 0)) {
057ba76a
DM
883 Copy(svpv_p->pv, targ_pv, len, char);
884 targ_pv += len;
e839e6ed
DM
885 }
886 else if (UNLIKELY(len < 0)) {
887 /* negative length indicates two special cases */
888 const char *p = svpv_p->pv;
889 len = -len;
890 if (UNLIKELY(p)) {
891 /* copy plain-but-variant pv to a utf8 targ */
057ba76a 892 char * end_pv = targ_pv + len;
e839e6ed 893 assert(dst_utf8);
057ba76a 894 while (targ_pv < end_pv) {
e839e6ed 895 U8 c = (U8) *p++;
057ba76a 896 append_utf8_from_native_byte(c, (U8**)&targ_pv);
e839e6ed
DM
897 }
898 }
899 else
900 /* arg is already-copied targ */
057ba76a 901 targ_pv += len;
e839e6ed
DM
902 }
903
904 }
905 }
906
057ba76a
DM
907 *targ_pv = '\0';
908 SvCUR_set(targ, targ_pv - SvPVX(targ));
909 assert(grow >= SvCUR(targ) + 1);
910 assert(SvLEN(targ) >= SvCUR(targ) + 1);
e839e6ed
DM
911
912 /* --------------------------------------------------------------
913 * Phase 6:
914 *
af390142 915 * return result
e839e6ed
DM
916 */
917
af390142
DM
918 SP -= stack_adj;
919 SvTAINT(targ);
920 SETTARG;
921 RETURN;
e839e6ed 922
af390142
DM
923 /* --------------------------------------------------------------
924 * Phase 7:
925 *
926 * We only get here if any of the args (or targ too in the case of
927 * append) have something which might cause side effects, such
928 * as magic, overload, or an undef value in the presence of warnings.
929 * In that case, any earlier attempt to stringify the args will have
930 * been abandoned, and we come here instead.
931 *
932 * Here, we concat each arg in turn the old-fashioned way: essentially
933 * emulating pp_concat() in a loop. This means that all the weird edge
934 * cases will be handled correctly, if not necessarily speedily.
935 *
936 * Note that some args may already have been stringified - those are
937 * processed again, which is safe, since only args without side-effects
938 * were stringified earlier.
939 */
940
941 do_magical:
942 {
943 SSize_t i, n;
944 SV *left = NULL;
945 SV *right;
946 SV* nexttarg;
947 bool nextappend;
948 U32 utf8 = 0;
949 SV **svp;
950 const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
951 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
55b62dee 952 Size_t arg_count = 0; /* how many args have been processed */
af390142
DM
953
954 if (!cpv) {
955 cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
956 utf8 = SVf_UTF8;
957 }
958
959 svp = toparg - nargs + 1;
960
961 /* iterate for:
962 * nargs arguments,
963 * plus possible nargs+1 consts,
964 * plus, if appending, a final targ in an extra last iteration
965 */
966
967 n = nargs *2 + 1;
55b62dee
DM
968 for (i = 0; i <= n; i++) {
969 SSize_t len;
970
971 /* if necessary, stringify the final RHS result in
972 * something like $targ .= "$a$b$c" - simulating
973 * pp_stringify
974 */
975 if ( i == n
976 && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY)
977 && !(SvPOK(left))
978 /* extra conditions for backwards compatibility:
979 * probably incorrect, but keep the existing behaviour
980 * for now. The rules are:
981 * $x = "$ov" single arg: stringify;
982 * $x = "$ov$y" multiple args: don't stringify,
983 * $lex = "$ov$y$z" except TARGMY with at least 2 concats
984 */
985 && ( arg_count == 1
986 || ( arg_count >= 3
987 && !is_append
988 && (PL_op->op_private & OPpTARGET_MY)
989 && !(PL_op->op_private & OPpLVAL_INTRO)
990 )
991 )
992 )
993 {
994 SV *tmp = sv_newmortal();
995 sv_copypv(tmp, left);
996 SvSETMAGIC(tmp);
997 left = tmp;
998 }
999
1000 /* do one extra iteration to handle $targ in $targ .= ... */
1001 if (i == n && !is_append)
1002 break;
1003
af390142 1004 /* get the next arg SV or regen the next const SV */
55b62dee 1005 len = lens[i >> 1].ssize;
af390142
DM
1006 if (i == n) {
1007 /* handle the final targ .= (....) */
1008 right = left;
1009 left = targ;
1010 }
1011 else if (i & 1)
1012 right = svp[(i >> 1)];
1013 else if (len < 0)
1014 continue; /* no const in this position */
1015 else {
1016 right = newSVpvn_flags(cpv, len, (utf8 | SVs_TEMP));
1017 cpv += len;
1018 }
e839e6ed 1019
55b62dee
DM
1020 arg_count++;
1021
1022 if (arg_count <= 1) {
af390142
DM
1023 left = right;
1024 continue; /* need at least two SVs to concat together */
1025 }
1026
55b62dee 1027 if (arg_count == 2 && i < n) {
af390142
DM
1028 /* for the first concat, create a mortal acting like the
1029 * padtmp from OP_CONST. In later iterations this will
1030 * be appended to */
1031 nexttarg = sv_newmortal();
1032 nextappend = FALSE;
af390142
DM
1033 }
1034 else {
1035 nexttarg = left;
1036 nextappend = TRUE;
1037 }
1038
1039 /* Handle possible overloading.
1040 * This is basically an unrolled
1041 * tryAMAGICbin_MG(concat_amg, AMGf_assign);
1042 * and
1043 * Perl_try_amagic_bin()
1044 * call, but using left and right rather than SP[-1], SP[0],
1045 * and not relying on OPf_STACKED implying .=
e839e6ed 1046 */
e839e6ed 1047
af390142
DM
1048 if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) {
1049 SvGETMAGIC(left);
1050 if (left != right)
1051 SvGETMAGIC(right);
1052
1053 if ((SvAMAGIC(left) || SvAMAGIC(right))
1054 /* sprintf doesn't do concat overloading,
1055 * but allow for $x .= sprintf(...)
1056 */
1057 && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE)
1058 || i == n)
e839e6ed 1059 )
af390142
DM
1060 {
1061 SV * const tmpsv = amagic_call(left, right, concat_amg,
1062 (nextappend ? AMGf_assign: 0));
1063 if (tmpsv) {
7554d344
DM
1064 /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test
1065 * here, which isn't needed as any implicit
1066 * assign done under OPpTARGET_MY is done after
af390142
DM
1067 * this loop */
1068 if (nextappend) {
1069 sv_setsv(left, tmpsv);
1070 SvSETMAGIC(left);
e839e6ed 1071 }
af390142
DM
1072 else
1073 left = tmpsv;
1074 continue;
1075 }
1076 }
1077
1078 /* if both args are the same magical value, make one a copy */
1079 if (left == right && SvGMAGICAL(left)) {
1080 left = sv_newmortal();
1081 /* Print the uninitialized warning now, so it includes the
1082 * variable name. */
1083 if (!SvOK(right)) {
1084 if (ckWARN(WARN_UNINITIALIZED))
1085 report_uninit(right);
1086 sv_setsv_flags(left, &PL_sv_no, 0);
e839e6ed 1087 }
af390142
DM
1088 else
1089 sv_setsv_flags(left, right, 0);
1090 SvGETMAGIC(right);
e839e6ed
DM
1091 }
1092 }
e839e6ed 1093
af390142
DM
1094 /* nexttarg = left . right */
1095 S_do_concat(aTHX_ left, right, nexttarg, 0);
1096 left = nexttarg;
e839e6ed 1097 }
e839e6ed 1098
af390142 1099 SP = toparg - stack_adj + 1;
e839e6ed 1100
4e521aaf
DM
1101 /* Return the result of all RHS concats, unless this op includes
1102 * an assign ($lex = x.y.z or expr = x.y.z), in which case copy
1103 * to target (which will be $lex or expr).
af390142
DM
1104 * If we are appending, targ will already have been appended to in
1105 * the loop */
4e521aaf
DM
1106 if ( !is_append
1107 && ( (PL_op->op_flags & OPf_STACKED)
1108 || (PL_op->op_private & OPpTARGET_MY))
1109 ) {
af390142
DM
1110 sv_setsv(targ, left);
1111 SvSETMAGIC(targ);
1112 }
4e521aaf
DM
1113 else
1114 targ = left;
af390142
DM
1115 SETs(targ);
1116 RETURN;
1117 }
e839e6ed
DM
1118}
1119
1120
0b5aba47
DM
1121/* push the elements of av onto the stack.
1122 * Returns PL_op->op_next to allow tail-call optimisation of its callers */
d5524600 1123
0b5aba47 1124STATIC OP*
d5524600
DM
1125S_pushav(pTHX_ AV* const av)
1126{
1127 dSP;
c70927a6 1128 const SSize_t maxarg = AvFILL(av) + 1;
d5524600 1129 EXTEND(SP, maxarg);
5d9574c1 1130 if (UNLIKELY(SvRMAGICAL(av))) {
c70927a6
FC
1131 PADOFFSET i;
1132 for (i=0; i < (PADOFFSET)maxarg; i++) {
fd77b29b
FC
1133 SV ** const svp = av_fetch(av, i, FALSE);
1134 SP[i+1] = LIKELY(svp)
1135 ? *svp
1136 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1f1dcfb5 1137 ? av_nonelem(av,i)
fd77b29b 1138 : &PL_sv_undef;
d5524600
DM
1139 }
1140 }
1141 else {
c70927a6
FC
1142 PADOFFSET i;
1143 for (i=0; i < (PADOFFSET)maxarg; i++) {
6661956a 1144 SV *sv = AvARRAY(av)[i];
1604cfb0 1145 SP[i+1] = LIKELY(sv)
fd77b29b
FC
1146 ? sv
1147 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1f1dcfb5 1148 ? av_nonelem(av,i)
fd77b29b 1149 : &PL_sv_undef;
ce0d59fd 1150 }
d5524600
DM
1151 }
1152 SP += maxarg;
1153 PUTBACK;
0b5aba47 1154 return NORMAL;
d5524600
DM
1155}
1156
1157
a7fd8ef6
DM
1158/* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
1159
1160PP(pp_padrange)
1161{
20b7effb 1162 dSP;
a7fd8ef6
DM
1163 PADOFFSET base = PL_op->op_targ;
1164 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
d5524600
DM
1165 if (PL_op->op_flags & OPf_SPECIAL) {
1166 /* fake the RHS of my ($x,$y,..) = @_ */
1167 PUSHMARK(SP);
0b5aba47 1168 (void)S_pushav(aTHX_ GvAVn(PL_defgv));
d5524600
DM
1169 SPAGAIN;
1170 }
1171
a7fd8ef6
DM
1172 /* note, this is only skipped for compile-time-known void cxt */
1173 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
19742f39
AL
1174 int i;
1175
a7fd8ef6
DM
1176 EXTEND(SP, count);
1177 PUSHMARK(SP);
1178 for (i = 0; i <count; i++)
1179 *++SP = PAD_SV(base+i);
1180 }
1181 if (PL_op->op_private & OPpLVAL_INTRO) {
4e09461c
DM
1182 SV **svp = &(PAD_SVl(base));
1183 const UV payload = (UV)(
1184 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
1185 | (count << SAVE_TIGHT_SHIFT)
1186 | SAVEt_CLEARPADRANGE);
19742f39
AL
1187 int i;
1188
6d59e610 1189 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
d081a355
DM
1190 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
1191 == (Size_t)base);
a3444cc5
DM
1192 {
1193 dSS_ADD;
1194 SS_ADD_UV(payload);
1195 SS_ADD_END(1);
1196 }
4e09461c 1197
a7fd8ef6 1198 for (i = 0; i <count; i++)
4e09461c 1199 SvPADSTALE_off(*svp++); /* mark lexical as active */
a7fd8ef6
DM
1200 }
1201 RETURN;
1202}
1203
1204
a0d0e21e
LW
1205PP(pp_padsv)
1206{
20b7effb 1207 dSP;
6c28b496
DD
1208 EXTEND(SP, 1);
1209 {
1604cfb0
MS
1210 OP * const op = PL_op;
1211 /* access PL_curpad once */
1212 SV ** const padentry = &(PAD_SVl(op->op_targ));
1213 {
1214 dTARG;
1215 TARG = *padentry;
1216 PUSHs(TARG);
1217 PUTBACK; /* no pop/push after this, TOPs ok */
1218 }
1219 if (op->op_flags & OPf_MOD) {
1220 if (op->op_private & OPpLVAL_INTRO)
1221 if (!(op->op_private & OPpPAD_STATE))
1222 save_clearsv(padentry);
1223 if (op->op_private & OPpDEREF) {
1224 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
1225 than TARG reduces the scope of TARG, so it does not
1226 span the call to save_clearsv, resulting in smaller
1227 machine code. */
1228 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
1229 }
1230 }
1231 return op->op_next;
4633a7c4 1232 }
a0d0e21e
LW
1233}
1234
1235PP(pp_readline)
1236{
30901a8a 1237 dSP;
12dc5f94
DM
1238 /* pp_coreargs pushes a NULL to indicate no args passed to
1239 * CORE::readline() */
30901a8a 1240 if (TOPs) {
1604cfb0
MS
1241 SvGETMAGIC(TOPs);
1242 tryAMAGICunTARGETlist(iter_amg, 0);
1243 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
30901a8a
FC
1244 }
1245 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
6e592b3a 1246 if (!isGV_with_GP(PL_last_in_gv)) {
1604cfb0
MS
1247 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
1248 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
1249 else {
1250 dSP;
1251 XPUSHs(MUTABLE_SV(PL_last_in_gv));
1252 PUTBACK;
1253 Perl_pp_rv2gv(aTHX);
1254 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
745e740c 1255 assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
1604cfb0 1256 }
f5284f61 1257 }
a0d0e21e
LW
1258 return do_readline();
1259}
1260
1261PP(pp_eq)
1262{
20b7effb 1263 dSP;
33efebe6 1264 SV *left, *right;
fe9826e3 1265 U32 flags_and, flags_or;
33efebe6 1266
0872de45 1267 tryAMAGICbin_MG(eq_amg, AMGf_numeric);
33efebe6
DM
1268 right = POPs;
1269 left = TOPs;
fe9826e3
RL
1270 flags_and = SvFLAGS(left) & SvFLAGS(right);
1271 flags_or = SvFLAGS(left) | SvFLAGS(right);
1272
33efebe6 1273 SETs(boolSV(
fe9826e3
RL
1274 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
1275 ? (SvIVX(left) == SvIVX(right))
1276 : (flags_and & SVf_NOK)
1277 ? (SvNVX(left) == SvNVX(right))
1278 : ( do_ncmp(left, right) == 0)
33efebe6
DM
1279 ));
1280 RETURN;
a0d0e21e
LW
1281}
1282
b1c05ba5 1283
4c2c3128 1284/* also used for: pp_i_preinc() */
b1c05ba5 1285
a0d0e21e
LW
1286PP(pp_preinc)
1287{
4c2c3128
DM
1288 SV *sv = *PL_stack_sp;
1289
1290 if (LIKELY(((sv->sv_flags &
1291 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1292 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1293 == SVf_IOK))
1294 && SvIVX(sv) != IV_MAX)
1295 {
1604cfb0 1296 SvIV_set(sv, SvIVX(sv) + 1);
4c2c3128
DM
1297 }
1298 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
1604cfb0 1299 sv_inc(sv);
4c2c3128
DM
1300 SvSETMAGIC(sv);
1301 return NORMAL;
1302}
1303
1304
1305/* also used for: pp_i_predec() */
1306
1307PP(pp_predec)
1308{
1309 SV *sv = *PL_stack_sp;
1310
1311 if (LIKELY(((sv->sv_flags &
1312 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1313 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1314 == SVf_IOK))
1315 && SvIVX(sv) != IV_MIN)
55497cff 1316 {
1604cfb0 1317 SvIV_set(sv, SvIVX(sv) - 1);
748a9306 1318 }
4c2c3128 1319 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */
1604cfb0 1320 sv_dec(sv);
4c2c3128 1321 SvSETMAGIC(sv);
a0d0e21e
LW
1322 return NORMAL;
1323}
1324
b1c05ba5
DM
1325
1326/* also used for: pp_orassign() */
1327
a0d0e21e
LW
1328PP(pp_or)
1329{
20b7effb 1330 dSP;
f4c975aa 1331 SV *sv;
f410a211 1332 PERL_ASYNC_CHECK();
f4c975aa
DM
1333 sv = TOPs;
1334 if (SvTRUE_NN(sv))
1604cfb0 1335 RETURN;
a0d0e21e 1336 else {
1604cfb0 1337 if (PL_op->op_type == OP_OR)
c960fc3b 1338 --SP;
1604cfb0 1339 RETURNOP(cLOGOP->op_other);
a0d0e21e
LW
1340 }
1341}
1342
b1c05ba5
DM
1343
1344/* also used for: pp_dor() pp_dorassign() */
1345
25a55bd7 1346PP(pp_defined)
c963b151 1347{
20b7effb 1348 dSP;
eb578fdb 1349 SV* sv;
6136c704 1350 bool defined;
25a55bd7 1351 const int op_type = PL_op->op_type;
ea5195b7 1352 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
c963b151 1353
6136c704 1354 if (is_dor) {
1604cfb0 1355 PERL_ASYNC_CHECK();
25a55bd7 1356 sv = TOPs;
5d9574c1 1357 if (UNLIKELY(!sv || !SvANY(sv))) {
1604cfb0
MS
1358 if (op_type == OP_DOR)
1359 --SP;
25a55bd7
SP
1360 RETURNOP(cLOGOP->op_other);
1361 }
b7c44293
RGS
1362 }
1363 else {
1604cfb0 1364 /* OP_DEFINED */
25a55bd7 1365 sv = POPs;
5d9574c1 1366 if (UNLIKELY(!sv || !SvANY(sv)))
25a55bd7 1367 RETPUSHNO;
b7c44293 1368 }
25a55bd7 1369
6136c704 1370 defined = FALSE;
c963b151
BD
1371 switch (SvTYPE(sv)) {
1372 case SVt_PVAV:
1604cfb0
MS
1373 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1374 defined = TRUE;
1375 break;
c963b151 1376 case SVt_PVHV:
1604cfb0
MS
1377 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1378 defined = TRUE;
1379 break;
c963b151 1380 case SVt_PVCV:
1604cfb0
MS
1381 if (CvROOT(sv) || CvXSUB(sv))
1382 defined = TRUE;
1383 break;
c963b151 1384 default:
1604cfb0
MS
1385 SvGETMAGIC(sv);
1386 if (SvOK(sv))
1387 defined = TRUE;
1388 break;
c963b151 1389 }
6136c704
AL
1390
1391 if (is_dor) {
c960fc3b
SP
1392 if(defined)
1393 RETURN;
1394 if(op_type == OP_DOR)
1395 --SP;
25a55bd7 1396 RETURNOP(cLOGOP->op_other);
25a55bd7 1397 }
d9aa96a4
SP
1398 /* assuming OP_DEFINED */
1399 if(defined)
1400 RETPUSHYES;
1401 RETPUSHNO;
c963b151
BD
1402}
1403
230ee21f
DM
1404
1405
a0d0e21e
LW
1406PP(pp_add)
1407{
20b7effb 1408 dSP; dATARGET; bool useleft; SV *svl, *svr;
230ee21f 1409
6f1401dc
DM
1410 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
1411 svr = TOPs;
1412 svl = TOPm1s;
1413
28e5dec8 1414#ifdef PERL_PRESERVE_IVUV
230ee21f
DM
1415
1416 /* special-case some simple common cases */
1417 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1418 IV il, ir;
1419 U32 flags = (svl->sv_flags & svr->sv_flags);
1420 if (flags & SVf_IOK) {
1421 /* both args are simple IVs */
1422 UV topl, topr;
1423 il = SvIVX(svl);
1424 ir = SvIVX(svr);
1425 do_iv:
1426 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1427 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1428
1429 /* if both are in a range that can't under/overflow, do a
1430 * simple integer add: if the top of both numbers
1431 * are 00 or 11, then it's safe */
1432 if (!( ((topl+1) | (topr+1)) & 2)) {
1433 SP--;
1434 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1435 SETs(TARG);
1436 RETURN;
1437 }
1438 goto generic;
1439 }
1440 else if (flags & SVf_NOK) {
1441 /* both args are NVs */
1442 NV nl = SvNVX(svl);
1443 NV nr = SvNVX(svr);
1444
3a019afd 1445 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
230ee21f
DM
1446 /* nothing was lost by converting to IVs */
1447 goto do_iv;
3a019afd 1448 }
230ee21f
DM
1449 SP--;
1450 TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1451 SETs(TARG);
1452 RETURN;
1453 }
1454 }
1455
1456 generic:
1457
1458 useleft = USE_LEFT(svl);
28e5dec8
JH
1459 /* We must see if we can perform the addition with integers if possible,
1460 as the integer code detects overflow while the NV code doesn't.
1461 If either argument hasn't had a numeric conversion yet attempt to get
1462 the IV. It's important to do this now, rather than just assuming that
1463 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1464 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1465 integer in case the second argument is IV=9223372036854775806
1466 We can (now) rely on sv_2iv to do the right thing, only setting the
1467 public IOK flag if the value in the NV (or PV) slot is truly integer.
1468
1469 A side effect is that this also aggressively prefers integer maths over
7dca457a
NC
1470 fp maths for integer values.
1471
a00b5bd3 1472 How to detect overflow?
7dca457a
NC
1473
1474 C 99 section 6.2.6.1 says
1475
1476 The range of nonnegative values of a signed integer type is a subrange
1477 of the corresponding unsigned integer type, and the representation of
1478 the same value in each type is the same. A computation involving
1479 unsigned operands can never overflow, because a result that cannot be
1480 represented by the resulting unsigned integer type is reduced modulo
1481 the number that is one greater than the largest value that can be
1482 represented by the resulting type.
1483
1484 (the 9th paragraph)
1485
1486 which I read as "unsigned ints wrap."
1487
1488 signed integer overflow seems to be classed as "exception condition"
1489
1490 If an exceptional condition occurs during the evaluation of an
1491 expression (that is, if the result is not mathematically defined or not
1492 in the range of representable values for its type), the behavior is
1493 undefined.
1494
1495 (6.5, the 5th paragraph)
1496
1497 I had assumed that on 2s complement machines signed arithmetic would
1498 wrap, hence coded pp_add and pp_subtract on the assumption that
1499 everything perl builds on would be happy. After much wailing and
1500 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1501 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
1502 unsigned code below is actually shorter than the old code. :-)
1503 */
1504
01f91bf2 1505 if (SvIV_please_nomg(svr)) {
1604cfb0
MS
1506 /* Unless the left argument is integer in range we are going to have to
1507 use NV maths. Hence only attempt to coerce the right argument if
1508 we know the left is integer. */
1509 UV auv = 0;
1510 bool auvok = FALSE;
1511 bool a_valid = 0;
1512
1513 if (!useleft) {
1514 auv = 0;
1515 a_valid = auvok = 1;
1516 /* left operand is undef, treat as zero. + 0 is identity,
1517 Could SETi or SETu right now, but space optimise by not adding
1518 lots of code to speed up what is probably a rarish case. */
1519 } else {
1520 /* Left operand is defined, so is it IV? */
1521 if (SvIV_please_nomg(svl)) {
1522 if ((auvok = SvUOK(svl)))
1523 auv = SvUVX(svl);
1524 else {
1525 const IV aiv = SvIVX(svl);
1526 if (aiv >= 0) {
1527 auv = aiv;
1528 auvok = 1; /* Now acting as a sign flag. */
1529 } else {
9354a41f
KW
1530 /* Using 0- here and later to silence bogus warning
1531 * from MS VC */
1532 auv = (UV) (0 - (UV) aiv);
1604cfb0
MS
1533 }
1534 }
1535 a_valid = 1;
1536 }
1537 }
1538 if (a_valid) {
1539 bool result_good = 0;
1540 UV result;
1541 UV buv;
1542 bool buvok = SvUOK(svr);
1543
1544 if (buvok)
1545 buv = SvUVX(svr);
1546 else {
1547 const IV biv = SvIVX(svr);
1548 if (biv >= 0) {
1549 buv = biv;
1550 buvok = 1;
1551 } else
9354a41f 1552 buv = (UV) (0 - (UV) biv);
1604cfb0
MS
1553 }
1554 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1555 else "IV" now, independent of how it came in.
1556 if a, b represents positive, A, B negative, a maps to -A etc
1557 a + b => (a + b)
1558 A + b => -(a - b)
1559 a + B => (a - b)
1560 A + B => -(a + b)
1561 all UV maths. negate result if A negative.
1562 add if signs same, subtract if signs differ. */
1563
1564 if (auvok ^ buvok) {
1565 /* Signs differ. */
1566 if (auv >= buv) {
1567 result = auv - buv;
1568 /* Must get smaller */
1569 if (result <= auv)
1570 result_good = 1;
1571 } else {
1572 result = buv - auv;
1573 if (result <= buv) {
1574 /* result really should be -(auv-buv). as its negation
1575 of true value, need to swap our result flag */
1576 auvok = !auvok;
1577 result_good = 1;
1578 }
1579 }
1580 } else {
1581 /* Signs same */
1582 result = auv + buv;
1583 if (result >= auv)
1584 result_good = 1;
1585 }
1586 if (result_good) {
1587 SP--;
1588 if (auvok)
1589 SETu( result );
1590 else {
1591 /* Negate result */
1592 if (result <= (UV)IV_MIN)
53e2bfb7
DM
1593 SETi(result == (UV)IV_MIN
1594 ? IV_MIN : -(IV)result);
1604cfb0
MS
1595 else {
1596 /* result valid, but out of range for IV. */
1597 SETn( -(NV)result );
1598 }
1599 }
1600 RETURN;
1601 } /* Overflow, drop through to NVs. */
1602 }
28e5dec8 1603 }
230ee21f
DM
1604
1605#else
1606 useleft = USE_LEFT(svl);
28e5dec8 1607#endif
230ee21f 1608
a0d0e21e 1609 {
1604cfb0
MS
1610 NV value = SvNV_nomg(svr);
1611 (void)POPs;
1612 if (!useleft) {
1613 /* left operand is undef, treat as zero. + 0.0 is identity. */
1614 SETn(value);
1615 RETURN;
1616 }
1617 SETn( value + SvNV_nomg(svl) );
1618 RETURN;
a0d0e21e
LW
1619 }
1620}
1621
b1c05ba5
DM
1622
1623/* also used for: pp_aelemfast_lex() */
1624
a0d0e21e
LW
1625PP(pp_aelemfast)
1626{
20b7effb 1627 dSP;
93bad3fd 1628 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
1604cfb0 1629 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
a3b680e6 1630 const U32 lval = PL_op->op_flags & OPf_MOD;
7e169e84
DM
1631 const I8 key = (I8)PL_op->op_private;
1632 SV** svp;
1633 SV *sv;
1634
1635 assert(SvTYPE(av) == SVt_PVAV);
1636
f4484b87
DM
1637 EXTEND(SP, 1);
1638
7e169e84
DM
1639 /* inlined av_fetch() for simple cases ... */
1640 if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
1641 sv = AvARRAY(av)[key];
9fb994be 1642 if (sv) {
7e169e84
DM
1643 PUSHs(sv);
1644 RETURN;
1645 }
1646 }
1647
1648 /* ... else do it the hard way */
1649 svp = av_fetch(av, key, lval);
1650 sv = (svp ? *svp : &PL_sv_undef);
b024352e
DM
1651
1652 if (UNLIKELY(!svp && lval))
7e169e84 1653 DIE(aTHX_ PL_no_aelem, (int)key);
b024352e 1654
39cf747a 1655 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
1604cfb0 1656 mg_get(sv);
be6c24e0 1657 PUSHs(sv);
a0d0e21e
LW
1658 RETURN;
1659}
1660
1661PP(pp_join)
1662{
20b7effb 1663 dSP; dMARK; dTARGET;
a0d0e21e
LW
1664 MARK++;
1665 do_join(TARG, *MARK, MARK, SP);
1666 SP = MARK;
1667 SETs(TARG);
1668 RETURN;
1669}
1670
a0d0e21e
LW
1671/* Oversized hot code. */
1672
b1c05ba5
DM
1673/* also used for: pp_say() */
1674
a0d0e21e
LW
1675PP(pp_print)
1676{
20b7effb 1677 dSP; dMARK; dORIGMARK;
eb578fdb 1678 PerlIO *fp;
236988e4 1679 MAGIC *mg;
159b6efe 1680 GV * const gv
1604cfb0 1681 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 1682 IO *io = GvIO(gv);
5b468f54 1683
9c9f25b8 1684 if (io
1604cfb0 1685 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
5b468f54 1686 {
01bb7c6d 1687 had_magic:
1604cfb0
MS
1688 if (MARK == ORIGMARK) {
1689 /* If using default handle then we need to make space to
1690 * pass object as 1st arg, so move other args up ...
1691 */
1692 MEXTEND(SP, 1);
1693 ++MARK;
1694 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1695 ++SP;
1696 }
1697 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
1698 mg,
1699 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
1700 | (PL_op->op_type == OP_SAY
1701 ? TIED_METHOD_SAY : 0)), sp - mark);
236988e4 1702 }
9c9f25b8 1703 if (!io) {
68b590d9 1704 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
1604cfb0 1705 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
01bb7c6d 1706 goto had_magic;
1604cfb0
MS
1707 report_evil_fh(gv);
1708 SETERRNO(EBADF,RMS_IFI);
1709 goto just_say_no;
a0d0e21e
LW
1710 }
1711 else if (!(fp = IoOFP(io))) {
1604cfb0
MS
1712 if (IoIFP(io))
1713 report_wrongway_fh(gv, '<');
1714 else
1715 report_evil_fh(gv);
1716 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1717 goto just_say_no;
a0d0e21e
LW
1718 }
1719 else {
1604cfb0
MS
1720 SV * const ofs = GvSV(PL_ofsgv); /* $, */
1721 MARK++;
1722 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
1723 while (MARK <= SP) {
1724 if (!do_print(*MARK, fp))
1725 break;
1726 MARK++;
1727 if (MARK <= SP) {
1728 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
1729 if (!do_print(GvSV(PL_ofsgv), fp)) {
1730 MARK--;
1731 break;
1732 }
1733 }
1734 }
1735 }
1736 else {
1737 while (MARK <= SP) {
1738 if (!do_print(*MARK, fp))
1739 break;
1740 MARK++;
1741 }
1742 }
1743 if (MARK <= SP)
1744 goto just_say_no;
1745 else {
1746 if (PL_op->op_type == OP_SAY) {
1747 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
1748 goto just_say_no;
1749 }
cfc4a7da 1750 else if (PL_ors_sv && SvOK(PL_ors_sv))
1604cfb0
MS
1751 if (!do_print(PL_ors_sv, fp)) /* $\ */
1752 goto just_say_no;
a0d0e21e 1753
1604cfb0
MS
1754 if (IoFLAGS(io) & IOf_FLUSH)
1755 if (PerlIO_flush(fp) == EOF)
1756 goto just_say_no;
1757 }
a0d0e21e
LW
1758 }
1759 SP = ORIGMARK;
e52fd6f4 1760 XPUSHs(&PL_sv_yes);
a0d0e21e
LW
1761 RETURN;
1762
1763 just_say_no:
1764 SP = ORIGMARK;
e52fd6f4 1765 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
1766 RETURN;
1767}
1768
b1c05ba5 1769
aa36782f
DM
1770/* do the common parts of pp_padhv() and pp_rv2hv()
1771 * It assumes the caller has done EXTEND(SP, 1) or equivalent.
af3b1cba 1772 * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
e84e4286
DM
1773 * 'has_targ' indicates that the op has a target - this should
1774 * be a compile-time constant so that the code can constant-folded as
1775 * appropriate
aa36782f
DM
1776 * */
1777
1778PERL_STATIC_INLINE OP*
e84e4286 1779S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
aa36782f 1780{
e80717e7
DM
1781 bool is_tied;
1782 bool is_bool;
e1ad5d4c 1783 MAGIC *mg;
aa36782f 1784 dSP;
e80717e7
DM
1785 IV i;
1786 SV *sv;
aa36782f
DM
1787
1788 assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
1789
1790 if (gimme == G_ARRAY) {
8dc9003f 1791 hv_pushkv(hv, 3);
af3b1cba 1792 return NORMAL;
aa36782f
DM
1793 }
1794
1795 if (is_keys)
1796 /* 'keys %h' masquerading as '%h': reset iterator */
1797 (void)hv_iterinit(hv);
1798
6f2dc9a6
DM
1799 if (gimme == G_VOID)
1800 return NORMAL;
1801
e80717e7
DM
1802 is_bool = ( PL_op->op_private & OPpTRUEBOOL
1803 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
1804 && block_gimme() == G_VOID));
1805 is_tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
1806
1807 if (UNLIKELY(is_tied)) {
1808 if (is_keys && !is_bool) {
1809 i = 0;
1810 while (hv_iternext(hv))
1811 i++;
1812 goto push_i;
1813 }
1814 else {
1815 sv = magic_scalarpack(hv, mg);
1816 goto push_sv;
1817 }
3cd2c7d4 1818 }
e80717e7
DM
1819 else {
1820 i = HvUSEDKEYS(hv);
1821 if (is_bool) {
1822 sv = i ? &PL_sv_yes : &PL_sv_zero;
1823 push_sv:
1824 PUSHs(sv);
1825 }
1826 else {
1827 push_i:
e84e4286
DM
1828 if (has_targ) {
1829 dTARGET;
1830 PUSHi(i);
1831 }
1832 else
6f2dc9a6
DM
1833 if (is_keys) {
1834 /* parent op should be an unused OP_KEYS whose targ we can
1835 * use */
1836 dTARG;
1837 OP *k;
1838
1839 assert(!OpHAS_SIBLING(PL_op));
1840 k = PL_op->op_sibparent;
1841 assert(k->op_type == OP_KEYS);
1842 TARG = PAD_SV(k->op_targ);
1843 PUSHi(i);
1844 }
1845 else
e84e4286 1846 mPUSHi(i);
aa36782f 1847 }
aa36782f
DM
1848 }
1849
1850 PUTBACK;
1851 return NORMAL;
1852}
1853
1854
e855b461
DM
1855/* This is also called directly by pp_lvavref. */
1856PP(pp_padav)
1857{
1858 dSP; dTARGET;
1859 U8 gimme;
1860 assert(SvTYPE(TARG) == SVt_PVAV);
1861 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1604cfb0
MS
1862 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1863 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
e855b461
DM
1864 EXTEND(SP, 1);
1865
1866 if (PL_op->op_flags & OPf_REF) {
1604cfb0
MS
1867 PUSHs(TARG);
1868 RETURN;
e855b461
DM
1869 }
1870 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1871 const I32 flags = is_lvalue_sub();
1872 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1604cfb0 1873 if (GIMME_V == G_SCALAR)
e855b461
DM
1874 /* diag_listed_as: Can't return %s to lvalue scalar context */
1875 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
1876 PUSHs(TARG);
1877 RETURN;
1878 }
1879 }
1880
1881 gimme = GIMME_V;
0b5aba47
DM
1882 if (gimme == G_ARRAY)
1883 return S_pushav(aTHX_ (AV*)TARG);
327c9b9e
DM
1884
1885 if (gimme == G_SCALAR) {
1604cfb0 1886 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
e855b461
DM
1887 if (!maxarg)
1888 PUSHs(&PL_sv_zero);
1889 else if (PL_op->op_private & OPpTRUEBOOL)
1890 PUSHs(&PL_sv_yes);
1891 else
1892 mPUSHi(maxarg);
1893 }
1894 RETURN;
1895}
1896
1897
1898PP(pp_padhv)
1899{
1900 dSP; dTARGET;
1901 U8 gimme;
e855b461
DM
1902
1903 assert(SvTYPE(TARG) == SVt_PVHV);
e855b461 1904 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1604cfb0
MS
1905 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1906 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
e855b461 1907
aa36782f
DM
1908 EXTEND(SP, 1);
1909
1910 if (PL_op->op_flags & OPf_REF) {
1911 PUSHs(TARG);
1604cfb0 1912 RETURN;
aa36782f 1913 }
e855b461
DM
1914 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1915 const I32 flags = is_lvalue_sub();
1916 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1917 if (GIMME_V == G_SCALAR)
1918 /* diag_listed_as: Can't return %s to lvalue scalar context */
1919 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
aa36782f 1920 PUSHs(TARG);
e855b461
DM
1921 RETURN;
1922 }
1923 }
1924
1925 gimme = GIMME_V;
e855b461 1926
aa36782f 1927 return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
e84e4286
DM
1928 cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
1929 0 /* has_targ*/);
e855b461
DM
1930}
1931
1932
b1c05ba5 1933/* also used for: pp_rv2hv() */
bdaf10a5 1934/* also called directly by pp_lvavref */
b1c05ba5 1935
a0d0e21e
LW
1936PP(pp_rv2av)
1937{
20b7effb 1938 dSP; dTOPss;
1c23e2bd 1939 const U8 gimme = GIMME_V;
13c59d41
MH
1940 static const char an_array[] = "an ARRAY";
1941 static const char a_hash[] = "a HASH";
bdaf10a5 1942 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
1604cfb0 1943 || PL_op->op_type == OP_LVAVREF;
d83b45b8 1944 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e 1945
9026059d 1946 SvGETMAGIC(sv);
a0d0e21e 1947 if (SvROK(sv)) {
1604cfb0
MS
1948 if (UNLIKELY(SvAMAGIC(sv))) {
1949 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
1950 }
1951 sv = SvRV(sv);
1952 if (UNLIKELY(SvTYPE(sv) != type))
1953 /* diag_listed_as: Not an ARRAY reference */
1954 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
1955 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
1956 && PL_op->op_private & OPpLVAL_INTRO))
1957 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e 1958 }
5d9574c1 1959 else if (UNLIKELY(SvTYPE(sv) != type)) {
1604cfb0
MS
1960 GV *gv;
1961
1962 if (!isGV_with_GP(sv)) {
1963 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
1964 type, &sp);
1965 if (!gv)
1966 RETURN;
1967 }
1968 else {
1969 gv = MUTABLE_GV(sv);
1970 }
1971 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
1972 if (PL_op->op_private & OPpLVAL_INTRO)
1973 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
9f527363
FC
1974 }
1975 if (PL_op->op_flags & OPf_REF) {
1604cfb0
MS
1976 SETs(sv);
1977 RETURN;
9f527363 1978 }
5d9574c1 1979 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
1604cfb0
MS
1980 const I32 flags = is_lvalue_sub();
1981 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1982 if (gimme != G_ARRAY)
1983 goto croak_cant_return;
1984 SETs(sv);
1985 RETURN;
1986 }
a0d0e21e
LW
1987 }
1988
17ab7946 1989 if (is_pp_rv2av) {
1604cfb0 1990 AV *const av = MUTABLE_AV(sv);
0b5aba47 1991
1604cfb0 1992 if (gimme == G_ARRAY) {
d5524600
DM
1993 SP--;
1994 PUTBACK;
0b5aba47 1995 return S_pushav(aTHX_ av);
1604cfb0 1996 }
0b5aba47 1997
1604cfb0
MS
1998 if (gimme == G_SCALAR) {
1999 const SSize_t maxarg = AvFILL(av) + 1;
7be75ccf
DM
2000 if (PL_op->op_private & OPpTRUEBOOL)
2001 SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
2002 else {
2003 dTARGET;
2004 SETi(maxarg);
2005 }
1604cfb0 2006 }
7be75ccf
DM
2007 }
2008 else {
aa36782f
DM
2009 SP--; PUTBACK;
2010 return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
e84e4286
DM
2011 cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
2012 1 /* has_targ*/);
17ab7946 2013 }
be85d344 2014 RETURN;
042560a6
NC
2015
2016 croak_cant_return:
2017 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
1604cfb0 2018 is_pp_rv2av ? "array" : "hash");
77e217c6 2019 RETURN;
a0d0e21e
LW
2020}
2021
10c8fecd 2022STATIC void
fb8f4cf8 2023S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
10c8fecd 2024{
7918f24d
NC
2025 PERL_ARGS_ASSERT_DO_ODDBALL;
2026
fb8f4cf8 2027 if (*oddkey) {
6d822dc4 2028 if (ckWARN(WARN_MISC)) {
1604cfb0
MS
2029 const char *err;
2030 if (oddkey == firstkey &&
2031 SvROK(*oddkey) &&
2032 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
2033 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
2034 {
2035 err = "Reference found where even-sized list expected";
2036 }
2037 else
2038 err = "Odd number of elements in hash assignment";
2039 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
2040 }
6d822dc4 2041
10c8fecd
GS
2042 }
2043}
2044
a5f48505
DM
2045
2046/* Do a mark and sweep with the SVf_BREAK flag to detect elements which
2047 * are common to both the LHS and RHS of an aassign, and replace them
2048 * with copies. All these copies are made before the actual list assign is
2049 * done.
2050 *
2051 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
2052 * element ($b) to the first LH element ($a), modifies $a; when the
2053 * second assignment is done, the second RH element now has the wrong
2054 * value. So we initially replace the RHS with ($b, mortalcopy($a)).
2055 * Note that we don't need to make a mortal copy of $b.
2056 *
2057 * The algorithm below works by, for every RHS element, mark the
2058 * corresponding LHS target element with SVf_BREAK. Then if the RHS
2059 * element is found with SVf_BREAK set, it means it would have been
2060 * modified, so make a copy.
2061 * Note that by scanning both LHS and RHS in lockstep, we avoid
2062 * unnecessary copies (like $b above) compared with a naive
2063 * "mark all LHS; copy all marked RHS; unmark all LHS".
2064 *
2065 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
2066 * it can't be common and can be skipped.
ebc643ce
DM
2067 *
2068 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
2069 * that we thought we didn't need to call S_aassign_copy_common(), but we
2070 * have anyway for sanity checking. If we find we need to copy, then panic.
a5f48505
DM
2071 */
2072
2073PERL_STATIC_INLINE void
2074S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
ebc643ce
DM
2075 SV **firstrelem, SV **lastrelem
2076#ifdef DEBUGGING
2077 , bool fake
2078#endif
2079)
a5f48505 2080{
a5f48505
DM
2081 SV **relem;
2082 SV **lelem;
2083 SSize_t lcount = lastlelem - firstlelem + 1;
2084 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
2085 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
beb08a1e 2086 bool copy_all = FALSE;
a5f48505
DM
2087
2088 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
2089 assert(firstlelem < lastlelem); /* at least 2 LH elements */
2090 assert(firstrelem < lastrelem); /* at least 2 RH elements */
2091
ebc643ce
DM
2092
2093 lelem = firstlelem;
a5f48505
DM
2094 /* we never have to copy the first RH element; it can't be corrupted
2095 * by assigning something to the corresponding first LH element.
2096 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
2097 */
ebc643ce 2098 relem = firstrelem + 1;
a5f48505
DM
2099
2100 for (; relem <= lastrelem; relem++) {
2101 SV *svr;
2102
2103 /* mark next LH element */
2104
2105 if (--lcount >= 0) {
2106 SV *svl = *lelem++;
2107
2108 if (UNLIKELY(!svl)) {/* skip AV alias marker */
2109 assert (lelem <= lastlelem);
2110 svl = *lelem++;
2111 lcount--;
2112 }
2113
2114 assert(svl);
beb08a1e
TC
2115 if (SvSMAGICAL(svl)) {
2116 copy_all = TRUE;
2117 }
a5f48505
DM
2118 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
2119 if (!marked)
2120 return;
2121 /* this LH element will consume all further args;
2122 * no need to mark any further LH elements (if any).
2123 * But we still need to scan any remaining RHS elements;
2124 * set lcount negative to distinguish from lcount == 0,
2125 * so the loop condition continues being true
2126 */
2127 lcount = -1;
2128 lelem--; /* no need to unmark this element */
2129 }
94a5f659 2130 else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
a5f48505
DM
2131 SvFLAGS(svl) |= SVf_BREAK;
2132 marked = TRUE;
2133 }
2134 else if (!marked) {
2135 /* don't check RH element if no SVf_BREAK flags set yet */
2136 if (!lcount)
2137 break;
2138 continue;
2139 }
2140 }
2141
2142 /* see if corresponding RH element needs copying */
2143
2144 assert(marked);
2145 svr = *relem;
2146 assert(svr);
2147
5c1db569 2148 if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
1050723f 2149 U32 brk = (SvFLAGS(svr) & SVf_BREAK);
a5f48505 2150
ebc643ce
DM
2151#ifdef DEBUGGING
2152 if (fake) {
9ae0115f 2153 /* op_dump(PL_op); */
ebc643ce
DM
2154 Perl_croak(aTHX_
2155 "panic: aassign skipped needed copy of common RH elem %"
2156 UVuf, (UV)(relem - firstrelem));
2157 }
2158#endif
2159
a5f48505
DM
2160 TAINT_NOT; /* Each item is independent */
2161
2162 /* Dear TODO test in t/op/sort.t, I love you.
2163 (It's relying on a panic, not a "semi-panic" from newSVsv()
2164 and then an assertion failure below.) */
2165 if (UNLIKELY(SvIS_FREED(svr))) {
2166 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
2167 (void*)svr);
2168 }
2169 /* avoid break flag while copying; otherwise COW etc
2170 * disabled... */
2171 SvFLAGS(svr) &= ~SVf_BREAK;
2172 /* Not newSVsv(), as it does not allow copy-on-write,
8c1e192f
DM
2173 resulting in wasteful copies.
2174 Also, we use SV_NOSTEAL in case the SV is used more than
2175 once, e.g. (...) = (f())[0,0]
2176 Where the same SV appears twice on the RHS without a ref
2177 count bump. (Although I suspect that the SV won't be
2178 stealable here anyway - DAPM).
2179 */
a5f48505
DM
2180 *relem = sv_mortalcopy_flags(svr,
2181 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2182 /* ... but restore afterwards in case it's needed again,
2183 * e.g. ($a,$b,$c) = (1,$a,$a)
2184 */
1050723f 2185 SvFLAGS(svr) |= brk;
a5f48505
DM
2186 }
2187
2188 if (!lcount)
2189 break;
2190 }
2191
2192 if (!marked)
2193 return;
2194
2195 /*unmark LHS */
2196
2197 while (lelem > firstlelem) {
2198 SV * const svl = *(--lelem);
2199 if (svl)
2200 SvFLAGS(svl) &= ~SVf_BREAK;
2201 }
2202}
2203
2204
2205
a0d0e21e
LW
2206PP(pp_aassign)
2207{
c91f661c 2208 dSP;
3280af22
NIS
2209 SV **lastlelem = PL_stack_sp;
2210 SV **lastrelem = PL_stack_base + POPMARK;
2211 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
2212 SV **firstlelem = lastrelem + 1;
2213
eb578fdb
KW
2214 SV **relem;
2215 SV **lelem;
1c23e2bd 2216 U8 gimme;
a68090fe
DM
2217 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
2218 * only need to save locally, not on the save stack */
2219 U16 old_delaymagic = PL_delaymagic;
ebc643ce
DM
2220#ifdef DEBUGGING
2221 bool fake = 0;
2222#endif
5637b936 2223
3280af22 2224 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
a0d0e21e
LW
2225
2226 /* If there's a common identifier on both sides we have to take
2227 * special care that assigning the identifier on the left doesn't
2228 * clobber a value on the right that's used later in the list.
2229 */
acdea6f0 2230
beb08a1e
TC
2231 /* at least 2 LH and RH elements, or commonality isn't an issue */
2232 if (firstlelem < lastlelem && firstrelem < lastrelem) {
5c1db569
TC
2233 for (relem = firstrelem+1; relem <= lastrelem; relem++) {
2234 if (SvGMAGICAL(*relem))
2235 goto do_scan;
2236 }
beb08a1e
TC
2237 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2238 if (*lelem && SvSMAGICAL(*lelem))
2239 goto do_scan;
a5f48505 2240 }
beb08a1e
TC
2241 if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
2242 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
2243 /* skip the scan if all scalars have a ref count of 1 */
2244 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
8b0c3377 2245 SV *sv = *lelem;
beb08a1e
TC
2246 if (!sv || SvREFCNT(sv) == 1)
2247 continue;
2248 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
2249 goto do_scan;
2250 break;
2251 }
2252 }
2253 else {
2254 do_scan:
2255 S_aassign_copy_common(aTHX_
2256 firstlelem, lastlelem, firstrelem, lastrelem
ebc643ce 2257#ifdef DEBUGGING
beb08a1e 2258 , fake
ebc643ce 2259#endif
beb08a1e
TC
2260 );
2261 }
a5f48505 2262 }
a0d0e21e 2263 }
ebc643ce
DM
2264#ifdef DEBUGGING
2265 else {
2266 /* on debugging builds, do the scan even if we've concluded we
2267 * don't need to, then panic if we find commonality. Note that the
2268 * scanner assumes at least 2 elements */
2269 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2270 fake = 1;
2271 goto do_scan;
2272 }
2273 }
2274#endif
a0d0e21e 2275
a5f48505 2276 gimme = GIMME_V;
a0d0e21e
LW
2277 relem = firstrelem;
2278 lelem = firstlelem;
10c8fecd 2279
8b0c3377
DM
2280 if (relem > lastrelem)
2281 goto no_relems;
2282
2283 /* first lelem loop while there are still relems */
5d9574c1 2284 while (LIKELY(lelem <= lastlelem)) {
1604cfb0
MS
2285 bool alias = FALSE;
2286 SV *lsv = *lelem++;
8b0c3377 2287
c73f612f
DM
2288 TAINT_NOT; /* Each item stands on its own, taintwise. */
2289
8b0c3377 2290 assert(relem <= lastrelem);
1604cfb0
MS
2291 if (UNLIKELY(!lsv)) {
2292 alias = TRUE;
2293 lsv = *lelem++;
2294 ASSUME(SvTYPE(lsv) == SVt_PVAV);
2295 }
2296
2297 switch (SvTYPE(lsv)) {
2298 case SVt_PVAV: {
8b0c3377
DM
2299 SV **svp;
2300 SSize_t i;
2301 SSize_t tmps_base;
2302 SSize_t nelems = lastrelem - relem + 1;
b09ed995 2303 AV *ary = MUTABLE_AV(lsv);
8b0c3377
DM
2304
2305 /* Assigning to an aggregate is tricky. First there is the
2306 * issue of commonality, e.g. @a = ($a[0]). Since the
2307 * stack isn't refcounted, clearing @a prior to storing
2308 * elements will free $a[0]. Similarly with
2309 * sub FETCH { $status[$_[1]] } @status = @tied[0,1];
2310 *
2311 * The way to avoid these issues is to make the copy of each
2312 * SV (and we normally store a *copy* in the array) *before*
2313 * clearing the array. But this has a problem in that
2314 * if the code croaks during copying, the not-yet-stored copies
2315 * could leak. One way to avoid this is to make all the copies
2316 * mortal, but that's quite expensive.
2317 *
2318 * The current solution to these issues is to use a chunk
2319 * of the tmps stack as a temporary refcounted-stack. SVs
2320 * will be put on there during processing to avoid leaks,
2321 * but will be removed again before the end of this block,
2322 * so free_tmps() is never normally called. Also, the
2323 * sv_refcnt of the SVs doesn't have to be manipulated, since
2324 * the ownership of 1 reference count is transferred directly
2325 * from the tmps stack to the AV when the SV is stored.
2326 *
2327 * We disarm slots in the temps stack by storing PL_sv_undef
2328 * there: it doesn't matter if that SV's refcount is
2329 * repeatedly decremented during a croak. But usually this is
2330 * only an interim measure. By the end of this code block
2331 * we try where possible to not leave any PL_sv_undef's on the
2332 * tmps stack e.g. by shuffling newer entries down.
2333 *
2334 * There is one case where we don't copy: non-magical
2335 * SvTEMP(sv)'s with a ref count of 1. The only owner of these
2336 * is on the tmps stack, so its safe to directly steal the SV
2337 * rather than copying. This is common in things like function
2338 * returns, map etc, which all return a list of such SVs.
2339 *
2340 * Note however something like @a = (f())[0,0], where there is
2341 * a danger of the same SV being shared: this avoided because
2342 * when the SV is stored as $a[0], its ref count gets bumped,
2343 * so the RC==1 test fails and the second element is copied
2344 * instead.
2345 *
2346 * We also use one slot in the tmps stack to hold an extra
2347 * ref to the array, to ensure it doesn't get prematurely
2348 * freed. Again, this is removed before the end of this block.
2349 *
2350 * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
2351 * @a = ($a[0]) case, but the current implementation uses the
2352 * same algorithm regardless, so ignores that flag. (It *is*
2353 * used in the hash branch below, however).
2354 */
2355
2356 /* Reserve slots for ary, plus the elems we're about to copy,
2357 * then protect ary and temporarily void the remaining slots
2358 * with &PL_sv_undef */
2359 EXTEND_MORTAL(nelems + 1);
2360 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
2361 tmps_base = PL_tmps_ix + 1;
2362 for (i = 0; i < nelems; i++)
2363 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2364 PL_tmps_ix += nelems;
2365
2366 /* Make a copy of each RHS elem and save on the tmps_stack
2367 * (or pass through where we can optimise away the copy) */
2368
2369 if (UNLIKELY(alias)) {
2370 U32 lval = (gimme == G_ARRAY)
2371 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
a5f48505 2372 for (svp = relem; svp <= lastrelem; svp++) {
8b0c3377
DM
2373 SV *rsv = *svp;
2374
2375 SvGETMAGIC(rsv);
2376 if (!SvROK(rsv))
2377 DIE(aTHX_ "Assigned value is not a reference");
2378 if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
2379 /* diag_listed_as: Assigned value is not %s reference */
2380 DIE(aTHX_
2381 "Assigned value is not a SCALAR reference");
2382 if (lval)
2383 *svp = rsv = sv_mortalcopy(rsv);
2384 /* XXX else check for weak refs? */
2385 rsv = SvREFCNT_inc_NN(SvRV(rsv));
2386 assert(tmps_base <= PL_tmps_max);
2387 PL_tmps_stack[tmps_base++] = rsv;
a5f48505 2388 }
a5f48505 2389 }
8b0c3377
DM
2390 else {
2391 for (svp = relem; svp <= lastrelem; svp++) {
2392 SV *rsv = *svp;
a5f48505 2393
8b0c3377
DM
2394 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2395 /* can skip the copy */
2396 SvREFCNT_inc_simple_void_NN(rsv);
2397 SvTEMP_off(rsv);
2398 }
a5f48505 2399 else {
8b0c3377
DM
2400 SV *nsv;
2401 /* do get before newSV, in case it dies and leaks */
2402 SvGETMAGIC(rsv);
2403 nsv = newSV(0);
8c1e192f
DM
2404 /* see comment in S_aassign_copy_common about
2405 * SV_NOSTEAL */
8b0c3377
DM
2406 sv_setsv_flags(nsv, rsv,
2407 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2408 rsv = *svp = nsv;
a5f48505 2409 }
8b0c3377
DM
2410
2411 assert(tmps_base <= PL_tmps_max);
2412 PL_tmps_stack[tmps_base++] = rsv;
2413 }
2414 }
2415
2416 if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
2417 av_clear(ary);
2418
2419 /* store in the array, the SVs that are in the tmps stack */
2420
2421 tmps_base -= nelems;
2422
80c1439f 2423 if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
8b0c3377
DM
2424 /* for arrays we can't cheat with, use the official API */
2425 av_extend(ary, nelems - 1);
2426 for (i = 0; i < nelems; i++) {
2427 SV **svp = &(PL_tmps_stack[tmps_base + i]);
2428 SV *rsv = *svp;
2429 /* A tied store won't take ownership of rsv, so keep
2430 * the 1 refcnt on the tmps stack; otherwise disarm
2431 * the tmps stack entry */
2432 if (av_store(ary, i, rsv))
2433 *svp = &PL_sv_undef;
2434 /* av_store() may have added set magic to rsv */;
2435 SvSETMAGIC(rsv);
2436 }
2437 /* disarm ary refcount: see comments below about leak */
2438 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2439 }
2440 else {
2441 /* directly access/set the guts of the AV */
2442 SSize_t fill = nelems - 1;
2443 if (fill > AvMAX(ary))
2444 av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
2445 &AvARRAY(ary));
2446 AvFILLp(ary) = fill;
2447 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
2448 /* Quietly remove all the SVs from the tmps stack slots,
2449 * since ary has now taken ownership of the refcnt.
2450 * Also remove ary: which will now leak if we die before
2451 * the SvREFCNT_dec_NN(ary) below */
2452 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2453 Move(&PL_tmps_stack[tmps_base + nelems],
2454 &PL_tmps_stack[tmps_base - 1],
2455 PL_tmps_ix - (tmps_base + nelems) + 1,
2456 SV*);
2457 PL_tmps_ix -= (nelems + 1);
2458 }
2459
1604cfb0 2460 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
8b0c3377 2461 /* its assumed @ISA set magic can't die and leak ary */
1604cfb0 2462 SvSETMAGIC(MUTABLE_SV(ary));
8b0c3377
DM
2463 SvREFCNT_dec_NN(ary);
2464
2465 relem = lastrelem + 1;
1604cfb0 2466 goto no_relems;
a5f48505
DM
2467 }
2468
1604cfb0 2469 case SVt_PVHV: { /* normal hash */
8b0c3377
DM
2470
2471 SV **svp;
2472 bool dirty_tmps;
2473 SSize_t i;
2474 SSize_t tmps_base;
2475 SSize_t nelems = lastrelem - relem + 1;
b09ed995 2476 HV *hash = MUTABLE_HV(lsv);
8b0c3377
DM
2477
2478 if (UNLIKELY(nelems & 1)) {
2479 do_oddball(lastrelem, relem);
2480 /* we have firstlelem to reuse, it's not needed any more */
2481 *++lastrelem = &PL_sv_undef;
2482 nelems++;
2483 }
2484
2485 /* See the SVt_PVAV branch above for a long description of
2486 * how the following all works. The main difference for hashes
2487 * is that we treat keys and values separately (and have
2488 * separate loops for them): as for arrays, values are always
2489 * copied (except for the SvTEMP optimisation), since they
2490 * need to be stored in the hash; while keys are only
2491 * processed where they might get prematurely freed or
2492 * whatever. */
2493
2494 /* tmps stack slots:
2495 * * reserve a slot for the hash keepalive;
2496 * * reserve slots for the hash values we're about to copy;
2497 * * preallocate for the keys we'll possibly copy or refcount bump
2498 * later;
2499 * then protect hash and temporarily void the remaining
2500 * value slots with &PL_sv_undef */
2501 EXTEND_MORTAL(nelems + 1);
2502
2503 /* convert to number of key/value pairs */
2504 nelems >>= 1;
2505
2506 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
2507 tmps_base = PL_tmps_ix + 1;
2508 for (i = 0; i < nelems; i++)
2509 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2510 PL_tmps_ix += nelems;
2511
2512 /* Make a copy of each RHS hash value and save on the tmps_stack
2513 * (or pass through where we can optimise away the copy) */
2514
2515 for (svp = relem + 1; svp <= lastrelem; svp += 2) {
2516 SV *rsv = *svp;
2517
2518 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2519 /* can skip the copy */
2520 SvREFCNT_inc_simple_void_NN(rsv);
2521 SvTEMP_off(rsv);
2522 }
2523 else {
2524 SV *nsv;
2525 /* do get before newSV, in case it dies and leaks */
2526 SvGETMAGIC(rsv);
2527 nsv = newSV(0);
2528 /* see comment in S_aassign_copy_common about
2529 * SV_NOSTEAL */
2530 sv_setsv_flags(nsv, rsv,
2531 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2532 rsv = *svp = nsv;
1c4ea384
RZ
2533 }
2534
8b0c3377
DM
2535 assert(tmps_base <= PL_tmps_max);
2536 PL_tmps_stack[tmps_base++] = rsv;
2537 }
2538 tmps_base -= nelems;
a5f48505 2539
a5f48505 2540
8b0c3377
DM
2541 /* possibly protect keys */
2542
2543 if (UNLIKELY(gimme == G_ARRAY)) {
2544 /* handle e.g.
2545 * @a = ((%h = ($$r, 1)), $r = "x");
2546 * $_++ for %h = (1,2,3,4);
2547 */
2548 EXTEND_MORTAL(nelems);
2549 for (svp = relem; svp <= lastrelem; svp += 2)
2550 *svp = sv_mortalcopy_flags(*svp,
2551 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2552 }
2553 else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
2554 /* for possible commonality, e.g.
2555 * %h = ($h{a},1)
2556 * avoid premature freeing RHS keys by mortalising
2557 * them.
2558 * For a magic element, make a copy so that its magic is
2559 * called *before* the hash is emptied (which may affect
2560 * a tied value for example).
2561 * In theory we should check for magic keys in all
2562 * cases, not just under OPpASSIGN_COMMON_AGG, but in
2563 * practice, !OPpASSIGN_COMMON_AGG implies only
2564 * constants or padtmps on the RHS.
2565 */
2566 EXTEND_MORTAL(nelems);
2567 for (svp = relem; svp <= lastrelem; svp += 2) {
2568 SV *rsv = *svp;
2569 if (UNLIKELY(SvGMAGICAL(rsv))) {
2570 SSize_t n;
a5f48505
DM
2571 *svp = sv_mortalcopy_flags(*svp,
2572 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
8b0c3377
DM
2573 /* allow other branch to continue pushing
2574 * onto tmps stack without checking each time */
2575 n = (lastrelem - relem) >> 1;
2576 EXTEND_MORTAL(n);
a5f48505 2577 }
8b0c3377
DM
2578 else
2579 PL_tmps_stack[++PL_tmps_ix] =
2580 SvREFCNT_inc_simple_NN(rsv);
a5f48505 2581 }
8b0c3377 2582 }
a5f48505 2583
8b0c3377
DM
2584 if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
2585 hv_clear(hash);
a5f48505 2586
8b0c3377
DM
2587 /* now assign the keys and values to the hash */
2588
2589 dirty_tmps = FALSE;
2590
2591 if (UNLIKELY(gimme == G_ARRAY)) {
2592 /* @a = (%h = (...)) etc */
2593 SV **svp;
2594 SV **topelem = relem;
2595
2596 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2597 SV *key = *svp++;
2598 SV *val = *svp;
2599 /* remove duplicates from list we return */
2600 if (!hv_exists_ent(hash, key, 0)) {
2601 /* copy key back: possibly to an earlier
2602 * stack location if we encountered dups earlier,
2603 * The values will be updated later
2604 */
2605 *topelem = key;
2606 topelem += 2;
632b9d6f 2607 }
8b0c3377
DM
2608 /* A tied store won't take ownership of val, so keep
2609 * the 1 refcnt on the tmps stack; otherwise disarm
2610 * the tmps stack entry */
2611 if (hv_store_ent(hash, key, val, 0))
2612 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2613 else
2614 dirty_tmps = TRUE;
2615 /* hv_store_ent() may have added set magic to val */;
2616 SvSETMAGIC(val);
2617 }
2618 if (topelem < svp) {
1c4ea384
RZ
2619 /* at this point we have removed the duplicate key/value
2620 * pairs from the stack, but the remaining values may be
2621 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
2622 * the (a 2), but the stack now probably contains
2623 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
2624 * obliterates the earlier key. So refresh all values. */
8b0c3377
DM
2625 lastrelem = topelem - 1;
2626 while (relem < lastrelem) {
1c4ea384
RZ
2627 HE *he;
2628 he = hv_fetch_ent(hash, *relem++, 0, 0);
2629 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
2630 }
2631 }
8b0c3377
DM
2632 }
2633 else {
2634 SV **svp;
2635 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2636 SV *key = *svp++;
2637 SV *val = *svp;
2638 if (hv_store_ent(hash, key, val, 0))
2639 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2640 else
2641 dirty_tmps = TRUE;
2642 /* hv_store_ent() may have added set magic to val */;
2643 SvSETMAGIC(val);
2644 }
2645 }
2646
2647 if (dirty_tmps) {
2648 /* there are still some 'live' recounts on the tmps stack
2649 * - usually caused by storing into a tied hash. So let
2650 * free_tmps() do the proper but slow job later.
2651 * Just disarm hash refcount: see comments below about leak
2652 */
2653 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2654 }
2655 else {
2656 /* Quietly remove all the SVs from the tmps stack slots,
2657 * since hash has now taken ownership of the refcnt.
2658 * Also remove hash: which will now leak if we die before
2659 * the SvREFCNT_dec_NN(hash) below */
2660 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2661 Move(&PL_tmps_stack[tmps_base + nelems],
2662 &PL_tmps_stack[tmps_base - 1],
2663 PL_tmps_ix - (tmps_base + nelems) + 1,
2664 SV*);
2665 PL_tmps_ix -= (nelems + 1);
2666 }
2667
2668 SvREFCNT_dec_NN(hash);
2669
2670 relem = lastrelem + 1;
1604cfb0
MS
2671 goto no_relems;
2672 }
8b0c3377 2673
1604cfb0
MS
2674 default:
2675 if (!SvIMMORTAL(lsv)) {
d24e3eb1
DM
2676 SV *ref;
2677
8b0c3377
DM
2678 if (UNLIKELY(
2679 SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
2680 (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
2681 ))
2682 Perl_warner(aTHX_
2683 packWARN(WARN_MISC),
2684 "Useless assignment to a temporary"
2685 );
d24e3eb1
DM
2686
2687 /* avoid freeing $$lsv if it might be needed for further
2688 * elements, e.g. ($ref, $foo) = (1, $$ref) */
2689 if ( SvROK(lsv)
2690 && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
2691 && lelem <= lastlelem
2692 ) {
2693 SSize_t ix;
2694 SvREFCNT_inc_simple_void_NN(ref);
2695 /* an unrolled sv_2mortal */
2696 ix = ++PL_tmps_ix;
2697 if (UNLIKELY(ix >= PL_tmps_max))
2698 /* speculatively grow enough to cover other
2699 * possible refs */
67c3640a 2700 (void)tmps_grow_p(ix + (lastlelem - lelem));
d24e3eb1
DM
2701 PL_tmps_stack[ix] = ref;
2702 }
2703
8b0c3377
DM
2704 sv_setsv(lsv, *relem);
2705 *relem = lsv;
2706 SvSETMAGIC(lsv);
2707 }
2708 if (++relem > lastrelem)
2709 goto no_relems;
1604cfb0 2710 break;
8b0c3377
DM
2711 } /* switch */
2712 } /* while */
2713
2714
2715 no_relems:
2716
2717 /* simplified lelem loop for when there are no relems left */
2718 while (LIKELY(lelem <= lastlelem)) {
1604cfb0 2719 SV *lsv = *lelem++;
c73f612f
DM
2720
2721 TAINT_NOT; /* Each item stands on its own, taintwise. */
2722
1604cfb0
MS
2723 if (UNLIKELY(!lsv)) {
2724 lsv = *lelem++;
2725 ASSUME(SvTYPE(lsv) == SVt_PVAV);
2726 }
8b0c3377 2727
1604cfb0
MS
2728 switch (SvTYPE(lsv)) {
2729 case SVt_PVAV:
b09ed995
DM
2730 if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
2731 av_clear((AV*)lsv);
8b0c3377 2732 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
b09ed995 2733 SvSETMAGIC(lsv);
8b0c3377
DM
2734 }
2735 break;
2736
1604cfb0 2737 case SVt_PVHV:
b09ed995
DM
2738 if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
2739 hv_clear((HV*)lsv);
8b0c3377
DM
2740 break;
2741
1604cfb0
MS
2742 default:
2743 if (!SvIMMORTAL(lsv)) {
e03e82a0 2744 sv_set_undef(lsv);
8b0c3377
DM
2745 SvSETMAGIC(lsv);
2746 }
282d9dfe 2747 *relem++ = lsv;
1604cfb0 2748 break;
8b0c3377
DM
2749 } /* switch */
2750 } /* while */
2751
c73f612f
DM
2752 TAINT_NOT; /* result of list assign isn't tainted */
2753
5d9574c1 2754 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1604cfb0
MS
2755 /* Will be used to set PL_tainting below */
2756 Uid_t tmp_uid = PerlProc_getuid();
2757 Uid_t tmp_euid = PerlProc_geteuid();
2758 Gid_t tmp_gid = PerlProc_getgid();
2759 Gid_t tmp_egid = PerlProc_getegid();
985213f2 2760
b469f1e0 2761 /* XXX $> et al currently silently ignore failures */
1604cfb0 2762 if (PL_delaymagic & DM_UID) {
a0d0e21e 2763#ifdef HAS_SETRESUID
1604cfb0 2764 PERL_UNUSED_RESULT(
b469f1e0
JH
2765 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2766 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
2767 (Uid_t)-1));
d1a21e44 2768#elif defined(HAS_SETREUID)
b469f1e0
JH
2769 PERL_UNUSED_RESULT(
2770 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2771 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
d1a21e44 2772#else
56febc5e 2773# ifdef HAS_SETRUID
1604cfb0
MS
2774 if ((PL_delaymagic & DM_UID) == DM_RUID) {
2775 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
2776 PL_delaymagic &= ~DM_RUID;
2777 }
56febc5e
AD
2778# endif /* HAS_SETRUID */
2779# ifdef HAS_SETEUID
1604cfb0
MS
2780 if ((PL_delaymagic & DM_UID) == DM_EUID) {
2781 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
2782 PL_delaymagic &= ~DM_EUID;
2783 }
56febc5e 2784# endif /* HAS_SETEUID */
1604cfb0
MS
2785 if (PL_delaymagic & DM_UID) {
2786 if (PL_delaymagic_uid != PL_delaymagic_euid)
2787 DIE(aTHX_ "No setreuid available");
2788 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
2789 }
56febc5e 2790#endif /* HAS_SETRESUID */
04783dc7 2791
1604cfb0
MS
2792 tmp_uid = PerlProc_getuid();
2793 tmp_euid = PerlProc_geteuid();
2794 }
b469f1e0 2795 /* XXX $> et al currently silently ignore failures */
1604cfb0 2796 if (PL_delaymagic & DM_GID) {
a0d0e21e 2797#ifdef HAS_SETRESGID
1604cfb0 2798 PERL_UNUSED_RESULT(
b469f1e0
JH
2799 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2800 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
2801 (Gid_t)-1));
d1a21e44 2802#elif defined(HAS_SETREGID)
1604cfb0 2803 PERL_UNUSED_RESULT(
b469f1e0
JH
2804 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2805 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
d1a21e44 2806#else
56febc5e 2807# ifdef HAS_SETRGID
1604cfb0
MS
2808 if ((PL_delaymagic & DM_GID) == DM_RGID) {
2809 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
2810 PL_delaymagic &= ~DM_RGID;
2811 }
56febc5e
AD
2812# endif /* HAS_SETRGID */
2813# ifdef HAS_SETEGID
1604cfb0
MS
2814 if ((PL_delaymagic & DM_GID) == DM_EGID) {
2815 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
2816 PL_delaymagic &= ~DM_EGID;
2817 }
56febc5e 2818# endif /* HAS_SETEGID */
1604cfb0
MS
2819 if (PL_delaymagic & DM_GID) {
2820 if (PL_delaymagic_gid != PL_delaymagic_egid)
2821 DIE(aTHX_ "No setregid available");
2822 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
2823 }
56febc5e 2824#endif /* HAS_SETRESGID */
04783dc7 2825
1604cfb0
MS
2826 tmp_gid = PerlProc_getgid();
2827 tmp_egid = PerlProc_getegid();
2828 }
2829 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
9a9b5ec9
DM
2830#ifdef NO_TAINT_SUPPORT
2831 PERL_UNUSED_VAR(tmp_uid);
2832 PERL_UNUSED_VAR(tmp_euid);
2833 PERL_UNUSED_VAR(tmp_gid);
2834 PERL_UNUSED_VAR(tmp_egid);
2835#endif
a0d0e21e 2836 }
a68090fe 2837 PL_delaymagic = old_delaymagic;
54310121 2838
54310121 2839 if (gimme == G_VOID)
1604cfb0 2840 SP = firstrelem - 1;
54310121 2841 else if (gimme == G_SCALAR) {
1604cfb0 2842 SP = firstrelem;
b09ed995 2843 EXTEND(SP,1);
7b394f12
DM
2844 if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
2845 SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
2846 else {
2847 dTARGET;
2848 SETi(firstlelem - firstrelem);
2849 }
54310121 2850 }
b09ed995
DM
2851 else
2852 SP = relem - 1;
08aeb9f7 2853
54310121 2854 RETURN;
a0d0e21e
LW
2855}
2856
8782bef2
GB
2857PP(pp_qr)
2858{
20b7effb 2859 dSP;
eb578fdb 2860 PMOP * const pm = cPMOP;
fe578d7f 2861 REGEXP * rx = PM_GETRE(pm);
196a02af
DM
2862 regexp *prog = ReANY(rx);
2863 SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
c4420975 2864 SV * const rv = sv_newmortal();
d63c20f2
DM
2865 CV **cvp;
2866 CV *cv;
288b8c02
NC
2867
2868 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
2869 /* For a subroutine describing itself as "This is a hacky workaround" I'm
2870 loathe to use it here, but it seems to be the right fix. Or close.
2871 The key part appears to be that it's essential for pp_qr to return a new
2872 object (SV), which implies that there needs to be an effective way to
2873 generate a new SV from the existing SV that is pre-compiled in the
2874 optree. */
2875 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
2876 SvROK_on(rv);
2877
8d919b0a 2878 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
5d9574c1 2879 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1604cfb0
MS
2880 *cvp = cv_clone(cv);
2881 SvREFCNT_dec_NN(cv);
d63c20f2
DM
2882 }
2883
288b8c02 2884 if (pkg) {
1604cfb0
MS
2885 HV *const stash = gv_stashsv(pkg, GV_ADD);
2886 SvREFCNT_dec_NN(pkg);
2887 (void)sv_bless(rv, stash);
288b8c02
NC
2888 }
2889
196a02af 2890 if (UNLIKELY(RXp_ISTAINTED(prog))) {
e08e52cf 2891 SvTAINTED_on(rv);
9274aefd
DM
2892 SvTAINTED_on(SvRV(rv));
2893 }
c8c13c22 2894 XPUSHs(rv);
2895 RETURN;
8782bef2
GB
2896}
2897
e0be7821
KW
2898STATIC bool
2899S_are_we_in_Debug_EXECUTE_r(pTHX)
2900{
2901 /* Given a 'use re' is in effect, does it ask for outputting execution
2902 * debug info?
2903 *
2904 * This is separated from the sole place it's called, an inline function,
2905 * because it is the large-ish slow portion of the function */
2906
2907 DECLARE_AND_GET_RE_DEBUG_FLAGS_NON_REGEX;
2908
2909 return cBOOL(RE_DEBUG_FLAG(RE_DEBUG_EXECUTE_MASK));
2910}
2911
2912PERL_STATIC_INLINE bool
2913S_should_we_output_Debug_r(pTHX_ regexp *prog)
2914{
2915 PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R;
2916
2917 /* pp_match can output regex debugging info. This function returns a
2918 * boolean as to whether or not it should.
2919 *
2920 * Under -Dr, it should. Any reasonable compiler will optimize this bit of
2921 * code away on non-debugging builds. */
2922 if (UNLIKELY(DEBUG_r_TEST)) {
2923 return TRUE;
2924 }
2925
2926 /* If the regex engine is using the non-debugging execution routine, then
2927 * no debugging should be output. Same if the field is NULL that pluggable
2928 * engines are not supposed to fill. */
2929 if ( LIKELY(prog->engine->exec == &Perl_regexec_flags)
2930 || UNLIKELY(prog->engine->op_comp == NULL))
2931 {
2932 return FALSE;
2933 }
2934
2935 /* Otherwise have to check */
2936 return S_are_we_in_Debug_EXECUTE_r(aTHX);
2937}
2938
a0d0e21e
LW
2939PP(pp_match)
2940{
20b7effb 2941 dSP; dTARG;
eb578fdb 2942 PMOP *pm = cPMOP;
d65afb4b 2943 PMOP *dynpm = pm;
eb578fdb 2944 const char *s;
5c144d81 2945 const char *strend;
99a90e59 2946 SSize_t curpos = 0; /* initial pos() or current $+[0] */
a0d0e21e 2947 I32 global;
7fadf4a7 2948 U8 r_flags = 0;
5c144d81 2949 const char *truebase; /* Start of string */
eb578fdb 2950 REGEXP *rx = PM_GETRE(pm);
196a02af 2951 regexp *prog = ReANY(rx);
b3eb6a9b 2952 bool rxtainted;
1c23e2bd 2953 const U8 gimme = GIMME_V;
a0d0e21e 2954 STRLEN len;
a3b680e6 2955 const I32 oldsave = PL_savestack_ix;
e60df1fa 2956 I32 had_zerolen = 0;
b1422d62 2957 MAGIC *mg = NULL;
a0d0e21e 2958
533c011a 2959 if (PL_op->op_flags & OPf_STACKED)
1604cfb0 2960 TARG = POPs;
a0d0e21e 2961 else {
9399c607
DM
2962 if (ARGTARG)
2963 GETTARGET;
2964 else {
2965 TARG = DEFSV;
2966 }
1604cfb0 2967 EXTEND(SP,1);
a0d0e21e 2968 }
d9f424b2 2969
c277df42 2970 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
2971 /* Skip get-magic if this is a qr// clone, because regcomp has
2972 already done it. */
196a02af 2973 truebase = prog->mother_re
1604cfb0
MS
2974 ? SvPV_nomg_const(TARG, len)
2975 : SvPV_const(TARG, len);
f1d31338 2976 if (!truebase)
1604cfb0 2977 DIE(aTHX_ "panic: pp_match");
f1d31338 2978 strend = truebase + len;
196a02af 2979 rxtainted = (RXp_ISTAINTED(prog) ||
1604cfb0 2980 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 2981 TAINT_NOT;
a0d0e21e 2982
6c864ec2 2983 /* We need to know this in case we fail out early - pos() must be reset */
de0df3c0
MH
2984 global = dynpm->op_pmflags & PMf_GLOBAL;
2985
d65afb4b 2986 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
2987 if (
2988#ifdef USE_ITHREADS
2989 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
2990#else
2991 pm->op_pmflags & PMf_USED
2992#endif
2993 ) {
e0be7821
KW
2994 if (UNLIKELY(should_we_output_Debug_r(prog))) {
2995 PerlIO_printf(Perl_debug_log, "?? already matched once");
2996 }
1604cfb0 2997 goto nope;
a0d0e21e
LW
2998 }
2999
5585e758 3000 /* handle the empty pattern */
196a02af 3001 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
5585e758
YO
3002 if (PL_curpm == PL_reg_curpm) {
3003 if (PL_curpm_under) {
3004 if (PL_curpm_under == PL_reg_curpm) {
3005 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
3006 } else {
3007 pm = PL_curpm_under;
3008 }
3009 }
3010 } else {
3011 pm = PL_curpm;
3012 }
3013 rx = PM_GETRE(pm);
196a02af 3014 prog = ReANY(rx);
a0d0e21e 3015 }
d65afb4b 3016
196a02af 3017 if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
e0be7821
KW
3018 if (UNLIKELY(should_we_output_Debug_r(prog))) {
3019 PerlIO_printf(Perl_debug_log,
3f5ee3fa 3020 "String shorter than min possible regex match (%zd < %zd)\n",
e0be7821
KW
3021 len, RXp_MINLEN(prog));
3022 }
1604cfb0 3023 goto nope;
e5dc5375 3024 }
c277df42 3025
8ef97b0e 3026 /* get pos() if //g */
de0df3c0 3027 if (global) {
b1422d62 3028 mg = mg_find_mglob(TARG);
8ef97b0e 3029 if (mg && mg->mg_len >= 0) {
25fdce4a 3030 curpos = MgBYTEPOS(mg, TARG, truebase, len);
8ef97b0e
DM
3031 /* last time pos() was set, it was zero-length match */
3032 if (mg->mg_flags & MGf_MINMATCH)
3033 had_zerolen = 1;
3034 }
a0d0e21e 3035 }
8ef97b0e 3036
6e240d0b 3037#ifdef PERL_SAWAMPERSAND
196a02af 3038 if ( RXp_NPARENS(prog)
6502e081 3039 || PL_sawampersand
196a02af 3040 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 3041 || (dynpm->op_pmflags & PMf_KEEPCOPY)
6e240d0b
FC
3042 )
3043#endif
3044 {
1604cfb0 3045 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
6502e081
DM
3046 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
3047 * only on the first iteration. Therefore we need to copy $' as well
3048 * as $&, to make the rest of the string available for captures in
3049 * subsequent iterations */
3050 if (! (global && gimme == G_ARRAY))
3051 r_flags |= REXEC_COPY_SKIP_POST;
3052 };
5b0e71e9
DM
3053#ifdef PERL_SAWAMPERSAND
3054 if (dynpm->op_pmflags & PMf_KEEPCOPY)
3055 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
3056 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
3057#endif
22e551b9 3058
f1d31338
DM
3059 s = truebase;
3060
d7be1480 3061 play_it_again:
985afbc1 3062 if (global)
1604cfb0 3063 s = truebase + curpos;
f722798b 3064
77da2310 3065 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1604cfb0
MS
3066 had_zerolen, TARG, NULL, r_flags))
3067 goto nope;
77da2310
NC
3068
3069 PL_curpm = pm;
985afbc1 3070 if (dynpm->op_pmflags & PMf_ONCE)
c737faaf 3071#ifdef USE_ITHREADS
1604cfb0 3072 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
c737faaf 3073#else
1604cfb0 3074 dynpm->op_pmflags |= PMf_USED;
c737faaf 3075#endif
a0d0e21e 3076
72311751 3077 if (rxtainted)
1604cfb0 3078 RXp_MATCH_TAINTED_on(prog);
196a02af 3079 TAINT_IF(RXp_MATCH_TAINTED(prog));
35c2ccc3
DM
3080
3081 /* update pos */
3082
3083 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
b1422d62 3084 if (!mg)
35c2ccc3 3085 mg = sv_magicext_mglob(TARG);
196a02af
DM
3086 MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
3087 if (RXp_ZERO_LEN(prog))
adf51885
DM
3088 mg->mg_flags |= MGf_MINMATCH;
3089 else
3090 mg->mg_flags &= ~MGf_MINMATCH;
35c2ccc3
DM
3091 }
3092
196a02af 3093 if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
1604cfb0
MS
3094 LEAVE_SCOPE(oldsave);
3095 RETPUSHYES;
bf9dff51
DM
3096 }
3097
88ab22af
DM
3098 /* push captures on stack */
3099
bf9dff51 3100 {
1604cfb0
MS
3101 const I32 nparens = RXp_NPARENS(prog);
3102 I32 i = (global && !nparens) ? 1 : 0;
3103
3104 SPAGAIN; /* EVAL blocks could move the stack. */
3105 EXTEND(SP, nparens + i);
3106 EXTEND_MORTAL(nparens + i);
3107 for (i = !i; i <= nparens; i++) {
3108 PUSHs(sv_newmortal());
3109 if (LIKELY((RXp_OFFS(prog)[i].start != -1)
196a02af 3110 && RXp_OFFS(prog)[i].end != -1 ))
5d9574c1 3111 {
1604cfb0
MS
3112 const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
3113 const char * const s = RXp_OFFS(prog)[i].start + truebase;
3114 if (UNLIKELY( RXp_OFFS(prog)[i].end < 0
196a02af
DM
3115 || RXp_OFFS(prog)[i].start < 0
3116 || len < 0
3117 || len > strend - s)
3118 )
1604cfb0
MS
3119 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
3120 "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
3121 (long) i, (long) RXp_OFFS(prog)[i].start,
3122 (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
3123 sv_setpvn(*SP, s, len);
3124 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
3125 SvUTF8_on(*SP);
3126 }
3127 }
3128 if (global) {
196a02af 3129 curpos = (UV)RXp_OFFS(prog)[0].end;
1604cfb0
MS
3130 had_zerolen = RXp_ZERO_LEN(prog);
3131 PUTBACK; /* EVAL blocks may use stack */
3132 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
3133 goto play_it_again;
3134 }
3135 LEAVE_SCOPE(oldsave);
3136 RETURN;
a0d0e21e 3137 }
e5964223 3138 NOT_REACHED; /* NOTREACHED */
a0d0e21e 3139
7b52d656 3140 nope:
d65afb4b 3141 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
b1422d62
DM
3142 if (!mg)
3143 mg = mg_find_mglob(TARG);
3144 if (mg)
3145 mg->mg_len = -1;
a0d0e21e 3146 }
4633a7c4 3147 LEAVE_SCOPE(oldsave);
a0d0e21e 3148 if (gimme == G_ARRAY)
1604cfb0 3149 RETURN;
a0d0e21e
LW
3150 RETPUSHNO;
3151}
3152
3153OP *
864dbfa3 3154Perl_do_readline(pTHX)
a0d0e21e 3155{
20b7effb 3156 dSP; dTARGETSTACKED;
eb578fdb 3157 SV *sv;
a0d0e21e
LW
3158 STRLEN tmplen = 0;
3159 STRLEN offset;
760ac839 3160 PerlIO *fp;
eb578fdb
KW
3161 IO * const io = GvIO(PL_last_in_gv);
3162 const I32 type = PL_op->op_type;
1c23e2bd 3163 const U8 gimme = GIMME_V;
a0d0e21e 3164
6136c704 3165 if (io) {
1604cfb0
MS
3166 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
3167 if (mg) {
3168 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
3169 if (gimme == G_SCALAR) {
3170 SPAGAIN;
3171 SvSetSV_nosteal(TARG, TOPs);
3172 SETTARG;
3173 }
3174 return NORMAL;
3175 }
e79b0511 3176 }
4608196e 3177 fp = NULL;
a0d0e21e 3178 if (io) {
1604cfb0
MS
3179 fp = IoIFP(io);
3180 if (!fp) {
3181 if (IoFLAGS(io) & IOf_ARGV) {
3182 if (IoFLAGS(io) & IOf_START) {
3183 IoLINES(io) = 0;
3184 if (av_count(GvAVn(PL_last_in_gv)) == 0) {
3185 IoFLAGS(io) &= ~IOf_START;
3186 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
3187 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
3188 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3189 SvSETMAGIC(GvSV(PL_last_in_gv));
3190 fp = IoIFP(io);
3191 goto have_fp;
3192 }
3193 }
3194 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3195 if (!fp) { /* Note: fp != IoIFP(io) */
3196 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
3197 }
3198 }
3199 else if (type == OP_GLOB)
3200 fp = Perl_start_glob(aTHX_ POPs, io);
3201 }
3202 else if (type == OP_GLOB)
3203 SP--;
3204 else if (IoTYPE(io) == IoTYPE_WRONLY) {
3205 report_wrongway_fh(PL_last_in_gv, '>');
3206 }
a0d0e21e
LW
3207 }
3208 if (!fp) {
1604cfb0
MS
3209 if ((!io || !(IoFLAGS(io) & IOf_START))
3210 && ckWARN(WARN_CLOSED)
de7dabb6 3211 && type != OP_GLOB)
1604cfb0
MS
3212 {
3213 report_evil_fh(PL_last_in_gv);
3214 }
3215 if (gimme == G_SCALAR) {
3216 /* undef TARG, and push that undefined value */
3217 if (type != OP_RCATLINE) {
3218 sv_set_undef(TARG);
3219 }
3220 PUSHTARG;
3221 }
3222 RETURN;
a0d0e21e 3223 }
a2008d6d 3224 have_fp:
54310121 3225 if (gimme == G_SCALAR) {
1604cfb0
MS
3226 sv = TARG;
3227 if (type == OP_RCATLINE && SvGMAGICAL(sv))
3228 mg_get(sv);
3229 if (SvROK(sv)) {
3230 if (type == OP_RCATLINE)
3231 SvPV_force_nomg_nolen(sv);
3232 else
3233 sv_unref(sv);
3234 }
3235 else if (isGV_with_GP(sv)) {
3236 SvPV_force_nomg_nolen(sv);
3237 }
3238 SvUPGRADE(sv, SVt_PV);
3239 tmplen = SvLEN(sv); /* remember if already alloced */
3240 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
f72e8700 3241 /* try short-buffering it. Please update t/op/readline.t
1604cfb0
MS
3242 * if you change the growth length.
3243 */
3244 Sv_Grow(sv, 80);
3245 }
3246 offset = 0;
3247 if (type == OP_RCATLINE && SvOK(sv)) {
3248 if (!SvPOK(sv)) {
3249 SvPV_force_nomg_nolen(sv);
3250 }
3251 offset = SvCUR(sv);
3252 }
a0d0e21e 3253 }
54310121 3254 else {
1604cfb0
MS
3255 sv = sv_2mortal(newSV(80));
3256 offset = 0;
54310121 3257 }
fbad3eb5 3258
3887d568
AP
3259 /* This should not be marked tainted if the fp is marked clean */
3260#define MAYBE_TAINT_LINE(io, sv) \
3261 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1604cfb0
MS
3262 TAINT; \
3263 SvTAINTED_on(sv); \
3887d568
AP
3264 }
3265
684bef36 3266/* delay EOF state for a snarfed empty file */
fbad3eb5 3267#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 3268 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 3269 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 3270
a0d0e21e 3271 for (;;) {
1604cfb0
MS
3272 PUTBACK;
3273 if (!sv_gets(sv, fp, offset)
3274 && (type == OP_GLOB
3275 || SNARF_EOF(gimme, PL_rs, io, sv)
3276 || PerlIO_error(fp)))
3277 {
3278 PerlIO_clearerr(fp);
3279 if (IoFLAGS(io) & IOf_ARGV) {
3280 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3281 if (fp)
3282 continue;
3283 (void)do_close(PL_last_in_gv, FALSE);
3284 }
3285 else if (type == OP_GLOB) {
3286 if (!do_close(PL_last_in_gv, FALSE)) {
3287 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
3288 "glob failed (child exited with status %d%s)",
3289 (int)(STATUS_CURRENT >> 8),
3290 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
3291 }
3292 }
3293 if (gimme == G_SCALAR) {
3294 if (type != OP_RCATLINE) {
3295 SV_CHECK_THINKFIRST_COW_DROP(TARG);
3296 SvOK_off(TARG);
3297 }
3298 SPAGAIN;
3299 PUSHTARG;
3300 }
3301 MAYBE_TAINT_LINE(io, sv);
3302 RETURN;
3303 }
3304 MAYBE_TAINT_LINE(io, sv);
3305 IoLINES(io)++;
3306 IoFLAGS(io) |= IOf_NOLINE;
3307 SvSETMAGIC(sv);
3308 SPAGAIN;
3309 XPUSHs(sv);
3310 if (type == OP_GLOB) {
3311 const char *t1;
3312 Stat_t statbuf;
3313
3314 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
3315 char * const tmps = SvEND(sv) - 1;
3316 if (*tmps == *SvPVX_const(PL_rs)) {
3317 *tmps = '\0';
3318 SvCUR_set(sv, SvCUR(sv) - 1);
3319 }
3320 }
3321 for (t1 = SvPVX_const(sv); *t1; t1++)
b51c3e77 3322#ifdef __VMS
1604cfb0 3323 if (memCHRs("*%?", *t1))
b51c3e77 3324#else
1604cfb0 3325 if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1))
b51c3e77 3326#endif
1604cfb0
MS
3327 break;
3328 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
3329 (void)POPs; /* Unmatched wildcard? Chuck it... */
3330 continue;
3331 }
3332 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
3333 if (ckWARN(WARN_UTF8)) {
3334 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
3335 const STRLEN len = SvCUR(sv) - offset;
3336 const U8 *f;
3337
3338 if (!is_utf8_string_loc(s, len, &f))
3339 /* Emulate :encoding(utf8) warning in the same case. */
3340 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3341 "utf8 \"\\x%02X\" does not map to Unicode",
3342 f < (U8*)SvEND(sv) ? *f : 0);
3343 }
3344 }
3345 if (gimme == G_ARRAY) {
3346 if (SvLEN(sv) - SvCUR(sv) > 20) {
3347 SvPV_shrink_to_cur(sv);
3348 }
3349 sv = sv_2mortal(newSV(80));
3350 continue;
3351 }
3352 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
3353 /* try to reclaim a bit of scalar space (only on 1st alloc) */
3354 const STRLEN new_len
3355 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
3356 SvPV_renew(sv, new_len);
3357 }
3358 RETURN;
a0d0e21e
LW
3359 }
3360}
3361
a0d0e21e
LW
3362PP(pp_helem)
3363{
20b7effb 3364 dSP;
760ac839 3365 HE* he;
ae77835f 3366 SV **svp;
c445ea15 3367 SV * const keysv = POPs;
85fbaab2 3368 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
3369 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3370 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 3371 SV *sv;
92970b93 3372 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 3373 bool preeminent = TRUE;
a0d0e21e 3374
6dfc73ea 3375 if (SvTYPE(hv) != SVt_PVHV)
1604cfb0 3376 RETPUSHUNDEF;
d4c19fe8 3377
92970b93 3378 if (localizing) {
1604cfb0
MS
3379 MAGIC *mg;
3380 HV *stash;
d30e492c 3381
1604cfb0
MS
3382 /* If we can determine whether the element exist,
3383 * Try to preserve the existenceness of a tied hash
3384 * element by using EXISTS and DELETE if possible.
3385 * Fallback to FETCH and STORE otherwise. */
3386 if (SvCANEXISTDELETE(hv))
3387 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 3388 }
d30e492c 3389
5f9d7e2b 3390 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
d4c19fe8 3391 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 3392 if (lval) {
1604cfb0
MS
3393 if (!svp || !*svp || *svp == &PL_sv_undef) {
3394 SV* lv;
3395 SV* key2;
3396 if (!defer) {
3397 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3398 }
3399 lv = sv_newmortal();
3400 sv_upgrade(lv, SVt_PVLV);
3401 LvTYPE(lv) = 'y';
3402 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
3403 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
3404 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3405 LvTARGLEN(lv) = 1;
3406 PUSHs(lv);
3407 RETURN;
3408 }
3409 if (localizing) {
3410 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
3411 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
3412 else if (preeminent)
3413 save_helem_flags(hv, keysv, svp,
3414 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
3415 else
3416 SAVEHDELETE(hv, keysv);
3417 }
3418 else if (PL_op->op_private & OPpDEREF) {
3419 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3420 RETURN;
3421 }
a0d0e21e 3422 }
746f6409 3423 sv = (svp && *svp ? *svp : &PL_sv_undef);
fd69380d
DM
3424 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
3425 * was to make C<local $tied{foo} = $tied{foo}> possible.
3426 * However, it seems no longer to be needed for that purpose, and
3427 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
3428 * would loop endlessly since the pos magic is getting set on the
3429 * mortal copy and lost. However, the copy has the effect of
3430 * triggering the get magic, and losing it altogether made things like
3431 * c<$tied{foo};> in void context no longer do get magic, which some
3432 * code relied on. Also, delayed triggering of magic on @+ and friends
3433 * meant the original regex may be out of scope by now. So as a
3434 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
3435 * being called too many times). */
39cf747a 3436 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1604cfb0 3437 mg_get(sv);
be6c24e0 3438 PUSHs(sv);
a0d0e21e
LW
3439 RETURN;
3440}
3441
fedf30e1
DM
3442
3443/* a stripped-down version of Perl_softref2xv() for use by
3444 * pp_multideref(), which doesn't use PL_op->op_flags */
3445
f9db5646 3446STATIC GV *
fedf30e1 3447S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
1604cfb0 3448 const svtype type)
fedf30e1
DM
3449{
3450 if (PL_op->op_private & HINT_STRICT_REFS) {
1604cfb0
MS
3451 if (SvOK(sv))
3452 Perl_die(aTHX_ PL_no_symref_sv, sv,
3453 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
3454 else
3455 Perl_die(aTHX_ PL_no_usym, what);
fedf30e1
DM
3456 }
3457 if (!SvOK(sv))
3458 Perl_die(aTHX_ PL_no_usym, what);
3459 return gv_fetchsv_nomg(sv, GV_ADD, type);
3460}
3461
3462
79815f56
DM
3463/* Handle one or more aggregate derefs and array/hash indexings, e.g.
3464 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
fedf30e1
DM
3465 *
3466 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
79815f56
DM
3467 * Each of these either contains a set of actions, or an argument, such as
3468 * an IV to use as an array index, or a lexical var to retrieve.
3469 * Several actions re stored per UV; we keep shifting new actions off the
3470 * one UV, and only reload when it becomes zero.
fedf30e1
DM
3471 */
3472
3473PP(pp_multideref)
3474{
3475 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
3476 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
3477 UV actions = items->uv;
3478
3479 assert(actions);
3480 /* this tells find_uninit_var() where we're up to */
3481 PL_multideref_pc = items;
3482
3483 while (1) {
3484 /* there are three main classes of action; the first retrieve
3485 * the initial AV or HV from a variable or the stack; the second
3486 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
3487 * the third an unrolled (/DREFHV, rv2hv, helem).
3488 */
3489 switch (actions & MDEREF_ACTION_MASK) {
3490
3491 case MDEREF_reload:
3492 actions = (++items)->uv;
3493 continue;
3494
3495 case MDEREF_AV_padav_aelem: /* $lex[...] */
3496 sv = PAD_SVl((++items)->pad_offset);
3497 goto do_AV_aelem;
3498
3499 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
3500 sv = UNOP_AUX_item_sv(++items);
3501 assert(isGV_with_GP(sv));
3502 sv = (SV*)GvAVn((GV*)sv);
3503 goto do_AV_aelem;
3504
3505 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
3506 {
3507 dSP;
3508 sv = POPs;
3509 PUTBACK;
3510 goto do_AV_rv2av_aelem;
3511 }
3512
3513 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
3514 sv = UNOP_AUX_item_sv(++items);
3515 assert(isGV_with_GP(sv));
3516 sv = GvSVn((GV*)sv);
3517 goto do_AV_vivify_rv2av_aelem;
3518
3519 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
3520 sv = PAD_SVl((++items)->pad_offset);
3521 /* FALLTHROUGH */
3522
3523 do_AV_vivify_rv2av_aelem:
3524 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
3525 /* this is the OPpDEREF action normally found at the end of
3526 * ops like aelem, helem, rv2sv */
3527 sv = vivify_ref(sv, OPpDEREF_AV);
3528 /* FALLTHROUGH */
3529
3530 do_AV_rv2av_aelem:
3531 /* this is basically a copy of pp_rv2av when it just has the
3532 * sKR/1 flags */
3533 SvGETMAGIC(sv);
3534 if (LIKELY(SvROK(sv))) {
3535 if (UNLIKELY(SvAMAGIC(sv))) {
3536 sv = amagic_deref_call(sv, to_av_amg);
3537 }
3538 sv = SvRV(sv);
3539 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
3540 DIE(aTHX_ "Not an ARRAY reference");
3541 }
3542 else if (SvTYPE(sv) != SVt_PVAV) {
3543 if (!isGV_with_GP(sv))
3544 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
3545 sv = MUTABLE_SV(GvAVn((GV*)sv));
3546 }
3547 /* FALLTHROUGH */
3548
3549 do_AV_aelem:
3550 {
3551 /* retrieve the key; this may be either a lexical or package
3552 * var (whose index/ptr is stored as an item) or a signed
3553 * integer constant stored as an item.
3554 */
3555 SV *elemsv;
3556 IV elem = 0; /* to shut up stupid compiler warnings */
3557
3558
3559 assert(SvTYPE(sv) == SVt_PVAV);
3560
3561 switch (actions & MDEREF_INDEX_MASK) {
3562 case MDEREF_INDEX_none:
3563 goto finish;
3564 case MDEREF_INDEX_const:
3565 elem = (++items)->iv;
3566 break;
3567 case MDEREF_INDEX_padsv:
3568 elemsv = PAD_SVl((++items)->pad_offset);
3569 goto check_elem;
3570 case MDEREF_INDEX_gvsv:
3571 elemsv = UNOP_AUX_item_sv(++items);
3572 assert(isGV_with_GP(elemsv));
3573 elemsv = GvSVn((GV*)elemsv);
3574 check_elem:
3575 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
3576 && ckWARN(WARN_MISC)))
3577 Perl_warner(aTHX_ packWARN(WARN_MISC),
147e3846 3578 "Use of reference \"%" SVf "\" as array index",
fedf30e1
DM
3579 SVfARG(elemsv));
3580 /* the only time that S_find_uninit_var() needs this
3581 * is to determine which index value triggered the
3582 * undef warning. So just update it here. Note that
3583 * since we don't save and restore this var (e.g. for
3584 * tie or overload execution), its value will be
3585 * meaningless apart from just here */
3586 PL_multideref_pc = items;
3587 elem = SvIV(elemsv);
3588 break;
3589 }
3590
3591
3592 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
3593
3594 if (!(actions & MDEREF_FLAG_last)) {
3595 SV** svp = av_fetch((AV*)sv, elem, 1);
3596 if (!svp || ! (sv=*svp))
3597 DIE(aTHX_ PL_no_aelem, elem);
3598 break;
3599 }
3600
3601 if (PL_op->op_private &
3602 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3603 {
3604 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3605 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
3606 }
3607 else {
3608 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3609 sv = av_delete((AV*)sv, elem, discard);
3610 if (discard)
3611 return NORMAL;
3612 if (!sv)
3613 sv = &PL_sv_undef;
3614 }
3615 }
3616 else {
3617 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3618 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3619 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3620 bool preeminent = TRUE;
3621 AV *const av = (AV*)sv;
3622 SV** svp;
3623
3624 if (UNLIKELY(localizing)) {
3625 MAGIC *mg;
3626 HV *stash;
3627
3628 /* If we can determine whether the element exist,
3629 * Try to preserve the existenceness of a tied array
3630 * element by using EXISTS and DELETE if possible.
3631 * Fallback to FETCH and STORE otherwise. */
3632 if (SvCANEXISTDELETE(av))
3633 preeminent = av_exists(av, elem);
3634 }
3635
3636 svp = av_fetch(av, elem, lval && !defer);
3637
3638 if (lval) {
3639 if (!svp || !(sv = *svp)) {
3640 IV len;
3641 if (!defer)
3642 DIE(aTHX_ PL_no_aelem, elem);
8272d5bd 3643 len = av_top_index(av);
9ef753fe
FC
3644 /* Resolve a negative index that falls within
3645 * the array. Leave it negative it if falls
3646 * outside the array. */
3647 if (elem < 0 && len + elem >= 0)
3648 elem = len + elem;
3649 if (elem >= 0 && elem <= len)
3650 /* Falls within the array. */
3651 sv = av_nonelem(av,elem);
3652 else
3653 /* Falls outside the array. If it is neg-
3654 ative, magic_setdefelem will use the
3655 index for error reporting. */
3656 sv = sv_2mortal(newSVavdefelem(av,elem,1));
fedf30e1
DM
3657 }
3658 else {
3659 if (UNLIKELY(localizing)) {
3660 if (preeminent) {
3661 save_aelem(av, elem, svp);
3662 sv = *svp; /* may have changed */
3663 }
3664 else
3665 SAVEADELETE(av, elem);
3666 }
3667 }
3668 }
3669 else {
3670 sv = (svp ? *svp : &PL_sv_undef);
3671 /* see note in pp_helem() */
3672 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
3673 mg_get(sv);
3674 }
3675 }
3676
3677 }
3678 finish:
3679 {
3680 dSP;
3681 XPUSHs(sv);
3682 RETURN;
3683 }
3684 /* NOTREACHED */
3685
3686
3687
3688
3689 case MDEREF_HV_padhv_helem: /* $lex{...} */
3690 sv = PAD_SVl((++items)->pad_offset);
3691 goto do_HV_helem;
3692
3693 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
3694 sv = UNOP_AUX_item_sv(++items);
3695 assert(isGV_with_GP(sv));
3696 sv = (SV*)GvHVn((GV*)sv);
3697 goto do_HV_helem;
3698
3699 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
3700 {
3701 dSP;
3702 sv = POPs;
3703 PUTBACK;
3704 goto do_HV_rv2hv_helem;
3705 }
3706
3707 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
3708 sv = UNOP_AUX_item_sv(++items);
3709 assert(isGV_with_GP(sv));
3710 sv = GvSVn((GV*)sv);
3711 goto do_HV_vivify_rv2hv_helem;
3712
3713 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
3714 sv = PAD_SVl((++items)->pad_offset);
3715 /* FALLTHROUGH */
3716
3717 do_HV_vivify_rv2hv_helem:
3718 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
3719 /* this is the OPpDEREF action normally found at the end of
3720 * ops like aelem, helem, rv2sv */
3721 sv = vivify_ref(sv, OPpDEREF_HV);
3722 /* FALLTHROUGH */
3723
3724 do_HV_rv2hv_helem:
3725 /* this is basically a copy of pp_rv2hv when it just has the
3726 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
3727
3728 SvGETMAGIC(sv);
3729 if (LIKELY(SvROK(sv))) {
3730 if (UNLIKELY(SvAMAGIC(sv))) {
3731 sv = amagic_deref_call(sv, to_hv_amg);
3732 }
3733 sv = SvRV(sv);
3734 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
3735 DIE(aTHX_ "Not a HASH reference");
3736 }
3737 else if (SvTYPE(sv) != SVt_PVHV) {
3738 if (!isGV_with_GP(sv))
3739 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
3740 sv = MUTABLE_SV(GvHVn((GV*)sv));
3741 }
3742 /* FALLTHROUGH */
3743
3744 do_HV_helem:
3745 {
3746 /* retrieve the key; this may be either a lexical / package
3747 * var or a string constant, whose index/ptr is stored as an
3748 * item
3749 */
3750 SV *keysv = NULL; /* to shut up stupid compiler warnings */
3751
3752 assert(SvTYPE(sv) == SVt_PVHV);
3753
3754 switch (actions & MDEREF_INDEX_MASK) {
3755 case MDEREF_INDEX_none:
3756 goto finish;
3757
3758 case MDEREF_INDEX_const:
3759 keysv = UNOP_AUX_item_sv(++items);
3760 break;
3761
3762 case MDEREF_INDEX_padsv:
3763 keysv = PAD_SVl((++items)->pad_offset);
3764 break;
3765
3766 case MDEREF_INDEX_gvsv:
3767 keysv = UNOP_AUX_item_sv(++items);
3768 keysv = GvSVn((GV*)keysv);
3769 break;
3770 }
3771
3772 /* see comment above about setting this var */
3773 PL_multideref_pc = items;
3774
3775
3776 /* ensure that candidate CONSTs have been HEKified */
3777 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
3778 || SvTYPE(keysv) >= SVt_PVMG
3779 || !SvOK(keysv)
3780 || SvROK(keysv)
3781 || SvIsCOW_shared_hash(keysv));
3782
3783 /* this is basically a copy of pp_helem with OPpDEREF skipped */
3784
3785 if (!(actions & MDEREF_FLAG_last)) {
3786 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
3787 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
3788 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3789 break;
3790 }
3791
3792 if (PL_op->op_private &
3793 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3794 {
3795 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3796 sv = hv_exists_ent((HV*)sv, keysv, 0)
3797 ? &PL_sv_yes : &PL_sv_no;
3798 }
3799 else {
3800 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3801 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
3802 if (discard)
3803 return NORMAL;
3804 if (!sv)
3805 sv = &PL_sv_undef;
3806 }
3807 }
3808 else {
3809 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3810 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3811 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3812 bool preeminent = TRUE;
3813 SV **svp;
3814 HV * const hv = (HV*)sv;
3815 HE* he;
3816
3817 if (UNLIKELY(localizing)) {
3818 MAGIC *mg;
3819 HV *stash;
3820
3821 /* If we can determine whether the element exist,
3822 * Try to preserve the existenceness of a tied hash
3823 * element by using EXISTS and DELETE if possible.
3824 * Fallback to FETCH and STORE otherwise. */
3825 if (SvCANEXISTDELETE(hv))
3826 preeminent = hv_exists_ent(hv, keysv, 0);
3827 }
3828
3829 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3830 svp = he ? &HeVAL(he) : NULL;
3831
3832
3833 if (lval) {
3834 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
3835 SV* lv;
3836 SV* key2;
3837 if (!defer)
3838 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3839 lv = sv_newmortal();
3840 sv_upgrade(lv, SVt_PVLV);
3841 LvTYPE(lv) = 'y';
3842 sv_magic(lv, key2 = newSVsv(keysv),
3843 PERL_MAGIC_defelem, NULL, 0);
3844 /* sv_magic() increments refcount */
3845 SvREFCNT_dec_NN(key2);
0ad694a7 3846 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
fedf30e1
DM
3847 LvTARGLEN(lv) = 1;
3848 sv = lv;
3849 }
3850 else {
3851 if (localizing) {
a35c9018 3852 if (HvNAME_get(hv) && isGV_or_RVCV(sv))
fedf30e1
DM
3853 save_gp(MUTABLE_GV(sv),
3854 !(PL_op->op_flags & OPf_SPECIAL));
3855 else if (preeminent) {
3856 save_helem_flags(hv, keysv, svp,
3857 (PL_op->op_flags & OPf_SPECIAL)
3858 ? 0 : SAVEf_SETMAGIC);
3859 sv = *svp; /* may have changed */
3860 }
3861 else
3862 SAVEHDELETE(hv, keysv);
3863 }
3864 }
3865 }
3866 else {
3867 sv = (svp && *svp ? *svp : &PL_sv_undef);
3868 /* see note in pp_helem() */
3869 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
3870 mg_get(sv);
3871 }
3872 }
3873 goto finish;
3874 }
3875
3876 } /* switch */
3877
3878 actions >>= MDEREF_SHIFT;
3879 } /* while */
3880 /* NOTREACHED */
3881}
3882
3883
a0d0e21e
LW
3884PP(pp_iter)
3885{
eb578fdb 3886 PERL_CONTEXT *cx;
7d6c2cef 3887 SV *oldsv;