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