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