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