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