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