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