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