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