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