This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perldelta for fb10a8a78bba
[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
3dd9d4e4
FC
79/* This is sometimes called directly by pp_coreargs, pp_grepstart and
80 amagic_call. */
a0d0e21e
LW
81PP(pp_pushmark)
82{
3280af22 83 PUSHMARK(PL_stack_sp);
a0d0e21e
LW
84 return NORMAL;
85}
86
87PP(pp_stringify)
88{
20b7effb 89 dSP; dTARGET;
4cc783ef
DD
90 SV * const sv = TOPs;
91 SETs(TARG);
92 sv_copypv(TARG, sv);
93 SvSETMAGIC(TARG);
94 /* no PUTBACK, SETs doesn't inc/dec SP */
95 return NORMAL;
a0d0e21e
LW
96}
97
98PP(pp_gv)
99{
20b7effb 100 dSP;
ad64d0ec 101 XPUSHs(MUTABLE_SV(cGVOP_gv));
ff2a62e0
FC
102 if (isGV(cGVOP_gv)
103 && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)))
104 PL_sawalias = TRUE;
a0d0e21e
LW
105 RETURN;
106}
107
b1c05ba5
DM
108
109/* also used for: pp_andassign() */
110
a0d0e21e
LW
111PP(pp_and)
112{
f410a211 113 PERL_ASYNC_CHECK();
4cc783ef
DD
114 {
115 /* SP is not used to remove a variable that is saved across the
116 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
117 register or load/store vs direct mem ops macro is introduced, this
118 should be a define block between direct PL_stack_sp and dSP operations,
119 presently, using PL_stack_sp is bias towards CISC cpus */
120 SV * const sv = *PL_stack_sp;
121 if (!SvTRUE_NN(sv))
122 return NORMAL;
123 else {
124 if (PL_op->op_type == OP_AND)
125 --PL_stack_sp;
126 return cLOGOP->op_other;
127 }
a0d0e21e
LW
128 }
129}
130
131PP(pp_sassign)
132{
20b7effb 133 dSP;
3e75a3c4
RU
134 /* sassign keeps its args in the optree traditionally backwards.
135 So we pop them differently.
136 */
137 SV *left = POPs; SV *right = TOPs;
748a9306 138
533c011a 139 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
0bd48802
AL
140 SV * const temp = left;
141 left = right; right = temp;
a0d0e21e 142 }
5d9574c1 143 if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
a0d0e21e 144 TAINT_NOT;
5d9574c1
DM
145 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
146 /* *foo =\&bar */
3e75a3c4 147 SV * const cv = SvRV(right);
e26df76a 148 const U32 cv_type = SvTYPE(cv);
3e75a3c4 149 const bool is_gv = isGV_with_GP(left);
6136c704 150 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
e26df76a
NC
151
152 if (!got_coderef) {
153 assert(SvROK(cv));
154 }
155
3e75a3c4
RU
156 /* Can do the optimisation if left (LVALUE) is not a typeglob,
157 right (RVALUE) is a reference to something, and we're in void
e26df76a 158 context. */
13be902c 159 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
e26df76a 160 /* Is the target symbol table currently empty? */
3e75a3c4 161 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
bb112e5a 162 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
e26df76a
NC
163 /* Good. Create a new proxy constant subroutine in the target.
164 The gv becomes a(nother) reference to the constant. */
165 SV *const value = SvRV(cv);
166
ad64d0ec 167 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
1ccdb730 168 SvPCS_IMPORTED_on(gv);
e26df76a 169 SvRV_set(gv, value);
b37c2d43 170 SvREFCNT_inc_simple_void(value);
3e75a3c4 171 SETs(left);
e26df76a
NC
172 RETURN;
173 }
174 }
175
176 /* Need to fix things up. */
13be902c 177 if (!is_gv) {
e26df76a 178 /* Need to fix GV. */
3e75a3c4 179 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
e26df76a
NC
180 }
181
182 if (!got_coderef) {
183 /* We've been returned a constant rather than a full subroutine,
184 but they expect a subroutine reference to apply. */
53a42478 185 if (SvROK(cv)) {
d343c3ef 186 ENTER_with_name("sassign_coderef");
53a42478
NC
187 SvREFCNT_inc_void(SvRV(cv));
188 /* newCONSTSUB takes a reference count on the passed in SV
189 from us. We set the name to NULL, otherwise we get into
190 all sorts of fun as the reference to our new sub is
191 donated to the GV that we're about to assign to.
192 */
3e75a3c4 193 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
ad64d0ec 194 SvRV(cv))));
fc2b2dca 195 SvREFCNT_dec_NN(cv);
d343c3ef 196 LEAVE_with_name("sassign_coderef");
53a42478
NC
197 } else {
198 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
199 is that
200 First: ops for \&{"BONK"}; return us the constant in the
201 symbol table
202 Second: ops for *{"BONK"} cause that symbol table entry
203 (and our reference to it) to be upgraded from RV
204 to typeblob)
205 Thirdly: We get here. cv is actually PVGV now, and its
206 GvCV() is actually the subroutine we're looking for
207
208 So change the reference so that it points to the subroutine
209 of that typeglob, as that's what they were after all along.
210 */
159b6efe 211 GV *const upgraded = MUTABLE_GV(cv);
53a42478
NC
212 CV *const source = GvCV(upgraded);
213
214 assert(source);
215 assert(CvFLAGS(source) & CVf_CONST);
216
217 SvREFCNT_inc_void(source);
fc2b2dca 218 SvREFCNT_dec_NN(upgraded);
3e75a3c4 219 SvRV_set(right, MUTABLE_SV(source));
53a42478 220 }
e26df76a 221 }
53a42478 222
e26df76a 223 }
8fe85e3f 224 if (
5d9574c1 225 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
3e75a3c4 226 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
8fe85e3f
FC
227 )
228 Perl_warner(aTHX_
229 packWARN(WARN_MISC), "Useless assignment to a temporary"
230 );
3e75a3c4
RU
231 SvSetMagicSV(left, right);
232 SETs(left);
a0d0e21e
LW
233 RETURN;
234}
235
236PP(pp_cond_expr)
237{
20b7effb 238 dSP;
f410a211 239 PERL_ASYNC_CHECK();
a0d0e21e 240 if (SvTRUEx(POPs))
1a67a97c 241 RETURNOP(cLOGOP->op_other);
a0d0e21e 242 else
1a67a97c 243 RETURNOP(cLOGOP->op_next);
a0d0e21e
LW
244}
245
246PP(pp_unstack)
247{
8f3964af 248 PERL_ASYNC_CHECK();
a0d0e21e 249 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 250 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 251 FREETMPS;
eae48c89
Z
252 if (!(PL_op->op_flags & OPf_SPECIAL)) {
253 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
254 LEAVE_SCOPE(oldsave);
255 }
a0d0e21e
LW
256 return NORMAL;
257}
258
a0d0e21e
LW
259PP(pp_concat)
260{
20b7effb 261 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
748a9306
LW
262 {
263 dPOPTOPssrl;
8d6d96c1
HS
264 bool lbyte;
265 STRLEN rlen;
d4c19fe8 266 const char *rpv = NULL;
a6b599c7 267 bool rbyte = FALSE;
a9c4fd4e 268 bool rcopied = FALSE;
8d6d96c1 269
6f1401dc
DM
270 if (TARG == right && right != left) { /* $r = $l.$r */
271 rpv = SvPV_nomg_const(right, rlen);
c75ab21a 272 rbyte = !DO_UTF8(right);
59cd0e26 273 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
349d4f2f 274 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
db79b45b 275 rcopied = TRUE;
8d6d96c1 276 }
7889fe52 277
89734059 278 if (TARG != left) { /* not $l .= $r */
a9c4fd4e 279 STRLEN llen;
6f1401dc 280 const char* const lpv = SvPV_nomg_const(left, llen);
90f5826e 281 lbyte = !DO_UTF8(left);
8d6d96c1
HS
282 sv_setpvn(TARG, lpv, llen);
283 if (!lbyte)
284 SvUTF8_on(TARG);
285 else
286 SvUTF8_off(TARG);
287 }
18ea7bf2
SM
288 else { /* $l .= $r and left == TARG */
289 if (!SvOK(left)) {
89734059 290 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
c75ab21a 291 report_uninit(right);
76f68e9b 292 sv_setpvs(left, "");
c75ab21a 293 }
18ea7bf2
SM
294 else {
295 SvPV_force_nomg_nolen(left);
296 }
583a5589 297 lbyte = !DO_UTF8(left);
90f5826e 298 if (IN_BYTES)
18ea7bf2 299 SvUTF8_off(left);
8d6d96c1 300 }
a12c0f56 301
c75ab21a 302 if (!rcopied) {
6f1401dc 303 rpv = SvPV_nomg_const(right, rlen);
c75ab21a
RH
304 rbyte = !DO_UTF8(right);
305 }
8d6d96c1
HS
306 if (lbyte != rbyte) {
307 if (lbyte)
308 sv_utf8_upgrade_nomg(TARG);
309 else {
db79b45b 310 if (!rcopied)
59cd0e26 311 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
8d6d96c1 312 sv_utf8_upgrade_nomg(right);
6f1401dc 313 rpv = SvPV_nomg_const(right, rlen);
69b47968 314 }
a0d0e21e 315 }
8d6d96c1 316 sv_catpvn_nomg(TARG, rpv, rlen);
43ebc500 317
a0d0e21e
LW
318 SETTARG;
319 RETURN;
748a9306 320 }
a0d0e21e
LW
321}
322
d5524600
DM
323/* push the elements of av onto the stack.
324 * XXX Note that padav has similar code but without the mg_get().
325 * I suspect that the mg_get is no longer needed, but while padav
326 * differs, it can't share this function */
327
f9ae8fb6 328STATIC void
d5524600
DM
329S_pushav(pTHX_ AV* const av)
330{
331 dSP;
c70927a6 332 const SSize_t maxarg = AvFILL(av) + 1;
d5524600 333 EXTEND(SP, maxarg);
5d9574c1 334 if (UNLIKELY(SvRMAGICAL(av))) {
c70927a6
FC
335 PADOFFSET i;
336 for (i=0; i < (PADOFFSET)maxarg; i++) {
d5524600
DM
337 SV ** const svp = av_fetch(av, i, FALSE);
338 /* See note in pp_helem, and bug id #27839 */
339 SP[i+1] = svp
340 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
341 : &PL_sv_undef;
342 }
343 }
344 else {
c70927a6
FC
345 PADOFFSET i;
346 for (i=0; i < (PADOFFSET)maxarg; i++) {
ce0d59fd 347 SV * const sv = AvARRAY(av)[i];
5d9574c1 348 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
ce0d59fd 349 }
d5524600
DM
350 }
351 SP += maxarg;
352 PUTBACK;
353}
354
355
a7fd8ef6
DM
356/* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
357
358PP(pp_padrange)
359{
20b7effb 360 dSP;
a7fd8ef6
DM
361 PADOFFSET base = PL_op->op_targ;
362 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
363 int i;
d5524600
DM
364 if (PL_op->op_flags & OPf_SPECIAL) {
365 /* fake the RHS of my ($x,$y,..) = @_ */
366 PUSHMARK(SP);
367 S_pushav(aTHX_ GvAVn(PL_defgv));
368 SPAGAIN;
369 }
370
a7fd8ef6
DM
371 /* note, this is only skipped for compile-time-known void cxt */
372 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
373 EXTEND(SP, count);
374 PUSHMARK(SP);
375 for (i = 0; i <count; i++)
376 *++SP = PAD_SV(base+i);
377 }
378 if (PL_op->op_private & OPpLVAL_INTRO) {
4e09461c
DM
379 SV **svp = &(PAD_SVl(base));
380 const UV payload = (UV)(
381 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
382 | (count << SAVE_TIGHT_SHIFT)
383 | SAVEt_CLEARPADRANGE);
6d59e610 384 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
4e09461c 385 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
a3444cc5
DM
386 {
387 dSS_ADD;
388 SS_ADD_UV(payload);
389 SS_ADD_END(1);
390 }
4e09461c 391
a7fd8ef6 392 for (i = 0; i <count; i++)
4e09461c 393 SvPADSTALE_off(*svp++); /* mark lexical as active */
a7fd8ef6
DM
394 }
395 RETURN;
396}
397
398
a0d0e21e
LW
399PP(pp_padsv)
400{
20b7effb 401 dSP;
6c28b496
DD
402 EXTEND(SP, 1);
403 {
404 OP * const op = PL_op;
405 /* access PL_curpad once */
406 SV ** const padentry = &(PAD_SVl(op->op_targ));
407 {
408 dTARG;
409 TARG = *padentry;
410 PUSHs(TARG);
411 PUTBACK; /* no pop/push after this, TOPs ok */
8ec5e241 412 }
6c28b496
DD
413 if (op->op_flags & OPf_MOD) {
414 if (op->op_private & OPpLVAL_INTRO)
415 if (!(op->op_private & OPpPAD_STATE))
416 save_clearsv(padentry);
417 if (op->op_private & OPpDEREF) {
8f90a16d
FC
418 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
419 than TARG reduces the scope of TARG, so it does not
420 span the call to save_clearsv, resulting in smaller
421 machine code. */
6c28b496
DD
422 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
423 }
424 }
425 return op->op_next;
4633a7c4 426 }
a0d0e21e
LW
427}
428
429PP(pp_readline)
430{
30901a8a
FC
431 dSP;
432 if (TOPs) {
433 SvGETMAGIC(TOPs);
fc99edcf 434 tryAMAGICunTARGETlist(iter_amg, 0);
30901a8a
FC
435 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
436 }
437 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
6e592b3a
BM
438 if (!isGV_with_GP(PL_last_in_gv)) {
439 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
159b6efe 440 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
8efb3254 441 else {
f5284f61 442 dSP;
ad64d0ec 443 XPUSHs(MUTABLE_SV(PL_last_in_gv));
f5284f61 444 PUTBACK;
897d3989 445 Perl_pp_rv2gv(aTHX);
159b6efe 446 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
84ee769f
FC
447 if (PL_last_in_gv == (GV *)&PL_sv_undef)
448 PL_last_in_gv = NULL;
449 else
450 assert(isGV_with_GP(PL_last_in_gv));
f5284f61
IZ
451 }
452 }
a0d0e21e
LW
453 return do_readline();
454}
455
456PP(pp_eq)
457{
20b7effb 458 dSP;
33efebe6
DM
459 SV *left, *right;
460
a42d0242 461 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
462 right = POPs;
463 left = TOPs;
464 SETs(boolSV(
465 (SvIOK_notUV(left) && SvIOK_notUV(right))
466 ? (SvIVX(left) == SvIVX(right))
467 : ( do_ncmp(left, right) == 0)
468 ));
469 RETURN;
a0d0e21e
LW
470}
471
b1c05ba5
DM
472
473/* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
474
a0d0e21e
LW
475PP(pp_preinc)
476{
20b7effb 477 dSP;
17058fe0
FC
478 const bool inc =
479 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
5d9574c1 480 if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
cb077ed2 481 Perl_croak_no_modify();
5d9574c1 482 if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
17058fe0 483 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
55497cff 484 {
17058fe0 485 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
55497cff 486 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 487 }
28e5dec8 488 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
17058fe0
FC
489 if (inc) sv_inc(TOPs);
490 else sv_dec(TOPs);
a0d0e21e
LW
491 SvSETMAGIC(TOPs);
492 return NORMAL;
493}
494
b1c05ba5
DM
495
496/* also used for: pp_orassign() */
497
a0d0e21e
LW
498PP(pp_or)
499{
20b7effb 500 dSP;
f410a211 501 PERL_ASYNC_CHECK();
a0d0e21e
LW
502 if (SvTRUE(TOPs))
503 RETURN;
504 else {
c960fc3b
SP
505 if (PL_op->op_type == OP_OR)
506 --SP;
a0d0e21e
LW
507 RETURNOP(cLOGOP->op_other);
508 }
509}
510
b1c05ba5
DM
511
512/* also used for: pp_dor() pp_dorassign() */
513
25a55bd7 514PP(pp_defined)
c963b151 515{
20b7effb 516 dSP;
eb578fdb 517 SV* sv;
6136c704 518 bool defined;
25a55bd7 519 const int op_type = PL_op->op_type;
ea5195b7 520 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
c963b151 521
6136c704 522 if (is_dor) {
f410a211 523 PERL_ASYNC_CHECK();
25a55bd7 524 sv = TOPs;
5d9574c1 525 if (UNLIKELY(!sv || !SvANY(sv))) {
2bd49cfc
NC
526 if (op_type == OP_DOR)
527 --SP;
25a55bd7
SP
528 RETURNOP(cLOGOP->op_other);
529 }
b7c44293
RGS
530 }
531 else {
532 /* OP_DEFINED */
25a55bd7 533 sv = POPs;
5d9574c1 534 if (UNLIKELY(!sv || !SvANY(sv)))
25a55bd7 535 RETPUSHNO;
b7c44293 536 }
25a55bd7 537
6136c704 538 defined = FALSE;
c963b151
BD
539 switch (SvTYPE(sv)) {
540 case SVt_PVAV:
541 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 542 defined = TRUE;
c963b151
BD
543 break;
544 case SVt_PVHV:
545 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 546 defined = TRUE;
c963b151
BD
547 break;
548 case SVt_PVCV:
549 if (CvROOT(sv) || CvXSUB(sv))
25a55bd7 550 defined = TRUE;
c963b151
BD
551 break;
552 default:
5b295bef 553 SvGETMAGIC(sv);
c963b151 554 if (SvOK(sv))
25a55bd7 555 defined = TRUE;
6136c704 556 break;
c963b151 557 }
6136c704
AL
558
559 if (is_dor) {
c960fc3b
SP
560 if(defined)
561 RETURN;
562 if(op_type == OP_DOR)
563 --SP;
25a55bd7 564 RETURNOP(cLOGOP->op_other);
25a55bd7 565 }
d9aa96a4
SP
566 /* assuming OP_DEFINED */
567 if(defined)
568 RETPUSHYES;
569 RETPUSHNO;
c963b151
BD
570}
571
a0d0e21e
LW
572PP(pp_add)
573{
20b7effb 574 dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
575 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
576 svr = TOPs;
577 svl = TOPm1s;
578
800401ee 579 useleft = USE_LEFT(svl);
28e5dec8
JH
580#ifdef PERL_PRESERVE_IVUV
581 /* We must see if we can perform the addition with integers if possible,
582 as the integer code detects overflow while the NV code doesn't.
583 If either argument hasn't had a numeric conversion yet attempt to get
584 the IV. It's important to do this now, rather than just assuming that
585 it's not IOK as a PV of "9223372036854775806" may not take well to NV
586 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
587 integer in case the second argument is IV=9223372036854775806
588 We can (now) rely on sv_2iv to do the right thing, only setting the
589 public IOK flag if the value in the NV (or PV) slot is truly integer.
590
591 A side effect is that this also aggressively prefers integer maths over
7dca457a
NC
592 fp maths for integer values.
593
a00b5bd3 594 How to detect overflow?
7dca457a
NC
595
596 C 99 section 6.2.6.1 says
597
598 The range of nonnegative values of a signed integer type is a subrange
599 of the corresponding unsigned integer type, and the representation of
600 the same value in each type is the same. A computation involving
601 unsigned operands can never overflow, because a result that cannot be
602 represented by the resulting unsigned integer type is reduced modulo
603 the number that is one greater than the largest value that can be
604 represented by the resulting type.
605
606 (the 9th paragraph)
607
608 which I read as "unsigned ints wrap."
609
610 signed integer overflow seems to be classed as "exception condition"
611
612 If an exceptional condition occurs during the evaluation of an
613 expression (that is, if the result is not mathematically defined or not
614 in the range of representable values for its type), the behavior is
615 undefined.
616
617 (6.5, the 5th paragraph)
618
619 I had assumed that on 2s complement machines signed arithmetic would
620 wrap, hence coded pp_add and pp_subtract on the assumption that
621 everything perl builds on would be happy. After much wailing and
622 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
623 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
624 unsigned code below is actually shorter than the old code. :-)
625 */
626
01f91bf2 627 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
628 /* Unless the left argument is integer in range we are going to have to
629 use NV maths. Hence only attempt to coerce the right argument if
630 we know the left is integer. */
eb578fdb 631 UV auv = 0;
9c5ffd7c 632 bool auvok = FALSE;
7dca457a
NC
633 bool a_valid = 0;
634
28e5dec8 635 if (!useleft) {
7dca457a
NC
636 auv = 0;
637 a_valid = auvok = 1;
638 /* left operand is undef, treat as zero. + 0 is identity,
639 Could SETi or SETu right now, but space optimise by not adding
640 lots of code to speed up what is probably a rarish case. */
641 } else {
642 /* Left operand is defined, so is it IV? */
01f91bf2 643 if (SvIV_please_nomg(svl)) {
800401ee
JH
644 if ((auvok = SvUOK(svl)))
645 auv = SvUVX(svl);
7dca457a 646 else {
eb578fdb 647 const IV aiv = SvIVX(svl);
7dca457a
NC
648 if (aiv >= 0) {
649 auv = aiv;
650 auvok = 1; /* Now acting as a sign flag. */
53e2bfb7
DM
651 } else {
652 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
7dca457a
NC
653 }
654 }
655 a_valid = 1;
28e5dec8
JH
656 }
657 }
7dca457a
NC
658 if (a_valid) {
659 bool result_good = 0;
660 UV result;
eb578fdb 661 UV buv;
800401ee 662 bool buvok = SvUOK(svr);
a00b5bd3 663
7dca457a 664 if (buvok)
800401ee 665 buv = SvUVX(svr);
7dca457a 666 else {
eb578fdb 667 const IV biv = SvIVX(svr);
7dca457a
NC
668 if (biv >= 0) {
669 buv = biv;
670 buvok = 1;
671 } else
53e2bfb7 672 buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
7dca457a
NC
673 }
674 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 675 else "IV" now, independent of how it came in.
7dca457a
NC
676 if a, b represents positive, A, B negative, a maps to -A etc
677 a + b => (a + b)
678 A + b => -(a - b)
679 a + B => (a - b)
680 A + B => -(a + b)
681 all UV maths. negate result if A negative.
682 add if signs same, subtract if signs differ. */
683
684 if (auvok ^ buvok) {
685 /* Signs differ. */
686 if (auv >= buv) {
687 result = auv - buv;
688 /* Must get smaller */
689 if (result <= auv)
690 result_good = 1;
691 } else {
692 result = buv - auv;
693 if (result <= buv) {
694 /* result really should be -(auv-buv). as its negation
695 of true value, need to swap our result flag */
696 auvok = !auvok;
697 result_good = 1;
28e5dec8
JH
698 }
699 }
7dca457a
NC
700 } else {
701 /* Signs same */
702 result = auv + buv;
703 if (result >= auv)
704 result_good = 1;
705 }
706 if (result_good) {
707 SP--;
708 if (auvok)
28e5dec8 709 SETu( result );
7dca457a
NC
710 else {
711 /* Negate result */
712 if (result <= (UV)IV_MIN)
53e2bfb7
DM
713 SETi(result == (UV)IV_MIN
714 ? IV_MIN : -(IV)result);
7dca457a
NC
715 else {
716 /* result valid, but out of range for IV. */
717 SETn( -(NV)result );
28e5dec8
JH
718 }
719 }
7dca457a
NC
720 RETURN;
721 } /* Overflow, drop through to NVs. */
28e5dec8
JH
722 }
723 }
724#endif
a0d0e21e 725 {
6f1401dc 726 NV value = SvNV_nomg(svr);
4efa5a16 727 (void)POPs;
28e5dec8
JH
728 if (!useleft) {
729 /* left operand is undef, treat as zero. + 0.0 is identity. */
730 SETn(value);
731 RETURN;
732 }
6f1401dc 733 SETn( value + SvNV_nomg(svl) );
28e5dec8 734 RETURN;
a0d0e21e
LW
735 }
736}
737
b1c05ba5
DM
738
739/* also used for: pp_aelemfast_lex() */
740
a0d0e21e
LW
741PP(pp_aelemfast)
742{
20b7effb 743 dSP;
93bad3fd 744 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
8f878375 745 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
a3b680e6 746 const U32 lval = PL_op->op_flags & OPf_MOD;
b024352e 747 SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
3280af22 748 SV *sv = (svp ? *svp : &PL_sv_undef);
b024352e
DM
749
750 if (UNLIKELY(!svp && lval))
751 DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
752
6ff81951 753 EXTEND(SP, 1);
39cf747a 754 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 755 mg_get(sv);
be6c24e0 756 PUSHs(sv);
a0d0e21e
LW
757 RETURN;
758}
759
760PP(pp_join)
761{
20b7effb 762 dSP; dMARK; dTARGET;
a0d0e21e
LW
763 MARK++;
764 do_join(TARG, *MARK, MARK, SP);
765 SP = MARK;
766 SETs(TARG);
767 RETURN;
768}
769
770PP(pp_pushre)
771{
20b7effb 772 dSP;
44a8e56a
PP
773#ifdef DEBUGGING
774 /*
775 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
776 * will be enough to hold an OP*.
777 */
c4420975 778 SV* const sv = sv_newmortal();
44a8e56a
PP
779 sv_upgrade(sv, SVt_PVLV);
780 LvTYPE(sv) = '/';
533c011a 781 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
44a8e56a
PP
782 XPUSHs(sv);
783#else
ad64d0ec 784 XPUSHs(MUTABLE_SV(PL_op));
44a8e56a 785#endif
a0d0e21e
LW
786 RETURN;
787}
788
789/* Oversized hot code. */
790
b1c05ba5
DM
791/* also used for: pp_say() */
792
a0d0e21e
LW
793PP(pp_print)
794{
20b7effb 795 dSP; dMARK; dORIGMARK;
eb578fdb 796 PerlIO *fp;
236988e4 797 MAGIC *mg;
159b6efe
NC
798 GV * const gv
799 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 800 IO *io = GvIO(gv);
5b468f54 801
9c9f25b8 802 if (io
ad64d0ec 803 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
5b468f54 804 {
01bb7c6d 805 had_magic:
68dc0745 806 if (MARK == ORIGMARK) {
1c846c1f 807 /* If using default handle then we need to make space to
a60c0954
NIS
808 * pass object as 1st arg, so move other args up ...
809 */
4352c267 810 MEXTEND(SP, 1);
68dc0745
PP
811 ++MARK;
812 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
813 ++SP;
814 }
3e0cb5de 815 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
94bc412f
NC
816 mg,
817 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
818 | (PL_op->op_type == OP_SAY
819 ? TIED_METHOD_SAY : 0)), sp - mark);
236988e4 820 }
9c9f25b8 821 if (!io) {
68b590d9 822 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
ad64d0ec 823 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
01bb7c6d 824 goto had_magic;
51087808 825 report_evil_fh(gv);
93189314 826 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
827 goto just_say_no;
828 }
829 else if (!(fp = IoOFP(io))) {
7716c5c5
NC
830 if (IoIFP(io))
831 report_wrongway_fh(gv, '<');
51087808 832 else
7716c5c5 833 report_evil_fh(gv);
93189314 834 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW
835 goto just_say_no;
836 }
837 else {
e23d9e2f 838 SV * const ofs = GvSV(PL_ofsgv); /* $, */
a0d0e21e 839 MARK++;
e23d9e2f 840 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
a0d0e21e
LW
841 while (MARK <= SP) {
842 if (!do_print(*MARK, fp))
843 break;
844 MARK++;
845 if (MARK <= SP) {
e23d9e2f
CS
846 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
847 if (!do_print(GvSV(PL_ofsgv), fp)) {
a0d0e21e
LW
848 MARK--;
849 break;
850 }
851 }
852 }
853 }
854 else {
855 while (MARK <= SP) {
856 if (!do_print(*MARK, fp))
857 break;
858 MARK++;
859 }
860 }
861 if (MARK <= SP)
862 goto just_say_no;
863 else {
cfc4a7da
GA
864 if (PL_op->op_type == OP_SAY) {
865 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
866 goto just_say_no;
867 }
868 else if (PL_ors_sv && SvOK(PL_ors_sv))
7889fe52 869 if (!do_print(PL_ors_sv, fp)) /* $\ */
a0d0e21e
LW
870 goto just_say_no;
871
872 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 873 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
874 goto just_say_no;
875 }
876 }
877 SP = ORIGMARK;
e52fd6f4 878 XPUSHs(&PL_sv_yes);
a0d0e21e
LW
879 RETURN;
880
881 just_say_no:
882 SP = ORIGMARK;
e52fd6f4 883 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
884 RETURN;
885}
886
b1c05ba5
DM
887
888/* also used for: pp_rv2hv() */
bdaf10a5 889/* also called directly by pp_lvavref */
b1c05ba5 890
a0d0e21e
LW
891PP(pp_rv2av)
892{
20b7effb 893 dSP; dTOPss;
cde874ca 894 const I32 gimme = GIMME_V;
13c59d41
MH
895 static const char an_array[] = "an ARRAY";
896 static const char a_hash[] = "a HASH";
bdaf10a5
FC
897 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
898 || PL_op->op_type == OP_LVAVREF;
d83b45b8 899 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e 900
9026059d 901 SvGETMAGIC(sv);
a0d0e21e 902 if (SvROK(sv)) {
5d9574c1 903 if (UNLIKELY(SvAMAGIC(sv))) {
93d7320b 904 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
93d7320b 905 }
17ab7946 906 sv = SvRV(sv);
5d9574c1 907 if (UNLIKELY(SvTYPE(sv) != type))
dcbac5bb 908 /* diag_listed_as: Not an ARRAY reference */
13c59d41 909 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
5d9574c1
DM
910 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
911 && PL_op->op_private & OPpLVAL_INTRO))
3da99855 912 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e 913 }
5d9574c1 914 else if (UNLIKELY(SvTYPE(sv) != type)) {
67955e0c 915 GV *gv;
1c846c1f 916
6e592b3a 917 if (!isGV_with_GP(sv)) {
13c59d41 918 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
dc3c76f8
NC
919 type, &sp);
920 if (!gv)
921 RETURN;
35cd451c
GS
922 }
923 else {
159b6efe 924 gv = MUTABLE_GV(sv);
a0d0e21e 925 }
ad64d0ec 926 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
533c011a 927 if (PL_op->op_private & OPpLVAL_INTRO)
ad64d0ec 928 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
9f527363
FC
929 }
930 if (PL_op->op_flags & OPf_REF) {
17ab7946 931 SETs(sv);
a0d0e21e 932 RETURN;
9f527363 933 }
5d9574c1 934 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
40c94d11
FC
935 const I32 flags = is_lvalue_sub();
936 if (flags && !(flags & OPpENTERSUB_INARGS)) {
cde874ca 937 if (gimme != G_ARRAY)
042560a6 938 goto croak_cant_return;
17ab7946 939 SETs(sv);
78f9721b 940 RETURN;
40c94d11 941 }
a0d0e21e
LW
942 }
943
17ab7946 944 if (is_pp_rv2av) {
502c6561 945 AV *const av = MUTABLE_AV(sv);
636fe681 946 /* The guts of pp_rv2av */
96913b52 947 if (gimme == G_ARRAY) {
d5524600
DM
948 SP--;
949 PUTBACK;
950 S_pushav(aTHX_ av);
951 SPAGAIN;
1c846c1f 952 }
96913b52
VP
953 else if (gimme == G_SCALAR) {
954 dTARGET;
c70927a6 955 const SSize_t maxarg = AvFILL(av) + 1;
96913b52 956 SETi(maxarg);
93965878 957 }
17ab7946
NC
958 } else {
959 /* The guts of pp_rv2hv */
96913b52
VP
960 if (gimme == G_ARRAY) { /* array wanted */
961 *PL_stack_sp = sv;
981b7185 962 return Perl_do_kv(aTHX);
96913b52 963 }
c8fe3bdf 964 else if ((PL_op->op_private & OPpTRUEBOOL
adc42c31 965 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
c8fe3bdf
FC
966 && block_gimme() == G_VOID ))
967 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
968 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
96913b52 969 else if (gimme == G_SCALAR) {
1a8bdda9 970 dTARG;
96913b52 971 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
96913b52
VP
972 SETTARG;
973 }
17ab7946 974 }
be85d344 975 RETURN;
042560a6
NC
976
977 croak_cant_return:
978 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
979 is_pp_rv2av ? "array" : "hash");
77e217c6 980 RETURN;
a0d0e21e
LW
981}
982
10c8fecd 983STATIC void
fb8f4cf8 984S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
10c8fecd 985{
7918f24d
NC
986 PERL_ARGS_ASSERT_DO_ODDBALL;
987
fb8f4cf8 988 if (*oddkey) {
6d822dc4 989 if (ckWARN(WARN_MISC)) {
a3b680e6 990 const char *err;
fb8f4cf8
RZ
991 if (oddkey == firstkey &&
992 SvROK(*oddkey) &&
993 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
994 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
10c8fecd 995 {
a3b680e6 996 err = "Reference found where even-sized list expected";
10c8fecd
GS
997 }
998 else
a3b680e6 999 err = "Odd number of elements in hash assignment";
f1f66076 1000 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
10c8fecd 1001 }
6d822dc4 1002
10c8fecd
GS
1003 }
1004}
1005
a0d0e21e
LW
1006PP(pp_aassign)
1007{
27da23d5 1008 dVAR; dSP;
3280af22
NIS
1009 SV **lastlelem = PL_stack_sp;
1010 SV **lastrelem = PL_stack_base + POPMARK;
1011 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
1012 SV **firstlelem = lastrelem + 1;
1013
eb578fdb
KW
1014 SV **relem;
1015 SV **lelem;
a0d0e21e 1016
eb578fdb
KW
1017 SV *sv;
1018 AV *ary;
a0d0e21e 1019
54310121 1020 I32 gimme;
a0d0e21e 1021 HV *hash;
c70927a6 1022 SSize_t i;
a0d0e21e 1023 int magic;
88e2091b 1024 U32 lval = 0;
5637b936 1025
3280af22 1026 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
ca65944e 1027 gimme = GIMME_V;
88e2091b
RZ
1028 if (gimme == G_ARRAY)
1029 lval = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e
LW
1030
1031 /* If there's a common identifier on both sides we have to take
1032 * special care that assigning the identifier on the left doesn't
1033 * clobber a value on the right that's used later in the list.
acdea6f0 1034 * Don't bother if LHS is just an empty hash or array.
a0d0e21e 1035 */
acdea6f0 1036
ff2a62e0 1037 if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
acdea6f0
DM
1038 && (
1039 firstlelem != lastlelem
1040 || ! ((sv = *firstlelem))
1041 || SvMAGICAL(sv)
1042 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1043 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1b95d04f 1044 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
acdea6f0
DM
1045 )
1046 ) {
cc5e57d2 1047 EXTEND_MORTAL(lastrelem - firstrelem + 1);
10c8fecd 1048 for (relem = firstrelem; relem <= lastrelem; relem++) {
5d9574c1 1049 if (LIKELY((sv = *relem))) {
a1f49e72 1050 TAINT_NOT; /* Each item is independent */
61e5f455
NC
1051
1052 /* Dear TODO test in t/op/sort.t, I love you.
1053 (It's relying on a panic, not a "semi-panic" from newSVsv()
1054 and then an assertion failure below.) */
5d9574c1 1055 if (UNLIKELY(SvIS_FREED(sv))) {
61e5f455
NC
1056 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1057 (void*)sv);
1058 }
2203fb5a
FC
1059 /* Not newSVsv(), as it does not allow copy-on-write,
1060 resulting in wasteful copies. We need a second copy of
1061 a temp here, hence the SV_NOSTEAL. */
1062 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1063 |SV_NOSTEAL);
a1f49e72 1064 }
10c8fecd 1065 }
a0d0e21e
LW
1066 }
1067
1068 relem = firstrelem;
1069 lelem = firstlelem;
4608196e
RGS
1070 ary = NULL;
1071 hash = NULL;
10c8fecd 1072
5d9574c1 1073 while (LIKELY(lelem <= lastlelem)) {
bdaf10a5 1074 bool alias = FALSE;
bbce6d69 1075 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e 1076 sv = *lelem++;
bdaf10a5
FC
1077 if (UNLIKELY(!sv)) {
1078 alias = TRUE;
1079 sv = *lelem++;
1080 ASSUME(SvTYPE(sv) == SVt_PVAV);
1081 }
a0d0e21e
LW
1082 switch (SvTYPE(sv)) {
1083 case SVt_PVAV:
60edcf09 1084 ary = MUTABLE_AV(sv);
748a9306 1085 magic = SvMAGICAL(ary) != 0;
60edcf09
FC
1086 ENTER;
1087 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1088 av_clear(ary);
7e42bd57 1089 av_extend(ary, lastrelem - relem);
a0d0e21e
LW
1090 i = 0;
1091 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 1092 SV **didstore;
5d9574c1 1093 if (LIKELY(*relem))
ce0d59fd 1094 SvGETMAGIC(*relem); /* before newSV, in case it dies */
bdaf10a5
FC
1095 if (LIKELY(!alias)) {
1096 sv = newSV(0);
1097 sv_setsv_nomg(sv, *relem);
1098 *relem = sv;
1099 }
1100 else {
1101 if (!SvROK(*relem))
1102 DIE(aTHX_ "Assigned value is not a reference");
1103 if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1104 /* diag_listed_as: Assigned value is not %s reference */
1105 DIE(aTHX_
1106 "Assigned value is not a SCALAR reference");
1107 if (lval)
1108 *relem = sv_mortalcopy(*relem);
1109 /* XXX else check for weak refs? */
1110 sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1111 }
1112 relem++;
5117ca91
GS
1113 didstore = av_store(ary,i++,sv);
1114 if (magic) {
18024492
FC
1115 if (!didstore)
1116 sv_2mortal(sv);
8ef24240 1117 if (SvSMAGICAL(sv))
fb73857a 1118 mg_set(sv);
5117ca91 1119 }
bbce6d69 1120 TAINT_NOT;
a0d0e21e 1121 }
5d9574c1 1122 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
ad64d0ec 1123 SvSETMAGIC(MUTABLE_SV(ary));
60edcf09 1124 LEAVE;
a0d0e21e 1125 break;
10c8fecd 1126 case SVt_PVHV: { /* normal hash */
a0d0e21e 1127 SV *tmpstr;
1c4ea384
RZ
1128 int odd;
1129 int duplicates = 0;
45960564 1130 SV** topelem = relem;
1c4ea384 1131 SV **firsthashrelem = relem;
a0d0e21e 1132
60edcf09 1133 hash = MUTABLE_HV(sv);
748a9306 1134 magic = SvMAGICAL(hash) != 0;
1c4ea384
RZ
1135
1136 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
5d9574c1 1137 if (UNLIKELY(odd)) {
fb8f4cf8 1138 do_oddball(lastrelem, firsthashrelem);
1d2b3927
HS
1139 /* we have firstlelem to reuse, it's not needed anymore
1140 */
1c4ea384
RZ
1141 *(lastrelem+1) = &PL_sv_undef;
1142 }
1143
60edcf09
FC
1144 ENTER;
1145 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 1146 hv_clear(hash);
5d9574c1 1147 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
5117ca91 1148 HE *didstore;
1c4ea384 1149 assert(*relem);
632b9d6f
FC
1150 /* Copy the key if aassign is called in lvalue context,
1151 to avoid having the next op modify our rhs. Copy
1152 it also if it is gmagical, lest it make the
1153 hv_store_ent call below croak, leaking the value. */
1154 sv = lval || SvGMAGICAL(*relem)
1155 ? sv_mortalcopy(*relem)
1156 : *relem;
45960564 1157 relem++;
1c4ea384 1158 assert(*relem);
632b9d6f
FC
1159 SvGETMAGIC(*relem);
1160 tmpstr = newSV(0);
1161 sv_setsv_nomg(tmpstr,*relem++); /* value */
a88bf2bc 1162 if (gimme == G_ARRAY) {
45960564
DM
1163 if (hv_exists_ent(hash, sv, 0))
1164 /* key overwrites an existing entry */
1165 duplicates += 2;
a88bf2bc 1166 else {
45960564 1167 /* copy element back: possibly to an earlier
1d2b3927
HS
1168 * stack location if we encountered dups earlier,
1169 * possibly to a later stack location if odd */
45960564
DM
1170 *topelem++ = sv;
1171 *topelem++ = tmpstr;
1172 }
1173 }
5117ca91 1174 didstore = hv_store_ent(hash,sv,tmpstr,0);
632b9d6f
FC
1175 if (magic) {
1176 if (!didstore) sv_2mortal(tmpstr);
1177 SvSETMAGIC(tmpstr);
1178 }
bbce6d69 1179 TAINT_NOT;
8e07c86e 1180 }
60edcf09 1181 LEAVE;
1c4ea384
RZ
1182 if (duplicates && gimme == G_ARRAY) {
1183 /* at this point we have removed the duplicate key/value
1184 * pairs from the stack, but the remaining values may be
1185 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1186 * the (a 2), but the stack now probably contains
1187 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1188 * obliterates the earlier key. So refresh all values. */
1189 lastrelem -= duplicates;
1190 relem = firsthashrelem;
1191 while (relem < lastrelem+odd) {
1192 HE *he;
1193 he = hv_fetch_ent(hash, *relem++, 0, 0);
1194 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1195 }
1196 }
1197 if (odd && gimme == G_ARRAY) lastrelem++;
a0d0e21e
LW
1198 }
1199 break;
1200 default:
6fc92669
GS
1201 if (SvIMMORTAL(sv)) {
1202 if (relem <= lastrelem)
1203 relem++;
1204 break;
a0d0e21e
LW
1205 }
1206 if (relem <= lastrelem) {
5d9574c1 1207 if (UNLIKELY(
1c70fb82
FC
1208 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1209 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
5d9574c1 1210 ))
1c70fb82
FC
1211 Perl_warner(aTHX_
1212 packWARN(WARN_MISC),
1213 "Useless assignment to a temporary"
1214 );
a0d0e21e
LW
1215 sv_setsv(sv, *relem);
1216 *(relem++) = sv;
1217 }
1218 else
3280af22 1219 sv_setsv(sv, &PL_sv_undef);
8ef24240 1220 SvSETMAGIC(sv);
a0d0e21e
LW
1221 break;
1222 }
1223 }
5d9574c1 1224 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
985213f2 1225 /* Will be used to set PL_tainting below */
dfff4baf
BF
1226 Uid_t tmp_uid = PerlProc_getuid();
1227 Uid_t tmp_euid = PerlProc_geteuid();
1228 Gid_t tmp_gid = PerlProc_getgid();
1229 Gid_t tmp_egid = PerlProc_getegid();
985213f2 1230
b469f1e0 1231 /* XXX $> et al currently silently ignore failures */
3280af22 1232 if (PL_delaymagic & DM_UID) {
a0d0e21e 1233#ifdef HAS_SETRESUID
b469f1e0
JH
1234 PERL_UNUSED_RESULT(
1235 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1236 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1237 (Uid_t)-1));
56febc5e
AD
1238#else
1239# ifdef HAS_SETREUID
b469f1e0
JH
1240 PERL_UNUSED_RESULT(
1241 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1242 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
56febc5e
AD
1243# else
1244# ifdef HAS_SETRUID
b28d0864 1245 if ((PL_delaymagic & DM_UID) == DM_RUID) {
b469f1e0 1246 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
b28d0864 1247 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1248 }
56febc5e
AD
1249# endif /* HAS_SETRUID */
1250# ifdef HAS_SETEUID
b28d0864 1251 if ((PL_delaymagic & DM_UID) == DM_EUID) {
b469f1e0 1252 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
b28d0864 1253 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1254 }
56febc5e 1255# endif /* HAS_SETEUID */
b28d0864 1256 if (PL_delaymagic & DM_UID) {
985213f2 1257 if (PL_delaymagic_uid != PL_delaymagic_euid)
cea2e8a9 1258 DIE(aTHX_ "No setreuid available");
b469f1e0 1259 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
a0d0e21e 1260 }
56febc5e
AD
1261# endif /* HAS_SETREUID */
1262#endif /* HAS_SETRESUID */
04783dc7 1263
985213f2
AB
1264 tmp_uid = PerlProc_getuid();
1265 tmp_euid = PerlProc_geteuid();
a0d0e21e 1266 }
b469f1e0 1267 /* XXX $> et al currently silently ignore failures */
3280af22 1268 if (PL_delaymagic & DM_GID) {
a0d0e21e 1269#ifdef HAS_SETRESGID
b469f1e0
JH
1270 PERL_UNUSED_RESULT(
1271 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1272 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1273 (Gid_t)-1));
56febc5e
AD
1274#else
1275# ifdef HAS_SETREGID
b469f1e0
JH
1276 PERL_UNUSED_RESULT(
1277 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1278 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
56febc5e
AD
1279# else
1280# ifdef HAS_SETRGID
b28d0864 1281 if ((PL_delaymagic & DM_GID) == DM_RGID) {
b469f1e0 1282 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
b28d0864 1283 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1284 }
56febc5e
AD
1285# endif /* HAS_SETRGID */
1286# ifdef HAS_SETEGID
b28d0864 1287 if ((PL_delaymagic & DM_GID) == DM_EGID) {
b469f1e0 1288 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
b28d0864 1289 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1290 }
56febc5e 1291# endif /* HAS_SETEGID */
b28d0864 1292 if (PL_delaymagic & DM_GID) {
985213f2 1293 if (PL_delaymagic_gid != PL_delaymagic_egid)
cea2e8a9 1294 DIE(aTHX_ "No setregid available");
b469f1e0 1295 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
a0d0e21e 1296 }
56febc5e
AD
1297# endif /* HAS_SETREGID */
1298#endif /* HAS_SETRESGID */
04783dc7 1299
985213f2
AB
1300 tmp_gid = PerlProc_getgid();
1301 tmp_egid = PerlProc_getegid();
a0d0e21e 1302 }
284167a5 1303 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
9a9b5ec9
DM
1304#ifdef NO_TAINT_SUPPORT
1305 PERL_UNUSED_VAR(tmp_uid);
1306 PERL_UNUSED_VAR(tmp_euid);
1307 PERL_UNUSED_VAR(tmp_gid);
1308 PERL_UNUSED_VAR(tmp_egid);
1309#endif
a0d0e21e 1310 }
3280af22 1311 PL_delaymagic = 0;
54310121 1312
54310121
PP
1313 if (gimme == G_VOID)
1314 SP = firstrelem - 1;
1315 else if (gimme == G_SCALAR) {
1316 dTARGET;
1317 SP = firstrelem;
231cbeb2 1318 SETi(lastrelem - firstrelem + 1);
54310121
PP
1319 }
1320 else {
1c4ea384 1321 if (ary || hash)
1d2b3927
HS
1322 /* note that in this case *firstlelem may have been overwritten
1323 by sv_undef in the odd hash case */
a0d0e21e 1324 SP = lastrelem;
1c4ea384 1325 else {
a0d0e21e 1326 SP = firstrelem + (lastlelem - firstlelem);
1c4ea384
RZ
1327 lelem = firstlelem + (relem - firstrelem);
1328 while (relem <= SP)
1329 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1330 }
a0d0e21e 1331 }
08aeb9f7 1332
54310121 1333 RETURN;
a0d0e21e
LW
1334}
1335
8782bef2
GB
1336PP(pp_qr)
1337{
20b7effb 1338 dSP;
eb578fdb 1339 PMOP * const pm = cPMOP;
fe578d7f 1340 REGEXP * rx = PM_GETRE(pm);
10599a69 1341 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
c4420975 1342 SV * const rv = sv_newmortal();
d63c20f2
DM
1343 CV **cvp;
1344 CV *cv;
288b8c02
NC
1345
1346 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
1347 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1348 loathe to use it here, but it seems to be the right fix. Or close.
1349 The key part appears to be that it's essential for pp_qr to return a new
1350 object (SV), which implies that there needs to be an effective way to
1351 generate a new SV from the existing SV that is pre-compiled in the
1352 optree. */
1353 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
1354 SvROK_on(rv);
1355
8d919b0a 1356 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
5d9574c1 1357 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
d63c20f2 1358 *cvp = cv_clone(cv);
fc2b2dca 1359 SvREFCNT_dec_NN(cv);
d63c20f2
DM
1360 }
1361
288b8c02 1362 if (pkg) {
f815daf2 1363 HV *const stash = gv_stashsv(pkg, GV_ADD);
fc2b2dca 1364 SvREFCNT_dec_NN(pkg);
288b8c02
NC
1365 (void)sv_bless(rv, stash);
1366 }
1367
5d9574c1 1368 if (UNLIKELY(RX_ISTAINTED(rx))) {
e08e52cf 1369 SvTAINTED_on(rv);
9274aefd
DM
1370 SvTAINTED_on(SvRV(rv));
1371 }
c8c13c22 1372 XPUSHs(rv);
1373 RETURN;
8782bef2
GB
1374}
1375
a0d0e21e
LW
1376PP(pp_match)
1377{
20b7effb 1378 dSP; dTARG;
eb578fdb 1379 PMOP *pm = cPMOP;
d65afb4b 1380 PMOP *dynpm = pm;
eb578fdb 1381 const char *s;
5c144d81 1382 const char *strend;
99a90e59 1383 SSize_t curpos = 0; /* initial pos() or current $+[0] */
a0d0e21e 1384 I32 global;
7fadf4a7 1385 U8 r_flags = 0;
5c144d81 1386 const char *truebase; /* Start of string */
eb578fdb 1387 REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1388 bool rxtainted;
82334630 1389 const I32 gimme = GIMME_V;
a0d0e21e 1390 STRLEN len;
a3b680e6 1391 const I32 oldsave = PL_savestack_ix;
e60df1fa 1392 I32 had_zerolen = 0;
b1422d62 1393 MAGIC *mg = NULL;
a0d0e21e 1394
533c011a 1395 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1396 TARG = POPs;
6ffceeb7 1397 else if (ARGTARG)
59f00321 1398 GETTARGET;
a0d0e21e 1399 else {
54b9620d 1400 TARG = DEFSV;
a0d0e21e
LW
1401 EXTEND(SP,1);
1402 }
d9f424b2 1403
c277df42 1404 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
1405 /* Skip get-magic if this is a qr// clone, because regcomp has
1406 already done it. */
f1d31338 1407 truebase = ReANY(rx)->mother_re
69dc4b30
FC
1408 ? SvPV_nomg_const(TARG, len)
1409 : SvPV_const(TARG, len);
f1d31338 1410 if (!truebase)
2269b42e 1411 DIE(aTHX_ "panic: pp_match");
f1d31338 1412 strend = truebase + len;
284167a5
SM
1413 rxtainted = (RX_ISTAINTED(rx) ||
1414 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1415 TAINT_NOT;
a0d0e21e 1416
6c864ec2 1417 /* We need to know this in case we fail out early - pos() must be reset */
de0df3c0
MH
1418 global = dynpm->op_pmflags & PMf_GLOBAL;
1419
d65afb4b 1420 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
1421 if (
1422#ifdef USE_ITHREADS
1423 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1424#else
1425 pm->op_pmflags & PMf_USED
1426#endif
1427 ) {
e5dc5375 1428 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
de0df3c0 1429 goto nope;
a0d0e21e
LW
1430 }
1431
7e313637
FC
1432 /* empty pattern special-cased to use last successful pattern if
1433 possible, except for qr// */
8d919b0a 1434 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
7e313637 1435 && PL_curpm) {
3280af22 1436 pm = PL_curpm;
aaa362c4 1437 rx = PM_GETRE(pm);
a0d0e21e 1438 }
d65afb4b 1439
389ecb56 1440 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
75d43e96
FC
1441 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1442 UVuf" < %"IVdf")\n",
1443 (UV)len, (IV)RX_MINLEN(rx)));
de0df3c0 1444 goto nope;
e5dc5375 1445 }
c277df42 1446
8ef97b0e 1447 /* get pos() if //g */
de0df3c0 1448 if (global) {
b1422d62 1449 mg = mg_find_mglob(TARG);
8ef97b0e 1450 if (mg && mg->mg_len >= 0) {
25fdce4a 1451 curpos = MgBYTEPOS(mg, TARG, truebase, len);
8ef97b0e
DM
1452 /* last time pos() was set, it was zero-length match */
1453 if (mg->mg_flags & MGf_MINMATCH)
1454 had_zerolen = 1;
1455 }
a0d0e21e 1456 }
8ef97b0e 1457
6e240d0b 1458#ifdef PERL_SAWAMPERSAND
a41aa44d 1459 if ( RX_NPARENS(rx)
6502e081 1460 || PL_sawampersand
6502e081 1461 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
5b0e71e9 1462 || (dynpm->op_pmflags & PMf_KEEPCOPY)
6e240d0b
FC
1463 )
1464#endif
1465 {
6502e081
DM
1466 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1467 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1468 * only on the first iteration. Therefore we need to copy $' as well
1469 * as $&, to make the rest of the string available for captures in
1470 * subsequent iterations */
1471 if (! (global && gimme == G_ARRAY))
1472 r_flags |= REXEC_COPY_SKIP_POST;
1473 };
5b0e71e9
DM
1474#ifdef PERL_SAWAMPERSAND
1475 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1476 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1477 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1478#endif
22e551b9 1479
f1d31338
DM
1480 s = truebase;
1481
d7be1480 1482 play_it_again:
985afbc1 1483 if (global)
03c83e26 1484 s = truebase + curpos;
f722798b 1485
77da2310 1486 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
03c83e26 1487 had_zerolen, TARG, NULL, r_flags))
03b6c93d 1488 goto nope;
77da2310
NC
1489
1490 PL_curpm = pm;
985afbc1 1491 if (dynpm->op_pmflags & PMf_ONCE)
c737faaf 1492#ifdef USE_ITHREADS
77da2310 1493 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
c737faaf 1494#else
77da2310 1495 dynpm->op_pmflags |= PMf_USED;
c737faaf 1496#endif
a0d0e21e 1497
72311751
GS
1498 if (rxtainted)
1499 RX_MATCH_TAINTED_on(rx);
1500 TAINT_IF(RX_MATCH_TAINTED(rx));
35c2ccc3
DM
1501
1502 /* update pos */
1503
1504 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
b1422d62 1505 if (!mg)
35c2ccc3 1506 mg = sv_magicext_mglob(TARG);
25fdce4a 1507 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
adf51885
DM
1508 if (RX_ZERO_LEN(rx))
1509 mg->mg_flags |= MGf_MINMATCH;
1510 else
1511 mg->mg_flags &= ~MGf_MINMATCH;
35c2ccc3
DM
1512 }
1513
bf9dff51
DM
1514 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1515 LEAVE_SCOPE(oldsave);
1516 RETPUSHYES;
1517 }
1518
88ab22af
DM
1519 /* push captures on stack */
1520
bf9dff51 1521 {
07bc277f 1522 const I32 nparens = RX_NPARENS(rx);
a3b680e6 1523 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 1524
c277df42 1525 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1526 EXTEND(SP, nparens + i);
1527 EXTEND_MORTAL(nparens + i);
1528 for (i = !i; i <= nparens; i++) {
a0d0e21e 1529 PUSHs(sv_newmortal());
5d9574c1
DM
1530 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1531 && RX_OFFS(rx)[i].end != -1 ))
1532 {
07bc277f 1533 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
f1d31338 1534 const char * const s = RX_OFFS(rx)[i].start + truebase;
5d9574c1
DM
1535 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1536 || len < 0 || len > strend - s))
5637ef5b
NC
1537 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1538 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1539 (long) i, (long) RX_OFFS(rx)[i].start,
1540 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
a0d0e21e 1541 sv_setpvn(*SP, s, len);
cce850e4 1542 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1543 SvUTF8_on(*SP);
a0d0e21e
LW
1544 }
1545 }
1546 if (global) {
0e0b3e82 1547 curpos = (UV)RX_OFFS(rx)[0].end;
03c83e26 1548 had_zerolen = RX_ZERO_LEN(rx);
c277df42 1549 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1550 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1551 goto play_it_again;
1552 }
4633a7c4 1553 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1554 RETURN;
1555 }
e5964223 1556 NOT_REACHED; /* NOTREACHED */
a0d0e21e 1557
7b52d656 1558 nope:
d65afb4b 1559 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
b1422d62
DM
1560 if (!mg)
1561 mg = mg_find_mglob(TARG);
1562 if (mg)
1563 mg->mg_len = -1;
a0d0e21e 1564 }
4633a7c4 1565 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1566 if (gimme == G_ARRAY)
1567 RETURN;
1568 RETPUSHNO;
1569}
1570
1571OP *
864dbfa3 1572Perl_do_readline(pTHX)
a0d0e21e 1573{
20b7effb 1574 dSP; dTARGETSTACKED;
eb578fdb 1575 SV *sv;
a0d0e21e
LW
1576 STRLEN tmplen = 0;
1577 STRLEN offset;
760ac839 1578 PerlIO *fp;
eb578fdb
KW
1579 IO * const io = GvIO(PL_last_in_gv);
1580 const I32 type = PL_op->op_type;
a3b680e6 1581 const I32 gimme = GIMME_V;
a0d0e21e 1582
6136c704 1583 if (io) {
50db69d8 1584 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 1585 if (mg) {
3e0cb5de 1586 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 1587 if (gimme == G_SCALAR) {
50db69d8
NC
1588 SPAGAIN;
1589 SvSetSV_nosteal(TARG, TOPs);
1590 SETTARG;
6136c704 1591 }
50db69d8 1592 return NORMAL;
0b7c7b4f 1593 }
e79b0511 1594 }
4608196e 1595 fp = NULL;
a0d0e21e
LW
1596 if (io) {
1597 fp = IoIFP(io);
1598 if (!fp) {
1599 if (IoFLAGS(io) & IOf_ARGV) {
1600 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1601 IoLINES(io) = 0;
b9f2b683 1602 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1603 IoFLAGS(io) &= ~IOf_START;
d5eb9a46 1604 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
4bac9ae4 1605 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
76f68e9b 1606 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3280af22 1607 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
1608 fp = IoIFP(io);
1609 goto have_fp;
a0d0e21e
LW
1610 }
1611 }
157fb5a1 1612 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
a0d0e21e 1613 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1614 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
1615 }
1616 }
0d44d22b
NC
1617 else if (type == OP_GLOB)
1618 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
1619 }
1620 else if (type == OP_GLOB)
1621 SP--;
7716c5c5 1622 else if (IoTYPE(io) == IoTYPE_WRONLY) {
a5390457 1623 report_wrongway_fh(PL_last_in_gv, '>');
a00b5bd3 1624 }
a0d0e21e
LW
1625 }
1626 if (!fp) {
041457d9 1627 if ((!io || !(IoFLAGS(io) & IOf_START))
de7dabb6
TC
1628 && ckWARN(WARN_CLOSED)
1629 && type != OP_GLOB)
041457d9 1630 {
de7dabb6 1631 report_evil_fh(PL_last_in_gv);
3f4520fe 1632 }
54310121 1633 if (gimme == G_SCALAR) {
79628082 1634 /* undef TARG, and push that undefined value */
ba92458f 1635 if (type != OP_RCATLINE) {
aab1202a 1636 sv_setsv(TARG,NULL);
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
6dfc73ea
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
79815f56
DM
1880/* Handle one or more aggregate derefs and array/hash indexings, e.g.
1881 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
fedf30e1
DM
1882 *
1883 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
79815f56
DM
1884 * Each of these either contains a set of actions, or an argument, such as
1885 * an IV to use as an array index, or a lexical var to retrieve.
1886 * Several actions re stored per UV; we keep shifting new actions off the
1887 * one UV, and only reload when it becomes zero.
fedf30e1
DM
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
1f0ba93b
DM
2950 if (CxMULTICALL(&cxstack[cxstack_ix])) {
2951 /* entry zero of a stack is always PL_sv_undef, which
2952 * simplifies converting a '()' return into undef in scalar context */
2953 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
9850bf21 2954 return 0;
1f0ba93b 2955 }
9850bf21 2956
a0d0e21e 2957 POPBLOCK(cx,newpm);
5dd42e15 2958 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2959
a1f49e72 2960 TAINT_NOT;
a0d0e21e
LW
2961 if (gimme == G_SCALAR) {
2962 MARK = newsp + 1;
5d9574c1 2963 if (LIKELY(MARK <= SP)) {
a8bba7fa 2964 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
6f48390a
FC
2965 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2966 && !SvMAGICAL(TOPs)) {
a29cdaf0
IZ
2967 *MARK = SvREFCNT_inc(TOPs);
2968 FREETMPS;
2969 sv_2mortal(*MARK);
cd06dffe
GS
2970 }
2971 else {
959e3673 2972 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2973 FREETMPS;
959e3673 2974 *MARK = sv_mortalcopy(sv);
fc2b2dca 2975 SvREFCNT_dec_NN(sv);
a29cdaf0 2976 }
cd06dffe 2977 }
6f48390a
FC
2978 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2979 && !SvMAGICAL(TOPs)) {
767eda44 2980 *MARK = TOPs;
767eda44 2981 }
cd06dffe 2982 else
767eda44 2983 *MARK = sv_mortalcopy(TOPs);
cd06dffe
GS
2984 }
2985 else {
f86702cc 2986 MEXTEND(MARK, 0);
3280af22 2987 *MARK = &PL_sv_undef;
a0d0e21e
LW
2988 }
2989 SP = MARK;
2990 }
54310121 2991 else if (gimme == G_ARRAY) {
f86702cc 2992 for (MARK = newsp + 1; MARK <= SP; MARK++) {
6f48390a
FC
2993 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2994 || SvMAGICAL(*MARK)) {
f86702cc 2995 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2996 TAINT_NOT; /* Each item is independent */
2997 }
f86702cc 2998 }
a0d0e21e 2999 }
f86702cc 3000 PUTBACK;
1c846c1f 3001
a57c6685 3002 LEAVE;
b0d9ce38 3003 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
25375124 3004 cxstack_ix--;
3280af22 3005 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 3006
b0d9ce38 3007 LEAVESUB(sv);
f39bc417 3008 return cx->blk_sub.retop;
a0d0e21e
LW
3009}
3010
3011PP(pp_entersub)
3012{
20b7effb 3013 dSP; dPOPss;
a0d0e21e 3014 GV *gv;
eb578fdb
KW
3015 CV *cv;
3016 PERL_CONTEXT *cx;
5d94fbed 3017 I32 gimme;
a9c4fd4e 3018 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e 3019
f5719c02 3020 if (UNLIKELY(!sv))
cea2e8a9 3021 DIE(aTHX_ "Not a CODE reference");
f5719c02
DM
3022 /* This is overwhelmingly the most common case: */
3023 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
313107ce
DM
3024 switch (SvTYPE(sv)) {
3025 case SVt_PVGV:
3026 we_have_a_glob:
3027 if (!(cv = GvCVu((const GV *)sv))) {
3028 HV *stash;
3029 cv = sv_2cv(sv, &stash, &gv, 0);
3030 }
3031 if (!cv) {
3032 ENTER;
3033 SAVETMPS;
3034 goto try_autoload;
3035 }
3036 break;
3037 case SVt_PVLV:
3038 if(isGV_with_GP(sv)) goto we_have_a_glob;
924ba076 3039 /* FALLTHROUGH */
313107ce
DM
3040 default:
3041 if (sv == &PL_sv_yes) { /* unfound import, ignore */
3042 if (hasargs)
3043 SP = PL_stack_base + POPMARK;
3044 else
3045 (void)POPMARK;
3046 RETURN;
3047 }
3048 SvGETMAGIC(sv);
3049 if (SvROK(sv)) {
3050 if (SvAMAGIC(sv)) {
3051 sv = amagic_deref_call(sv, to_cv_amg);
3052 /* Don't SPAGAIN here. */
3053 }
3054 }
3055 else {
3056 const char *sym;
3057 STRLEN len;
3058 if (!SvOK(sv))
3059 DIE(aTHX_ PL_no_usym, "a subroutine");
3060 sym = SvPV_nomg_const(sv, len);
3061 if (PL_op->op_private & HINT_STRICT_REFS)
3062 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
3063 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
3064 break;
3065 }
3066 cv = MUTABLE_CV(SvRV(sv));
3067 if (SvTYPE(cv) == SVt_PVCV)
3068 break;
924ba076 3069 /* FALLTHROUGH */
313107ce
DM
3070 case SVt_PVHV:
3071 case SVt_PVAV:
3072 DIE(aTHX_ "Not a CODE reference");
3073 /* This is the second most common case: */
3074 case SVt_PVCV:
3075 cv = MUTABLE_CV(sv);
3076 break;
3077 }
f5719c02 3078 }
a0d0e21e 3079
a57c6685 3080 ENTER;
a0d0e21e
LW
3081
3082 retry:
f5719c02 3083 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
541ed3a9 3084 DIE(aTHX_ "Closure prototype called");
f5719c02 3085 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
2f349aa0
NC
3086 GV* autogv;
3087 SV* sub_name;
3088
3089 /* anonymous or undef'd function leaves us no recourse */
ae77754a
FC
3090 if (CvLEXICAL(cv) && CvHASGV(cv))
3091 DIE(aTHX_ "Undefined subroutine &%"SVf" called",
ecf05a58 3092 SVfARG(cv_name(cv, NULL, 0)));
ae77754a 3093 if (CvANON(cv) || !CvHASGV(cv)) {
2f349aa0 3094 DIE(aTHX_ "Undefined subroutine called");
7d2057d8 3095 }
2f349aa0
NC
3096
3097 /* autoloaded stub? */
ae77754a 3098 if (cv != GvCV(gv = CvGV(cv))) {
2f349aa0
NC
3099 cv = GvCV(gv);
3100 }
3101 /* should call AUTOLOAD now? */
3102 else {
7b52d656 3103 try_autoload:
d1089224
BF
3104 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
3105 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2f349aa0
NC
3106 {
3107 cv = GvCV(autogv);
3108 }
2f349aa0 3109 else {
c220e1a1 3110 sorry:
2f349aa0 3111 sub_name = sv_newmortal();
6136c704 3112 gv_efullname3(sub_name, gv, NULL);
be2597df 3113 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2f349aa0
NC
3114 }
3115 }
3116 if (!cv)
c220e1a1 3117 goto sorry;
2f349aa0 3118 goto retry;
a0d0e21e
LW
3119 }
3120
f5719c02
DM
3121 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
3122 && !CvNODEBUG(cv)))
3123 {
005a8a35 3124 Perl_get_db_sub(aTHX_ &sv, cv);
a9ef256d
NC
3125 if (CvISXSUB(cv))
3126 PL_curcopdb = PL_curcop;
1ad62f64 3127 if (CvLVALUE(cv)) {
3128 /* check for lsub that handles lvalue subroutines */
07b605e5 3129 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
1ad62f64 3130 /* if lsub not found then fall back to DB::sub */
3131 if (!cv) cv = GvCV(PL_DBsub);
3132 } else {
3133 cv = GvCV(PL_DBsub);
3134 }
a9ef256d 3135
ccafdc96
RGS
3136 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
3137 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 3138 }
a0d0e21e 3139
f5719c02
DM
3140 gimme = GIMME_V;
3141
aed2304a 3142 if (!(CvISXSUB(cv))) {
f1025168 3143 /* This path taken at least 75% of the time */
a0d0e21e 3144 dMARK;
b70d5558 3145 PADLIST * const padlist = CvPADLIST(cv);
3689ad62 3146 I32 depth;
f5719c02 3147
a0d0e21e
LW
3148 PUSHBLOCK(cx, CXt_SUB, MARK);
3149 PUSHSUB(cx);
f39bc417 3150 cx->blk_sub.retop = PL_op->op_next;
3689ad62 3151 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3a76ca88 3152 PERL_STACK_OVERFLOW_CHECK();
3689ad62 3153 pad_push(padlist, depth);
a0d0e21e 3154 }
3a76ca88 3155 SAVECOMPPAD();
3689ad62 3156 PAD_SET_CUR_NOSAVE(padlist, depth);
f5719c02 3157 if (LIKELY(hasargs)) {
10533ace 3158 AV *const av = MUTABLE_AV(PAD_SVl(0));
bdf02c57
DM
3159 SSize_t items;
3160 AV **defavp;
3161
f5719c02 3162 if (UNLIKELY(AvREAL(av))) {
221373f0
GS
3163 /* @_ is normally not REAL--this should only ever
3164 * happen when DB::sub() calls things that modify @_ */
3165 av_clear(av);
3166 AvREAL_off(av);
3167 AvREIFY_on(av);
3168 }
bdf02c57
DM
3169 defavp = &GvAV(PL_defgv);
3170 cx->blk_sub.savearray = *defavp;
3171 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
dd2155a4 3172 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 3173 cx->blk_sub.argarray = av;
bdf02c57 3174 items = SP - MARK;
a0d0e21e 3175
f5719c02 3176 if (UNLIKELY(items - 1 > AvMAX(av))) {
77d27ef6
SF
3177 SV **ary = AvALLOC(av);
3178 AvMAX(av) = items - 1;
3179 Renew(ary, items, SV*);
3180 AvALLOC(av) = ary;
3181 AvARRAY(av) = ary;
3182 }
3183
bdf02c57 3184 Copy(MARK+1,AvARRAY(av),items,SV*);
93965878 3185 AvFILLp(av) = items - 1;
1c846c1f 3186
b479c9f2 3187 MARK = AvARRAY(av);
a0d0e21e
LW
3188 while (items--) {
3189 if (*MARK)
b479c9f2 3190 {
60779a30 3191 if (SvPADTMP(*MARK)) {
b479c9f2 3192 *MARK = sv_mortalcopy(*MARK);
60779a30 3193 }
a0d0e21e 3194 SvTEMP_off(*MARK);
b479c9f2 3195 }
a0d0e21e
LW
3196 MARK++;
3197 }
3198 }
b479c9f2 3199 SAVETMPS;
f5719c02
DM
3200 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3201 !CvLVALUE(cv)))
da1dff94 3202 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
4a925ff6
GS
3203 /* warning must come *after* we fully set up the context
3204 * stuff so that __WARN__ handlers can safely dounwind()
3205 * if they want to
3206 */
3689ad62 3207 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
f5719c02
DM
3208 && ckWARN(WARN_RECURSION)
3209 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
4a925ff6 3210 sub_crush_depth(cv);
a0d0e21e
LW
3211 RETURNOP(CvSTART(cv));
3212 }
f1025168 3213 else {
de935cc9 3214 SSize_t markix = TOPMARK;
f1025168 3215
b479c9f2 3216 SAVETMPS;
3a76ca88 3217 PUTBACK;
f1025168 3218
f5719c02 3219 if (UNLIKELY(((PL_op->op_private
4587c532
FC
3220 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
3221 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
f5719c02 3222 !CvLVALUE(cv)))
4587c532
FC
3223 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
3224
f5719c02 3225 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3a76ca88
RGS
3226 /* Need to copy @_ to stack. Alternative may be to
3227 * switch stack to @_, and copy return values
3228 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3229 AV * const av = GvAV(PL_defgv);
ad39f3a2 3230 const SSize_t items = AvFILL(av) + 1;
3a76ca88
RGS
3231
3232 if (items) {
dd2a7f90 3233 SSize_t i = 0;
ad39f3a2 3234 const bool m = cBOOL(SvRMAGICAL(av));
3a76ca88
RGS
3235 /* Mark is at the end of the stack. */
3236 EXTEND(SP, items);
dd2a7f90 3237 for (; i < items; ++i)
ad39f3a2
FC
3238 {
3239 SV *sv;
3240 if (m) {
3241 SV ** const svp = av_fetch(av, i, 0);
3242 sv = svp ? *svp : NULL;
3243 }
3244 else sv = AvARRAY(av)[i];
3245 if (sv) SP[i+1] = sv;
dd2a7f90 3246 else {
199f858d 3247 SP[i+1] = newSVavdefelem(av, i, 1);
dd2a7f90 3248 }
ad39f3a2 3249 }
3a76ca88
RGS
3250 SP += items;
3251 PUTBACK ;
3252 }
3253 }
3455055f
FC
3254 else {
3255 SV **mark = PL_stack_base + markix;
de935cc9 3256 SSize_t items = SP - mark;
3455055f
FC
3257 while (items--) {
3258 mark++;
60779a30 3259 if (*mark && SvPADTMP(*mark)) {
3455055f 3260 *mark = sv_mortalcopy(*mark);
60779a30 3261 }
3455055f
FC
3262 }
3263 }
3a76ca88 3264 /* We assume first XSUB in &DB::sub is the called one. */
f5719c02 3265 if (UNLIKELY(PL_curcopdb)) {
3a76ca88
RGS
3266 SAVEVPTR(PL_curcop);
3267 PL_curcop = PL_curcopdb;
3268 PL_curcopdb = NULL;
3269 }
3270 /* Do we need to open block here? XXXX */
72df79cf 3271
3272 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3273 assert(CvXSUB(cv));
16c91539 3274 CvXSUB(cv)(aTHX_ cv);
3a76ca88
RGS
3275
3276 /* Enforce some sanity in scalar context. */
89a18b40
DM
3277 if (gimme == G_SCALAR) {
3278 SV **svp = PL_stack_base + markix + 1;
3279 if (svp != PL_stack_sp) {
3280 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
3281 PL_stack_sp = svp;
3282 }
3a76ca88 3283 }
a57c6685 3284 LEAVE;
f1025168
NC
3285 return NORMAL;
3286 }
a0d0e21e
LW
3287}
3288
44a8e56a 3289void
864dbfa3 3290Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 3291{
7918f24d
NC
3292 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3293
44a8e56a 3294 if (CvANON(cv))
9014280d 3295 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 3296 else {
35c1215d 3297 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
ecf05a58 3298 SVfARG(cv_name(cv,NULL,0)));
44a8e56a
PP
3299 }
3300}
3301
a0d0e21e
LW
3302PP(pp_aelem)
3303{
20b7effb 3304 dSP;
a0d0e21e 3305 SV** svp;
a3b680e6 3306 SV* const elemsv = POPs;
d804643f 3307 IV elem = SvIV(elemsv);
502c6561 3308 AV *const av = MUTABLE_AV(POPs);
e1ec3a88 3309 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
bbfdc870 3310 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4ad10a0b
VP
3311 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3312 bool preeminent = TRUE;
be6c24e0 3313 SV *sv;
a0d0e21e 3314
5d9574c1 3315 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
95b63a38
JH
3316 Perl_warner(aTHX_ packWARN(WARN_MISC),
3317 "Use of reference \"%"SVf"\" as array index",
be2597df 3318 SVfARG(elemsv));
5d9574c1 3319 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
a0d0e21e 3320 RETPUSHUNDEF;
4ad10a0b 3321
5d9574c1 3322 if (UNLIKELY(localizing)) {
4ad10a0b
VP
3323 MAGIC *mg;
3324 HV *stash;
3325
3326 /* If we can determine whether the element exist,
3327 * Try to preserve the existenceness of a tied array
3328 * element by using EXISTS and DELETE if possible.
3329 * Fallback to FETCH and STORE otherwise. */
3330 if (SvCANEXISTDELETE(av))
3331 preeminent = av_exists(av, elem);
3332 }
3333
68dc0745 3334 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 3335 if (lval) {
2b573ace 3336#ifdef PERL_MALLOC_WRAP
2b573ace 3337 if (SvUOK(elemsv)) {
a9c4fd4e 3338 const UV uv = SvUV(elemsv);
2b573ace
JH
3339 elem = uv > IV_MAX ? IV_MAX : uv;
3340 }
3341 else if (SvNOK(elemsv))
3342 elem = (IV)SvNV(elemsv);
a3b680e6
AL
3343 if (elem > 0) {
3344 static const char oom_array_extend[] =
3345 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 3346 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 3347 }
2b573ace 3348#endif
ce0d59fd 3349 if (!svp || !*svp) {
bbfdc870 3350 IV len;
68dc0745 3351 if (!defer)
cea2e8a9 3352 DIE(aTHX_ PL_no_aelem, elem);
b9f2b683 3353 len = av_tindex(av);
199f858d 3354 mPUSHs(newSVavdefelem(av,
bbfdc870
FC
3355 /* Resolve a negative index now, unless it points before the
3356 beginning of the array, in which case record it for error
3357 reporting in magic_setdefelem. */
199f858d
FC
3358 elem < 0 && len + elem >= 0 ? len + elem : elem,
3359 1));
68dc0745
PP
3360 RETURN;
3361 }
5d9574c1 3362 if (UNLIKELY(localizing)) {
4ad10a0b
VP
3363 if (preeminent)
3364 save_aelem(av, elem, svp);
3365 else
3366 SAVEADELETE(av, elem);
3367 }
9026059d
GG
3368 else if (PL_op->op_private & OPpDEREF) {
3369 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3370 RETURN;
3371 }
a0d0e21e 3372 }
3280af22 3373 sv = (svp ? *svp : &PL_sv_undef);
39cf747a 3374 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 3375 mg_get(sv);
be6c24e0 3376 PUSHs(sv);
a0d0e21e
LW
3377 RETURN;
3378}
3379
9026059d 3380SV*
864dbfa3 3381Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 3382{
7918f24d
NC
3383 PERL_ARGS_ASSERT_VIVIFY_REF;
3384
5b295bef 3385 SvGETMAGIC(sv);
02a9e968
CS
3386 if (!SvOK(sv)) {
3387 if (SvREADONLY(sv))
cb077ed2 3388 Perl_croak_no_modify();
43230e26 3389 prepare_SV_for_RV(sv);
68dc0745 3390 switch (to_what) {
5f05dabc 3391 case OPpDEREF_SV:
561b68a9 3392 SvRV_set(sv, newSV(0));
5f05dabc
PP
3393 break;
3394 case OPpDEREF_AV:
ad64d0ec 3395 SvRV_set(sv, MUTABLE_SV(newAV()));
5f05dabc
PP
3396 break;
3397 case OPpDEREF_HV:
ad64d0ec 3398 SvRV_set(sv, MUTABLE_SV(newHV()));
5f05dabc
PP
3399 break;
3400 }
02a9e968
CS
3401 SvROK_on(sv);
3402 SvSETMAGIC(sv);
7e482323 3403 SvGETMAGIC(sv);
02a9e968 3404 }
9026059d
GG
3405 if (SvGMAGICAL(sv)) {
3406 /* copy the sv without magic to prevent magic from being
3407 executed twice */
3408 SV* msv = sv_newmortal();
3409 sv_setsv_nomg(msv, sv);
3410 return msv;
3411 }
3412 return sv;
02a9e968
CS
3413}
3414
7d6c333c 3415PERL_STATIC_INLINE HV *
3416S_opmethod_stash(pTHX_ SV* meth)
f5d5a27c 3417{
a0d0e21e 3418 SV* ob;
56304f61 3419 HV* stash;
b55b14d0 3420
d648ffcb 3421 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
f226e9be
FC
3422 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3423 "package or object reference", SVfARG(meth)),
3424 (SV *)NULL)
3425 : *(PL_stack_base + TOPMARK + 1);
f5d5a27c 3426
7d6c333c 3427 PERL_ARGS_ASSERT_OPMETHOD_STASH;
d648ffcb 3428
5d9574c1 3429 if (UNLIKELY(!sv))
7156e69a 3430 undefined:
a214957f
VP
3431 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3432 SVfARG(meth));
4f1b7578 3433
d648ffcb 3434 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
3435 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
3436 stash = gv_stashsv(sv, GV_CACHE_ONLY);
7d6c333c 3437 if (stash) return stash;
d648ffcb 3438 }
3439
a0d0e21e 3440 if (SvROK(sv))
ad64d0ec 3441 ob = MUTABLE_SV(SvRV(sv));
7156e69a 3442 else if (!SvOK(sv)) goto undefined;
a77c16f7
FC
3443 else if (isGV_with_GP(sv)) {
3444 if (!GvIO(sv))
3445 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3446 "without a package or object reference",
3447 SVfARG(meth));
3448 ob = sv;
3449 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3450 assert(!LvTARGLEN(ob));
3451 ob = LvTARG(ob);
3452 assert(ob);
3453 }
3454 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3455 }
a0d0e21e 3456 else {
89269094 3457 /* this isn't a reference */
a0d0e21e 3458 GV* iogv;
f937af42 3459 STRLEN packlen;
89269094 3460 const char * const packname = SvPV_nomg_const(sv, packlen);
d283e876 3461 const U32 packname_utf8 = SvUTF8(sv);
3462 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
7d6c333c 3463 if (stash) return stash;
081fc587 3464
89269094 3465 if (!(iogv = gv_fetchpvn_flags(
d283e876 3466 packname, packlen, packname_utf8, SVt_PVIO
da6b625f 3467 )) ||
ad64d0ec 3468 !(ob=MUTABLE_SV(GvIO(iogv))))
a0d0e21e 3469 {
af09ea45 3470 /* this isn't the name of a filehandle either */
89269094 3471 if (!packlen)
834a4ddd 3472 {