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