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