This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_try_amagic_un/bin re-indent
[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
55b62dee
DM
364 OPpMULTICONCAT_STRINGIFY: the RHS was of the form
365 "...$a...$b..." rather than
e839e6ed
DM
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;
55b62dee 951 Size_t arg_count = 0; /* how many args have been processed */
af390142
DM
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;
55b62dee
DM
967 for (i = 0; i <= n; i++) {
968 SSize_t len;
969
970 /* if necessary, stringify the final RHS result in
971 * something like $targ .= "$a$b$c" - simulating
972 * pp_stringify
973 */
974 if ( i == n
975 && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY)
976 && !(SvPOK(left))
977 /* extra conditions for backwards compatibility:
978 * probably incorrect, but keep the existing behaviour
979 * for now. The rules are:
980 * $x = "$ov" single arg: stringify;
981 * $x = "$ov$y" multiple args: don't stringify,
982 * $lex = "$ov$y$z" except TARGMY with at least 2 concats
983 */
984 && ( arg_count == 1
985 || ( arg_count >= 3
986 && !is_append
987 && (PL_op->op_private & OPpTARGET_MY)
988 && !(PL_op->op_private & OPpLVAL_INTRO)
989 )
990 )
991 )
992 {
993 SV *tmp = sv_newmortal();
994 sv_copypv(tmp, left);
995 SvSETMAGIC(tmp);
996 left = tmp;
997 }
998
999 /* do one extra iteration to handle $targ in $targ .= ... */
1000 if (i == n && !is_append)
1001 break;
1002
af390142 1003 /* get the next arg SV or regen the next const SV */
55b62dee 1004 len = lens[i >> 1].ssize;
af390142
DM
1005 if (i == n) {
1006 /* handle the final targ .= (....) */
1007 right = left;
1008 left = targ;
1009 }
1010 else if (i & 1)
1011 right = svp[(i >> 1)];
1012 else if (len < 0)
1013 continue; /* no const in this position */
1014 else {
1015 right = newSVpvn_flags(cpv, len, (utf8 | SVs_TEMP));
1016 cpv += len;
1017 }
e839e6ed 1018
55b62dee
DM
1019 arg_count++;
1020
1021 if (arg_count <= 1) {
af390142
DM
1022 left = right;
1023 continue; /* need at least two SVs to concat together */
1024 }
1025
55b62dee 1026 if (arg_count == 2 && i < n) {
af390142
DM
1027 /* for the first concat, create a mortal acting like the
1028 * padtmp from OP_CONST. In later iterations this will
1029 * be appended to */
1030 nexttarg = sv_newmortal();
1031 nextappend = FALSE;
af390142
DM
1032 }
1033 else {
1034 nexttarg = left;
1035 nextappend = TRUE;
1036 }
1037
1038 /* Handle possible overloading.
1039 * This is basically an unrolled
1040 * tryAMAGICbin_MG(concat_amg, AMGf_assign);
1041 * and
1042 * Perl_try_amagic_bin()
1043 * call, but using left and right rather than SP[-1], SP[0],
1044 * and not relying on OPf_STACKED implying .=
e839e6ed 1045 */
e839e6ed 1046
af390142
DM
1047 if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) {
1048 SvGETMAGIC(left);
1049 if (left != right)
1050 SvGETMAGIC(right);
1051
1052 if ((SvAMAGIC(left) || SvAMAGIC(right))
1053 /* sprintf doesn't do concat overloading,
1054 * but allow for $x .= sprintf(...)
1055 */
1056 && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE)
1057 || i == n)
e839e6ed 1058 )
af390142
DM
1059 {
1060 SV * const tmpsv = amagic_call(left, right, concat_amg,
1061 (nextappend ? AMGf_assign: 0));
1062 if (tmpsv) {
7554d344
DM
1063 /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test
1064 * here, which isn't needed as any implicit
1065 * assign done under OPpTARGET_MY is done after
af390142
DM
1066 * this loop */
1067 if (nextappend) {
1068 sv_setsv(left, tmpsv);
1069 SvSETMAGIC(left);
e839e6ed 1070 }
af390142
DM
1071 else
1072 left = tmpsv;
1073 continue;
1074 }
1075 }
1076
1077 /* if both args are the same magical value, make one a copy */
1078 if (left == right && SvGMAGICAL(left)) {
1079 left = sv_newmortal();
1080 /* Print the uninitialized warning now, so it includes the
1081 * variable name. */
1082 if (!SvOK(right)) {
1083 if (ckWARN(WARN_UNINITIALIZED))
1084 report_uninit(right);
1085 sv_setsv_flags(left, &PL_sv_no, 0);
e839e6ed 1086 }
af390142
DM
1087 else
1088 sv_setsv_flags(left, right, 0);
1089 SvGETMAGIC(right);
e839e6ed
DM
1090 }
1091 }
e839e6ed 1092
af390142
DM
1093 /* nexttarg = left . right */
1094 S_do_concat(aTHX_ left, right, nexttarg, 0);
1095 left = nexttarg;
e839e6ed 1096 }
e839e6ed 1097
af390142 1098 SP = toparg - stack_adj + 1;
e839e6ed 1099
af390142
DM
1100 /* Assign result of all RHS concats (left) to LHS (targ).
1101 * If we are appending, targ will already have been appended to in
1102 * the loop */
1103 if (is_append)
1104 SvTAINT(targ);
1105 else {
1106 sv_setsv(targ, left);
1107 SvSETMAGIC(targ);
1108 }
1109 SETs(targ);
1110 RETURN;
1111 }
e839e6ed
DM
1112}
1113
1114
0b5aba47
DM
1115/* push the elements of av onto the stack.
1116 * Returns PL_op->op_next to allow tail-call optimisation of its callers */
d5524600 1117
0b5aba47 1118STATIC OP*
d5524600
DM
1119S_pushav(pTHX_ AV* const av)
1120{
1121 dSP;
c70927a6 1122 const SSize_t maxarg = AvFILL(av) + 1;
d5524600 1123 EXTEND(SP, maxarg);
5d9574c1 1124 if (UNLIKELY(SvRMAGICAL(av))) {
c70927a6
FC
1125 PADOFFSET i;
1126 for (i=0; i < (PADOFFSET)maxarg; i++) {
fd77b29b
FC
1127 SV ** const svp = av_fetch(av, i, FALSE);
1128 SP[i+1] = LIKELY(svp)
1129 ? *svp
1130 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1f1dcfb5 1131 ? av_nonelem(av,i)
fd77b29b 1132 : &PL_sv_undef;
d5524600
DM
1133 }
1134 }
1135 else {
c70927a6
FC
1136 PADOFFSET i;
1137 for (i=0; i < (PADOFFSET)maxarg; i++) {
6661956a 1138 SV *sv = AvARRAY(av)[i];
fd77b29b
FC
1139 SP[i+1] = LIKELY(sv)
1140 ? sv
1141 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1f1dcfb5 1142 ? av_nonelem(av,i)
fd77b29b 1143 : &PL_sv_undef;
ce0d59fd 1144 }
d5524600
DM
1145 }
1146 SP += maxarg;
1147 PUTBACK;
0b5aba47 1148 return NORMAL;
d5524600
DM
1149}
1150
1151
a7fd8ef6
DM
1152/* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
1153
1154PP(pp_padrange)
1155{
20b7effb 1156 dSP;
a7fd8ef6
DM
1157 PADOFFSET base = PL_op->op_targ;
1158 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
d5524600
DM
1159 if (PL_op->op_flags & OPf_SPECIAL) {
1160 /* fake the RHS of my ($x,$y,..) = @_ */
1161 PUSHMARK(SP);
0b5aba47 1162 (void)S_pushav(aTHX_ GvAVn(PL_defgv));
d5524600
DM
1163 SPAGAIN;
1164 }
1165
a7fd8ef6
DM
1166 /* note, this is only skipped for compile-time-known void cxt */
1167 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
19742f39
AL
1168 int i;
1169
a7fd8ef6
DM
1170 EXTEND(SP, count);
1171 PUSHMARK(SP);
1172 for (i = 0; i <count; i++)
1173 *++SP = PAD_SV(base+i);
1174 }
1175 if (PL_op->op_private & OPpLVAL_INTRO) {
4e09461c
DM
1176 SV **svp = &(PAD_SVl(base));
1177 const UV payload = (UV)(
1178 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
1179 | (count << SAVE_TIGHT_SHIFT)
1180 | SAVEt_CLEARPADRANGE);
19742f39
AL
1181 int i;
1182
6d59e610 1183 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
d081a355
DM
1184 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
1185 == (Size_t)base);
a3444cc5
DM
1186 {
1187 dSS_ADD;
1188 SS_ADD_UV(payload);
1189 SS_ADD_END(1);
1190 }
4e09461c 1191
a7fd8ef6 1192 for (i = 0; i <count; i++)
4e09461c 1193 SvPADSTALE_off(*svp++); /* mark lexical as active */
a7fd8ef6
DM
1194 }
1195 RETURN;
1196}
1197
1198
a0d0e21e
LW
1199PP(pp_padsv)
1200{
20b7effb 1201 dSP;
6c28b496
DD
1202 EXTEND(SP, 1);
1203 {
1204 OP * const op = PL_op;
1205 /* access PL_curpad once */
1206 SV ** const padentry = &(PAD_SVl(op->op_targ));
1207 {
1208 dTARG;
1209 TARG = *padentry;
1210 PUSHs(TARG);
1211 PUTBACK; /* no pop/push after this, TOPs ok */
8ec5e241 1212 }
6c28b496
DD
1213 if (op->op_flags & OPf_MOD) {
1214 if (op->op_private & OPpLVAL_INTRO)
1215 if (!(op->op_private & OPpPAD_STATE))
1216 save_clearsv(padentry);
1217 if (op->op_private & OPpDEREF) {
8f90a16d
FC
1218 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
1219 than TARG reduces the scope of TARG, so it does not
1220 span the call to save_clearsv, resulting in smaller
1221 machine code. */
6c28b496
DD
1222 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
1223 }
1224 }
1225 return op->op_next;
4633a7c4 1226 }
a0d0e21e
LW
1227}
1228
1229PP(pp_readline)
1230{
30901a8a 1231 dSP;
12dc5f94
DM
1232 /* pp_coreargs pushes a NULL to indicate no args passed to
1233 * CORE::readline() */
30901a8a
FC
1234 if (TOPs) {
1235 SvGETMAGIC(TOPs);
fc99edcf 1236 tryAMAGICunTARGETlist(iter_amg, 0);
30901a8a
FC
1237 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1238 }
1239 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
6e592b3a
BM
1240 if (!isGV_with_GP(PL_last_in_gv)) {
1241 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
159b6efe 1242 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
8efb3254 1243 else {
f5284f61 1244 dSP;
ad64d0ec 1245 XPUSHs(MUTABLE_SV(PL_last_in_gv));
f5284f61 1246 PUTBACK;
897d3989 1247 Perl_pp_rv2gv(aTHX);
159b6efe 1248 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
745e740c 1249 assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
f5284f61
IZ
1250 }
1251 }
a0d0e21e
LW
1252 return do_readline();
1253}
1254
1255PP(pp_eq)
1256{
20b7effb 1257 dSP;
33efebe6
DM
1258 SV *left, *right;
1259
0872de45 1260 tryAMAGICbin_MG(eq_amg, AMGf_numeric);
33efebe6
DM
1261 right = POPs;
1262 left = TOPs;
1263 SETs(boolSV(
1264 (SvIOK_notUV(left) && SvIOK_notUV(right))
1265 ? (SvIVX(left) == SvIVX(right))
1266 : ( do_ncmp(left, right) == 0)
1267 ));
1268 RETURN;
a0d0e21e
LW
1269}
1270
b1c05ba5 1271
4c2c3128 1272/* also used for: pp_i_preinc() */
b1c05ba5 1273
a0d0e21e
LW
1274PP(pp_preinc)
1275{
4c2c3128
DM
1276 SV *sv = *PL_stack_sp;
1277
1278 if (LIKELY(((sv->sv_flags &
1279 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1280 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1281 == SVf_IOK))
1282 && SvIVX(sv) != IV_MAX)
1283 {
1284 SvIV_set(sv, SvIVX(sv) + 1);
1285 }
1286 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
1287 sv_inc(sv);
1288 SvSETMAGIC(sv);
1289 return NORMAL;
1290}
1291
1292
1293/* also used for: pp_i_predec() */
1294
1295PP(pp_predec)
1296{
1297 SV *sv = *PL_stack_sp;
1298
1299 if (LIKELY(((sv->sv_flags &
1300 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1301 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1302 == SVf_IOK))
1303 && SvIVX(sv) != IV_MIN)
55497cff 1304 {
4c2c3128 1305 SvIV_set(sv, SvIVX(sv) - 1);
748a9306 1306 }
4c2c3128
DM
1307 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */
1308 sv_dec(sv);
1309 SvSETMAGIC(sv);
a0d0e21e
LW
1310 return NORMAL;
1311}
1312
b1c05ba5
DM
1313
1314/* also used for: pp_orassign() */
1315
a0d0e21e
LW
1316PP(pp_or)
1317{
20b7effb 1318 dSP;
f4c975aa 1319 SV *sv;
f410a211 1320 PERL_ASYNC_CHECK();
f4c975aa
DM
1321 sv = TOPs;
1322 if (SvTRUE_NN(sv))
a0d0e21e
LW
1323 RETURN;
1324 else {
c960fc3b
SP
1325 if (PL_op->op_type == OP_OR)
1326 --SP;
a0d0e21e
LW
1327 RETURNOP(cLOGOP->op_other);
1328 }
1329}
1330
b1c05ba5
DM
1331
1332/* also used for: pp_dor() pp_dorassign() */
1333
25a55bd7 1334PP(pp_defined)
c963b151 1335{
20b7effb 1336 dSP;
eb578fdb 1337 SV* sv;
6136c704 1338 bool defined;
25a55bd7 1339 const int op_type = PL_op->op_type;
ea5195b7 1340 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
c963b151 1341
6136c704 1342 if (is_dor) {
f410a211 1343 PERL_ASYNC_CHECK();
25a55bd7 1344 sv = TOPs;
5d9574c1 1345 if (UNLIKELY(!sv || !SvANY(sv))) {
2bd49cfc
NC
1346 if (op_type == OP_DOR)
1347 --SP;
25a55bd7
SP
1348 RETURNOP(cLOGOP->op_other);
1349 }
b7c44293
RGS
1350 }
1351 else {
1352 /* OP_DEFINED */
25a55bd7 1353 sv = POPs;
5d9574c1 1354 if (UNLIKELY(!sv || !SvANY(sv)))
25a55bd7 1355 RETPUSHNO;
b7c44293 1356 }
25a55bd7 1357
6136c704 1358 defined = FALSE;
c963b151
BD
1359 switch (SvTYPE(sv)) {
1360 case SVt_PVAV:
1361 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 1362 defined = TRUE;
c963b151
BD
1363 break;
1364 case SVt_PVHV:
1365 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 1366 defined = TRUE;
c963b151
BD
1367 break;
1368 case SVt_PVCV:
1369 if (CvROOT(sv) || CvXSUB(sv))
25a55bd7 1370 defined = TRUE;
c963b151
BD
1371 break;
1372 default:
5b295bef 1373 SvGETMAGIC(sv);
c963b151 1374 if (SvOK(sv))
25a55bd7 1375 defined = TRUE;
6136c704 1376 break;
c963b151 1377 }
6136c704
AL
1378
1379 if (is_dor) {
c960fc3b
SP
1380 if(defined)
1381 RETURN;
1382 if(op_type == OP_DOR)
1383 --SP;
25a55bd7 1384 RETURNOP(cLOGOP->op_other);
25a55bd7 1385 }
d9aa96a4
SP
1386 /* assuming OP_DEFINED */
1387 if(defined)
1388 RETPUSHYES;
1389 RETPUSHNO;
c963b151
BD
1390}
1391
230ee21f
DM
1392
1393
a0d0e21e
LW
1394PP(pp_add)
1395{
20b7effb 1396 dSP; dATARGET; bool useleft; SV *svl, *svr;
230ee21f 1397
6f1401dc
DM
1398 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
1399 svr = TOPs;
1400 svl = TOPm1s;
1401
28e5dec8 1402#ifdef PERL_PRESERVE_IVUV
230ee21f
DM
1403
1404 /* special-case some simple common cases */
1405 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1406 IV il, ir;
1407 U32 flags = (svl->sv_flags & svr->sv_flags);
1408 if (flags & SVf_IOK) {
1409 /* both args are simple IVs */
1410 UV topl, topr;
1411 il = SvIVX(svl);
1412 ir = SvIVX(svr);
1413 do_iv:
1414 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1415 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1416
1417 /* if both are in a range that can't under/overflow, do a
1418 * simple integer add: if the top of both numbers
1419 * are 00 or 11, then it's safe */
1420 if (!( ((topl+1) | (topr+1)) & 2)) {
1421 SP--;
1422 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1423 SETs(TARG);
1424 RETURN;
1425 }
1426 goto generic;
1427 }
1428 else if (flags & SVf_NOK) {
1429 /* both args are NVs */
1430 NV nl = SvNVX(svl);
1431 NV nr = SvNVX(svr);
1432
3336af0b
DD
1433 if (
1434#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1435 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1436 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1437#else
1438 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1439#endif
1440 )
230ee21f
DM
1441 /* nothing was lost by converting to IVs */
1442 goto do_iv;
1443 SP--;
1444 TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1445 SETs(TARG);
1446 RETURN;
1447 }
1448 }
1449
1450 generic:
1451
1452 useleft = USE_LEFT(svl);
28e5dec8
JH
1453 /* We must see if we can perform the addition with integers if possible,
1454 as the integer code detects overflow while the NV code doesn't.
1455 If either argument hasn't had a numeric conversion yet attempt to get
1456 the IV. It's important to do this now, rather than just assuming that
1457 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1458 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1459 integer in case the second argument is IV=9223372036854775806
1460 We can (now) rely on sv_2iv to do the right thing, only setting the
1461 public IOK flag if the value in the NV (or PV) slot is truly integer.
1462
1463 A side effect is that this also aggressively prefers integer maths over
7dca457a
NC
1464 fp maths for integer values.
1465
a00b5bd3 1466 How to detect overflow?
7dca457a
NC
1467
1468 C 99 section 6.2.6.1 says
1469
1470 The range of nonnegative values of a signed integer type is a subrange
1471 of the corresponding unsigned integer type, and the representation of
1472 the same value in each type is the same. A computation involving
1473 unsigned operands can never overflow, because a result that cannot be
1474 represented by the resulting unsigned integer type is reduced modulo
1475 the number that is one greater than the largest value that can be
1476 represented by the resulting type.
1477
1478 (the 9th paragraph)
1479
1480 which I read as "unsigned ints wrap."
1481
1482 signed integer overflow seems to be classed as "exception condition"
1483
1484 If an exceptional condition occurs during the evaluation of an
1485 expression (that is, if the result is not mathematically defined or not
1486 in the range of representable values for its type), the behavior is
1487 undefined.
1488
1489 (6.5, the 5th paragraph)
1490
1491 I had assumed that on 2s complement machines signed arithmetic would
1492 wrap, hence coded pp_add and pp_subtract on the assumption that
1493 everything perl builds on would be happy. After much wailing and
1494 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1495 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
1496 unsigned code below is actually shorter than the old code. :-)
1497 */
1498
01f91bf2 1499 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1500 /* Unless the left argument is integer in range we are going to have to
1501 use NV maths. Hence only attempt to coerce the right argument if
1502 we know the left is integer. */
eb578fdb 1503 UV auv = 0;
9c5ffd7c 1504 bool auvok = FALSE;
7dca457a
NC
1505 bool a_valid = 0;
1506
28e5dec8 1507 if (!useleft) {
7dca457a
NC
1508 auv = 0;
1509 a_valid = auvok = 1;
1510 /* left operand is undef, treat as zero. + 0 is identity,
1511 Could SETi or SETu right now, but space optimise by not adding
1512 lots of code to speed up what is probably a rarish case. */
1513 } else {
1514 /* Left operand is defined, so is it IV? */
01f91bf2 1515 if (SvIV_please_nomg(svl)) {
800401ee
JH
1516 if ((auvok = SvUOK(svl)))
1517 auv = SvUVX(svl);
7dca457a 1518 else {
eb578fdb 1519 const IV aiv = SvIVX(svl);
7dca457a
NC
1520 if (aiv >= 0) {
1521 auv = aiv;
1522 auvok = 1; /* Now acting as a sign flag. */
53e2bfb7 1523 } else {
ad9b9a49 1524 auv = -(UV)aiv;
7dca457a
NC
1525 }
1526 }
1527 a_valid = 1;
28e5dec8
JH
1528 }
1529 }
7dca457a
NC
1530 if (a_valid) {
1531 bool result_good = 0;
1532 UV result;
eb578fdb 1533 UV buv;
800401ee 1534 bool buvok = SvUOK(svr);
a00b5bd3 1535
7dca457a 1536 if (buvok)
800401ee 1537 buv = SvUVX(svr);
7dca457a 1538 else {
eb578fdb 1539 const IV biv = SvIVX(svr);
7dca457a
NC
1540 if (biv >= 0) {
1541 buv = biv;
1542 buvok = 1;
1543 } else
ad9b9a49 1544 buv = -(UV)biv;
7dca457a
NC
1545 }
1546 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1547 else "IV" now, independent of how it came in.
7dca457a
NC
1548 if a, b represents positive, A, B negative, a maps to -A etc
1549 a + b => (a + b)
1550 A + b => -(a - b)
1551 a + B => (a - b)
1552 A + B => -(a + b)
1553 all UV maths. negate result if A negative.
1554 add if signs same, subtract if signs differ. */
1555
1556 if (auvok ^ buvok) {
1557 /* Signs differ. */
1558 if (auv >= buv) {
1559 result = auv - buv;
1560 /* Must get smaller */
1561 if (result <= auv)
1562 result_good = 1;
1563 } else {
1564 result = buv - auv;
1565 if (result <= buv) {
1566 /* result really should be -(auv-buv). as its negation
1567 of true value, need to swap our result flag */
1568 auvok = !auvok;
1569 result_good = 1;
28e5dec8
JH
1570 }
1571 }
7dca457a
NC
1572 } else {
1573 /* Signs same */
1574 result = auv + buv;
1575 if (result >= auv)
1576 result_good = 1;
1577 }
1578 if (result_good) {
1579 SP--;
1580 if (auvok)
28e5dec8 1581 SETu( result );
7dca457a
NC
1582 else {
1583 /* Negate result */
1584 if (result <= (UV)IV_MIN)
53e2bfb7
DM
1585 SETi(result == (UV)IV_MIN
1586 ? IV_MIN : -(IV)result);
7dca457a
NC
1587 else {
1588 /* result valid, but out of range for IV. */
1589 SETn( -(NV)result );
28e5dec8
JH
1590 }
1591 }
7dca457a
NC
1592 RETURN;
1593 } /* Overflow, drop through to NVs. */
28e5dec8
JH
1594 }
1595 }
230ee21f
DM
1596
1597#else
1598 useleft = USE_LEFT(svl);
28e5dec8 1599#endif
230ee21f 1600
a0d0e21e 1601 {
6f1401dc 1602 NV value = SvNV_nomg(svr);
4efa5a16 1603 (void)POPs;
28e5dec8
JH
1604 if (!useleft) {
1605 /* left operand is undef, treat as zero. + 0.0 is identity. */
1606 SETn(value);
1607 RETURN;
1608 }
6f1401dc 1609 SETn( value + SvNV_nomg(svl) );
28e5dec8 1610 RETURN;
a0d0e21e
LW
1611 }
1612}
1613
b1c05ba5
DM
1614
1615/* also used for: pp_aelemfast_lex() */
1616
a0d0e21e
LW
1617PP(pp_aelemfast)
1618{
20b7effb 1619 dSP;
93bad3fd 1620 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
8f878375 1621 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
a3b680e6 1622 const U32 lval = PL_op->op_flags & OPf_MOD;
7e169e84
DM
1623 const I8 key = (I8)PL_op->op_private;
1624 SV** svp;
1625 SV *sv;
1626
1627 assert(SvTYPE(av) == SVt_PVAV);
1628
f4484b87
DM
1629 EXTEND(SP, 1);
1630
7e169e84
DM
1631 /* inlined av_fetch() for simple cases ... */
1632 if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
1633 sv = AvARRAY(av)[key];
9fb994be 1634 if (sv) {
7e169e84
DM
1635 PUSHs(sv);
1636 RETURN;
1637 }
1638 }
1639
1640 /* ... else do it the hard way */
1641 svp = av_fetch(av, key, lval);
1642 sv = (svp ? *svp : &PL_sv_undef);
b024352e
DM
1643
1644 if (UNLIKELY(!svp && lval))
7e169e84 1645 DIE(aTHX_ PL_no_aelem, (int)key);
b024352e 1646
39cf747a 1647 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 1648 mg_get(sv);
be6c24e0 1649 PUSHs(sv);
a0d0e21e
LW
1650 RETURN;
1651}
1652
1653PP(pp_join)
1654{
20b7effb 1655 dSP; dMARK; dTARGET;
a0d0e21e
LW
1656 MARK++;
1657 do_join(TARG, *MARK, MARK, SP);
1658 SP = MARK;
1659 SETs(TARG);
1660 RETURN;
1661}
1662
a0d0e21e
LW
1663/* Oversized hot code. */
1664
b1c05ba5
DM
1665/* also used for: pp_say() */
1666
a0d0e21e
LW
1667PP(pp_print)
1668{
20b7effb 1669 dSP; dMARK; dORIGMARK;
eb578fdb 1670 PerlIO *fp;
236988e4 1671 MAGIC *mg;
159b6efe
NC
1672 GV * const gv
1673 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 1674 IO *io = GvIO(gv);
5b468f54 1675
9c9f25b8 1676 if (io
ad64d0ec 1677 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
5b468f54 1678 {
01bb7c6d 1679 had_magic:
68dc0745 1680 if (MARK == ORIGMARK) {
1c846c1f 1681 /* If using default handle then we need to make space to
a60c0954
NIS
1682 * pass object as 1st arg, so move other args up ...
1683 */
4352c267 1684 MEXTEND(SP, 1);
68dc0745
PP
1685 ++MARK;
1686 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1687 ++SP;
1688 }
3e0cb5de 1689 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
94bc412f
NC
1690 mg,
1691 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
1692 | (PL_op->op_type == OP_SAY
1693 ? TIED_METHOD_SAY : 0)), sp - mark);
236988e4 1694 }
9c9f25b8 1695 if (!io) {
68b590d9 1696 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
ad64d0ec 1697 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
01bb7c6d 1698 goto had_magic;
51087808 1699 report_evil_fh(gv);
93189314 1700 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
1701 goto just_say_no;
1702 }
1703 else if (!(fp = IoOFP(io))) {
7716c5c5
NC
1704 if (IoIFP(io))
1705 report_wrongway_fh(gv, '<');
51087808 1706 else
7716c5c5 1707 report_evil_fh(gv);
93189314 1708 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW
1709 goto just_say_no;
1710 }
1711 else {
e23d9e2f 1712 SV * const ofs = GvSV(PL_ofsgv); /* $, */
a0d0e21e 1713 MARK++;
e23d9e2f 1714 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
a0d0e21e
LW
1715 while (MARK <= SP) {
1716 if (!do_print(*MARK, fp))
1717 break;
1718 MARK++;
1719 if (MARK <= SP) {
e23d9e2f
CS
1720 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
1721 if (!do_print(GvSV(PL_ofsgv), fp)) {
a0d0e21e
LW
1722 MARK--;
1723 break;
1724 }
1725 }
1726 }
1727 }
1728 else {
1729 while (MARK <= SP) {
1730 if (!do_print(*MARK, fp))
1731 break;
1732 MARK++;
1733 }
1734 }
1735 if (MARK <= SP)
1736 goto just_say_no;
1737 else {
cfc4a7da
GA
1738 if (PL_op->op_type == OP_SAY) {
1739 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
1740 goto just_say_no;
1741 }
1742 else if (PL_ors_sv && SvOK(PL_ors_sv))
7889fe52 1743 if (!do_print(PL_ors_sv, fp)) /* $\ */
a0d0e21e
LW
1744 goto just_say_no;
1745
1746 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1747 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
1748 goto just_say_no;
1749 }
1750 }
1751 SP = ORIGMARK;
e52fd6f4 1752 XPUSHs(&PL_sv_yes);
a0d0e21e
LW
1753 RETURN;
1754
1755 just_say_no:
1756 SP = ORIGMARK;
e52fd6f4 1757 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
1758 RETURN;
1759}
1760
b1c05ba5 1761
aa36782f
DM
1762/* do the common parts of pp_padhv() and pp_rv2hv()
1763 * It assumes the caller has done EXTEND(SP, 1) or equivalent.
af3b1cba 1764 * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
e84e4286
DM
1765 * 'has_targ' indicates that the op has a target - this should
1766 * be a compile-time constant so that the code can constant-folded as
1767 * appropriate
aa36782f
DM
1768 * */
1769
1770PERL_STATIC_INLINE OP*
e84e4286 1771S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
aa36782f 1772{
e80717e7
DM
1773 bool is_tied;
1774 bool is_bool;
e1ad5d4c 1775 MAGIC *mg;
aa36782f 1776 dSP;
e80717e7
DM
1777 IV i;
1778 SV *sv;
aa36782f
DM
1779
1780 assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
1781
1782 if (gimme == G_ARRAY) {
8dc9003f 1783 hv_pushkv(hv, 3);
af3b1cba 1784 return NORMAL;
aa36782f
DM
1785 }
1786
1787 if (is_keys)
1788 /* 'keys %h' masquerading as '%h': reset iterator */
1789 (void)hv_iterinit(hv);
1790
6f2dc9a6
DM
1791 if (gimme == G_VOID)
1792 return NORMAL;
1793
e80717e7
DM
1794 is_bool = ( PL_op->op_private & OPpTRUEBOOL
1795 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
1796 && block_gimme() == G_VOID));
1797 is_tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
1798
1799 if (UNLIKELY(is_tied)) {
1800 if (is_keys && !is_bool) {
1801 i = 0;
1802 while (hv_iternext(hv))
1803 i++;
1804 goto push_i;
1805 }
1806 else {
1807 sv = magic_scalarpack(hv, mg);
1808 goto push_sv;
1809 }
3cd2c7d4 1810 }
e80717e7
DM
1811 else {
1812 i = HvUSEDKEYS(hv);
1813 if (is_bool) {
1814 sv = i ? &PL_sv_yes : &PL_sv_zero;
1815 push_sv:
1816 PUSHs(sv);
1817 }
1818 else {
1819 push_i:
e84e4286
DM
1820 if (has_targ) {
1821 dTARGET;
1822 PUSHi(i);
1823 }
1824 else
6f2dc9a6
DM
1825 if (is_keys) {
1826 /* parent op should be an unused OP_KEYS whose targ we can
1827 * use */
1828 dTARG;
1829 OP *k;
1830
1831 assert(!OpHAS_SIBLING(PL_op));
1832 k = PL_op->op_sibparent;
1833 assert(k->op_type == OP_KEYS);
1834 TARG = PAD_SV(k->op_targ);
1835 PUSHi(i);
1836 }
1837 else
e84e4286 1838 mPUSHi(i);
aa36782f 1839 }
aa36782f
DM
1840 }
1841
1842 PUTBACK;
1843 return NORMAL;
1844}
1845
1846
e855b461
DM
1847/* This is also called directly by pp_lvavref. */
1848PP(pp_padav)
1849{
1850 dSP; dTARGET;
1851 U8 gimme;
1852 assert(SvTYPE(TARG) == SVt_PVAV);
1853 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1854 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1855 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1856 EXTEND(SP, 1);
1857
1858 if (PL_op->op_flags & OPf_REF) {
1859 PUSHs(TARG);
1860 RETURN;
1861 }
1862 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1863 const I32 flags = is_lvalue_sub();
1864 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1865 if (GIMME_V == G_SCALAR)
1866 /* diag_listed_as: Can't return %s to lvalue scalar context */
1867 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
1868 PUSHs(TARG);
1869 RETURN;
1870 }
1871 }
1872
1873 gimme = GIMME_V;
0b5aba47
DM
1874 if (gimme == G_ARRAY)
1875 return S_pushav(aTHX_ (AV*)TARG);
327c9b9e
DM
1876
1877 if (gimme == G_SCALAR) {
e855b461
DM
1878 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
1879 if (!maxarg)
1880 PUSHs(&PL_sv_zero);
1881 else if (PL_op->op_private & OPpTRUEBOOL)
1882 PUSHs(&PL_sv_yes);
1883 else
1884 mPUSHi(maxarg);
1885 }
1886 RETURN;
1887}
1888
1889
1890PP(pp_padhv)
1891{
1892 dSP; dTARGET;
1893 U8 gimme;
e855b461
DM
1894
1895 assert(SvTYPE(TARG) == SVt_PVHV);
e855b461
DM
1896 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1897 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1898 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1899
aa36782f
DM
1900 EXTEND(SP, 1);
1901
1902 if (PL_op->op_flags & OPf_REF) {
1903 PUSHs(TARG);
e855b461 1904 RETURN;
aa36782f 1905 }
e855b461
DM
1906 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1907 const I32 flags = is_lvalue_sub();
1908 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1909 if (GIMME_V == G_SCALAR)
1910 /* diag_listed_as: Can't return %s to lvalue scalar context */
1911 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
aa36782f 1912 PUSHs(TARG);
e855b461
DM
1913 RETURN;
1914 }
1915 }
1916
1917 gimme = GIMME_V;
e855b461 1918
aa36782f 1919 return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
e84e4286
DM
1920 cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
1921 0 /* has_targ*/);
e855b461
DM
1922}
1923
1924
b1c05ba5 1925/* also used for: pp_rv2hv() */
bdaf10a5 1926/* also called directly by pp_lvavref */
b1c05ba5 1927
a0d0e21e
LW
1928PP(pp_rv2av)
1929{
20b7effb 1930 dSP; dTOPss;
1c23e2bd 1931 const U8 gimme = GIMME_V;
13c59d41
MH
1932 static const char an_array[] = "an ARRAY";
1933 static const char a_hash[] = "a HASH";
bdaf10a5
FC
1934 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
1935 || PL_op->op_type == OP_LVAVREF;
d83b45b8 1936 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e 1937
9026059d 1938 SvGETMAGIC(sv);
a0d0e21e 1939 if (SvROK(sv)) {
5d9574c1 1940 if (UNLIKELY(SvAMAGIC(sv))) {
93d7320b 1941 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
93d7320b 1942 }
17ab7946 1943 sv = SvRV(sv);
5d9574c1 1944 if (UNLIKELY(SvTYPE(sv) != type))
dcbac5bb 1945 /* diag_listed_as: Not an ARRAY reference */
13c59d41 1946 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
5d9574c1
DM
1947 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
1948 && PL_op->op_private & OPpLVAL_INTRO))
3da99855 1949 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e 1950 }
5d9574c1 1951 else if (UNLIKELY(SvTYPE(sv) != type)) {
67955e0c 1952 GV *gv;
1c846c1f 1953
6e592b3a 1954 if (!isGV_with_GP(sv)) {
13c59d41 1955 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
dc3c76f8
NC
1956 type, &sp);
1957 if (!gv)
1958 RETURN;
35cd451c
GS
1959 }
1960 else {
159b6efe 1961 gv = MUTABLE_GV(sv);
a0d0e21e 1962 }
ad64d0ec 1963 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
533c011a 1964 if (PL_op->op_private & OPpLVAL_INTRO)
ad64d0ec 1965 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
9f527363
FC
1966 }
1967 if (PL_op->op_flags & OPf_REF) {
17ab7946 1968 SETs(sv);
a0d0e21e 1969 RETURN;
9f527363 1970 }
5d9574c1 1971 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
40c94d11
FC
1972 const I32 flags = is_lvalue_sub();
1973 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 1974 if (gimme != G_ARRAY)
042560a6 1975 goto croak_cant_return;
17ab7946 1976 SETs(sv);
78f9721b 1977 RETURN;
40c94d11 1978 }
a0d0e21e
LW
1979 }
1980
17ab7946 1981 if (is_pp_rv2av) {
502c6561 1982 AV *const av = MUTABLE_AV(sv);
0b5aba47 1983
96913b52 1984 if (gimme == G_ARRAY) {
d5524600
DM
1985 SP--;
1986 PUTBACK;
0b5aba47 1987 return S_pushav(aTHX_ av);
1c846c1f 1988 }
0b5aba47
DM
1989
1990 if (gimme == G_SCALAR) {
c70927a6 1991 const SSize_t maxarg = AvFILL(av) + 1;
7be75ccf
DM
1992 if (PL_op->op_private & OPpTRUEBOOL)
1993 SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
1994 else {
1995 dTARGET;
1996 SETi(maxarg);
1997 }
93965878 1998 }
7be75ccf
DM
1999 }
2000 else {
aa36782f
DM
2001 SP--; PUTBACK;
2002 return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
e84e4286
DM
2003 cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
2004 1 /* has_targ*/);
17ab7946 2005 }
be85d344 2006 RETURN;
042560a6
NC
2007
2008 croak_cant_return:
2009 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
2010 is_pp_rv2av ? "array" : "hash");
77e217c6 2011 RETURN;
a0d0e21e
LW
2012}
2013
10c8fecd 2014STATIC void
fb8f4cf8 2015S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
10c8fecd 2016{
7918f24d
NC
2017 PERL_ARGS_ASSERT_DO_ODDBALL;
2018
fb8f4cf8 2019 if (*oddkey) {
6d822dc4 2020 if (ckWARN(WARN_MISC)) {
a3b680e6 2021 const char *err;
fb8f4cf8
RZ
2022 if (oddkey == firstkey &&
2023 SvROK(*oddkey) &&
2024 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
2025 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
10c8fecd 2026 {
a3b680e6 2027 err = "Reference found where even-sized list expected";
10c8fecd
GS
2028 }
2029 else
a3b680e6 2030 err = "Odd number of elements in hash assignment";
f1f66076 2031 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
10c8fecd 2032 }
6d822dc4 2033
10c8fecd
GS
2034 }
2035}
2036
a5f48505
DM
2037
2038/* Do a mark and sweep with the SVf_BREAK flag to detect elements which
2039 * are common to both the LHS and RHS of an aassign, and replace them
2040 * with copies. All these copies are made before the actual list assign is
2041 * done.
2042 *
2043 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
2044 * element ($b) to the first LH element ($a), modifies $a; when the
2045 * second assignment is done, the second RH element now has the wrong
2046 * value. So we initially replace the RHS with ($b, mortalcopy($a)).
2047 * Note that we don't need to make a mortal copy of $b.
2048 *
2049 * The algorithm below works by, for every RHS element, mark the
2050 * corresponding LHS target element with SVf_BREAK. Then if the RHS
2051 * element is found with SVf_BREAK set, it means it would have been
2052 * modified, so make a copy.
2053 * Note that by scanning both LHS and RHS in lockstep, we avoid
2054 * unnecessary copies (like $b above) compared with a naive
2055 * "mark all LHS; copy all marked RHS; unmark all LHS".
2056 *
2057 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
2058 * it can't be common and can be skipped.
ebc643ce
DM
2059 *
2060 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
2061 * that we thought we didn't need to call S_aassign_copy_common(), but we
2062 * have anyway for sanity checking. If we find we need to copy, then panic.
a5f48505
DM
2063 */
2064
2065PERL_STATIC_INLINE void
2066S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
ebc643ce
DM
2067 SV **firstrelem, SV **lastrelem
2068#ifdef DEBUGGING
2069 , bool fake
2070#endif
2071)
a5f48505
DM
2072{
2073 dVAR;
2074 SV **relem;
2075 SV **lelem;
2076 SSize_t lcount = lastlelem - firstlelem + 1;
2077 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
2078 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
beb08a1e 2079 bool copy_all = FALSE;
a5f48505
DM
2080
2081 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
2082 assert(firstlelem < lastlelem); /* at least 2 LH elements */
2083 assert(firstrelem < lastrelem); /* at least 2 RH elements */
2084
ebc643ce
DM
2085
2086 lelem = firstlelem;
a5f48505
DM
2087 /* we never have to copy the first RH element; it can't be corrupted
2088 * by assigning something to the corresponding first LH element.
2089 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
2090 */
ebc643ce 2091 relem = firstrelem + 1;
a5f48505
DM
2092
2093 for (; relem <= lastrelem; relem++) {
2094 SV *svr;
2095
2096 /* mark next LH element */
2097
2098 if (--lcount >= 0) {
2099 SV *svl = *lelem++;
2100
2101 if (UNLIKELY(!svl)) {/* skip AV alias marker */
2102 assert (lelem <= lastlelem);
2103 svl = *lelem++;
2104 lcount--;
2105 }
2106
2107 assert(svl);
beb08a1e
TC
2108 if (SvSMAGICAL(svl)) {
2109 copy_all = TRUE;
2110 }
a5f48505
DM
2111 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
2112 if (!marked)
2113 return;
2114 /* this LH element will consume all further args;
2115 * no need to mark any further LH elements (if any).
2116 * But we still need to scan any remaining RHS elements;
2117 * set lcount negative to distinguish from lcount == 0,
2118 * so the loop condition continues being true
2119 */
2120 lcount = -1;
2121 lelem--; /* no need to unmark this element */
2122 }
94a5f659 2123 else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
a5f48505
DM
2124 SvFLAGS(svl) |= SVf_BREAK;
2125 marked = TRUE;
2126 }
2127 else if (!marked) {
2128 /* don't check RH element if no SVf_BREAK flags set yet */
2129 if (!lcount)
2130 break;
2131 continue;
2132 }
2133 }
2134
2135 /* see if corresponding RH element needs copying */
2136
2137 assert(marked);
2138 svr = *relem;
2139 assert(svr);
2140
5c1db569 2141 if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
1050723f 2142 U32 brk = (SvFLAGS(svr) & SVf_BREAK);
a5f48505 2143
ebc643ce
DM
2144#ifdef DEBUGGING
2145 if (fake) {
9ae0115f 2146 /* op_dump(PL_op); */
ebc643ce
DM
2147 Perl_croak(aTHX_
2148 "panic: aassign skipped needed copy of common RH elem %"
2149 UVuf, (UV)(relem - firstrelem));
2150 }
2151#endif
2152
a5f48505
DM
2153 TAINT_NOT; /* Each item is independent */
2154
2155 /* Dear TODO test in t/op/sort.t, I love you.
2156 (It's relying on a panic, not a "semi-panic" from newSVsv()
2157 and then an assertion failure below.) */
2158 if (UNLIKELY(SvIS_FREED(svr))) {
2159 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
2160 (void*)svr);
2161 }
2162 /* avoid break flag while copying; otherwise COW etc
2163 * disabled... */
2164 SvFLAGS(svr) &= ~SVf_BREAK;
2165 /* Not newSVsv(), as it does not allow copy-on-write,
8c1e192f
DM
2166 resulting in wasteful copies.
2167 Also, we use SV_NOSTEAL in case the SV is used more than
2168 once, e.g. (...) = (f())[0,0]
2169 Where the same SV appears twice on the RHS without a ref
2170 count bump. (Although I suspect that the SV won't be
2171 stealable here anyway - DAPM).
2172 */
a5f48505
DM
2173 *relem = sv_mortalcopy_flags(svr,
2174 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2175 /* ... but restore afterwards in case it's needed again,
2176 * e.g. ($a,$b,$c) = (1,$a,$a)
2177 */
1050723f 2178 SvFLAGS(svr) |= brk;
a5f48505
DM
2179 }
2180
2181 if (!lcount)
2182 break;
2183 }
2184
2185 if (!marked)
2186 return;
2187
2188 /*unmark LHS */
2189
2190 while (lelem > firstlelem) {
2191 SV * const svl = *(--lelem);
2192 if (svl)
2193 SvFLAGS(svl) &= ~SVf_BREAK;
2194 }
2195}
2196
2197
2198
a0d0e21e
LW
2199PP(pp_aassign)
2200{
27da23d5 2201 dVAR; dSP;
3280af22
NIS
2202 SV **lastlelem = PL_stack_sp;
2203 SV **lastrelem = PL_stack_base + POPMARK;
2204 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
2205 SV **firstlelem = lastrelem + 1;
2206
eb578fdb
KW
2207 SV **relem;
2208 SV **lelem;
1c23e2bd 2209 U8 gimme;
a68090fe
DM
2210 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
2211 * only need to save locally, not on the save stack */
2212 U16 old_delaymagic = PL_delaymagic;
ebc643ce
DM
2213#ifdef DEBUGGING
2214 bool fake = 0;
2215#endif
5637b936 2216
3280af22 2217 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
a0d0e21e
LW
2218
2219 /* If there's a common identifier on both sides we have to take
2220 * special care that assigning the identifier on the left doesn't
2221 * clobber a value on the right that's used later in the list.
2222 */
acdea6f0 2223
beb08a1e
TC
2224 /* at least 2 LH and RH elements, or commonality isn't an issue */
2225 if (firstlelem < lastlelem && firstrelem < lastrelem) {
5c1db569
TC
2226 for (relem = firstrelem+1; relem <= lastrelem; relem++) {
2227 if (SvGMAGICAL(*relem))
2228 goto do_scan;
2229 }
beb08a1e
TC
2230 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2231 if (*lelem && SvSMAGICAL(*lelem))
2232 goto do_scan;
a5f48505 2233 }
beb08a1e
TC
2234 if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
2235 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
2236 /* skip the scan if all scalars have a ref count of 1 */
2237 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
8b0c3377 2238 SV *sv = *lelem;
beb08a1e
TC
2239 if (!sv || SvREFCNT(sv) == 1)
2240 continue;
2241 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
2242 goto do_scan;
2243 break;
2244 }
2245 }
2246 else {
2247 do_scan:
2248 S_aassign_copy_common(aTHX_
2249 firstlelem, lastlelem, firstrelem, lastrelem
ebc643ce 2250#ifdef DEBUGGING
beb08a1e 2251 , fake
ebc643ce 2252#endif
beb08a1e
TC
2253 );
2254 }
a5f48505 2255 }
a0d0e21e 2256 }
ebc643ce
DM
2257#ifdef DEBUGGING
2258 else {
2259 /* on debugging builds, do the scan even if we've concluded we
2260 * don't need to, then panic if we find commonality. Note that the
2261 * scanner assumes at least 2 elements */
2262 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2263 fake = 1;
2264 goto do_scan;
2265 }
2266 }
2267#endif
a0d0e21e 2268
a5f48505 2269 gimme = GIMME_V;
a0d0e21e
LW
2270 relem = firstrelem;
2271 lelem = firstlelem;
10c8fecd 2272
8b0c3377
DM
2273 if (relem > lastrelem)
2274 goto no_relems;
2275
2276 /* first lelem loop while there are still relems */
5d9574c1 2277 while (LIKELY(lelem <= lastlelem)) {
bdaf10a5 2278 bool alias = FALSE;
8b0c3377
DM
2279 SV *lsv = *lelem++;
2280
c73f612f
DM
2281 TAINT_NOT; /* Each item stands on its own, taintwise. */
2282
8b0c3377
DM
2283 assert(relem <= lastrelem);
2284 if (UNLIKELY(!lsv)) {
bdaf10a5 2285 alias = TRUE;
8b0c3377
DM
2286 lsv = *lelem++;
2287 ASSUME(SvTYPE(lsv) == SVt_PVAV);
bdaf10a5 2288 }
a5f48505 2289
8b0c3377
DM
2290 switch (SvTYPE(lsv)) {
2291 case SVt_PVAV: {
2292 SV **svp;
2293 SSize_t i;
2294 SSize_t tmps_base;
2295 SSize_t nelems = lastrelem - relem + 1;
b09ed995 2296 AV *ary = MUTABLE_AV(lsv);
8b0c3377
DM
2297
2298 /* Assigning to an aggregate is tricky. First there is the
2299 * issue of commonality, e.g. @a = ($a[0]). Since the
2300 * stack isn't refcounted, clearing @a prior to storing
2301 * elements will free $a[0]. Similarly with
2302 * sub FETCH { $status[$_[1]] } @status = @tied[0,1];
2303 *
2304 * The way to avoid these issues is to make the copy of each
2305 * SV (and we normally store a *copy* in the array) *before*
2306 * clearing the array. But this has a problem in that
2307 * if the code croaks during copying, the not-yet-stored copies
2308 * could leak. One way to avoid this is to make all the copies
2309 * mortal, but that's quite expensive.
2310 *
2311 * The current solution to these issues is to use a chunk
2312 * of the tmps stack as a temporary refcounted-stack. SVs
2313 * will be put on there during processing to avoid leaks,
2314 * but will be removed again before the end of this block,
2315 * so free_tmps() is never normally called. Also, the
2316 * sv_refcnt of the SVs doesn't have to be manipulated, since
2317 * the ownership of 1 reference count is transferred directly
2318 * from the tmps stack to the AV when the SV is stored.
2319 *
2320 * We disarm slots in the temps stack by storing PL_sv_undef
2321 * there: it doesn't matter if that SV's refcount is
2322 * repeatedly decremented during a croak. But usually this is
2323 * only an interim measure. By the end of this code block
2324 * we try where possible to not leave any PL_sv_undef's on the
2325 * tmps stack e.g. by shuffling newer entries down.
2326 *
2327 * There is one case where we don't copy: non-magical
2328 * SvTEMP(sv)'s with a ref count of 1. The only owner of these
2329 * is on the tmps stack, so its safe to directly steal the SV
2330 * rather than copying. This is common in things like function
2331 * returns, map etc, which all return a list of such SVs.
2332 *
2333 * Note however something like @a = (f())[0,0], where there is
2334 * a danger of the same SV being shared: this avoided because
2335 * when the SV is stored as $a[0], its ref count gets bumped,
2336 * so the RC==1 test fails and the second element is copied
2337 * instead.
2338 *
2339 * We also use one slot in the tmps stack to hold an extra
2340 * ref to the array, to ensure it doesn't get prematurely
2341 * freed. Again, this is removed before the end of this block.
2342 *
2343 * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
2344 * @a = ($a[0]) case, but the current implementation uses the
2345 * same algorithm regardless, so ignores that flag. (It *is*
2346 * used in the hash branch below, however).
2347 */
2348
2349 /* Reserve slots for ary, plus the elems we're about to copy,
2350 * then protect ary and temporarily void the remaining slots
2351 * with &PL_sv_undef */
2352 EXTEND_MORTAL(nelems + 1);
2353 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
2354 tmps_base = PL_tmps_ix + 1;
2355 for (i = 0; i < nelems; i++)
2356 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2357 PL_tmps_ix += nelems;
2358
2359 /* Make a copy of each RHS elem and save on the tmps_stack
2360 * (or pass through where we can optimise away the copy) */
2361
2362 if (UNLIKELY(alias)) {
2363 U32 lval = (gimme == G_ARRAY)
2364 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
a5f48505 2365 for (svp = relem; svp <= lastrelem; svp++) {
8b0c3377
DM
2366 SV *rsv = *svp;
2367
2368 SvGETMAGIC(rsv);
2369 if (!SvROK(rsv))
2370 DIE(aTHX_ "Assigned value is not a reference");
2371 if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
2372 /* diag_listed_as: Assigned value is not %s reference */
2373 DIE(aTHX_
2374 "Assigned value is not a SCALAR reference");
2375 if (lval)
2376 *svp = rsv = sv_mortalcopy(rsv);
2377 /* XXX else check for weak refs? */
2378 rsv = SvREFCNT_inc_NN(SvRV(rsv));
2379 assert(tmps_base <= PL_tmps_max);
2380 PL_tmps_stack[tmps_base++] = rsv;
a5f48505 2381 }
a5f48505 2382 }
8b0c3377
DM
2383 else {
2384 for (svp = relem; svp <= lastrelem; svp++) {
2385 SV *rsv = *svp;
a5f48505 2386
8b0c3377
DM
2387 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2388 /* can skip the copy */
2389 SvREFCNT_inc_simple_void_NN(rsv);
2390 SvTEMP_off(rsv);
2391 }
a5f48505 2392 else {
8b0c3377
DM
2393 SV *nsv;
2394 /* do get before newSV, in case it dies and leaks */
2395 SvGETMAGIC(rsv);
2396 nsv = newSV(0);
8c1e192f
DM
2397 /* see comment in S_aassign_copy_common about
2398 * SV_NOSTEAL */
8b0c3377
DM
2399 sv_setsv_flags(nsv, rsv,
2400 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2401 rsv = *svp = nsv;
a5f48505 2402 }
8b0c3377
DM
2403
2404 assert(tmps_base <= PL_tmps_max);
2405 PL_tmps_stack[tmps_base++] = rsv;
2406 }
2407 }
2408
2409 if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
2410 av_clear(ary);
2411
2412 /* store in the array, the SVs that are in the tmps stack */
2413
2414 tmps_base -= nelems;
2415
80c1439f 2416 if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
8b0c3377
DM
2417 /* for arrays we can't cheat with, use the official API */
2418 av_extend(ary, nelems - 1);
2419 for (i = 0; i < nelems; i++) {
2420 SV **svp = &(PL_tmps_stack[tmps_base + i]);
2421 SV *rsv = *svp;
2422 /* A tied store won't take ownership of rsv, so keep
2423 * the 1 refcnt on the tmps stack; otherwise disarm
2424 * the tmps stack entry */
2425 if (av_store(ary, i, rsv))
2426 *svp = &PL_sv_undef;
2427 /* av_store() may have added set magic to rsv */;
2428 SvSETMAGIC(rsv);
2429 }
2430 /* disarm ary refcount: see comments below about leak */
2431 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2432 }
2433 else {
2434 /* directly access/set the guts of the AV */
2435 SSize_t fill = nelems - 1;
2436 if (fill > AvMAX(ary))
2437 av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
2438 &AvARRAY(ary));
2439 AvFILLp(ary) = fill;
2440 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
2441 /* Quietly remove all the SVs from the tmps stack slots,
2442 * since ary has now taken ownership of the refcnt.
2443 * Also remove ary: which will now leak if we die before
2444 * the SvREFCNT_dec_NN(ary) below */
2445 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2446 Move(&PL_tmps_stack[tmps_base + nelems],
2447 &PL_tmps_stack[tmps_base - 1],
2448 PL_tmps_ix - (tmps_base + nelems) + 1,
2449 SV*);
2450 PL_tmps_ix -= (nelems + 1);
2451 }
2452
5d9574c1 2453 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
8b0c3377 2454 /* its assumed @ISA set magic can't die and leak ary */
ad64d0ec 2455 SvSETMAGIC(MUTABLE_SV(ary));
8b0c3377
DM
2456 SvREFCNT_dec_NN(ary);
2457
2458 relem = lastrelem + 1;
2459 goto no_relems;
a5f48505
DM
2460 }
2461
10c8fecd 2462 case SVt_PVHV: { /* normal hash */
8b0c3377
DM
2463
2464 SV **svp;
2465 bool dirty_tmps;
2466 SSize_t i;
2467 SSize_t tmps_base;
2468 SSize_t nelems = lastrelem - relem + 1;
b09ed995 2469 HV *hash = MUTABLE_HV(lsv);
8b0c3377
DM
2470
2471 if (UNLIKELY(nelems & 1)) {
2472 do_oddball(lastrelem, relem);
2473 /* we have firstlelem to reuse, it's not needed any more */
2474 *++lastrelem = &PL_sv_undef;
2475 nelems++;
2476 }
2477
2478 /* See the SVt_PVAV branch above for a long description of
2479 * how the following all works. The main difference for hashes
2480 * is that we treat keys and values separately (and have
2481 * separate loops for them): as for arrays, values are always
2482 * copied (except for the SvTEMP optimisation), since they
2483 * need to be stored in the hash; while keys are only
2484 * processed where they might get prematurely freed or
2485 * whatever. */
2486
2487 /* tmps stack slots:
2488 * * reserve a slot for the hash keepalive;
2489 * * reserve slots for the hash values we're about to copy;
2490 * * preallocate for the keys we'll possibly copy or refcount bump
2491 * later;
2492 * then protect hash and temporarily void the remaining
2493 * value slots with &PL_sv_undef */
2494 EXTEND_MORTAL(nelems + 1);
2495
2496 /* convert to number of key/value pairs */
2497 nelems >>= 1;
2498
2499 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
2500 tmps_base = PL_tmps_ix + 1;
2501 for (i = 0; i < nelems; i++)
2502 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2503 PL_tmps_ix += nelems;
2504
2505 /* Make a copy of each RHS hash value and save on the tmps_stack
2506 * (or pass through where we can optimise away the copy) */
2507
2508 for (svp = relem + 1; svp <= lastrelem; svp += 2) {
2509 SV *rsv = *svp;
2510
2511 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2512 /* can skip the copy */
2513 SvREFCNT_inc_simple_void_NN(rsv);
2514 SvTEMP_off(rsv);
2515 }
2516 else {
2517 SV *nsv;
2518 /* do get before newSV, in case it dies and leaks */
2519 SvGETMAGIC(rsv);
2520 nsv = newSV(0);
2521 /* see comment in S_aassign_copy_common about
2522 * SV_NOSTEAL */
2523 sv_setsv_flags(nsv, rsv,
2524 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2525 rsv = *svp = nsv;
1c4ea384
RZ
2526 }
2527
8b0c3377
DM
2528 assert(tmps_base <= PL_tmps_max);
2529 PL_tmps_stack[tmps_base++] = rsv;
2530 }
2531 tmps_base -= nelems;
a5f48505 2532
a5f48505 2533
8b0c3377
DM
2534 /* possibly protect keys */
2535
2536 if (UNLIKELY(gimme == G_ARRAY)) {
2537 /* handle e.g.
2538 * @a = ((%h = ($$r, 1)), $r = "x");
2539 * $_++ for %h = (1,2,3,4);
2540 */
2541 EXTEND_MORTAL(nelems);
2542 for (svp = relem; svp <= lastrelem; svp += 2)
2543 *svp = sv_mortalcopy_flags(*svp,
2544 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2545 }
2546 else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
2547 /* for possible commonality, e.g.
2548 * %h = ($h{a},1)
2549 * avoid premature freeing RHS keys by mortalising
2550 * them.
2551 * For a magic element, make a copy so that its magic is
2552 * called *before* the hash is emptied (which may affect
2553 * a tied value for example).
2554 * In theory we should check for magic keys in all
2555 * cases, not just under OPpASSIGN_COMMON_AGG, but in
2556 * practice, !OPpASSIGN_COMMON_AGG implies only
2557 * constants or padtmps on the RHS.
2558 */
2559 EXTEND_MORTAL(nelems);
2560 for (svp = relem; svp <= lastrelem; svp += 2) {
2561 SV *rsv = *svp;
2562 if (UNLIKELY(SvGMAGICAL(rsv))) {
2563 SSize_t n;
a5f48505
DM
2564 *svp = sv_mortalcopy_flags(*svp,
2565 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
8b0c3377
DM
2566 /* allow other branch to continue pushing
2567 * onto tmps stack without checking each time */
2568 n = (lastrelem - relem) >> 1;
2569 EXTEND_MORTAL(n);
a5f48505 2570 }
8b0c3377
DM
2571 else
2572 PL_tmps_stack[++PL_tmps_ix] =
2573 SvREFCNT_inc_simple_NN(rsv);
a5f48505 2574 }
8b0c3377 2575 }
a5f48505 2576
8b0c3377
DM
2577 if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
2578 hv_clear(hash);
a5f48505 2579
8b0c3377
DM
2580 /* now assign the keys and values to the hash */
2581
2582 dirty_tmps = FALSE;
2583
2584 if (UNLIKELY(gimme == G_ARRAY)) {
2585 /* @a = (%h = (...)) etc */
2586 SV **svp;
2587 SV **topelem = relem;
2588
2589 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2590 SV *key = *svp++;
2591 SV *val = *svp;
2592 /* remove duplicates from list we return */
2593 if (!hv_exists_ent(hash, key, 0)) {
2594 /* copy key back: possibly to an earlier
2595 * stack location if we encountered dups earlier,
2596 * The values will be updated later
2597 */
2598 *topelem = key;
2599 topelem += 2;
632b9d6f 2600 }
8b0c3377
DM
2601 /* A tied store won't take ownership of val, so keep
2602 * the 1 refcnt on the tmps stack; otherwise disarm
2603 * the tmps stack entry */
2604 if (hv_store_ent(hash, key, val, 0))
2605 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2606 else
2607 dirty_tmps = TRUE;
2608 /* hv_store_ent() may have added set magic to val */;
2609 SvSETMAGIC(val);
2610 }
2611 if (topelem < svp) {
1c4ea384
RZ
2612 /* at this point we have removed the duplicate key/value
2613 * pairs from the stack, but the remaining values may be
2614 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
2615 * the (a 2), but the stack now probably contains
2616 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
2617 * obliterates the earlier key. So refresh all values. */
8b0c3377
DM
2618 lastrelem = topelem - 1;
2619 while (relem < lastrelem) {
1c4ea384
RZ
2620 HE *he;
2621 he = hv_fetch_ent(hash, *relem++, 0, 0);
2622 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
2623 }
2624 }
8b0c3377
DM
2625 }
2626 else {
2627 SV **svp;
2628 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2629 SV *key = *svp++;
2630 SV *val = *svp;
2631 if (hv_store_ent(hash, key, val, 0))
2632 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2633 else
2634 dirty_tmps = TRUE;
2635 /* hv_store_ent() may have added set magic to val */;
2636 SvSETMAGIC(val);
2637 }
2638 }
2639
2640 if (dirty_tmps) {
2641 /* there are still some 'live' recounts on the tmps stack
2642 * - usually caused by storing into a tied hash. So let
2643 * free_tmps() do the proper but slow job later.
2644 * Just disarm hash refcount: see comments below about leak
2645 */
2646 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2647 }
2648 else {
2649 /* Quietly remove all the SVs from the tmps stack slots,
2650 * since hash has now taken ownership of the refcnt.
2651 * Also remove hash: which will now leak if we die before
2652 * the SvREFCNT_dec_NN(hash) below */
2653 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2654 Move(&PL_tmps_stack[tmps_base + nelems],
2655 &PL_tmps_stack[tmps_base - 1],
2656 PL_tmps_ix - (tmps_base + nelems) + 1,
2657 SV*);
2658 PL_tmps_ix -= (nelems + 1);
2659 }
2660
2661 SvREFCNT_dec_NN(hash);
2662
2663 relem = lastrelem + 1;
2664 goto no_relems;
2665 }
2666
a0d0e21e 2667 default:
8b0c3377 2668 if (!SvIMMORTAL(lsv)) {
d24e3eb1
DM
2669 SV *ref;
2670
8b0c3377
DM
2671 if (UNLIKELY(
2672 SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
2673 (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
2674 ))
2675 Perl_warner(aTHX_
2676 packWARN(WARN_MISC),
2677 "Useless assignment to a temporary"
2678 );
d24e3eb1
DM
2679
2680 /* avoid freeing $$lsv if it might be needed for further
2681 * elements, e.g. ($ref, $foo) = (1, $$ref) */
2682 if ( SvROK(lsv)
2683 && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
2684 && lelem <= lastlelem
2685 ) {
2686 SSize_t ix;
2687 SvREFCNT_inc_simple_void_NN(ref);
2688 /* an unrolled sv_2mortal */
2689 ix = ++PL_tmps_ix;
2690 if (UNLIKELY(ix >= PL_tmps_max))
2691 /* speculatively grow enough to cover other
2692 * possible refs */
67c3640a 2693 (void)tmps_grow_p(ix + (lastlelem - lelem));
d24e3eb1
DM
2694 PL_tmps_stack[ix] = ref;
2695 }
2696
8b0c3377
DM
2697 sv_setsv(lsv, *relem);
2698 *relem = lsv;
2699 SvSETMAGIC(lsv);
2700 }
2701 if (++relem > lastrelem)
2702 goto no_relems;
a0d0e21e 2703 break;
8b0c3377
DM
2704 } /* switch */
2705 } /* while */
2706
2707
2708 no_relems:
2709
2710 /* simplified lelem loop for when there are no relems left */
2711 while (LIKELY(lelem <= lastlelem)) {
2712 SV *lsv = *lelem++;
c73f612f
DM
2713
2714 TAINT_NOT; /* Each item stands on its own, taintwise. */
2715
8b0c3377
DM
2716 if (UNLIKELY(!lsv)) {
2717 lsv = *lelem++;
2718 ASSUME(SvTYPE(lsv) == SVt_PVAV);
a0d0e21e 2719 }
8b0c3377
DM
2720
2721 switch (SvTYPE(lsv)) {
2722 case SVt_PVAV:
b09ed995
DM
2723 if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
2724 av_clear((AV*)lsv);
8b0c3377 2725 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
b09ed995 2726 SvSETMAGIC(lsv);
8b0c3377
DM
2727 }
2728 break;
2729
2730 case SVt_PVHV:
b09ed995
DM
2731 if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
2732 hv_clear((HV*)lsv);
8b0c3377
DM
2733 break;
2734
2735 default:
2736 if (!SvIMMORTAL(lsv)) {
e03e82a0 2737 sv_set_undef(lsv);
8b0c3377 2738 SvSETMAGIC(lsv);
b09ed995 2739 *relem++ = lsv;
8b0c3377
DM
2740 }
2741 break;
2742 } /* switch */
2743 } /* while */
2744
c73f612f
DM
2745 TAINT_NOT; /* result of list assign isn't tainted */
2746
5d9574c1 2747 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
985213f2 2748 /* Will be used to set PL_tainting below */
dfff4baf
BF
2749 Uid_t tmp_uid = PerlProc_getuid();
2750 Uid_t tmp_euid = PerlProc_geteuid();
2751 Gid_t tmp_gid = PerlProc_getgid();
2752 Gid_t tmp_egid = PerlProc_getegid();
985213f2 2753
b469f1e0 2754 /* XXX $> et al currently silently ignore failures */
3280af22 2755 if (PL_delaymagic & DM_UID) {
a0d0e21e 2756#ifdef HAS_SETRESUID
b469f1e0
JH
2757 PERL_UNUSED_RESULT(
2758 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2759 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
2760 (Uid_t)-1));
d1a21e44 2761#elif defined(HAS_SETREUID)
b469f1e0
JH
2762 PERL_UNUSED_RESULT(
2763 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2764 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
d1a21e44 2765#else
56febc5e 2766# ifdef HAS_SETRUID
b28d0864 2767 if ((PL_delaymagic & DM_UID) == DM_RUID) {
b469f1e0 2768 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
b28d0864 2769 PL_delaymagic &= ~DM_RUID;
a0d0e21e 2770 }
56febc5e
AD
2771# endif /* HAS_SETRUID */
2772# ifdef HAS_SETEUID
b28d0864 2773 if ((PL_delaymagic & DM_UID) == DM_EUID) {
b469f1e0 2774 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
b28d0864 2775 PL_delaymagic &= ~DM_EUID;
a0d0e21e 2776 }
56febc5e 2777# endif /* HAS_SETEUID */
b28d0864 2778 if (PL_delaymagic & DM_UID) {
985213f2 2779 if (PL_delaymagic_uid != PL_delaymagic_euid)
cea2e8a9 2780 DIE(aTHX_ "No setreuid available");
b469f1e0 2781 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
a0d0e21e 2782 }
56febc5e 2783#endif /* HAS_SETRESUID */
04783dc7 2784
985213f2
AB
2785 tmp_uid = PerlProc_getuid();
2786 tmp_euid = PerlProc_geteuid();
a0d0e21e 2787 }
b469f1e0 2788 /* XXX $> et al currently silently ignore failures */
3280af22 2789 if (PL_delaymagic & DM_GID) {
a0d0e21e 2790#ifdef HAS_SETRESGID
b469f1e0
JH
2791 PERL_UNUSED_RESULT(
2792 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2793 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
2794 (Gid_t)-1));
d1a21e44 2795#elif defined(HAS_SETREGID)
b469f1e0
JH
2796 PERL_UNUSED_RESULT(
2797 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2798 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
d1a21e44 2799#else
56febc5e 2800# ifdef HAS_SETRGID
b28d0864 2801 if ((PL_delaymagic & DM_GID) == DM_RGID) {
b469f1e0 2802 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
b28d0864 2803 PL_delaymagic &= ~DM_RGID;
a0d0e21e 2804 }
56febc5e
AD
2805# endif /* HAS_SETRGID */
2806# ifdef HAS_SETEGID
b28d0864 2807 if ((PL_delaymagic & DM_GID) == DM_EGID) {
b469f1e0 2808 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
b28d0864 2809 PL_delaymagic &= ~DM_EGID;
a0d0e21e 2810 }
56febc5e 2811# endif /* HAS_SETEGID */
b28d0864 2812 if (PL_delaymagic & DM_GID) {
985213f2 2813 if (PL_delaymagic_gid != PL_delaymagic_egid)
cea2e8a9 2814 DIE(aTHX_ "No setregid available");
b469f1e0 2815 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
a0d0e21e 2816 }
56febc5e 2817#endif /* HAS_SETRESGID */
04783dc7 2818
985213f2
AB
2819 tmp_gid = PerlProc_getgid();
2820 tmp_egid = PerlProc_getegid();
a0d0e21e 2821 }
284167a5 2822 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
9a9b5ec9
DM
2823#ifdef NO_TAINT_SUPPORT
2824 PERL_UNUSED_VAR(tmp_uid);
2825 PERL_UNUSED_VAR(tmp_euid);
2826 PERL_UNUSED_VAR(tmp_gid);
2827 PERL_UNUSED_VAR(tmp_egid);
2828#endif
a0d0e21e 2829 }
a68090fe 2830 PL_delaymagic = old_delaymagic;
54310121 2831
54310121
PP
2832 if (gimme == G_VOID)
2833 SP = firstrelem - 1;
2834 else if (gimme == G_SCALAR) {
54310121 2835 SP = firstrelem;
b09ed995 2836 EXTEND(SP,1);
7b394f12
DM
2837 if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
2838 SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
2839 else {
2840 dTARGET;
2841 SETi(firstlelem - firstrelem);
2842 }
54310121 2843 }
b09ed995
DM
2844 else
2845 SP = relem - 1;
08aeb9f7 2846
54310121 2847 RETURN;
a0d0e21e
LW
2848}
2849
8782bef2
GB
2850PP(pp_qr)
2851{
20b7effb 2852 dSP;
eb578fdb 2853 PMOP * const pm = cPMOP;
fe578d7f 2854 REGEXP * rx = PM_GETRE(pm);
196a02af
DM
2855 regexp *prog = ReANY(rx);
2856 SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
c4420975 2857 SV * const rv = sv_newmortal();
d63c20f2
DM
2858 CV **cvp;
2859 CV *cv;
288b8c02
NC
2860
2861 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
2862 /* For a subroutine describing itself as "This is a hacky workaround" I'm
2863 loathe to use it here, but it seems to be the right fix. Or close.
2864 The key part appears to be that it's essential for pp_qr to return a new
2865 object (SV), which implies that there needs to be an effective way to
2866 generate a new SV from the existing SV that is pre-compiled in the
2867 optree. */
2868 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
2869 SvROK_on(rv);
2870
8d919b0a 2871 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
5d9574c1 2872 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
d63c20f2 2873 *cvp = cv_clone(cv);
fc2b2dca 2874 SvREFCNT_dec_NN(cv);
d63c20f2
DM
2875 }
2876
288b8c02 2877 if (pkg) {
f815daf2 2878 HV *const stash = gv_stashsv(pkg, GV_ADD);
fc2b2dca 2879 SvREFCNT_dec_NN(pkg);
288b8c02
NC
2880 (void)sv_bless(rv, stash);
2881 }
2882
196a02af 2883 if (UNLIKELY(RXp_ISTAINTED(prog))) {
e08e52cf 2884 SvTAINTED_on(rv);
9274aefd
DM
2885 SvTAINTED_on(SvRV(rv));
2886 }
c8c13c22 2887 XPUSHs(rv);
2888 RETURN;
8782bef2
GB
2889}
2890
a0d0e21e
LW
2891PP(pp_match)
2892{
20b7effb 2893 dSP; dTARG;
eb578fdb 2894 PMOP *pm = cPMOP;
d65afb4b 2895 PMOP *dynpm = pm;
eb578fdb 2896 const char *s;
5c144d81 2897 const char *strend;
99a90e59 2898 SSize_t curpos = 0; /* initial pos() or current $+[0] */
a0d0e21e 2899 I32 global;
7fadf4a7 2900 U8 r_flags = 0;
5c144d81 2901 const char *truebase; /* Start of string */
eb578fdb 2902 REGEXP *rx = PM_GETRE(pm);
196a02af 2903 regexp *prog = ReANY(rx);
b3eb6a9b 2904 bool rxtainted;
1c23e2bd 2905 const U8 gimme = GIMME_V;
a0d0e21e 2906 STRLEN len;
a3b680e6 2907 const I32 oldsave = PL_savestack_ix;
e60df1fa 2908 I32 had_zerolen = 0;
b1422d62 2909 MAGIC *mg = NULL;
a0d0e21e 2910
533c011a 2911 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
2912 TARG = POPs;
2913 else {
9399c607
DM
2914 if (ARGTARG)
2915 GETTARGET;
2916 else {
2917 TARG = DEFSV;
2918 }
a0d0e21e
LW
2919 EXTEND(SP,1);
2920 }
d9f424b2 2921
c277df42 2922 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
2923 /* Skip get-magic if this is a qr// clone, because regcomp has
2924 already done it. */
196a02af 2925 truebase = prog->mother_re
69dc4b30
FC
2926 ? SvPV_nomg_const(TARG, len)
2927 : SvPV_const(TARG, len);
f1d31338 2928 if (!truebase)
2269b42e 2929 DIE(aTHX_ "panic: pp_match");
f1d31338 2930 strend = truebase + len;
196a02af 2931 rxtainted = (RXp_ISTAINTED(prog) ||
284167a5 2932 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 2933 TAINT_NOT;
a0d0e21e 2934
6c864ec2 2935 /* We need to know this in case we fail out early - pos() must be reset */
de0df3c0
MH
2936 global = dynpm->op_pmflags & PMf_GLOBAL;
2937
d65afb4b 2938 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
2939 if (
2940#ifdef USE_ITHREADS
2941 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
2942#else
2943 pm->op_pmflags & PMf_USED
2944#endif
2945 ) {
e5dc5375 2946 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
de0df3c0 2947 goto nope;
a0d0e21e
LW
2948 }
2949
5585e758 2950 /* handle the empty pattern */
196a02af 2951 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
5585e758
YO
2952 if (PL_curpm == PL_reg_curpm) {
2953 if (PL_curpm_under) {
2954 if (PL_curpm_under == PL_reg_curpm) {
2955 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
2956 } else {
2957 pm = PL_curpm_under;
2958 }
2959 }
2960 } else {
2961 pm = PL_curpm;
2962 }
2963 rx = PM_GETRE(pm);
196a02af 2964 prog = ReANY(rx);
a0d0e21e 2965 }
d65afb4b 2966
196a02af 2967 if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
75d43e96 2968 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
147e3846 2969 UVuf " < %" IVdf ")\n",
196a02af 2970 (UV)len, (IV)RXp_MINLEN(prog)));
de0df3c0 2971 goto nope;
e5dc5375 2972 }
c277df42 2973
8ef97b0e 2974 /* get pos() if //g */
de0df3c0 2975 if (global) {
b1422d62 2976 mg = mg_find_mglob(TARG);
8ef97b0e 2977 if (mg && mg->mg_len >= 0) {
25fdce4a 2978 curpos = MgBYTEPOS(mg, TARG, truebase, len);
8ef97b0e
DM
2979 /* last time pos() was set, it was zero-length match */
2980 if (mg->mg_flags & MGf_MINMATCH)
2981 had_zerolen = 1;
2982 }
a0d0e21e 2983 }
8ef97b0e 2984
6e240d0b 2985#ifdef PERL_SAWAMPERSAND
196a02af 2986 if ( RXp_NPARENS(prog)
6502e081 2987 || PL_sawampersand
196a02af 2988 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 2989 || (dynpm->op_pmflags & PMf_KEEPCOPY)
6e240d0b
FC
2990 )
2991#endif
2992 {
6502e081
DM
2993 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
2994 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
2995 * only on the first iteration. Therefore we need to copy $' as well
2996 * as $&, to make the rest of the string available for captures in
2997 * subsequent iterations */
2998 if (! (global && gimme == G_ARRAY))
2999 r_flags |= REXEC_COPY_SKIP_POST;
3000 };
5b0e71e9
DM
3001#ifdef PERL_SAWAMPERSAND
3002 if (dynpm->op_pmflags & PMf_KEEPCOPY)
3003 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
3004 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
3005#endif
22e551b9 3006
f1d31338
DM
3007 s = truebase;
3008
d7be1480 3009 play_it_again:
985afbc1 3010 if (global)
03c83e26 3011 s = truebase + curpos;
f722798b 3012
77da2310 3013 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
03c83e26 3014 had_zerolen, TARG, NULL, r_flags))
03b6c93d 3015 goto nope;
77da2310
NC
3016
3017 PL_curpm = pm;
985afbc1 3018 if (dynpm->op_pmflags & PMf_ONCE)
c737faaf 3019#ifdef USE_ITHREADS
77da2310 3020 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
c737faaf 3021#else
77da2310 3022 dynpm->op_pmflags |= PMf_USED;
c737faaf 3023#endif
a0d0e21e 3024
72311751 3025 if (rxtainted)
196a02af
DM
3026 RXp_MATCH_TAINTED_on(prog);
3027 TAINT_IF(RXp_MATCH_TAINTED(prog));
35c2ccc3
DM
3028
3029 /* update pos */
3030
3031 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
b1422d62 3032 if (!mg)
35c2ccc3 3033 mg = sv_magicext_mglob(TARG);
196a02af
DM
3034 MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
3035 if (RXp_ZERO_LEN(prog))
adf51885
DM
3036 mg->mg_flags |= MGf_MINMATCH;
3037 else
3038 mg->mg_flags &= ~MGf_MINMATCH;
35c2ccc3
DM
3039 }
3040
196a02af 3041 if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
bf9dff51
DM
3042 LEAVE_SCOPE(oldsave);
3043 RETPUSHYES;
3044 }
3045
88ab22af
DM
3046 /* push captures on stack */
3047
bf9dff51 3048 {
196a02af 3049 const I32 nparens = RXp_NPARENS(prog);
a3b680e6 3050 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 3051
c277df42 3052 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
3053 EXTEND(SP, nparens + i);
3054 EXTEND_MORTAL(nparens + i);
3055 for (i = !i; i <= nparens; i++) {
a0d0e21e 3056 PUSHs(sv_newmortal());
196a02af
DM
3057 if (LIKELY((RXp_OFFS(prog)[i].start != -1)
3058 && RXp_OFFS(prog)[i].end != -1 ))
5d9574c1 3059 {
196a02af
DM
3060 const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
3061 const char * const s = RXp_OFFS(prog)[i].start + truebase;
3062 if (UNLIKELY( RXp_OFFS(prog)[i].end < 0
3063 || RXp_OFFS(prog)[i].start < 0
3064 || len < 0
3065 || len > strend - s)
3066 )
5637ef5b 3067 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
147e3846 3068 "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
196a02af
DM
3069 (long) i, (long) RXp_OFFS(prog)[i].start,
3070 (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
a0d0e21e 3071 sv_setpvn(*SP, s, len);
cce850e4 3072 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 3073 SvUTF8_on(*SP);
a0d0e21e
LW
3074 }
3075 }
3076 if (global) {
196a02af
DM
3077 curpos = (UV)RXp_OFFS(prog)[0].end;
3078 had_zerolen = RXp_ZERO_LEN(prog);
c277df42 3079 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 3080 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
3081 goto play_it_again;
3082 }
4633a7c4 3083 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
3084 RETURN;
3085 }
e5964223 3086 NOT_REACHED; /* NOTREACHED */
a0d0e21e 3087
7b52d656 3088 nope:
d65afb4b 3089 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
b1422d62
DM
3090 if (!mg)
3091 mg = mg_find_mglob(TARG);
3092 if (mg)
3093 mg->mg_len = -1;
a0d0e21e 3094 }
4633a7c4 3095 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
3096 if (gimme == G_ARRAY)
3097 RETURN;
3098 RETPUSHNO;
3099}
3100
3101OP *
864dbfa3 3102Perl_do_readline(pTHX)
a0d0e21e 3103{
20b7effb 3104 dSP; dTARGETSTACKED;
eb578fdb 3105 SV *sv;
a0d0e21e
LW
3106 STRLEN tmplen = 0;
3107 STRLEN offset;
760ac839 3108 PerlIO *fp;
eb578fdb
KW
3109 IO * const io = GvIO(PL_last_in_gv);
3110 const I32 type = PL_op->op_type;
1c23e2bd 3111 const U8 gimme = GIMME_V;
a0d0e21e 3112
6136c704 3113 if (io) {
50db69d8 3114 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 3115 if (mg) {
3e0cb5de 3116 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 3117 if (gimme == G_SCALAR) {
50db69d8
NC
3118 SPAGAIN;
3119 SvSetSV_nosteal(TARG, TOPs);
3120 SETTARG;
6136c704 3121 }
50db69d8 3122 return NORMAL;
0b7c7b4f 3123 }
e79b0511 3124 }
4608196e 3125 fp = NULL;
a0d0e21e
LW
3126 if (io) {
3127 fp = IoIFP(io);
3128 if (!fp) {
3129 if (IoFLAGS(io) & IOf_ARGV) {
3130 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 3131 IoLINES(io) = 0;
b9f2b683 3132 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 3133 IoFLAGS(io) &= ~IOf_START;
d5eb9a46 3134 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
4bac9ae4 3135 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
76f68e9b 3136 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3280af22 3137 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
3138 fp = IoIFP(io);
3139 goto have_fp;
a0d0e21e
LW
3140 }
3141 }
157fb5a1 3142 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e 3143 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 3144 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
3145 }
3146 }
0d44d22b
NC
3147 else if (type == OP_GLOB)
3148 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
3149 }
3150 else if (type == OP_GLOB)
3151 SP--;
7716c5c5 3152 else if (IoTYPE(io) == IoTYPE_WRONLY) {
a5390457 3153 report_wrongway_fh(PL_last_in_gv, '>');
a00b5bd3 3154 }
a0d0e21e
LW
3155 }
3156 if (!fp) {
041457d9 3157 if ((!io || !(IoFLAGS(io) & IOf_START))
de7dabb6
TC
3158 && ckWARN(WARN_CLOSED)
3159 && type != OP_GLOB)
041457d9 3160 {
de7dabb6 3161 report_evil_fh(PL_last_in_gv);
3f4520fe 3162 }
54310121 3163 if (gimme == G_SCALAR) {
79628082 3164 /* undef TARG, and push that undefined value */
ba92458f 3165 if (type != OP_RCATLINE) {
3773545d 3166 sv_set_undef(TARG);
ba92458f 3167 }
a0d0e21e
LW
3168 PUSHTARG;
3169 }
3170 RETURN;
3171 }
a2008d6d 3172 have_fp:
54310121 3173 if (gimme == G_SCALAR) {
a0d0e21e 3174 sv = TARG;
0f722b55
RGS
3175 if (type == OP_RCATLINE && SvGMAGICAL(sv))
3176 mg_get(sv);
48de12d9
RGS
3177 if (SvROK(sv)) {
3178 if (type == OP_RCATLINE)
5668452f 3179 SvPV_force_nomg_nolen(sv);
48de12d9
RGS
3180 else
3181 sv_unref(sv);
3182 }
f7877b28 3183 else if (isGV_with_GP(sv)) {
5668452f 3184 SvPV_force_nomg_nolen(sv);
f7877b28 3185 }
862a34c6 3186 SvUPGRADE(sv, SVt_PV);
a0d0e21e 3187 tmplen = SvLEN(sv); /* remember if already alloced */
e3918bb7 3188 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
f72e8700
JJ
3189 /* try short-buffering it. Please update t/op/readline.t
3190 * if you change the growth length.
3191 */
3192 Sv_Grow(sv, 80);
3193 }
2b5e58c4
AMS
3194 offset = 0;
3195 if (type == OP_RCATLINE && SvOK(sv)) {
3196 if (!SvPOK(sv)) {
5668452f 3197 SvPV_force_nomg_nolen(sv);
2b5e58c4 3198 }
a0d0e21e 3199 offset = SvCUR(sv);
2b5e58c4 3200 }
a0d0e21e 3201 }
54310121 3202 else {
561b68a9 3203 sv = sv_2mortal(newSV(80));
54310121
PP
3204 offset = 0;
3205 }
fbad3eb5 3206
3887d568
AP
3207 /* This should not be marked tainted if the fp is marked clean */
3208#define MAYBE_TAINT_LINE(io, sv) \
3209 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
3210 TAINT; \
3211 SvTAINTED_on(sv); \
3212 }
3213
684bef36 3214/* delay EOF state for a snarfed empty file */
fbad3eb5 3215#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 3216 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 3217 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 3218
a0d0e21e 3219 for (;;) {
09e8efcc 3220 PUTBACK;
fbad3eb5 3221 if (!sv_gets(sv, fp, offset)
2d726892
TF
3222 && (type == OP_GLOB
3223 || SNARF_EOF(gimme, PL_rs, io, sv)
3224 || PerlIO_error(fp)))
fbad3eb5 3225 {
760ac839 3226 PerlIO_clearerr(fp);
a0d0e21e 3227 if (IoFLAGS(io) & IOf_ARGV) {
157fb5a1 3228 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e
LW
3229 if (fp)
3230 continue;
3280af22 3231 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
3232 }
3233 else if (type == OP_GLOB) {
a2a5de95
NC
3234 if (!do_close(PL_last_in_gv, FALSE)) {
3235 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
3236 "glob failed (child exited with status %d%s)",
3237 (int)(STATUS_CURRENT >> 8),
3238 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 3239 }
a0d0e21e 3240 }
54310121 3241 if (gimme == G_SCALAR) {
ba92458f
AE
3242 if (type != OP_RCATLINE) {
3243 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 3244 SvOK_off(TARG);
ba92458f 3245 }
09e8efcc 3246 SPAGAIN;
a0d0e21e
LW
3247 PUSHTARG;
3248 }
3887d568 3249 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
3250 RETURN;
3251 }
3887d568 3252 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 3253 IoLINES(io)++;
b9fee9ba 3254 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 3255 SvSETMAGIC(sv);
09e8efcc 3256 SPAGAIN;
a0d0e21e 3257 XPUSHs(sv);
a0d0e21e 3258 if (type == OP_GLOB) {
349d4f2f 3259 const char *t1;
45a23732 3260 Stat_t statbuf;
a0d0e21e 3261
3280af22 3262 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
6136c704 3263 char * const tmps = SvEND(sv) - 1;
aa07b2f6 3264 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 3265 *tmps = '\0';
b162af07 3266 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd
PP
3267 }
3268 }
349d4f2f 3269 for (t1 = SvPVX_const(sv); *t1; t1++)
b51c3e77
CB
3270#ifdef __VMS
3271 if (strchr("*%?", *t1))
3272#else
7ad1e72d 3273 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
b51c3e77 3274#endif
a0d0e21e 3275 break;
45a23732 3276 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
a0d0e21e
LW
3277 (void)POPs; /* Unmatched wildcard? Chuck it... */
3278 continue;
3279 }
2d79bf7f 3280 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL
3281 if (ckWARN(WARN_UTF8)) {
3282 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
3283 const STRLEN len = SvCUR(sv) - offset;
3284 const U8 *f;
3285
3286 if (!is_utf8_string_loc(s, len, &f))
3287 /* Emulate :encoding(utf8) warning in the same case. */
3288 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3289 "utf8 \"\\x%02X\" does not map to Unicode",
3290 f < (U8*)SvEND(sv) ? *f : 0);
3291 }
a0d0e21e 3292 }
54310121 3293 if (gimme == G_ARRAY) {
a0d0e21e 3294 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 3295 SvPV_shrink_to_cur(sv);
a0d0e21e 3296 }
561b68a9 3297 sv = sv_2mortal(newSV(80));
a0d0e21e
LW
3298 continue;
3299 }
54310121 3300 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 3301 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
3302 const STRLEN new_len
3303 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 3304 SvPV_renew(sv, new_len);
a0d0e21e
LW
3305 }
3306 RETURN;
3307 }
3308}
3309
a0d0e21e
LW
3310PP(pp_helem)
3311{
20b7effb 3312 dSP;
760ac839 3313 HE* he;
ae77835f 3314 SV **svp;
c445ea15 3315 SV * const keysv = POPs;
85fbaab2 3316 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
3317 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3318 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 3319 SV *sv;
92970b93 3320 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 3321 bool preeminent = TRUE;
a0d0e21e 3322
6dfc73ea
SM
3323 if (SvTYPE(hv) != SVt_PVHV)
3324 RETPUSHUNDEF;
d4c19fe8 3325
92970b93 3326 if (localizing) {
d4c19fe8
AL
3327 MAGIC *mg;
3328 HV *stash;
d30e492c
VP
3329
3330 /* If we can determine whether the element exist,
3331 * Try to preserve the existenceness of a tied hash
3332 * element by using EXISTS and DELETE if possible.
3333 * Fallback to FETCH and STORE otherwise. */
2c5f48c2 3334 if (SvCANEXISTDELETE(hv))
d30e492c 3335 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 3336 }
d30e492c 3337
5f9d7e2b 3338 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
d4c19fe8 3339 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 3340 if (lval) {
746f6409 3341 if (!svp || !*svp || *svp == &PL_sv_undef) {
68dc0745
PP
3342 SV* lv;
3343 SV* key2;
2d8e6c8d 3344 if (!defer) {
be2597df 3345 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 3346 }
68dc0745
PP
3347 lv = sv_newmortal();
3348 sv_upgrade(lv, SVt_PVLV);
3349 LvTYPE(lv) = 'y';
6136c704 3350 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
fc2b2dca 3351 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
0ad694a7 3352 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
68dc0745
PP
3353 LvTARGLEN(lv) = 1;
3354 PUSHs(lv);
3355 RETURN;
3356 }
92970b93 3357 if (localizing) {
6881372e 3358 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
159b6efe 3359 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP
3360 else if (preeminent)
3361 save_helem_flags(hv, keysv, svp,
3362 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
3363 else
3364 SAVEHDELETE(hv, keysv);
5f05dabc 3365 }
9026059d
GG
3366 else if (PL_op->op_private & OPpDEREF) {
3367 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3368 RETURN;
3369 }
a0d0e21e 3370 }
746f6409 3371 sv = (svp && *svp ? *svp : &PL_sv_undef);
fd69380d
DM
3372 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
3373 * was to make C<local $tied{foo} = $tied{foo}> possible.
3374 * However, it seems no longer to be needed for that purpose, and
3375 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
3376 * would loop endlessly since the pos magic is getting set on the
3377 * mortal copy and lost. However, the copy has the effect of
3378 * triggering the get magic, and losing it altogether made things like
3379 * c<$tied{foo};> in void context no longer do get magic, which some
3380 * code relied on. Also, delayed triggering of magic on @+ and friends
3381 * meant the original regex may be out of scope by now. So as a
3382 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
3383 * being called too many times). */
39cf747a 3384 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
fd69380d 3385 mg_get(sv);
be6c24e0 3386 PUSHs(sv);
a0d0e21e
LW
3387 RETURN;
3388}
3389
fedf30e1
DM
3390
3391/* a stripped-down version of Perl_softref2xv() for use by
3392 * pp_multideref(), which doesn't use PL_op->op_flags */
3393
f9db5646 3394STATIC GV *
fedf30e1
DM
3395S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
3396 const svtype type)
3397{
3398 if (PL_op->op_private & HINT_STRICT_REFS) {
3399 if (SvOK(sv))
3400 Perl_die(aTHX_ PL_no_symref_sv, sv,
3401 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
3402 else
3403 Perl_die(aTHX_ PL_no_usym, what);
3404 }
3405 if (!SvOK(sv))
3406 Perl_die(aTHX_ PL_no_usym, what);
3407 return gv_fetchsv_nomg(sv, GV_ADD, type);
3408}
3409
3410
79815f56
DM
3411/* Handle one or more aggregate derefs and array/hash indexings, e.g.
3412 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
fedf30e1
DM
3413 *
3414 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
79815f56
DM
3415 * Each of these either contains a set of actions, or an argument, such as
3416 * an IV to use as an array index, or a lexical var to retrieve.
3417 * Several actions re stored per UV; we keep shifting new actions off the
3418 * one UV, and only reload when it becomes zero.
fedf30e1
DM
3419 */
3420
3421PP(pp_multideref)
3422{
3423 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
3424 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
3425 UV actions = items->uv;
3426
3427 assert(actions);
3428 /* this tells find_uninit_var() where we're up to */
3429 PL_multideref_pc = items;
3430
3431 while (1) {
3432 /* there are three main classes of action; the first retrieve
3433 * the initial AV or HV from a variable or the stack; the second
3434 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
3435 * the third an unrolled (/DREFHV, rv2hv, helem).
3436 */
3437 switch (actions & MDEREF_ACTION_MASK) {
3438
3439 case MDEREF_reload:
3440 actions = (++items)->uv;
3441 continue;
3442
3443 case MDEREF_AV_padav_aelem: /* $lex[...] */
3444 sv = PAD_SVl((++items)->pad_offset);
3445 goto do_AV_aelem;
3446
3447 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
3448 sv = UNOP_AUX_item_sv(++items);
3449 assert(isGV_with_GP(sv));
3450 sv = (SV*)GvAVn((GV*)sv);
3451 goto do_AV_aelem;
3452
3453 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
3454 {
3455 dSP;
3456 sv = POPs;
3457 PUTBACK;
3458 goto do_AV_rv2av_aelem;
3459 }
3460
3461 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
3462 sv = UNOP_AUX_item_sv(++items);
3463 assert(isGV_with_GP(sv));
3464 sv = GvSVn((GV*)sv);
3465 goto do_AV_vivify_rv2av_aelem;
3466
3467 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
3468 sv = PAD_SVl((++items)->pad_offset);
3469 /* FALLTHROUGH */
3470
3471 do_AV_vivify_rv2av_aelem:
3472 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
3473 /* this is the OPpDEREF action normally found at the end of
3474 * ops like aelem, helem, rv2sv */
3475 sv = vivify_ref(sv, OPpDEREF_AV);
3476 /* FALLTHROUGH */
3477
3478 do_AV_rv2av_aelem:
3479 /* this is basically a copy of pp_rv2av when it just has the
3480 * sKR/1 flags */
3481 SvGETMAGIC(sv);
3482 if (LIKELY(SvROK(sv))) {
3483 if (UNLIKELY(SvAMAGIC(sv))) {
3484 sv = amagic_deref_call(sv, to_av_amg);
3485 }
3486 sv = SvRV(sv);
3487 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
3488 DIE(aTHX_ "Not an ARRAY reference");
3489 }
3490 else if (SvTYPE(sv) != SVt_PVAV) {
3491 if (!isGV_with_GP(sv))
3492 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
3493 sv = MUTABLE_SV(GvAVn((GV*)sv));
3494 }
3495 /* FALLTHROUGH */
3496
3497 do_AV_aelem:
3498 {
3499 /* retrieve the key; this may be either a lexical or package
3500 * var (whose index/ptr is stored as an item) or a signed
3501 * integer constant stored as an item.
3502 */
3503 SV *elemsv;
3504 IV elem = 0; /* to shut up stupid compiler warnings */
3505
3506
3507 assert(SvTYPE(sv) == SVt_PVAV);
3508
3509 switch (actions & MDEREF_INDEX_MASK) {
3510 case MDEREF_INDEX_none:
3511 goto finish;
3512 case MDEREF_INDEX_const:
3513 elem = (++items)->iv;
3514 break;
3515 case MDEREF_INDEX_padsv:
3516 elemsv = PAD_SVl((++items)->pad_offset);
3517 goto check_elem;
3518 case MDEREF_INDEX_gvsv:
3519 elemsv = UNOP_AUX_item_sv(++items);
3520 assert(isGV_with_GP(elemsv));
3521 elemsv = GvSVn((GV*)elemsv);
3522 check_elem:
3523 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
3524 && ckWARN(WARN_MISC)))
3525 Perl_warner(aTHX_ packWARN(WARN_MISC),
147e3846 3526 "Use of reference \"%" SVf "\" as array index",
fedf30e1
DM
3527 SVfARG(elemsv));
3528 /* the only time that S_find_uninit_var() needs this
3529 * is to determine which index value triggered the
3530 * undef warning. So just update it here. Note that
3531 * since we don't save and restore this var (e.g. for
3532 * tie or overload execution), its value will be
3533 * meaningless apart from just here */
3534 PL_multideref_pc = items;
3535 elem = SvIV(elemsv);
3536 break;
3537 }
3538
3539
3540 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
3541
3542 if (!(actions & MDEREF_FLAG_last)) {
3543 SV** svp = av_fetch((AV*)sv, elem, 1);
3544 if (!svp || ! (sv=*svp))
3545 DIE(aTHX_ PL_no_aelem, elem);
3546 break;
3547 }
3548
3549 if (PL_op->op_private &
3550 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3551 {
3552 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3553 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
3554 }
3555 else {
3556 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3557 sv = av_delete((AV*)sv, elem, discard);
3558 if (discard)
3559 return NORMAL;
3560 if (!sv)
3561 sv = &PL_sv_undef;
3562 }
3563 }
3564 else {
3565 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3566 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3567 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3568 bool preeminent = TRUE;
3569 AV *const av = (AV*)sv;
3570 SV** svp;
3571
3572 if (UNLIKELY(localizing)) {
3573 MAGIC *mg;
3574 HV *stash;
3575
3576 /* If we can determine whether the element exist,
3577 * Try to preserve the existenceness of a tied array
3578 * element by using EXISTS and DELETE if possible.
3579 * Fallback to FETCH and STORE otherwise. */
3580 if (SvCANEXISTDELETE(av))
3581 preeminent = av_exists(av, elem);
3582 }
3583
3584 svp = av_fetch(av, elem, lval && !defer);
3585
3586 if (lval) {
3587 if (!svp || !(sv = *svp)) {
3588 IV len;
3589 if (!defer)
3590 DIE(aTHX_ PL_no_aelem, elem);
3591 len = av_tindex(av);
9ef753fe
FC
3592 /* Resolve a negative index that falls within
3593 * the array. Leave it negative it if falls
3594 * outside the array. */
3595 if (elem < 0 && len + elem >= 0)
3596 elem = len + elem;
3597 if (elem >= 0 && elem <= len)
3598 /* Falls within the array. */
3599 sv = av_nonelem(av,elem);
3600 else
3601 /* Falls outside the array. If it is neg-
3602 ative, magic_setdefelem will use the
3603 index for error reporting. */
3604 sv = sv_2mortal(newSVavdefelem(av,elem,1));
fedf30e1
DM
3605 }
3606 else {
3607 if (UNLIKELY(localizing)) {
3608 if (preeminent) {
3609 save_aelem(av, elem, svp);
3610 sv = *svp; /* may have changed */
3611 }
3612 else
3613 SAVEADELETE(av, elem);
3614 }
3615 }
3616 }
3617 else {
3618 sv = (svp ? *svp : &PL_sv_undef);
3619 /* see note in pp_helem() */
3620 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
3621 mg_get(sv);
3622 }
3623 }
3624
3625 }
3626 finish:
3627 {
3628 dSP;
3629 XPUSHs(sv);
3630 RETURN;
3631 }
3632 /* NOTREACHED */
3633
3634
3635
3636
3637 case MDEREF_HV_padhv_helem: /* $lex{...} */
3638 sv = PAD_SVl((++items)->pad_offset);
3639 goto do_HV_helem;
3640
3641 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
3642 sv = UNOP_AUX_item_sv(++items);
3643 assert(isGV_with_GP(sv));
3644 sv = (SV*)GvHVn((GV*)sv);
3645 goto do_HV_helem;
3646
3647 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
3648 {
3649 dSP;
3650 sv = POPs;
3651 PUTBACK;
3652 goto do_HV_rv2hv_helem;
3653 }
3654
3655 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
3656 sv = UNOP_AUX_item_sv(++items);
3657 assert(isGV_with_GP(sv));
3658 sv = GvSVn((GV*)sv);
3659 goto do_HV_vivify_rv2hv_helem;
3660
3661 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
3662 sv = PAD_SVl((++items)->pad_offset);
3663 /* FALLTHROUGH */
3664
3665 do_HV_vivify_rv2hv_helem:
3666 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
3667 /* this is the OPpDEREF action normally found at the end of
3668 * ops like aelem, helem, rv2sv */
3669 sv = vivify_ref(sv, OPpDEREF_HV);
3670 /* FALLTHROUGH */
3671
3672 do_HV_rv2hv_helem:
3673 /* this is basically a copy of pp_rv2hv when it just has the
3674 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
3675
3676 SvGETMAGIC(sv);
3677 if (LIKELY(SvROK(sv))) {
3678 if (UNLIKELY(SvAMAGIC(sv))) {
3679 sv = amagic_deref_call(sv, to_hv_amg);
3680 }
3681 sv = SvRV(sv);
3682 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
3683 DIE(aTHX_ "Not a HASH reference");
3684 }
3685 else if (SvTYPE(sv) != SVt_PVHV) {
3686 if (!isGV_with_GP(sv))
3687 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
3688 sv = MUTABLE_SV(GvHVn((GV*)sv));
3689 }
3690 /* FALLTHROUGH */
3691
3692 do_HV_helem:
3693 {
3694 /* retrieve the key; this may be either a lexical / package
3695 * var or a string constant, whose index/ptr is stored as an
3696 * item
3697 */
3698 SV *keysv = NULL; /* to shut up stupid compiler warnings */
3699
3700 assert(SvTYPE(sv) == SVt_PVHV);
3701
3702 switch (actions & MDEREF_INDEX_MASK) {
3703 case MDEREF_INDEX_none:
3704 goto finish;
3705
3706 case MDEREF_INDEX_const:
3707 keysv = UNOP_AUX_item_sv(++items);
3708 break;
3709
3710 case MDEREF_INDEX_padsv:
3711 keysv = PAD_SVl((++items)->pad_offset);
3712 break;
3713
3714 case MDEREF_INDEX_gvsv:
3715 keysv = UNOP_AUX_item_sv(++items);
3716 keysv = GvSVn((GV*)keysv);
3717 break;
3718 }
3719
3720 /* see comment above about setting this var */
3721 PL_multideref_pc = items;
3722
3723
3724 /* ensure that candidate CONSTs have been HEKified */
3725 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
3726 || SvTYPE(keysv) >= SVt_PVMG
3727 || !SvOK(keysv)
3728 || SvROK(keysv)
3729 || SvIsCOW_shared_hash(keysv));
3730
3731 /* this is basically a copy of pp_helem with OPpDEREF skipped */
3732
3733 if (!(actions & MDEREF_FLAG_last)) {
3734 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
3735 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
3736 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3737 break;
3738 }
3739
3740 if (PL_op->op_private &
3741 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3742 {
3743 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3744 sv = hv_exists_ent((HV*)sv, keysv, 0)
3745 ? &PL_sv_yes : &PL_sv_no;
3746 }
3747 else {
3748 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3749 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
3750 if (discard)
3751 return NORMAL;
3752 if (!sv)
3753 sv = &PL_sv_undef;
3754 }
3755 }
3756 else {
3757 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3758 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3759 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3760 bool preeminent = TRUE;
3761 SV **svp;
3762 HV * const hv = (HV*)sv;
3763 HE* he;
3764
3765