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