This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
S_padhv_rv2hv_common(): unroll hv_scalar() calls
[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
DM
975{
976 bool tied;
e1ad5d4c 977 MAGIC *mg;
aa36782f
DM
978 dSP;
979
980 assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
981
982 if (gimme == G_ARRAY) {
af3b1cba
DM
983 hv_pushkv(hv);
984 return NORMAL;
aa36782f
DM
985 }
986
987 if (is_keys)
988 /* 'keys %h' masquerading as '%h': reset iterator */
989 (void)hv_iterinit(hv);
990
e1ad5d4c 991 tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
aa36782f
DM
992
993 if ( ( PL_op->op_private & OPpTRUEBOOL
994 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
995 && block_gimme() == G_VOID)
996 )
3cd2c7d4
DM
997 ) {
998 if (tied)
e1ad5d4c 999 PUSHs(magic_scalarpack(hv, mg));
3cd2c7d4
DM
1000 else
1001 PUSHs(HvUSEDKEYS(hv) ? &PL_sv_yes : &PL_sv_zero);
1002 }
aa36782f
DM
1003 else if (gimme == G_SCALAR) {
1004 if (is_keys) {
1005 IV i;
1006 if (tied) {
1007 i = 0;
1008 while (hv_iternext(hv))
1009 i++;
1010 }
1011 else
1012 i = HvUSEDKEYS(hv);
e84e4286
DM
1013 if (has_targ) {
1014 dTARGET;
1015 PUSHi(i);
1016 }
1017 else
1018 mPUSHi(i);
aa36782f 1019 }
e1ad5d4c
DM
1020 else {
1021 if (tied)
1022 PUSHs(magic_scalarpack(hv, mg));
1023 else
1024 mPUSHi(HvUSEDKEYS(hv));
1025 }
aa36782f
DM
1026 }
1027
1028 PUTBACK;
1029 return NORMAL;
1030}
1031
1032
e855b461
DM
1033/* This is also called directly by pp_lvavref. */
1034PP(pp_padav)
1035{
1036 dSP; dTARGET;
1037 U8 gimme;
1038 assert(SvTYPE(TARG) == SVt_PVAV);
1039 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1040 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1041 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1042 EXTEND(SP, 1);
1043
1044 if (PL_op->op_flags & OPf_REF) {
1045 PUSHs(TARG);
1046 RETURN;
1047 }
1048 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1049 const I32 flags = is_lvalue_sub();
1050 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1051 if (GIMME_V == G_SCALAR)
1052 /* diag_listed_as: Can't return %s to lvalue scalar context */
1053 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
1054 PUSHs(TARG);
1055 RETURN;
1056 }
1057 }
1058
1059 gimme = GIMME_V;
0b5aba47
DM
1060 if (gimme == G_ARRAY)
1061 return S_pushav(aTHX_ (AV*)TARG);
327c9b9e
DM
1062
1063 if (gimme == G_SCALAR) {
e855b461
DM
1064 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
1065 if (!maxarg)
1066 PUSHs(&PL_sv_zero);
1067 else if (PL_op->op_private & OPpTRUEBOOL)
1068 PUSHs(&PL_sv_yes);
1069 else
1070 mPUSHi(maxarg);
1071 }
1072 RETURN;
1073}
1074
1075
1076PP(pp_padhv)
1077{
1078 dSP; dTARGET;
1079 U8 gimme;
e855b461
DM
1080
1081 assert(SvTYPE(TARG) == SVt_PVHV);
e855b461
DM
1082 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1083 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1084 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1085
aa36782f
DM
1086 EXTEND(SP, 1);
1087
1088 if (PL_op->op_flags & OPf_REF) {
1089 PUSHs(TARG);
e855b461 1090 RETURN;
aa36782f 1091 }
e855b461
DM
1092 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1093 const I32 flags = is_lvalue_sub();
1094 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1095 if (GIMME_V == G_SCALAR)
1096 /* diag_listed_as: Can't return %s to lvalue scalar context */
1097 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
aa36782f 1098 PUSHs(TARG);
e855b461
DM
1099 RETURN;
1100 }
1101 }
1102
1103 gimme = GIMME_V;
e855b461 1104
aa36782f 1105 return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
e84e4286
DM
1106 cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
1107 0 /* has_targ*/);
e855b461
DM
1108}
1109
1110
b1c05ba5 1111/* also used for: pp_rv2hv() */
bdaf10a5 1112/* also called directly by pp_lvavref */
b1c05ba5 1113
a0d0e21e
LW
1114PP(pp_rv2av)
1115{
20b7effb 1116 dSP; dTOPss;
1c23e2bd 1117 const U8 gimme = GIMME_V;
13c59d41
MH
1118 static const char an_array[] = "an ARRAY";
1119 static const char a_hash[] = "a HASH";
bdaf10a5
FC
1120 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
1121 || PL_op->op_type == OP_LVAVREF;
d83b45b8 1122 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e 1123
9026059d 1124 SvGETMAGIC(sv);
a0d0e21e 1125 if (SvROK(sv)) {
5d9574c1 1126 if (UNLIKELY(SvAMAGIC(sv))) {
93d7320b 1127 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
93d7320b 1128 }
17ab7946 1129 sv = SvRV(sv);
5d9574c1 1130 if (UNLIKELY(SvTYPE(sv) != type))
dcbac5bb 1131 /* diag_listed_as: Not an ARRAY reference */
13c59d41 1132 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
5d9574c1
DM
1133 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
1134 && PL_op->op_private & OPpLVAL_INTRO))
3da99855 1135 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e 1136 }
5d9574c1 1137 else if (UNLIKELY(SvTYPE(sv) != type)) {
67955e0c 1138 GV *gv;
1c846c1f 1139
6e592b3a 1140 if (!isGV_with_GP(sv)) {
13c59d41 1141 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
dc3c76f8
NC
1142 type, &sp);
1143 if (!gv)
1144 RETURN;
35cd451c
GS
1145 }
1146 else {
159b6efe 1147 gv = MUTABLE_GV(sv);
a0d0e21e 1148 }
ad64d0ec 1149 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
533c011a 1150 if (PL_op->op_private & OPpLVAL_INTRO)
ad64d0ec 1151 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
9f527363
FC
1152 }
1153 if (PL_op->op_flags & OPf_REF) {
17ab7946 1154 SETs(sv);
a0d0e21e 1155 RETURN;
9f527363 1156 }
5d9574c1 1157 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
40c94d11
FC
1158 const I32 flags = is_lvalue_sub();
1159 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 1160 if (gimme != G_ARRAY)
042560a6 1161 goto croak_cant_return;
17ab7946 1162 SETs(sv);
78f9721b 1163 RETURN;
40c94d11 1164 }
a0d0e21e
LW
1165 }
1166
17ab7946 1167 if (is_pp_rv2av) {
502c6561 1168 AV *const av = MUTABLE_AV(sv);
0b5aba47 1169
96913b52 1170 if (gimme == G_ARRAY) {
d5524600
DM
1171 SP--;
1172 PUTBACK;
0b5aba47 1173 return S_pushav(aTHX_ av);
1c846c1f 1174 }
0b5aba47
DM
1175
1176 if (gimme == G_SCALAR) {
c70927a6 1177 const SSize_t maxarg = AvFILL(av) + 1;
7be75ccf
DM
1178 if (PL_op->op_private & OPpTRUEBOOL)
1179 SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
1180 else {
1181 dTARGET;
1182 SETi(maxarg);
1183 }
93965878 1184 }
7be75ccf
DM
1185 }
1186 else {
aa36782f
DM
1187 SP--; PUTBACK;
1188 return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
e84e4286
DM
1189 cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
1190 1 /* has_targ*/);
17ab7946 1191 }
be85d344 1192 RETURN;
042560a6
NC
1193
1194 croak_cant_return:
1195 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
1196 is_pp_rv2av ? "array" : "hash");
77e217c6 1197 RETURN;
a0d0e21e
LW
1198}
1199
10c8fecd 1200STATIC void
fb8f4cf8 1201S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
10c8fecd 1202{
7918f24d
NC
1203 PERL_ARGS_ASSERT_DO_ODDBALL;
1204
fb8f4cf8 1205 if (*oddkey) {
6d822dc4 1206 if (ckWARN(WARN_MISC)) {
a3b680e6 1207 const char *err;
fb8f4cf8
RZ
1208 if (oddkey == firstkey &&
1209 SvROK(*oddkey) &&
1210 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
1211 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
10c8fecd 1212 {
a3b680e6 1213 err = "Reference found where even-sized list expected";
10c8fecd
GS
1214 }
1215 else
a3b680e6 1216 err = "Odd number of elements in hash assignment";
f1f66076 1217 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
10c8fecd 1218 }
6d822dc4 1219
10c8fecd
GS
1220 }
1221}
1222
a5f48505
DM
1223
1224/* Do a mark and sweep with the SVf_BREAK flag to detect elements which
1225 * are common to both the LHS and RHS of an aassign, and replace them
1226 * with copies. All these copies are made before the actual list assign is
1227 * done.
1228 *
1229 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
1230 * element ($b) to the first LH element ($a), modifies $a; when the
1231 * second assignment is done, the second RH element now has the wrong
1232 * value. So we initially replace the RHS with ($b, mortalcopy($a)).
1233 * Note that we don't need to make a mortal copy of $b.
1234 *
1235 * The algorithm below works by, for every RHS element, mark the
1236 * corresponding LHS target element with SVf_BREAK. Then if the RHS
1237 * element is found with SVf_BREAK set, it means it would have been
1238 * modified, so make a copy.
1239 * Note that by scanning both LHS and RHS in lockstep, we avoid
1240 * unnecessary copies (like $b above) compared with a naive
1241 * "mark all LHS; copy all marked RHS; unmark all LHS".
1242 *
1243 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
1244 * it can't be common and can be skipped.
ebc643ce
DM
1245 *
1246 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
1247 * that we thought we didn't need to call S_aassign_copy_common(), but we
1248 * have anyway for sanity checking. If we find we need to copy, then panic.
a5f48505
DM
1249 */
1250
1251PERL_STATIC_INLINE void
1252S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
ebc643ce
DM
1253 SV **firstrelem, SV **lastrelem
1254#ifdef DEBUGGING
1255 , bool fake
1256#endif
1257)
a5f48505
DM
1258{
1259 dVAR;
1260 SV **relem;
1261 SV **lelem;
1262 SSize_t lcount = lastlelem - firstlelem + 1;
1263 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
1264 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
beb08a1e 1265 bool copy_all = FALSE;
a5f48505
DM
1266
1267 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
1268 assert(firstlelem < lastlelem); /* at least 2 LH elements */
1269 assert(firstrelem < lastrelem); /* at least 2 RH elements */
1270
ebc643ce
DM
1271
1272 lelem = firstlelem;
a5f48505
DM
1273 /* we never have to copy the first RH element; it can't be corrupted
1274 * by assigning something to the corresponding first LH element.
1275 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
1276 */
ebc643ce 1277 relem = firstrelem + 1;
a5f48505
DM
1278
1279 for (; relem <= lastrelem; relem++) {
1280 SV *svr;
1281
1282 /* mark next LH element */
1283
1284 if (--lcount >= 0) {
1285 SV *svl = *lelem++;
1286
1287 if (UNLIKELY(!svl)) {/* skip AV alias marker */
1288 assert (lelem <= lastlelem);
1289 svl = *lelem++;
1290 lcount--;
1291 }
1292
1293 assert(svl);
beb08a1e
TC
1294 if (SvSMAGICAL(svl)) {
1295 copy_all = TRUE;
1296 }
a5f48505
DM
1297 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
1298 if (!marked)
1299 return;
1300 /* this LH element will consume all further args;
1301 * no need to mark any further LH elements (if any).
1302 * But we still need to scan any remaining RHS elements;
1303 * set lcount negative to distinguish from lcount == 0,
1304 * so the loop condition continues being true
1305 */
1306 lcount = -1;
1307 lelem--; /* no need to unmark this element */
1308 }
94a5f659 1309 else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
a5f48505
DM
1310 SvFLAGS(svl) |= SVf_BREAK;
1311 marked = TRUE;
1312 }
1313 else if (!marked) {
1314 /* don't check RH element if no SVf_BREAK flags set yet */
1315 if (!lcount)
1316 break;
1317 continue;
1318 }
1319 }
1320
1321 /* see if corresponding RH element needs copying */
1322
1323 assert(marked);
1324 svr = *relem;
1325 assert(svr);
1326
5c1db569 1327 if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
1050723f 1328 U32 brk = (SvFLAGS(svr) & SVf_BREAK);
a5f48505 1329
ebc643ce
DM
1330#ifdef DEBUGGING
1331 if (fake) {
9ae0115f 1332 /* op_dump(PL_op); */
ebc643ce
DM
1333 Perl_croak(aTHX_
1334 "panic: aassign skipped needed copy of common RH elem %"
1335 UVuf, (UV)(relem - firstrelem));
1336 }
1337#endif
1338
a5f48505
DM
1339 TAINT_NOT; /* Each item is independent */
1340
1341 /* Dear TODO test in t/op/sort.t, I love you.
1342 (It's relying on a panic, not a "semi-panic" from newSVsv()
1343 and then an assertion failure below.) */
1344 if (UNLIKELY(SvIS_FREED(svr))) {
1345 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1346 (void*)svr);
1347 }
1348 /* avoid break flag while copying; otherwise COW etc
1349 * disabled... */
1350 SvFLAGS(svr) &= ~SVf_BREAK;
1351 /* Not newSVsv(), as it does not allow copy-on-write,
8c1e192f
DM
1352 resulting in wasteful copies.
1353 Also, we use SV_NOSTEAL in case the SV is used more than
1354 once, e.g. (...) = (f())[0,0]
1355 Where the same SV appears twice on the RHS without a ref
1356 count bump. (Although I suspect that the SV won't be
1357 stealable here anyway - DAPM).
1358 */
a5f48505
DM
1359 *relem = sv_mortalcopy_flags(svr,
1360 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1361 /* ... but restore afterwards in case it's needed again,
1362 * e.g. ($a,$b,$c) = (1,$a,$a)
1363 */
1050723f 1364 SvFLAGS(svr) |= brk;
a5f48505
DM
1365 }
1366
1367 if (!lcount)
1368 break;
1369 }
1370
1371 if (!marked)
1372 return;
1373
1374 /*unmark LHS */
1375
1376 while (lelem > firstlelem) {
1377 SV * const svl = *(--lelem);
1378 if (svl)
1379 SvFLAGS(svl) &= ~SVf_BREAK;
1380 }
1381}
1382
1383
1384
a0d0e21e
LW
1385PP(pp_aassign)
1386{
27da23d5 1387 dVAR; dSP;
3280af22
NIS
1388 SV **lastlelem = PL_stack_sp;
1389 SV **lastrelem = PL_stack_base + POPMARK;
1390 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
1391 SV **firstlelem = lastrelem + 1;
1392
eb578fdb
KW
1393 SV **relem;
1394 SV **lelem;
1c23e2bd 1395 U8 gimme;
a68090fe
DM
1396 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
1397 * only need to save locally, not on the save stack */
1398 U16 old_delaymagic = PL_delaymagic;
ebc643ce
DM
1399#ifdef DEBUGGING
1400 bool fake = 0;
1401#endif
5637b936 1402
3280af22 1403 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
a0d0e21e
LW
1404
1405 /* If there's a common identifier on both sides we have to take
1406 * special care that assigning the identifier on the left doesn't
1407 * clobber a value on the right that's used later in the list.
1408 */
acdea6f0 1409
beb08a1e
TC
1410 /* at least 2 LH and RH elements, or commonality isn't an issue */
1411 if (firstlelem < lastlelem && firstrelem < lastrelem) {
5c1db569
TC
1412 for (relem = firstrelem+1; relem <= lastrelem; relem++) {
1413 if (SvGMAGICAL(*relem))
1414 goto do_scan;
1415 }
beb08a1e
TC
1416 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1417 if (*lelem && SvSMAGICAL(*lelem))
1418 goto do_scan;
a5f48505 1419 }
beb08a1e
TC
1420 if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
1421 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
1422 /* skip the scan if all scalars have a ref count of 1 */
1423 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
8b0c3377 1424 SV *sv = *lelem;
beb08a1e
TC
1425 if (!sv || SvREFCNT(sv) == 1)
1426 continue;
1427 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
1428 goto do_scan;
1429 break;
1430 }
1431 }
1432 else {
1433 do_scan:
1434 S_aassign_copy_common(aTHX_
1435 firstlelem, lastlelem, firstrelem, lastrelem
ebc643ce 1436#ifdef DEBUGGING
beb08a1e 1437 , fake
ebc643ce 1438#endif
beb08a1e
TC
1439 );
1440 }
a5f48505 1441 }
a0d0e21e 1442 }
ebc643ce
DM
1443#ifdef DEBUGGING
1444 else {
1445 /* on debugging builds, do the scan even if we've concluded we
1446 * don't need to, then panic if we find commonality. Note that the
1447 * scanner assumes at least 2 elements */
1448 if (firstlelem < lastlelem && firstrelem < lastrelem) {
1449 fake = 1;
1450 goto do_scan;
1451 }
1452 }
1453#endif
a0d0e21e 1454
a5f48505 1455 gimme = GIMME_V;
a0d0e21e
LW
1456 relem = firstrelem;
1457 lelem = firstlelem;
10c8fecd 1458
8b0c3377
DM
1459 if (relem > lastrelem)
1460 goto no_relems;
1461
1462 /* first lelem loop while there are still relems */
5d9574c1 1463 while (LIKELY(lelem <= lastlelem)) {
bdaf10a5 1464 bool alias = FALSE;
8b0c3377
DM
1465 SV *lsv = *lelem++;
1466
c73f612f
DM
1467 TAINT_NOT; /* Each item stands on its own, taintwise. */
1468
8b0c3377
DM
1469 assert(relem <= lastrelem);
1470 if (UNLIKELY(!lsv)) {
bdaf10a5 1471 alias = TRUE;
8b0c3377
DM
1472 lsv = *lelem++;
1473 ASSUME(SvTYPE(lsv) == SVt_PVAV);
bdaf10a5 1474 }
a5f48505 1475
8b0c3377
DM
1476 switch (SvTYPE(lsv)) {
1477 case SVt_PVAV: {
1478 SV **svp;
1479 SSize_t i;
1480 SSize_t tmps_base;
1481 SSize_t nelems = lastrelem - relem + 1;
b09ed995 1482 AV *ary = MUTABLE_AV(lsv);
8b0c3377
DM
1483
1484 /* Assigning to an aggregate is tricky. First there is the
1485 * issue of commonality, e.g. @a = ($a[0]). Since the
1486 * stack isn't refcounted, clearing @a prior to storing
1487 * elements will free $a[0]. Similarly with
1488 * sub FETCH { $status[$_[1]] } @status = @tied[0,1];
1489 *
1490 * The way to avoid these issues is to make the copy of each
1491 * SV (and we normally store a *copy* in the array) *before*
1492 * clearing the array. But this has a problem in that
1493 * if the code croaks during copying, the not-yet-stored copies
1494 * could leak. One way to avoid this is to make all the copies
1495 * mortal, but that's quite expensive.
1496 *
1497 * The current solution to these issues is to use a chunk
1498 * of the tmps stack as a temporary refcounted-stack. SVs
1499 * will be put on there during processing to avoid leaks,
1500 * but will be removed again before the end of this block,
1501 * so free_tmps() is never normally called. Also, the
1502 * sv_refcnt of the SVs doesn't have to be manipulated, since
1503 * the ownership of 1 reference count is transferred directly
1504 * from the tmps stack to the AV when the SV is stored.
1505 *
1506 * We disarm slots in the temps stack by storing PL_sv_undef
1507 * there: it doesn't matter if that SV's refcount is
1508 * repeatedly decremented during a croak. But usually this is
1509 * only an interim measure. By the end of this code block
1510 * we try where possible to not leave any PL_sv_undef's on the
1511 * tmps stack e.g. by shuffling newer entries down.
1512 *
1513 * There is one case where we don't copy: non-magical
1514 * SvTEMP(sv)'s with a ref count of 1. The only owner of these
1515 * is on the tmps stack, so its safe to directly steal the SV
1516 * rather than copying. This is common in things like function
1517 * returns, map etc, which all return a list of such SVs.
1518 *
1519 * Note however something like @a = (f())[0,0], where there is
1520 * a danger of the same SV being shared: this avoided because
1521 * when the SV is stored as $a[0], its ref count gets bumped,
1522 * so the RC==1 test fails and the second element is copied
1523 * instead.
1524 *
1525 * We also use one slot in the tmps stack to hold an extra
1526 * ref to the array, to ensure it doesn't get prematurely
1527 * freed. Again, this is removed before the end of this block.
1528 *
1529 * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
1530 * @a = ($a[0]) case, but the current implementation uses the
1531 * same algorithm regardless, so ignores that flag. (It *is*
1532 * used in the hash branch below, however).
1533 */
1534
1535 /* Reserve slots for ary, plus the elems we're about to copy,
1536 * then protect ary and temporarily void the remaining slots
1537 * with &PL_sv_undef */
1538 EXTEND_MORTAL(nelems + 1);
1539 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
1540 tmps_base = PL_tmps_ix + 1;
1541 for (i = 0; i < nelems; i++)
1542 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1543 PL_tmps_ix += nelems;
1544
1545 /* Make a copy of each RHS elem and save on the tmps_stack
1546 * (or pass through where we can optimise away the copy) */
1547
1548 if (UNLIKELY(alias)) {
1549 U32 lval = (gimme == G_ARRAY)
1550 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
a5f48505 1551 for (svp = relem; svp <= lastrelem; svp++) {
8b0c3377
DM
1552 SV *rsv = *svp;
1553
1554 SvGETMAGIC(rsv);
1555 if (!SvROK(rsv))
1556 DIE(aTHX_ "Assigned value is not a reference");
1557 if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
1558 /* diag_listed_as: Assigned value is not %s reference */
1559 DIE(aTHX_
1560 "Assigned value is not a SCALAR reference");
1561 if (lval)
1562 *svp = rsv = sv_mortalcopy(rsv);
1563 /* XXX else check for weak refs? */
1564 rsv = SvREFCNT_inc_NN(SvRV(rsv));
1565 assert(tmps_base <= PL_tmps_max);
1566 PL_tmps_stack[tmps_base++] = rsv;
a5f48505 1567 }
a5f48505 1568 }
8b0c3377
DM
1569 else {
1570 for (svp = relem; svp <= lastrelem; svp++) {
1571 SV *rsv = *svp;
a5f48505 1572
8b0c3377
DM
1573 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
1574 /* can skip the copy */
1575 SvREFCNT_inc_simple_void_NN(rsv);
1576 SvTEMP_off(rsv);
1577 }
a5f48505 1578 else {
8b0c3377
DM
1579 SV *nsv;
1580 /* do get before newSV, in case it dies and leaks */
1581 SvGETMAGIC(rsv);
1582 nsv = newSV(0);
8c1e192f
DM
1583 /* see comment in S_aassign_copy_common about
1584 * SV_NOSTEAL */
8b0c3377
DM
1585 sv_setsv_flags(nsv, rsv,
1586 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1587 rsv = *svp = nsv;
a5f48505 1588 }
8b0c3377
DM
1589
1590 assert(tmps_base <= PL_tmps_max);
1591 PL_tmps_stack[tmps_base++] = rsv;
1592 }
1593 }
1594
1595 if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
1596 av_clear(ary);
1597
1598 /* store in the array, the SVs that are in the tmps stack */
1599
1600 tmps_base -= nelems;
1601
80c1439f 1602 if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
8b0c3377
DM
1603 /* for arrays we can't cheat with, use the official API */
1604 av_extend(ary, nelems - 1);
1605 for (i = 0; i < nelems; i++) {
1606 SV **svp = &(PL_tmps_stack[tmps_base + i]);
1607 SV *rsv = *svp;
1608 /* A tied store won't take ownership of rsv, so keep
1609 * the 1 refcnt on the tmps stack; otherwise disarm
1610 * the tmps stack entry */
1611 if (av_store(ary, i, rsv))
1612 *svp = &PL_sv_undef;
1613 /* av_store() may have added set magic to rsv */;
1614 SvSETMAGIC(rsv);
1615 }
1616 /* disarm ary refcount: see comments below about leak */
1617 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
1618 }
1619 else {
1620 /* directly access/set the guts of the AV */
1621 SSize_t fill = nelems - 1;
1622 if (fill > AvMAX(ary))
1623 av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
1624 &AvARRAY(ary));
1625 AvFILLp(ary) = fill;
1626 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
1627 /* Quietly remove all the SVs from the tmps stack slots,
1628 * since ary has now taken ownership of the refcnt.
1629 * Also remove ary: which will now leak if we die before
1630 * the SvREFCNT_dec_NN(ary) below */
1631 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
1632 Move(&PL_tmps_stack[tmps_base + nelems],
1633 &PL_tmps_stack[tmps_base - 1],
1634 PL_tmps_ix - (tmps_base + nelems) + 1,
1635 SV*);
1636 PL_tmps_ix -= (nelems + 1);
1637 }
1638
5d9574c1 1639 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
8b0c3377 1640 /* its assumed @ISA set magic can't die and leak ary */
ad64d0ec 1641 SvSETMAGIC(MUTABLE_SV(ary));
8b0c3377
DM
1642 SvREFCNT_dec_NN(ary);
1643
1644 relem = lastrelem + 1;
1645 goto no_relems;
a5f48505
DM
1646 }
1647
10c8fecd 1648 case SVt_PVHV: { /* normal hash */
8b0c3377
DM
1649
1650 SV **svp;
1651 bool dirty_tmps;
1652 SSize_t i;
1653 SSize_t tmps_base;
1654 SSize_t nelems = lastrelem - relem + 1;
b09ed995 1655 HV *hash = MUTABLE_HV(lsv);
8b0c3377
DM
1656
1657 if (UNLIKELY(nelems & 1)) {
1658 do_oddball(lastrelem, relem);
1659 /* we have firstlelem to reuse, it's not needed any more */
1660 *++lastrelem = &PL_sv_undef;
1661 nelems++;
1662 }
1663
1664 /* See the SVt_PVAV branch above for a long description of
1665 * how the following all works. The main difference for hashes
1666 * is that we treat keys and values separately (and have
1667 * separate loops for them): as for arrays, values are always
1668 * copied (except for the SvTEMP optimisation), since they
1669 * need to be stored in the hash; while keys are only
1670 * processed where they might get prematurely freed or
1671 * whatever. */
1672
1673 /* tmps stack slots:
1674 * * reserve a slot for the hash keepalive;
1675 * * reserve slots for the hash values we're about to copy;
1676 * * preallocate for the keys we'll possibly copy or refcount bump
1677 * later;
1678 * then protect hash and temporarily void the remaining
1679 * value slots with &PL_sv_undef */
1680 EXTEND_MORTAL(nelems + 1);
1681
1682 /* convert to number of key/value pairs */
1683 nelems >>= 1;
1684
1685 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
1686 tmps_base = PL_tmps_ix + 1;
1687 for (i = 0; i < nelems; i++)
1688 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1689 PL_tmps_ix += nelems;
1690
1691 /* Make a copy of each RHS hash value and save on the tmps_stack
1692 * (or pass through where we can optimise away the copy) */
1693
1694 for (svp = relem + 1; svp <= lastrelem; svp += 2) {
1695 SV *rsv = *svp;
1696
1697 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
1698 /* can skip the copy */
1699 SvREFCNT_inc_simple_void_NN(rsv);
1700 SvTEMP_off(rsv);
1701 }
1702 else {
1703 SV *nsv;
1704 /* do get before newSV, in case it dies and leaks */
1705 SvGETMAGIC(rsv);
1706 nsv = newSV(0);
1707 /* see comment in S_aassign_copy_common about
1708 * SV_NOSTEAL */
1709 sv_setsv_flags(nsv, rsv,
1710 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1711 rsv = *svp = nsv;
1c4ea384
RZ
1712 }
1713
8b0c3377
DM
1714 assert(tmps_base <= PL_tmps_max);
1715 PL_tmps_stack[tmps_base++] = rsv;
1716 }
1717 tmps_base -= nelems;
a5f48505 1718
a5f48505 1719
8b0c3377
DM
1720 /* possibly protect keys */
1721
1722 if (UNLIKELY(gimme == G_ARRAY)) {
1723 /* handle e.g.
1724 * @a = ((%h = ($$r, 1)), $r = "x");
1725 * $_++ for %h = (1,2,3,4);
1726 */
1727 EXTEND_MORTAL(nelems);
1728 for (svp = relem; svp <= lastrelem; svp += 2)
1729 *svp = sv_mortalcopy_flags(*svp,
1730 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1731 }
1732 else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
1733 /* for possible commonality, e.g.
1734 * %h = ($h{a},1)
1735 * avoid premature freeing RHS keys by mortalising
1736 * them.
1737 * For a magic element, make a copy so that its magic is
1738 * called *before* the hash is emptied (which may affect
1739 * a tied value for example).
1740 * In theory we should check for magic keys in all
1741 * cases, not just under OPpASSIGN_COMMON_AGG, but in
1742 * practice, !OPpASSIGN_COMMON_AGG implies only
1743 * constants or padtmps on the RHS.
1744 */
1745 EXTEND_MORTAL(nelems);
1746 for (svp = relem; svp <= lastrelem; svp += 2) {
1747 SV *rsv = *svp;
1748 if (UNLIKELY(SvGMAGICAL(rsv))) {
1749 SSize_t n;
a5f48505
DM
1750 *svp = sv_mortalcopy_flags(*svp,
1751 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
8b0c3377
DM
1752 /* allow other branch to continue pushing
1753 * onto tmps stack without checking each time */
1754 n = (lastrelem - relem) >> 1;
1755 EXTEND_MORTAL(n);
a5f48505 1756 }
8b0c3377
DM
1757 else
1758 PL_tmps_stack[++PL_tmps_ix] =
1759 SvREFCNT_inc_simple_NN(rsv);
a5f48505 1760 }
8b0c3377 1761 }
a5f48505 1762
8b0c3377
DM
1763 if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
1764 hv_clear(hash);
a5f48505 1765
8b0c3377
DM
1766 /* now assign the keys and values to the hash */
1767
1768 dirty_tmps = FALSE;
1769
1770 if (UNLIKELY(gimme == G_ARRAY)) {
1771 /* @a = (%h = (...)) etc */
1772 SV **svp;
1773 SV **topelem = relem;
1774
1775 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
1776 SV *key = *svp++;
1777 SV *val = *svp;
1778 /* remove duplicates from list we return */
1779 if (!hv_exists_ent(hash, key, 0)) {
1780 /* copy key back: possibly to an earlier
1781 * stack location if we encountered dups earlier,
1782 * The values will be updated later
1783 */
1784 *topelem = key;
1785 topelem += 2;
632b9d6f 1786 }
8b0c3377
DM
1787 /* A tied store won't take ownership of val, so keep
1788 * the 1 refcnt on the tmps stack; otherwise disarm
1789 * the tmps stack entry */
1790 if (hv_store_ent(hash, key, val, 0))
1791 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1792 else
1793 dirty_tmps = TRUE;
1794 /* hv_store_ent() may have added set magic to val */;
1795 SvSETMAGIC(val);
1796 }
1797 if (topelem < svp) {
1c4ea384
RZ
1798 /* at this point we have removed the duplicate key/value
1799 * pairs from the stack, but the remaining values may be
1800 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1801 * the (a 2), but the stack now probably contains
1802 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1803 * obliterates the earlier key. So refresh all values. */
8b0c3377
DM
1804 lastrelem = topelem - 1;
1805 while (relem < lastrelem) {
1c4ea384
RZ
1806 HE *he;
1807 he = hv_fetch_ent(hash, *relem++, 0, 0);
1808 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1809 }
1810 }
8b0c3377
DM
1811 }
1812 else {
1813 SV **svp;
1814 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
1815 SV *key = *svp++;
1816 SV *val = *svp;
1817 if (hv_store_ent(hash, key, val, 0))
1818 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1819 else
1820 dirty_tmps = TRUE;
1821 /* hv_store_ent() may have added set magic to val */;
1822 SvSETMAGIC(val);
1823 }
1824 }
1825
1826 if (dirty_tmps) {
1827 /* there are still some 'live' recounts on the tmps stack
1828 * - usually caused by storing into a tied hash. So let
1829 * free_tmps() do the proper but slow job later.
1830 * Just disarm hash refcount: see comments below about leak
1831 */
1832 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
1833 }
1834 else {
1835 /* Quietly remove all the SVs from the tmps stack slots,
1836 * since hash has now taken ownership of the refcnt.
1837 * Also remove hash: which will now leak if we die before
1838 * the SvREFCNT_dec_NN(hash) below */
1839 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
1840 Move(&PL_tmps_stack[tmps_base + nelems],
1841 &PL_tmps_stack[tmps_base - 1],
1842 PL_tmps_ix - (tmps_base + nelems) + 1,
1843 SV*);
1844 PL_tmps_ix -= (nelems + 1);
1845 }
1846
1847 SvREFCNT_dec_NN(hash);
1848
1849 relem = lastrelem + 1;
1850 goto no_relems;
1851 }
1852
a0d0e21e 1853 default:
8b0c3377 1854 if (!SvIMMORTAL(lsv)) {
d24e3eb1
DM
1855 SV *ref;
1856
8b0c3377
DM
1857 if (UNLIKELY(
1858 SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
1859 (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
1860 ))
1861 Perl_warner(aTHX_
1862 packWARN(WARN_MISC),
1863 "Useless assignment to a temporary"
1864 );
d24e3eb1
DM
1865
1866 /* avoid freeing $$lsv if it might be needed for further
1867 * elements, e.g. ($ref, $foo) = (1, $$ref) */
1868 if ( SvROK(lsv)
1869 && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
1870 && lelem <= lastlelem
1871 ) {
1872 SSize_t ix;
1873 SvREFCNT_inc_simple_void_NN(ref);
1874 /* an unrolled sv_2mortal */
1875 ix = ++PL_tmps_ix;
1876 if (UNLIKELY(ix >= PL_tmps_max))
1877 /* speculatively grow enough to cover other
1878 * possible refs */
67c3640a 1879 (void)tmps_grow_p(ix + (lastlelem - lelem));
d24e3eb1
DM
1880 PL_tmps_stack[ix] = ref;
1881 }
1882
8b0c3377
DM
1883 sv_setsv(lsv, *relem);
1884 *relem = lsv;
1885 SvSETMAGIC(lsv);
1886 }
1887 if (++relem > lastrelem)
1888 goto no_relems;
a0d0e21e 1889 break;
8b0c3377
DM
1890 } /* switch */
1891 } /* while */
1892
1893
1894 no_relems:
1895
1896 /* simplified lelem loop for when there are no relems left */
1897 while (LIKELY(lelem <= lastlelem)) {
1898 SV *lsv = *lelem++;
c73f612f
DM
1899
1900 TAINT_NOT; /* Each item stands on its own, taintwise. */
1901
8b0c3377
DM
1902 if (UNLIKELY(!lsv)) {
1903 lsv = *lelem++;
1904 ASSUME(SvTYPE(lsv) == SVt_PVAV);
a0d0e21e 1905 }
8b0c3377
DM
1906
1907 switch (SvTYPE(lsv)) {
1908 case SVt_PVAV:
b09ed995
DM
1909 if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
1910 av_clear((AV*)lsv);
8b0c3377 1911 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
b09ed995 1912 SvSETMAGIC(lsv);
8b0c3377
DM
1913 }
1914 break;
1915
1916 case SVt_PVHV:
b09ed995
DM
1917 if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
1918 hv_clear((HV*)lsv);
8b0c3377
DM
1919 break;
1920
1921 default:
1922 if (!SvIMMORTAL(lsv)) {
e03e82a0 1923 sv_set_undef(lsv);
8b0c3377 1924 SvSETMAGIC(lsv);
b09ed995 1925 *relem++ = lsv;
8b0c3377
DM
1926 }
1927 break;
1928 } /* switch */
1929 } /* while */
1930
c73f612f
DM
1931 TAINT_NOT; /* result of list assign isn't tainted */
1932
5d9574c1 1933 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
985213f2 1934 /* Will be used to set PL_tainting below */
dfff4baf
BF
1935 Uid_t tmp_uid = PerlProc_getuid();
1936 Uid_t tmp_euid = PerlProc_geteuid();
1937 Gid_t tmp_gid = PerlProc_getgid();
1938 Gid_t tmp_egid = PerlProc_getegid();
985213f2 1939
b469f1e0 1940 /* XXX $> et al currently silently ignore failures */
3280af22 1941 if (PL_delaymagic & DM_UID) {
a0d0e21e 1942#ifdef HAS_SETRESUID
b469f1e0
JH
1943 PERL_UNUSED_RESULT(
1944 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1945 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1946 (Uid_t)-1));
56febc5e
AD
1947#else
1948# ifdef HAS_SETREUID
b469f1e0
JH
1949 PERL_UNUSED_RESULT(
1950 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1951 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
56febc5e
AD
1952# else
1953# ifdef HAS_SETRUID
b28d0864 1954 if ((PL_delaymagic & DM_UID) == DM_RUID) {
b469f1e0 1955 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
b28d0864 1956 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1957 }
56febc5e
AD
1958# endif /* HAS_SETRUID */
1959# ifdef HAS_SETEUID
b28d0864 1960 if ((PL_delaymagic & DM_UID) == DM_EUID) {
b469f1e0 1961 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
b28d0864 1962 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1963 }
56febc5e 1964# endif /* HAS_SETEUID */
b28d0864 1965 if (PL_delaymagic & DM_UID) {
985213f2 1966 if (PL_delaymagic_uid != PL_delaymagic_euid)
cea2e8a9 1967 DIE(aTHX_ "No setreuid available");
b469f1e0 1968 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
a0d0e21e 1969 }
56febc5e
AD
1970# endif /* HAS_SETREUID */
1971#endif /* HAS_SETRESUID */
04783dc7 1972
985213f2
AB
1973 tmp_uid = PerlProc_getuid();
1974 tmp_euid = PerlProc_geteuid();
a0d0e21e 1975 }
b469f1e0 1976 /* XXX $> et al currently silently ignore failures */
3280af22 1977 if (PL_delaymagic & DM_GID) {
a0d0e21e 1978#ifdef HAS_SETRESGID
b469f1e0
JH
1979 PERL_UNUSED_RESULT(
1980 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1981 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1982 (Gid_t)-1));
56febc5e
AD
1983#else
1984# ifdef HAS_SETREGID
b469f1e0
JH
1985 PERL_UNUSED_RESULT(
1986 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1987 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
56febc5e
AD
1988# else
1989# ifdef HAS_SETRGID
b28d0864 1990 if ((PL_delaymagic & DM_GID) == DM_RGID) {
b469f1e0 1991 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
b28d0864 1992 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1993 }
56febc5e
AD
1994# endif /* HAS_SETRGID */
1995# ifdef HAS_SETEGID
b28d0864 1996 if ((PL_delaymagic & DM_GID) == DM_EGID) {
b469f1e0 1997 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
b28d0864 1998 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1999 }
56febc5e 2000# endif /* HAS_SETEGID */
b28d0864 2001 if (PL_delaymagic & DM_GID) {
985213f2 2002 if (PL_delaymagic_gid != PL_delaymagic_egid)
cea2e8a9 2003 DIE(aTHX_ "No setregid available");
b469f1e0 2004 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
a0d0e21e 2005 }
56febc5e
AD
2006# endif /* HAS_SETREGID */
2007#endif /* HAS_SETRESGID */
04783dc7 2008
985213f2
AB
2009 tmp_gid = PerlProc_getgid();
2010 tmp_egid = PerlProc_getegid();
a0d0e21e 2011 }
284167a5 2012 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
9a9b5ec9
DM
2013#ifdef NO_TAINT_SUPPORT
2014 PERL_UNUSED_VAR(tmp_uid);
2015 PERL_UNUSED_VAR(tmp_euid);
2016 PERL_UNUSED_VAR(tmp_gid);
2017 PERL_UNUSED_VAR(tmp_egid);
2018#endif
a0d0e21e 2019 }
a68090fe 2020 PL_delaymagic = old_delaymagic;
54310121 2021
54310121
PP
2022 if (gimme == G_VOID)
2023 SP = firstrelem - 1;
2024 else if (gimme == G_SCALAR) {
54310121 2025 SP = firstrelem;
b09ed995 2026 EXTEND(SP,1);
7b394f12
DM
2027 if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
2028 SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
2029 else {
2030 dTARGET;
2031 SETi(firstlelem - firstrelem);
2032 }
54310121 2033 }
b09ed995
DM
2034 else
2035 SP = relem - 1;
08aeb9f7 2036
54310121 2037 RETURN;
a0d0e21e
LW
2038}
2039
8782bef2
GB
2040PP(pp_qr)
2041{
20b7effb 2042 dSP;
eb578fdb 2043 PMOP * const pm = cPMOP;
fe578d7f 2044 REGEXP * rx = PM_GETRE(pm);
196a02af
DM
2045 regexp *prog = ReANY(rx);
2046 SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
c4420975 2047 SV * const rv = sv_newmortal();
d63c20f2
DM
2048 CV **cvp;
2049 CV *cv;
288b8c02
NC
2050
2051 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
2052 /* For a subroutine describing itself as "This is a hacky workaround" I'm
2053 loathe to use it here, but it seems to be the right fix. Or close.
2054 The key part appears to be that it's essential for pp_qr to return a new
2055 object (SV), which implies that there needs to be an effective way to
2056 generate a new SV from the existing SV that is pre-compiled in the
2057 optree. */
2058 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
2059 SvROK_on(rv);
2060
8d919b0a 2061 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
5d9574c1 2062 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
d63c20f2 2063 *cvp = cv_clone(cv);
fc2b2dca 2064 SvREFCNT_dec_NN(cv);
d63c20f2
DM
2065 }
2066
288b8c02 2067 if (pkg) {
f815daf2 2068 HV *const stash = gv_stashsv(pkg, GV_ADD);
fc2b2dca 2069 SvREFCNT_dec_NN(pkg);
288b8c02
NC
2070 (void)sv_bless(rv, stash);
2071 }
2072
196a02af 2073 if (UNLIKELY(RXp_ISTAINTED(prog))) {
e08e52cf 2074 SvTAINTED_on(rv);
9274aefd
DM
2075 SvTAINTED_on(SvRV(rv));
2076 }
c8c13c22 2077 XPUSHs(rv);
2078 RETURN;
8782bef2
GB
2079}
2080
a0d0e21e
LW
2081PP(pp_match)
2082{
20b7effb 2083 dSP; dTARG;
eb578fdb 2084 PMOP *pm = cPMOP;
d65afb4b 2085 PMOP *dynpm = pm;
eb578fdb 2086 const char *s;
5c144d81 2087 const char *strend;
99a90e59 2088 SSize_t curpos = 0; /* initial pos() or current $+[0] */
a0d0e21e 2089 I32 global;
7fadf4a7 2090 U8 r_flags = 0;
5c144d81 2091 const char *truebase; /* Start of string */
eb578fdb 2092 REGEXP *rx = PM_GETRE(pm);
196a02af 2093 regexp *prog = ReANY(rx);
b3eb6a9b 2094 bool rxtainted;
1c23e2bd 2095 const U8 gimme = GIMME_V;
a0d0e21e 2096 STRLEN len;
a3b680e6 2097 const I32 oldsave = PL_savestack_ix;
e60df1fa 2098 I32 had_zerolen = 0;
b1422d62 2099 MAGIC *mg = NULL;
a0d0e21e 2100
533c011a 2101 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
2102 TARG = POPs;
2103 else {
9399c607
DM
2104 if (ARGTARG)
2105 GETTARGET;
2106 else {
2107 TARG = DEFSV;
2108 }
a0d0e21e
LW
2109 EXTEND(SP,1);
2110 }
d9f424b2 2111
c277df42 2112 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
2113 /* Skip get-magic if this is a qr// clone, because regcomp has
2114 already done it. */
196a02af 2115 truebase = prog->mother_re
69dc4b30
FC
2116 ? SvPV_nomg_const(TARG, len)
2117 : SvPV_const(TARG, len);
f1d31338 2118 if (!truebase)
2269b42e 2119 DIE(aTHX_ "panic: pp_match");
f1d31338 2120 strend = truebase + len;
196a02af 2121 rxtainted = (RXp_ISTAINTED(prog) ||
284167a5 2122 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 2123 TAINT_NOT;
a0d0e21e 2124
6c864ec2 2125 /* We need to know this in case we fail out early - pos() must be reset */
de0df3c0
MH
2126 global = dynpm->op_pmflags & PMf_GLOBAL;
2127
d65afb4b 2128 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
2129 if (
2130#ifdef USE_ITHREADS
2131 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
2132#else
2133 pm->op_pmflags & PMf_USED
2134#endif
2135 ) {
e5dc5375 2136 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
de0df3c0 2137 goto nope;
a0d0e21e
LW
2138 }
2139
5585e758 2140 /* handle the empty pattern */
196a02af 2141 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
5585e758
YO
2142 if (PL_curpm == PL_reg_curpm) {
2143 if (PL_curpm_under) {
2144 if (PL_curpm_under == PL_reg_curpm) {
2145 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
2146 } else {
2147 pm = PL_curpm_under;
2148 }
2149 }
2150 } else {
2151 pm = PL_curpm;
2152 }
2153 rx = PM_GETRE(pm);
196a02af 2154 prog = ReANY(rx);
a0d0e21e 2155 }
d65afb4b 2156
196a02af 2157 if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
75d43e96 2158 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
147e3846 2159 UVuf " < %" IVdf ")\n",
196a02af 2160 (UV)len, (IV)RXp_MINLEN(prog)));
de0df3c0 2161 goto nope;
e5dc5375 2162 }
c277df42 2163
8ef97b0e 2164 /* get pos() if //g */
de0df3c0 2165 if (global) {
b1422d62 2166 mg = mg_find_mglob(TARG);
8ef97b0e 2167 if (mg && mg->mg_len >= 0) {
25fdce4a 2168 curpos = MgBYTEPOS(mg, TARG, truebase, len);
8ef97b0e
DM
2169 /* last time pos() was set, it was zero-length match */
2170 if (mg->mg_flags & MGf_MINMATCH)
2171 had_zerolen = 1;
2172 }
a0d0e21e 2173 }
8ef97b0e 2174
6e240d0b 2175#ifdef PERL_SAWAMPERSAND
196a02af 2176 if ( RXp_NPARENS(prog)
6502e081 2177 || PL_sawampersand
196a02af 2178 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 2179 || (dynpm->op_pmflags & PMf_KEEPCOPY)
6e240d0b
FC
2180 )
2181#endif
2182 {
6502e081
DM
2183 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
2184 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
2185 * only on the first iteration. Therefore we need to copy $' as well
2186 * as $&, to make the rest of the string available for captures in
2187 * subsequent iterations */
2188 if (! (global && gimme == G_ARRAY))
2189 r_flags |= REXEC_COPY_SKIP_POST;
2190 };
5b0e71e9
DM
2191#ifdef PERL_SAWAMPERSAND
2192 if (dynpm->op_pmflags & PMf_KEEPCOPY)
2193 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
2194 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
2195#endif
22e551b9 2196
f1d31338
DM
2197 s = truebase;
2198
d7be1480 2199 play_it_again:
985afbc1 2200 if (global)
03c83e26 2201 s = truebase + curpos;
f722798b 2202
77da2310 2203 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
03c83e26 2204 had_zerolen, TARG, NULL, r_flags))
03b6c93d 2205 goto nope;
77da2310
NC
2206
2207 PL_curpm = pm;
985afbc1 2208 if (dynpm->op_pmflags & PMf_ONCE)
c737faaf 2209#ifdef USE_ITHREADS
77da2310 2210 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
c737faaf 2211#else
77da2310 2212 dynpm->op_pmflags |= PMf_USED;
c737faaf 2213#endif
a0d0e21e 2214
72311751 2215 if (rxtainted)
196a02af
DM
2216 RXp_MATCH_TAINTED_on(prog);
2217 TAINT_IF(RXp_MATCH_TAINTED(prog));
35c2ccc3
DM
2218
2219 /* update pos */
2220
2221 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
b1422d62 2222 if (!mg)
35c2ccc3 2223 mg = sv_magicext_mglob(TARG);
196a02af
DM
2224 MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
2225 if (RXp_ZERO_LEN(prog))
adf51885
DM
2226 mg->mg_flags |= MGf_MINMATCH;
2227 else
2228 mg->mg_flags &= ~MGf_MINMATCH;
35c2ccc3
DM
2229 }
2230
196a02af 2231 if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
bf9dff51
DM
2232 LEAVE_SCOPE(oldsave);
2233 RETPUSHYES;
2234 }
2235
88ab22af
DM
2236 /* push captures on stack */
2237
bf9dff51 2238 {
196a02af 2239 const I32 nparens = RXp_NPARENS(prog);
a3b680e6 2240 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 2241
c277df42 2242 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
2243 EXTEND(SP, nparens + i);
2244 EXTEND_MORTAL(nparens + i);
2245 for (i = !i; i <= nparens; i++) {
a0d0e21e 2246 PUSHs(sv_newmortal());
196a02af
DM
2247 if (LIKELY((RXp_OFFS(prog)[i].start != -1)
2248 && RXp_OFFS(prog)[i].end != -1 ))
5d9574c1 2249 {
196a02af
DM
2250 const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
2251 const char * const s = RXp_OFFS(prog)[i].start + truebase;
2252 if (UNLIKELY( RXp_OFFS(prog)[i].end < 0
2253 || RXp_OFFS(prog)[i].start < 0
2254 || len < 0
2255 || len > strend - s)
2256 )
5637ef5b 2257 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
147e3846 2258 "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
196a02af
DM
2259 (long) i, (long) RXp_OFFS(prog)[i].start,
2260 (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
a0d0e21e 2261 sv_setpvn(*SP, s, len);
cce850e4 2262 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 2263 SvUTF8_on(*SP);
a0d0e21e
LW
2264 }
2265 }
2266 if (global) {
196a02af
DM
2267 curpos = (UV)RXp_OFFS(prog)[0].end;
2268 had_zerolen = RXp_ZERO_LEN(prog);
c277df42 2269 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 2270 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
2271 goto play_it_again;
2272 }
4633a7c4 2273 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2274 RETURN;
2275 }
e5964223 2276 NOT_REACHED; /* NOTREACHED */
a0d0e21e 2277
7b52d656 2278 nope:
d65afb4b 2279 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
b1422d62
DM
2280 if (!mg)
2281 mg = mg_find_mglob(TARG);
2282 if (mg)
2283 mg->mg_len = -1;
a0d0e21e 2284 }
4633a7c4 2285 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2286 if (gimme == G_ARRAY)
2287 RETURN;
2288 RETPUSHNO;
2289}
2290
2291OP *
864dbfa3 2292Perl_do_readline(pTHX)
a0d0e21e 2293{
20b7effb 2294 dSP; dTARGETSTACKED;
eb578fdb 2295 SV *sv;
a0d0e21e
LW
2296 STRLEN tmplen = 0;
2297 STRLEN offset;
760ac839 2298 PerlIO *fp;
eb578fdb
KW
2299 IO * const io = GvIO(PL_last_in_gv);
2300 const I32 type = PL_op->op_type;
1c23e2bd 2301 const U8 gimme = GIMME_V;
a0d0e21e 2302
6136c704 2303 if (io) {
50db69d8 2304 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 2305 if (mg) {
3e0cb5de 2306 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 2307 if (gimme == G_SCALAR) {
50db69d8
NC
2308 SPAGAIN;
2309 SvSetSV_nosteal(TARG, TOPs);
2310 SETTARG;
6136c704 2311 }
50db69d8 2312 return NORMAL;
0b7c7b4f 2313 }
e79b0511 2314 }
4608196e 2315 fp = NULL;
a0d0e21e
LW
2316 if (io) {
2317 fp = IoIFP(io);
2318 if (!fp) {
2319 if (IoFLAGS(io) & IOf_ARGV) {
2320 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 2321 IoLINES(io) = 0;
b9f2b683 2322 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 2323 IoFLAGS(io) &= ~IOf_START;
d5eb9a46 2324 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
4bac9ae4 2325 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
76f68e9b 2326 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3280af22 2327 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
2328 fp = IoIFP(io);
2329 goto have_fp;
a0d0e21e
LW
2330 }
2331 }
157fb5a1 2332 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e 2333 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 2334 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
2335 }
2336 }
0d44d22b
NC
2337 else if (type == OP_GLOB)
2338 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
2339 }
2340 else if (type == OP_GLOB)
2341 SP--;
7716c5c5 2342 else if (IoTYPE(io) == IoTYPE_WRONLY) {
a5390457 2343 report_wrongway_fh(PL_last_in_gv, '>');
a00b5bd3 2344 }
a0d0e21e
LW
2345 }
2346 if (!fp) {
041457d9 2347 if ((!io || !(IoFLAGS(io) & IOf_START))
de7dabb6
TC
2348 && ckWARN(WARN_CLOSED)
2349 && type != OP_GLOB)
041457d9 2350 {
de7dabb6 2351 report_evil_fh(PL_last_in_gv);
3f4520fe 2352 }
54310121 2353 if (gimme == G_SCALAR) {
79628082 2354 /* undef TARG, and push that undefined value */
ba92458f 2355 if (type != OP_RCATLINE) {
3773545d 2356 sv_set_undef(TARG);
ba92458f 2357 }
a0d0e21e
LW
2358 PUSHTARG;
2359 }
2360 RETURN;
2361 }
a2008d6d 2362 have_fp:
54310121 2363 if (gimme == G_SCALAR) {
a0d0e21e 2364 sv = TARG;
0f722b55
RGS
2365 if (type == OP_RCATLINE && SvGMAGICAL(sv))
2366 mg_get(sv);
48de12d9
RGS
2367 if (SvROK(sv)) {
2368 if (type == OP_RCATLINE)
5668452f 2369 SvPV_force_nomg_nolen(sv);
48de12d9
RGS
2370 else
2371 sv_unref(sv);
2372 }
f7877b28 2373 else if (isGV_with_GP(sv)) {
5668452f 2374 SvPV_force_nomg_nolen(sv);
f7877b28 2375 }
862a34c6 2376 SvUPGRADE(sv, SVt_PV);
a0d0e21e 2377 tmplen = SvLEN(sv); /* remember if already alloced */
e3918bb7 2378 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
f72e8700
JJ
2379 /* try short-buffering it. Please update t/op/readline.t
2380 * if you change the growth length.
2381 */
2382 Sv_Grow(sv, 80);
2383 }
2b5e58c4
AMS
2384 offset = 0;
2385 if (type == OP_RCATLINE && SvOK(sv)) {
2386 if (!SvPOK(sv)) {
5668452f 2387 SvPV_force_nomg_nolen(sv);
2b5e58c4 2388 }
a0d0e21e 2389 offset = SvCUR(sv);
2b5e58c4 2390 }
a0d0e21e 2391 }
54310121 2392 else {
561b68a9 2393 sv = sv_2mortal(newSV(80));
54310121
PP
2394 offset = 0;
2395 }
fbad3eb5 2396
3887d568
AP
2397 /* This should not be marked tainted if the fp is marked clean */
2398#define MAYBE_TAINT_LINE(io, sv) \
2399 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
2400 TAINT; \
2401 SvTAINTED_on(sv); \
2402 }
2403
684bef36 2404/* delay EOF state for a snarfed empty file */
fbad3eb5 2405#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 2406 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 2407 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 2408
a0d0e21e 2409 for (;;) {
09e8efcc 2410 PUTBACK;
fbad3eb5 2411 if (!sv_gets(sv, fp, offset)
2d726892
TF
2412 && (type == OP_GLOB
2413 || SNARF_EOF(gimme, PL_rs, io, sv)
2414 || PerlIO_error(fp)))
fbad3eb5 2415 {
760ac839 2416 PerlIO_clearerr(fp);
a0d0e21e 2417 if (IoFLAGS(io) & IOf_ARGV) {
157fb5a1 2418 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e
LW
2419 if (fp)
2420 continue;
3280af22 2421 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
2422 }
2423 else if (type == OP_GLOB) {
a2a5de95
NC
2424 if (!do_close(PL_last_in_gv, FALSE)) {
2425 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
2426 "glob failed (child exited with status %d%s)",
2427 (int)(STATUS_CURRENT >> 8),
2428 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 2429 }
a0d0e21e 2430 }
54310121 2431 if (gimme == G_SCALAR) {
ba92458f
AE
2432 if (type != OP_RCATLINE) {
2433 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 2434 SvOK_off(TARG);
ba92458f 2435 }
09e8efcc 2436 SPAGAIN;
a0d0e21e
LW
2437 PUSHTARG;
2438 }
3887d568 2439 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
2440 RETURN;
2441 }
3887d568 2442 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 2443 IoLINES(io)++;
b9fee9ba 2444 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 2445 SvSETMAGIC(sv);
09e8efcc 2446 SPAGAIN;
a0d0e21e 2447 XPUSHs(sv);
a0d0e21e 2448 if (type == OP_GLOB) {
349d4f2f 2449 const char *t1;
45a23732 2450 Stat_t statbuf;
a0d0e21e 2451
3280af22 2452 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
6136c704 2453 char * const tmps = SvEND(sv) - 1;
aa07b2f6 2454 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 2455 *tmps = '\0';
b162af07 2456 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd
PP
2457 }
2458 }
349d4f2f 2459 for (t1 = SvPVX_const(sv); *t1; t1++)
b51c3e77
CB
2460#ifdef __VMS
2461 if (strchr("*%?", *t1))
2462#else
7ad1e72d 2463 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
b51c3e77 2464#endif
a0d0e21e 2465 break;
45a23732 2466 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
a0d0e21e
LW
2467 (void)POPs; /* Unmatched wildcard? Chuck it... */
2468 continue;
2469 }
2d79bf7f 2470 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL
2471 if (ckWARN(WARN_UTF8)) {
2472 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
2473 const STRLEN len = SvCUR(sv) - offset;
2474 const U8 *f;
2475
2476 if (!is_utf8_string_loc(s, len, &f))
2477 /* Emulate :encoding(utf8) warning in the same case. */
2478 Perl_warner(aTHX_ packWARN(WARN_UTF8),
2479 "utf8 \"\\x%02X\" does not map to Unicode",
2480 f < (U8*)SvEND(sv) ? *f : 0);
2481 }
a0d0e21e 2482 }
54310121 2483 if (gimme == G_ARRAY) {
a0d0e21e 2484 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 2485 SvPV_shrink_to_cur(sv);
a0d0e21e 2486 }
561b68a9 2487 sv = sv_2mortal(newSV(80));
a0d0e21e
LW
2488 continue;
2489 }
54310121 2490 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 2491 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
2492 const STRLEN new_len
2493 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 2494 SvPV_renew(sv, new_len);
a0d0e21e
LW
2495 }
2496 RETURN;
2497 }
2498}
2499
a0d0e21e
LW
2500PP(pp_helem)
2501{
20b7effb 2502 dSP;
760ac839 2503 HE* he;
ae77835f 2504 SV **svp;
c445ea15 2505 SV * const keysv = POPs;
85fbaab2 2506 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
2507 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2508 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 2509 SV *sv;
92970b93 2510 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 2511 bool preeminent = TRUE;
a0d0e21e 2512
6dfc73ea
SM
2513 if (SvTYPE(hv) != SVt_PVHV)
2514 RETPUSHUNDEF;
d4c19fe8 2515
92970b93 2516 if (localizing) {
d4c19fe8
AL
2517 MAGIC *mg;
2518 HV *stash;
d30e492c
VP
2519
2520 /* If we can determine whether the element exist,
2521 * Try to preserve the existenceness of a tied hash
2522 * element by using EXISTS and DELETE if possible.
2523 * Fallback to FETCH and STORE otherwise. */
2c5f48c2 2524 if (SvCANEXISTDELETE(hv))
d30e492c 2525 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 2526 }
d30e492c 2527
5f9d7e2b 2528 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
d4c19fe8 2529 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 2530 if (lval) {
746f6409 2531 if (!svp || !*svp || *svp == &PL_sv_undef) {
68dc0745
PP
2532 SV* lv;
2533 SV* key2;
2d8e6c8d 2534 if (!defer) {
be2597df 2535 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 2536 }
68dc0745
PP
2537 lv = sv_newmortal();
2538 sv_upgrade(lv, SVt_PVLV);
2539 LvTYPE(lv) = 'y';
6136c704 2540 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
fc2b2dca 2541 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
0ad694a7 2542 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
68dc0745
PP
2543 LvTARGLEN(lv) = 1;
2544 PUSHs(lv);
2545 RETURN;
2546 }
92970b93 2547 if (localizing) {
bfcb3514 2548 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 2549 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP
2550 else if (preeminent)
2551 save_helem_flags(hv, keysv, svp,
2552 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
2553 else
2554 SAVEHDELETE(hv, keysv);
5f05dabc 2555 }
9026059d
GG
2556 else if (PL_op->op_private & OPpDEREF) {
2557 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2558 RETURN;
2559 }
a0d0e21e 2560 }
746f6409 2561 sv = (svp && *svp ? *svp : &PL_sv_undef);
fd69380d
DM
2562 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
2563 * was to make C<local $tied{foo} = $tied{foo}> possible.
2564 * However, it seems no longer to be needed for that purpose, and
2565 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
2566 * would loop endlessly since the pos magic is getting set on the
2567 * mortal copy and lost. However, the copy has the effect of
2568 * triggering the get magic, and losing it altogether made things like
2569 * c<$tied{foo};> in void context no longer do get magic, which some
2570 * code relied on. Also, delayed triggering of magic on @+ and friends
2571 * meant the original regex may be out of scope by now. So as a
2572 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
2573 * being called too many times). */
39cf747a 2574 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
fd69380d 2575 mg_get(sv);
be6c24e0 2576 PUSHs(sv);
a0d0e21e
LW
2577 RETURN;
2578}
2579
fedf30e1
DM
2580
2581/* a stripped-down version of Perl_softref2xv() for use by
2582 * pp_multideref(), which doesn't use PL_op->op_flags */
2583
f9db5646 2584STATIC GV *
fedf30e1
DM
2585S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
2586 const svtype type)
2587{
2588 if (PL_op->op_private & HINT_STRICT_REFS) {
2589 if (SvOK(sv))
2590 Perl_die(aTHX_ PL_no_symref_sv, sv,
2591 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
2592 else
2593 Perl_die(aTHX_ PL_no_usym, what);
2594 }
2595 if (!SvOK(sv))
2596 Perl_die(aTHX_ PL_no_usym, what);
2597 return gv_fetchsv_nomg(sv, GV_ADD, type);
2598}
2599
2600
79815f56
DM
2601/* Handle one or more aggregate derefs and array/hash indexings, e.g.
2602 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
fedf30e1
DM
2603 *
2604 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
79815f56
DM
2605 * Each of these either contains a set of actions, or an argument, such as
2606 * an IV to use as an array index, or a lexical var to retrieve.
2607 * Several actions re stored per UV; we keep shifting new actions off the
2608 * one UV, and only reload when it becomes zero.
fedf30e1
DM
2609 */
2610
2611PP(pp_multideref)
2612{
2613 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
2614 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
2615 UV actions = items->uv;
2616
2617 assert(actions);
2618 /* this tells find_uninit_var() where we're up to */
2619 PL_multideref_pc = items;
2620
2621 while (1) {
2622 /* there are three main classes of action; the first retrieve
2623 * the initial AV or HV from a variable or the stack; the second
2624 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
2625 * the third an unrolled (/DREFHV, rv2hv, helem).
2626 */
2627 switch (actions & MDEREF_ACTION_MASK) {
2628
2629 case MDEREF_reload:
2630 actions = (++items)->uv;
2631 continue;
2632
2633 case MDEREF_AV_padav_aelem: /* $lex[...] */
2634 sv = PAD_SVl((++items)->pad_offset);
2635 goto do_AV_aelem;
2636
2637 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
2638 sv = UNOP_AUX_item_sv(++items);
2639 assert(isGV_with_GP(sv));
2640 sv = (SV*)GvAVn((GV*)sv);
2641 goto do_AV_aelem;
2642
2643 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
2644 {
2645 dSP;
2646 sv = POPs;
2647 PUTBACK;
2648 goto do_AV_rv2av_aelem;
2649 }
2650
2651 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
2652 sv = UNOP_AUX_item_sv(++items);
2653 assert(isGV_with_GP(sv));
2654 sv = GvSVn((GV*)sv);
2655 goto do_AV_vivify_rv2av_aelem;
2656
2657 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
2658 sv = PAD_SVl((++items)->pad_offset);
2659 /* FALLTHROUGH */
2660
2661 do_AV_vivify_rv2av_aelem:
2662 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
2663 /* this is the OPpDEREF action normally found at the end of
2664 * ops like aelem, helem, rv2sv */
2665 sv = vivify_ref(sv, OPpDEREF_AV);
2666 /* FALLTHROUGH */
2667
2668 do_AV_rv2av_aelem:
2669 /* this is basically a copy of pp_rv2av when it just has the
2670 * sKR/1 flags */
2671 SvGETMAGIC(sv);
2672 if (LIKELY(SvROK(sv))) {
2673 if (UNLIKELY(SvAMAGIC(sv))) {
2674 sv = amagic_deref_call(sv, to_av_amg);
2675 }
2676 sv = SvRV(sv);
2677 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
2678 DIE(aTHX_ "Not an ARRAY reference");
2679 }
2680 else if (SvTYPE(sv) != SVt_PVAV) {
2681 if (!isGV_with_GP(sv))
2682 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
2683 sv = MUTABLE_SV(GvAVn((GV*)sv));
2684 }
2685 /* FALLTHROUGH */
2686
2687 do_AV_aelem:
2688 {
2689 /* retrieve the key; this may be either a lexical or package
2690 * var (whose index/ptr is stored as an item) or a signed
2691 * integer constant stored as an item.
2692 */
2693 SV *elemsv;
2694 IV elem = 0; /* to shut up stupid compiler warnings */
2695
2696
2697 assert(SvTYPE(sv) == SVt_PVAV);
2698
2699 switch (actions & MDEREF_INDEX_MASK) {
2700 case MDEREF_INDEX_none:
2701 goto finish;
2702 case MDEREF_INDEX_const:
2703 elem = (++items)->iv;
2704 break;
2705 case MDEREF_INDEX_padsv:
2706 elemsv = PAD_SVl((++items)->pad_offset);
2707 goto check_elem;
2708 case MDEREF_INDEX_gvsv:
2709 elemsv = UNOP_AUX_item_sv(++items);
2710 assert(isGV_with_GP(elemsv));
2711 elemsv = GvSVn((GV*)elemsv);
2712 check_elem:
2713 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
2714 && ckWARN(WARN_MISC)))
2715 Perl_warner(aTHX_ packWARN(WARN_MISC),
147e3846 2716 "Use of reference \"%" SVf "\" as array index",
fedf30e1
DM
2717 SVfARG(elemsv));
2718 /* the only time that S_find_uninit_var() needs this
2719 * is to determine which index value triggered the
2720 * undef warning. So just update it here. Note that
2721 * since we don't save and restore this var (e.g. for
2722 * tie or overload execution), its value will be
2723 * meaningless apart from just here */
2724 PL_multideref_pc = items;
2725 elem = SvIV(elemsv);
2726 break;
2727 }
2728
2729
2730 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2731
2732 if (!(actions & MDEREF_FLAG_last)) {
2733 SV** svp = av_fetch((AV*)sv, elem, 1);
2734 if (!svp || ! (sv=*svp))
2735 DIE(aTHX_ PL_no_aelem, elem);
2736 break;
2737 }
2738
2739 if (PL_op->op_private &
2740 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2741 {
2742 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2743 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2744 }
2745 else {
2746 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2747 sv = av_delete((AV*)sv, elem, discard);
2748 if (discard)
2749 return NORMAL;
2750 if (!sv)
2751 sv = &PL_sv_undef;
2752 }
2753 }
2754 else {
2755 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2756 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2757 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2758 bool preeminent = TRUE;
2759 AV *const av = (AV*)sv;
2760 SV** svp;
2761
2762 if (UNLIKELY(localizing)) {
2763 MAGIC *mg;
2764 HV *stash;
2765
2766 /* If we can determine whether the element exist,
2767 * Try to preserve the existenceness of a tied array
2768 * element by using EXISTS and DELETE if possible.
2769 * Fallback to FETCH and STORE otherwise. */
2770 if (SvCANEXISTDELETE(av))
2771 preeminent = av_exists(av, elem);
2772 }
2773
2774 svp = av_fetch(av, elem, lval && !defer);
2775
2776 if (lval) {
2777 if (!svp || !(sv = *svp)) {
2778 IV len;
2779 if (!defer)
2780 DIE(aTHX_ PL_no_aelem, elem);
2781 len = av_tindex(av);
2782 sv = sv_2mortal(newSVavdefelem(av,
2783 /* Resolve a negative index now, unless it points
2784 * before the beginning of the array, in which
2785 * case record it for error reporting in
2786 * magic_setdefelem. */
2787 elem < 0 && len + elem >= 0
2788 ? len + elem : elem, 1));
2789 }
2790 else {
2791 if (UNLIKELY(localizing)) {
2792 if (preeminent) {
2793 save_aelem(av, elem, svp);
2794 sv = *svp; /* may have changed */
2795 }
2796 else
2797 SAVEADELETE(av, elem);
2798 }
2799 }
2800 }
2801 else {
2802 sv = (svp ? *svp : &PL_sv_undef);
2803 /* see note in pp_helem() */
2804 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2805 mg_get(sv);
2806 }
2807 }
2808
2809 }
2810 finish:
2811 {
2812 dSP;
2813 XPUSHs(sv);
2814 RETURN;
2815 }
2816 /* NOTREACHED */
2817
2818
2819
2820
2821 case MDEREF_HV_padhv_helem: /* $lex{...} */
2822 sv = PAD_SVl((++items)->pad_offset);
2823 goto do_HV_helem;
2824
2825 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
2826 sv = UNOP_AUX_item_sv(++items);
2827 assert(isGV_with_GP(sv));
2828 sv = (SV*)GvHVn((GV*)sv);
2829 goto do_HV_helem;
2830
2831 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
2832 {
2833 dSP;
2834 sv = POPs;
2835 PUTBACK;
2836 goto do_HV_rv2hv_helem;
2837 }
2838
2839 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
2840 sv = UNOP_AUX_item_sv(++items);
2841 assert(isGV_with_GP(sv));
2842 sv = GvSVn((GV*)sv);
2843 goto do_HV_vivify_rv2hv_helem;
2844
2845 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
2846 sv = PAD_SVl((++items)->pad_offset);
2847 /* FALLTHROUGH */
2848
2849 do_HV_vivify_rv2hv_helem:
2850 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
2851 /* this is the OPpDEREF action normally found at the end of
2852 * ops like aelem, helem, rv2sv */
2853 sv = vivify_ref(sv, OPpDEREF_HV);
2854 /* FALLTHROUGH */
2855
2856 do_HV_rv2hv_helem:
2857 /* this is basically a copy of pp_rv2hv when it just has the
2858 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2859
2860 SvGETMAGIC(sv);
2861 if (LIKELY(SvROK(sv))) {
2862 if (UNLIKELY(SvAMAGIC(sv))) {
2863 sv = amagic_deref_call(sv, to_hv_amg);
2864 }
2865 sv = SvRV(sv);
2866 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2867 DIE(aTHX_ "Not a HASH reference");
2868 }
2869 else if (SvTYPE(sv) != SVt_PVHV) {
2870 if (!isGV_with_GP(sv))
2871 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2872 sv = MUTABLE_SV(GvHVn((GV*)sv));
2873 }
2874 /* FALLTHROUGH */
2875
2876 do_HV_helem:
2877 {
2878 /* retrieve the key; this may be either a lexical / package
2879 * var or a string constant, whose index/ptr is stored as an
2880 * item
2881 */
2882 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2883
2884 assert(SvTYPE(sv) == SVt_PVHV);
2885
2886 switch (actions & MDEREF_INDEX_MASK) {
2887 case MDEREF_INDEX_none:
2888 goto finish;
2889
2890 case MDEREF_INDEX_const:
2891 keysv = UNOP_AUX_item_sv(++items);
2892 break;
2893
2894 case MDEREF_INDEX_padsv:
2895 keysv = PAD_SVl((++items)->pad_offset);
2896 break;
2897
2898 case MDEREF_INDEX_gvsv:
2899 keysv = UNOP_AUX_item_sv(++items);
2900 keysv = GvSVn((GV*)keysv);
2901 break;
2902 }
2903
2904 /* see comment above about setting this var */
2905 PL_multideref_pc = items;
2906
2907
2908 /* ensure that candidate CONSTs have been HEKified */
2909 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2910 || SvTYPE(keysv) >= SVt_PVMG
2911 || !SvOK(keysv)
2912 || SvROK(keysv)
2913 || SvIsCOW_shared_hash(keysv));
2914
2915 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2916
2917 if (!(actions & MDEREF_FLAG_last)) {
2918 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2919 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2920 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2921 break;
2922 }
2923
2924 if (PL_op->op_private &
2925 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2926 {
2927 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2928 sv = hv_exists_ent((HV*)sv, keysv, 0)
2929 ? &PL_sv_yes : &PL_sv_no;
2930 }
2931 else {
2932 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2933 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2934 if (discard)
2935 return NORMAL;
2936 if (!sv)
2937 sv = &PL_sv_undef;
2938 }
2939 }
2940 else {
2941 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2942 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2943 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2944 bool preeminent = TRUE;
2945 SV **svp;
2946 HV * const hv = (HV*)sv;
2947 HE* he;
2948
2949 if (UNLIKELY(localizing)) {
2950 MAGIC *mg;
2951 HV *stash;
2952
2953 /* If we can determine whether the element exist,
2954 * Try to preserve the existenceness of a tied hash
2955 * element by using EXISTS and DELETE if possible.
2956 * Fallback to FETCH and STORE otherwise. */
2957 if (SvCANEXISTDELETE(hv))
2958 preeminent = hv_exists_ent(hv, keysv, 0);
2959 }
2960
2961 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2962 svp = he ? &HeVAL(he) : NULL;
2963
2964
2965 if (lval) {
2966 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2967 SV* lv;
2968 SV* key2;
2969 if (!defer)
2970 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2971 lv = sv_newmortal();
2972 sv_upgrade(lv, SVt_PVLV);
2973 LvTYPE(lv) = 'y';
2974 sv_magic(lv, key2 = newSVsv(keysv),
2975 PERL_MAGIC_defelem, NULL, 0);
2976 /* sv_magic() increments refcount */
2977 SvREFCNT_dec_NN(key2);
0ad694a7 2978 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
fedf30e1
DM
2979 LvTARGLEN(lv) = 1;
2980 sv = lv;
2981 }
2982 else {
2983 if (localizing) {
2984 if (HvNAME_get(hv) && isGV(sv))
2985 save_gp(MUTABLE_GV(sv),
2986 !(PL_op->op_flags & OPf_SPECIAL));
2987 else if (preeminent) {
2988 save_helem_flags(hv, keysv, svp,
2989 (PL_op->op_flags & OPf_SPECIAL)
2990 ? 0 : SAVEf_SETMAGIC);
2991 sv = *svp; /* may have changed */
2992 }
2993 else
2994 SAVEHDELETE(hv, keysv);
2995 }
2996 }
2997 }
2998 else {
2999 sv = (svp && *svp ? *svp : &PL_sv_undef);
3000 /* see note in pp_helem() */
3001 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
3002 mg_get(sv);
3003 }
3004 }
3005 goto finish;
3006 }
3007
3008 } /* switch */
3009
3010 actions >>= MDEREF_SHIFT;
3011 } /* while */
3012 /* NOTREACHED */
3013}
3014
3015
a0d0e21e
LW
3016PP(pp_iter)
3017{
eb578fdb 3018 PERL_CONTEXT *cx;
7d6c2cef 3019 SV *oldsv;
1d7c1841 3020 SV **itersvp;
a0d0e21e 3021
84f05d57
JH
3022 SV *sv;
3023 AV *av;
3024 IV ix;
3025 IV inc;
3026
4ebe6e95 3027 cx = CX_CUR();
1d7c1841 3028 itersvp = CxITERVAR(cx);
4b5c941e 3029 assert(itersvp);
a48ce6be
DM
3030
3031 switch (CxTYPE(cx)) {
17c91640 3032
b552b52c
DM
3033 case CXt_LOOP_LAZYSV: /* string increment */
3034 {
3035 SV* cur = cx->blk_loop.state_u.lazysv.cur;
3036 SV *end = cx->blk_loop.state_u.lazysv.end;
3037 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
3038 It has SvPVX of "" and SvCUR of 0, which is what we want. */
3039 STRLEN maxlen = 0;
3040 const char *max = SvPV_const(end, maxlen);
d6c970c7
AC
3041 if (DO_UTF8(end) && IN_UNI_8_BIT)
3042 maxlen = sv_len_utf8_nomg(end);
5d9574c1 3043 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
8a1f10dd 3044 goto retno;
b552b52c
DM
3045
3046 oldsv = *itersvp;
6d3ca00e
DM
3047 /* NB: on the first iteration, oldsv will have a ref count of at
3048 * least 2 (one extra from blk_loop.itersave), so the GV or pad
3049 * slot will get localised; on subsequent iterations the RC==1
3050 * optimisation may kick in and the SV will be reused. */
3051 if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
b552b52c
DM
3052 /* safe to reuse old SV */
3053 sv_setsv(oldsv, cur);
a48ce6be 3054 }
b552b52c
DM
3055 else
3056 {
3057 /* we need a fresh SV every time so that loop body sees a
3058 * completely new SV for closures/references to work as
3059 * they used to */
3060 *itersvp = newSVsv(cur);
6d3ca00e 3061 SvREFCNT_dec(oldsv);
b552b52c
DM
3062 }
3063 if (strEQ(SvPVX_const(cur), max))
3064 sv_setiv(cur, 0); /* terminate next time */
3065 else
3066 sv_inc(cur);
3067 break;
3068 }
a48ce6be 3069
fcef60b4
DM
3070 case CXt_LOOP_LAZYIV: /* integer increment */
3071 {
3072 IV cur = cx->blk_loop.state_u.lazyiv.cur;
5d9574c1 3073 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
8a1f10dd 3074 goto retno;
7f61b687 3075
fcef60b4 3076 oldsv = *itersvp;
6d3ca00e
DM
3077 /* see NB comment above */
3078 if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
eaa5c2d6 3079 /* safe to reuse old SV */
47b96a1e
DM
3080
3081 if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
3082 == SVt_IV)
3083 {
3084 /* Cheap SvIOK_only().
3085 * Assert that flags which SvIOK_only() would test or
3086 * clear can't be set, because we're SVt_IV */
3087 assert(!(SvFLAGS(oldsv) &
3088 (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
3089 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
3090 /* SvIV_set() where sv_any points to head */
3091 oldsv->sv_u.svu_iv = cur;
3092
3093 }
3094 else
3095 sv_setiv(oldsv, cur);
eaa5c2d6 3096 }
1c846c1f 3097 else
eaa5c2d6
GA
3098 {
3099 /* we need a fresh SV every time so that loop body sees a
3100 * completely new SV for closures/references to work as they
3101 * used to */
fcef60b4 3102 *itersvp = newSViv(cur);
6d3ca00e 3103 SvREFCNT_dec(oldsv);
eaa5c2d6 3104 }
a2309040 3105
5d9574c1 3106 if (UNLIKELY(cur == IV_MAX)) {
cdc1aa42
NC
3107 /* Handle end of range at IV_MAX */
3108 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
3109 } else
3110 ++cx->blk_loop.state_u.lazyiv.cur;
a48ce6be 3111 break;
fcef60b4 3112 }
a48ce6be 3113
93661e56
DM
3114 case CXt_LOOP_LIST: /* for (1,2,3) */
3115
3116 assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
3117 inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
3118 ix = (cx->blk_loop.state_u.stack.ix += inc);
3119 if (UNLIKELY(inc > 0
3120 ? ix > cx->blk_oldsp
3121 : ix <= cx->blk_loop.state_u.stack.basesp)
3122 )
8a1f10dd 3123 goto retno;
93661e56
DM
3124
3125 sv = PL_stack_base[ix];
3126 av = NULL;
3127 goto loop_ary_common;
3128
3129 case CXt_LOOP_ARY: /* for (@ary) */
3130
3131 av = cx->blk_loop.state_u.ary.ary;
3132 inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
3133 ix = (cx->blk_loop.state_u.ary.ix += inc);
3134 if (UNLIKELY(inc > 0
3135 ? ix > AvFILL(av)
3136 : ix < 0)
3137 )
8a1f10dd 3138 goto retno;
de080daa 3139
9d1ee8e0 3140 if (UNLIKELY(SvRMAGICAL(av))) {
a8a20bb6
DM
3141 SV * const * const svp = av_fetch(av, ix, FALSE);
3142 sv = svp ? *svp : NULL;
3143 }
3144 else {
3145 sv = AvARRAY(av)[ix];
de080daa 3146 }
ef3e5ea9 3147
93661e56
DM
3148 loop_ary_common:
3149
d39c26a6
FC
3150 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
3151 SvSetMagicSV(*itersvp, sv);
3152 break;
3153 }
3154
5d9574c1
DM
3155 if (LIKELY(sv)) {
3156 if (UNLIKELY(SvIS_FREED(sv))) {
f38aa882
DM
3157 *itersvp = NULL;
3158 Perl_croak(aTHX_ "Use of freed value in iteration");
3159 }
60779a30 3160 if (SvPADTMP(sv)) {
8e079c2a 3161 sv = newSVsv(sv);
60779a30 3162 }
8e079c2a
FC
3163 else {
3164 SvTEMP_off(sv);
3165 SvREFCNT_inc_simple_void_NN(sv);
3166 }
de080daa 3167 }
93661e56 3168 else if (av) {
199f858d 3169 sv = newSVavdefelem(av, ix, 0);
de080daa 3170 }
a600f7e6
FC
3171 else
3172 sv = &PL_sv_undef;
a0d0e21e 3173
de080daa
DM
3174 oldsv = *itersvp;
3175 *itersvp = sv;
3176 SvREFCNT_dec(oldsv);
de080daa 3177 break;
a48ce6be
DM
3178
3179 default:
3180 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
3181 }
8a1f10dd 3182
7c114860
DM
3183 /* Bypass pushing &PL_sv_yes and calling pp_and(); instead
3184 * jump straight to the AND op's op_other */
3185 assert(PL_op->op_next->op_type == OP_AND);
3186 assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
3187 return cLOGOPx(PL_op->op_next)->op_other;
3188
3189 retno:
3190 /* Bypass pushing &PL_sv_no and calling pp_and(); instead
3191 * jump straight to the AND op's op_next */
3192 assert(PL_op->op_next->op_type == OP_AND);
3193 assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
8a1f10dd 3194 /* pp_enteriter should have pre-extended the stack */
87058c31 3195 EXTEND_SKIP(PL_stack_sp, 1);
7c114860
DM
3196 /* we only need this for the rare case where the OP_AND isn't
3197 * in void context, e.g. $x = do { for (..) {...} };
3198 * but its cheaper to just push it rather than testing first
3199 */
3200 *++PL_stack_sp = &PL_sv_no;
3201 return PL_op->op_next->op_next;
a0d0e21e
LW
3202}
3203
7c114860 3204
ef07e810
DM
3205/*
3206A description of how taint works in pattern matching and substitution.
3207
284167a5
SM
3208This is all conditional on NO_TAINT_SUPPORT not being defined. Under
3209NO_TAINT_SUPPORT, taint-related operations should become no-ops.
3210
4e19c54b 3211While the pattern is being assembled/concatenated and then compiled,
284167a5
SM
3212PL_tainted will get set (via TAINT_set) if any component of the pattern
3213is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
3214the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1738e041
DM
3215TAINT_get). It will also be set if any component of the pattern matches
3216based on locale-dependent behavior.
ef07e810 3217
0ab462a6
DM
3218When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
3219the pattern is marked as tainted. This means that subsequent usage, such
284167a5
SM
3220as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
3221on the new pattern too.
ef07e810 3222
272d35c9 3223RXf_TAINTED_SEEN is used post-execution by the get magic code
ef07e810
DM
3224of $1 et al to indicate whether the returned value should be tainted.
3225It is the responsibility of the caller of the pattern (i.e. pp_match,
3226pp_subst etc) to set this flag for any other circumstances where $1 needs
3227to be tainted.
3228
3229The taint behaviour of pp_subst (and pp_substcont) is quite complex.
3230
3231There are three possible sources of taint
3232 * the source string
3233 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
3234 * the replacement string (or expression under /e)
3235
3236There are four destinations of taint and they are affected by the sources
3237according to the rules below:
3238
3239 * the return value (not including /r):
3240 tainted by the source string and pattern, but only for the
3241 number-of-iterations case; boolean returns aren't tainted;
3242 * the modified string (or modified copy under /r):
3243 tainted by the source string, pattern, and replacement strings;
3244 * $1 et al:
3245 tainted by the pattern, and under 'use re "taint"', by the source
3246 string too;
3247 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
3248 should always be unset before executing subsequent code.
3249
3250The overall action of pp_subst is:
3251
3252 * at the start, set bits in rxtainted indicating the taint status of
3253 the various sources.
3254
3255 * After each pattern execution, update the SUBST_TAINT_PAT bit in
3256 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
3257 pattern has subsequently become tainted via locale ops.
3258
3259 * If control is being passed to pp_substcont to execute a /e block,
3260 save rxtainted in the CXt_SUBST block, for future use by
3261 pp_substcont.
3262
3263 * Whenever control is being returned to perl code (either by falling
3264 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
3265 use the flag bits in rxtainted to make all the appropriate types of
0ab462a6
DM
3266 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
3267 et al will appear tainted.
ef07e810
DM
3268
3269pp_match is just a simpler version of the above.
3270
3271*/
3272
a0d0e21e
LW
3273PP(pp_subst)
3274{
20b7effb 3275 dSP; dTARG;
eb578fdb 3276 PMOP *pm = cPMOP;
a0d0e21e 3277 PMOP *rpm = pm;
eb578fdb 3278 char *s;
a0d0e21e 3279 char *strend;
5c144d81 3280 const char *c;
a0d0e21e 3281 STRLEN clen;
3c6ef0a5
FC
3282 SSize_t iters = 0;
3283 SSize_t maxiters;
a0d0e21e 3284 bool once;
ef07e810
DM
3285 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
3286 See "how taint works" above */
a0d0e21e 3287 char *orig;
1ed74d04 3288 U8 r_flags;
eb578fdb 3289 REGEXP *rx = PM_GETRE(pm);
196a02af 3290 regexp *prog = ReANY(rx);
a0d0e21e
LW
3291 STRLEN len;
3292 int force_on_match = 0;
0bcc34c2 3293 const I32 oldsave = PL_savestack_ix;
792b2c16 3294 STRLEN slen;
26a74523 3295 bool doutf8 = FALSE; /* whether replacement is in utf8 */
db2c6cb3 3296#ifdef PERL_ANY_COW
106d9a13 3297 bool was_cow;
ed252734 3298#endif
a0714e2c 3299 SV *nsv = NULL;
b770e143 3300 /* known replacement string? */
eb578fdb 3301 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
a0d0e21e 3302
f410a211
NC
3303 PERL_ASYNC_CHECK();
3304
533c011a 3305 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
3306 TARG = POPs;
3307 else {
9399c607
DM
3308 if (ARGTARG)
3309 GETTARGET;
3310 else {
3311 TARG = DEFSV;
3312 }
a0d0e21e 3313 EXTEND(SP,1);
1c846c1f 3314 }
d9f424b2 3315
64534138 3316 SvGETMAGIC(TARG); /* must come before cow check */
db2c6cb3 3317#ifdef PERL_ANY_COW
106d9a13
DM
3318 /* note that a string might get converted to COW during matching */
3319 was_cow = cBOOL(SvIsCOW(TARG));
ed252734 3320#endif
d13a5d3b
TC
3321 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3322#ifndef PERL_ANY_COW
3323 if (SvIsCOW(TARG))
3324 sv_force_normal_flags(TARG,0);
3325#endif
3326 if ((SvREADONLY(TARG)
3327 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
3328 || SvTYPE(TARG) > SVt_PVLV)
3329 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
3330 Perl_croak_no_modify();
3331 }
8ec5e241
NIS
3332 PUTBACK;
3333
6ac6605d
DM
3334 orig = SvPV_nomg(TARG, len);
3335 /* note we don't (yet) force the var into being a string; if we fail
92711104 3336 * to match, we leave as-is; on successful match however, we *will*
6ac6605d 3337 * coerce into a string, then repeat the match */
4499db73 3338 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
a0d0e21e 3339 force_on_match = 1;
20be6587
DM
3340
3341 /* only replace once? */
3342 once = !(rpm->op_pmflags & PMf_GLOBAL);
3343
ef07e810 3344 /* See "how taint works" above */
284167a5 3345 if (TAINTING_get) {
20be6587
DM
3346 rxtainted = (
3347 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
196a02af 3348 | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
20be6587
DM
3349 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
3350 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
3351 ? SUBST_TAINT_BOOLRET : 0));
3352 TAINT_NOT;
3353 }
a12c0f56 3354
a0d0e21e 3355 force_it:
6ac6605d
DM
3356 if (!pm || !orig)
3357 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
a0d0e21e 3358
6ac6605d
DM
3359 strend = orig + len;
3360 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
792b2c16
JH
3361 maxiters = 2 * slen + 10; /* We can match twice at each
3362 position, once with zero-length,
3363 second time with non-zero. */
a0d0e21e 3364
794826f4 3365 /* handle the empty pattern */
196a02af 3366 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
5585e758
YO
3367 if (PL_curpm == PL_reg_curpm) {
3368 if (PL_curpm_under) {
3369 if (PL_curpm_under == PL_reg_curpm) {
3370 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
3371 } else {
3372 pm = PL_curpm_under;
3373 }
3374 }
3375 } else {
3376 pm = PL_curpm;
3377 }
3378 rx = PM_GETRE(pm);
196a02af 3379 prog = ReANY(rx);
a0d0e21e 3380 }
6502e081 3381
6e240d0b 3382#ifdef PERL_SAWAMPERSAND
196a02af 3383 r_flags = ( RXp_NPARENS(prog)
6502e081 3384 || PL_sawampersand
196a02af 3385 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 3386 || (rpm->op_pmflags & PMf_KEEPCOPY)
6502e081
DM
3387 )
3388 ? REXEC_COPY_STR
3389 : 0;
6e240d0b
FC
3390#else
3391 r_flags = REXEC_COPY_STR;
3392#endif
7fba1cd6 3393
0395280b 3394 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
8b64c330 3395 {
5e79dfb9
DM
3396 SPAGAIN;
3397 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
3398 LEAVE_SCOPE(oldsave);
3399 RETURN;
3400 }
1754320d
FC
3401 PL_curpm = pm;
3402
71be2cbc 3403 /* known replacement string? */
f272994b 3404 if (dstr) {
8514a05a
JH
3405 /* replacement needing upgrading? */
3406 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 3407 nsv = sv_newmortal();
4a176938 3408 SvSetSV(nsv, dstr);
8df0e7a2 3409 sv_utf8_upgrade(nsv);
5c144d81 3410 c = SvPV_const(nsv, clen);
4a176938
JH
3411 doutf8 = TRUE;
3412 }
3413 else {
5c144d81 3414 c = SvPV_const(dstr, clen);
4a176938 3415 doutf8 = DO_UTF8(dstr);
8514a05a 3416 }
bb933b9b
FC
3417
3418 if (SvTAINTED(dstr))
3419 rxtainted |= SUBST_TAINT_REPL;
f272994b
A
3420 }
3421 else {
6136c704 3422 c = NULL;
f272994b
A
3423 doutf8 = FALSE;
3424 }
3425
71be2cbc 3426 /* can do inplace substitution? */
ed252734 3427 if (c
db2c6cb3 3428#ifdef PERL_ANY_COW
106d9a13 3429 && !was_cow
ed252734 3430#endif
196a02af 3431 && (I32)clen <= RXp_MINLENRET(prog)
9cefd268
FC
3432 && ( once
3433 || !(r_flags & REXEC_COPY_STR)
196a02af 3434 || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
9cefd268 3435 )
196a02af 3436 && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
8ca8a454
NC
3437 && (!doutf8 || SvUTF8(TARG))
3438 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
8b030b38 3439 {
ec911639 3440
db2c6cb3 3441#ifdef PERL_ANY_COW
106d9a13 3442 /* string might have got converted to COW since we set was_cow */
ed252734 3443 if (SvIsCOW(TARG)) {
f7a8268c 3444 if (!force_on_match)
ed252734 3445 goto have_a_cow;
f7a8268c 3446 assert(SvVOK(TARG));
ed252734
NC
3447 }
3448#endif
71be2cbc 3449 if (force_on_match) {
6ac6605d
DM
3450 /* redo the first match, this time with the orig var
3451 * forced into being a string */
71be2cbc 3452 force_on_match = 0;
6ac6605d 3453 orig = SvPV_force_nomg(TARG, len);
71be2cbc
PP
3454 goto force_it;
3455 }
39b40493 3456
71be2cbc 3457 if (once) {
c67ab8f2 3458 char *d, *m;
196a02af 3459 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
20be6587 3460 rxtainted |= SUBST_TAINT_PAT;
196a02af
DM
3461 m = orig + RXp_OFFS(prog)[0].start;
3462 d = orig + RXp_OFFS(prog)[0].end;
71be2cbc
PP
3463 s = orig;
3464 if (m - s > strend - d) { /* faster to shorten from end */
2ec7214c 3465 I32 i;
71be2cbc
PP
3466 if (clen) {
3467 Copy(c, m, clen, char);
3468 m += clen;
a0d0e21e 3469 }
71be2cbc
PP
3470 i = strend - d;
3471 if (i > 0) {
3472 Move(d, m, i, char);
3473 m += i;
a0d0e21e 3474 }
71be2cbc
PP
3475 *m = '\0';
3476 SvCUR_set(TARG, m - s);
3477 }
2ec7214c
DM
3478 else { /* faster from front */
3479 I32 i = m - s;
71be2cbc 3480 d -= clen;
2ec7214c
DM
3481 if (i > 0)
3482 Move(s, d - i, i, char);
71be2cbc 3483 sv_chop(TARG, d-i);
71be2cbc 3484 if (clen)
c947cd8d 3485 Copy(c, d, clen, char);
71be2cbc 3486 }
8ec5e241 3487 SPAGAIN;
8ca8a454 3488 PUSHs(&PL_sv_yes);
71be2cbc
PP
3489 }
3490 else {
c67ab8f2 3491 char *d, *m;
196a02af 3492 d = s = RXp_OFFS(prog)[0].start + orig;
71be2cbc 3493 do {
2b25edcf 3494 I32 i;
5d9574c1 3495 if (UNLIKELY(iters++ > maxiters))
cea2e8a9 3496 DIE(aTHX_ "Substitution loop");
196a02af
DM
3497 /* run time pattern taint, eg locale */
3498 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
20be6587 3499 rxtainted |= SUBST_TAINT_PAT;
196a02af 3500 m = RXp_OFFS(prog)[0].start + orig;
155aba94 3501 if ((i = m - s)) {
71be2cbc
PP
3502 if (s != d)
3503 Move(s, d, i, char);
3504 d += i;
a0d0e21e 3505 }
71be2cbc
PP
3506 if (clen) {
3507 Copy(c, d, clen, char);
3508 d += clen;
3509 }
196a02af 3510 s = RXp_OFFS(prog)[0].end + orig;
7ce41e5c
FC
3511 } while (CALLREGEXEC(rx, s, strend, orig,
3512 s == m, /* don't match same null twice */
f722798b 3513 TARG, NULL,
d5e7783a 3514 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
71be2cbc 3515 if (s != d) {
2b25edcf 3516 I32 i = strend - s;
aa07b2f6 3517 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
71be2cbc 3518 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 3519 }
8ec5e241 3520 SPAGAIN;
7b394f12
DM
3521 if (PL_op->op_private & OPpTRUEBOOL)
3522 PUSHs(iters ? &PL_sv_yes : &PL_sv_zero);
3523 else
3524 mPUSHi(iters);
a0d0e21e
LW
3525 }
3526 }
ff6e92e8 3527 else {
1754320d 3528 bool first;
c67ab8f2 3529 char *m;
1754320d 3530 SV *repl;
a0d0e21e 3531 if (force_on_match) {
6ac6605d
DM
3532 /* redo the first match, this time with the orig var
3533 * forced into being a string */
a0d0e21e 3534 force_on_match = 0;
0c1438a1
NC
3535 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3536 /* I feel that it should be possible to avoid this mortal copy
3537 given that the code below copies into a new destination.
3538 However, I suspect it isn't worth the complexity of
3539 unravelling the C<goto force_it> for the small number of
3540 cases where it would be viable to drop into the copy code. */
3541 TARG = sv_2mortal(newSVsv(TARG));
3542 }
6ac6605d 3543 orig = SvPV_force_nomg(TARG, len);
a0d0e21e
LW
3544 goto force_it;
3545 }
db2c6cb3 3546#ifdef PERL_ANY_COW
ed252734
NC
3547 have_a_cow:
3548#endif
196a02af 3549 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
20be6587 3550 rxtainted |= SUBST_TAINT_PAT;
1754320d 3551 repl = dstr;
196a02af 3552 s = RXp_OFFS(prog)[0].start + orig;
0395280b
DM
3553 dstr = newSVpvn_flags(orig, s-orig,
3554 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
a0d0e21e 3555 if (!c) {
eb578fdb 3556 PERL_CONTEXT *cx;
8ec5e241 3557 SPAGAIN;
0395280b 3558 m = orig;
20be6587
DM
3559 /* note that a whole bunch of local vars are saved here for
3560 * use by pp_substcont: here's a list of them in case you're
3561 * searching for places in this sub that uses a particular var:
3562 * iters maxiters r_flags oldsave rxtainted orig dstr targ
3563 * s m strend rx once */
490576d1 3564 CX_PUSHSUBST(cx);
20e98b0f 3565 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
a0d0e21e 3566 }
1754320d 3567 first = TRUE;
a0d0e21e 3568 do {
5d9574c1 3569 if (UNLIKELY(iters++ > maxiters))
cea2e8a9 3570 DIE(aTHX_ "Substitution loop");
196a02af 3571 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
20be6587 3572 rxtainted |= SUBST_TAINT_PAT;
196a02af 3573 if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
c67ab8f2
DM
3574 char *old_s = s;
3575 char *old_orig = orig;
196a02af 3576 assert(RXp_SUBOFFSET(prog) == 0);
c67ab8f2 3577
196a02af 3578 orig = RXp_SUBBEG(prog);
c67ab8f2
DM
3579 s = orig + (old_s - old_orig);
3580 strend = s + (strend - old_s);
a0d0e21e 3581 }
196a02af 3582 m = RXp_OFFS(prog)[0].start + orig;
64534138 3583 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
196a02af 3584 s = RXp_OFFS(prog)[0].end + orig;
1754320d
FC
3585 if (first) {
3586 /* replacement already stringified */
3587 if (clen)
64534138 3588 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
1754320d
FC
3589 first = FALSE;
3590 }
3591 else {
8df0e7a2 3592 sv_catsv(dstr, repl);
5d9574c1 3593 if (UNLIKELY(SvTAINTED(repl)))
bb933b9b 3594 rxtainted |= SUBST_TAINT_REPL;
1754320d 3595 }
a0d0e21e
LW
3596 if (once)
3597 break;
ff27773b
KW
3598 } while (CALLREGEXEC(rx, s, strend, orig,
3599 s == m, /* Yields minend of 0 or 1 */
d5e7783a
DM
3600 TARG, NULL,
3601 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
aba224f7 3602 assert(strend >= s);
64534138 3603 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
748a9306 3604
8ca8a454
NC
3605 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3606 /* From here on down we're using the copy, and leaving the original
3607 untouched. */
3608 TARG = dstr;
3609 SPAGAIN;
3610 PUSHs(dstr);
3611 } else {
db2c6cb3 3612#ifdef PERL_ANY_COW
8ca8a454
NC
3613 /* The match may make the string COW. If so, brilliant, because
3614 that's just saved us one malloc, copy and free - the regexp has
3615 donated the old buffer, and we malloc an entirely new one, rather
3616 than the regexp malloc()ing a buffer and copying our original,
3617 only for us to throw it away here during the substitution. */
3618 if (SvIsCOW(TARG)) {
3619 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
3620 } else
ed252734 3621#endif
8ca8a454
NC
3622 {
3623 SvPV_free(TARG);
3624 }
3625 SvPV_set(TARG, SvPVX(dstr));
3626 SvCUR_set(TARG, SvCUR(dstr));
3627 SvLEN_set(TARG, SvLEN(dstr));
64534138 3628 SvFLAGS(TARG) |= SvUTF8(dstr);
8ca8a454 3629 SvPV_set(dstr, NULL);
748a9306 3630
8ca8a454 3631 SPAGAIN;
3c6ef0a5 3632 mPUSHi(iters);
8ca8a454
NC
3633 }
3634 }
3635
3636 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3637 (void)SvPOK_only_UTF8(TARG);
a0d0e21e 3638 }
20be6587 3639
ef07e810 3640 /* See "how taint works" above */
284167a5 3641 if (TAINTING_get) {
20be6587
DM
3642 if ((rxtainted & SUBST_TAINT_PAT) ||
3643 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
3644 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
3645 )