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