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