This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Convert t/op/inc.t to test.pl and use strict.
[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.
992 */
10c8fecd 993 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
cc5e57d2 994 EXTEND_MORTAL(lastrelem - firstrelem + 1);
10c8fecd 995 for (relem = firstrelem; relem <= lastrelem; relem++) {
155aba94 996 if ((sv = *relem)) {
a1f49e72 997 TAINT_NOT; /* Each item is independent */
61e5f455
NC
998
999 /* Dear TODO test in t/op/sort.t, I love you.
1000 (It's relying on a panic, not a "semi-panic" from newSVsv()
1001 and then an assertion failure below.) */
1002 if (SvIS_FREED(sv)) {
1003 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1004 (void*)sv);
1005 }
1006 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1007 and we need a second copy of a temp here. */
1008 *relem = sv_2mortal(newSVsv(sv));
a1f49e72 1009 }
10c8fecd 1010 }
a0d0e21e
LW
1011 }
1012
1013 relem = firstrelem;
1014 lelem = firstlelem;
4608196e
RGS
1015 ary = NULL;
1016 hash = NULL;
10c8fecd 1017
a0d0e21e 1018 while (lelem <= lastlelem) {
bbce6d69 1019 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e
LW
1020 sv = *lelem++;
1021 switch (SvTYPE(sv)) {
1022 case SVt_PVAV:
502c6561 1023 ary = MUTABLE_AV(sv);
748a9306 1024 magic = SvMAGICAL(ary) != 0;
a0d0e21e 1025 av_clear(ary);
7e42bd57 1026 av_extend(ary, lastrelem - relem);
a0d0e21e
LW
1027 i = 0;
1028 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 1029 SV **didstore;
a0d0e21e 1030 assert(*relem);
4f0556e9
NC
1031 sv = newSV(0);
1032 sv_setsv(sv, *relem);
a0d0e21e 1033 *(relem++) = sv;
5117ca91
GS
1034 didstore = av_store(ary,i++,sv);
1035 if (magic) {
8ef24240 1036 if (SvSMAGICAL(sv))
fb73857a 1037 mg_set(sv);
5117ca91 1038 if (!didstore)
8127e0e3 1039 sv_2mortal(sv);
5117ca91 1040 }
bbce6d69 1041 TAINT_NOT;
a0d0e21e 1042 }
354b0578 1043 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 1044 SvSETMAGIC(MUTABLE_SV(ary));
a0d0e21e 1045 break;
10c8fecd 1046 case SVt_PVHV: { /* normal hash */
a0d0e21e 1047 SV *tmpstr;
45960564 1048 SV** topelem = relem;
a0d0e21e 1049
85fbaab2 1050 hash = MUTABLE_HV(sv);
748a9306 1051 magic = SvMAGICAL(hash) != 0;
a0d0e21e 1052 hv_clear(hash);
ca65944e 1053 firsthashrelem = relem;
a0d0e21e
LW
1054
1055 while (relem < lastrelem) { /* gobble up all the rest */
5117ca91 1056 HE *didstore;
6136c704
AL
1057 sv = *relem ? *relem : &PL_sv_no;
1058 relem++;
561b68a9 1059 tmpstr = newSV(0);
a0d0e21e
LW
1060 if (*relem)
1061 sv_setsv(tmpstr,*relem); /* value */
45960564
DM
1062 relem++;
1063 if (gimme != G_VOID) {
1064 if (hv_exists_ent(hash, sv, 0))
1065 /* key overwrites an existing entry */
1066 duplicates += 2;
1067 else
1068 if (gimme == G_ARRAY) {
1069 /* copy element back: possibly to an earlier
1070 * stack location if we encountered dups earlier */
1071 *topelem++ = sv;
1072 *topelem++ = tmpstr;
1073 }
1074 }
5117ca91
GS
1075 didstore = hv_store_ent(hash,sv,tmpstr,0);
1076 if (magic) {
8ef24240 1077 if (SvSMAGICAL(tmpstr))
fb73857a 1078 mg_set(tmpstr);
5117ca91 1079 if (!didstore)
8127e0e3 1080 sv_2mortal(tmpstr);
5117ca91 1081 }
bbce6d69 1082 TAINT_NOT;
8e07c86e 1083 }
6a0deba8 1084 if (relem == lastrelem) {
10c8fecd 1085 do_oddball(hash, relem, firstrelem);
6a0deba8 1086 relem++;
1930e939 1087 }
a0d0e21e
LW
1088 }
1089 break;
1090 default:
6fc92669
GS
1091 if (SvIMMORTAL(sv)) {
1092 if (relem <= lastrelem)
1093 relem++;
1094 break;
a0d0e21e
LW
1095 }
1096 if (relem <= lastrelem) {
1097 sv_setsv(sv, *relem);
1098 *(relem++) = sv;
1099 }
1100 else
3280af22 1101 sv_setsv(sv, &PL_sv_undef);
8ef24240 1102 SvSETMAGIC(sv);
a0d0e21e
LW
1103 break;
1104 }
1105 }
3280af22
NIS
1106 if (PL_delaymagic & ~DM_DELAY) {
1107 if (PL_delaymagic & DM_UID) {
a0d0e21e 1108#ifdef HAS_SETRESUID
fb934a90
RD
1109 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1110 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1111 (Uid_t)-1);
56febc5e
AD
1112#else
1113# ifdef HAS_SETREUID
fb934a90
RD
1114 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1115 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
56febc5e
AD
1116# else
1117# ifdef HAS_SETRUID
b28d0864
NIS
1118 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1119 (void)setruid(PL_uid);
1120 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1121 }
56febc5e
AD
1122# endif /* HAS_SETRUID */
1123# ifdef HAS_SETEUID
b28d0864 1124 if ((PL_delaymagic & DM_UID) == DM_EUID) {
fb934a90 1125 (void)seteuid(PL_euid);
b28d0864 1126 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1127 }
56febc5e 1128# endif /* HAS_SETEUID */
b28d0864
NIS
1129 if (PL_delaymagic & DM_UID) {
1130 if (PL_uid != PL_euid)
cea2e8a9 1131 DIE(aTHX_ "No setreuid available");
b28d0864 1132 (void)PerlProc_setuid(PL_uid);
a0d0e21e 1133 }
56febc5e
AD
1134# endif /* HAS_SETREUID */
1135#endif /* HAS_SETRESUID */
d8eceb89
JH
1136 PL_uid = PerlProc_getuid();
1137 PL_euid = PerlProc_geteuid();
a0d0e21e 1138 }
3280af22 1139 if (PL_delaymagic & DM_GID) {
a0d0e21e 1140#ifdef HAS_SETRESGID
fb934a90
RD
1141 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1142 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1143 (Gid_t)-1);
56febc5e
AD
1144#else
1145# ifdef HAS_SETREGID
fb934a90
RD
1146 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1147 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
56febc5e
AD
1148# else
1149# ifdef HAS_SETRGID
b28d0864
NIS
1150 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1151 (void)setrgid(PL_gid);
1152 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1153 }
56febc5e
AD
1154# endif /* HAS_SETRGID */
1155# ifdef HAS_SETEGID
b28d0864 1156 if ((PL_delaymagic & DM_GID) == DM_EGID) {
fb934a90 1157 (void)setegid(PL_egid);
b28d0864 1158 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1159 }
56febc5e 1160# endif /* HAS_SETEGID */
b28d0864
NIS
1161 if (PL_delaymagic & DM_GID) {
1162 if (PL_gid != PL_egid)
cea2e8a9 1163 DIE(aTHX_ "No setregid available");
b28d0864 1164 (void)PerlProc_setgid(PL_gid);
a0d0e21e 1165 }
56febc5e
AD
1166# endif /* HAS_SETREGID */
1167#endif /* HAS_SETRESGID */
d8eceb89
JH
1168 PL_gid = PerlProc_getgid();
1169 PL_egid = PerlProc_getegid();
a0d0e21e 1170 }
3280af22 1171 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
a0d0e21e 1172 }
3280af22 1173 PL_delaymagic = 0;
54310121 1174
54310121
PP
1175 if (gimme == G_VOID)
1176 SP = firstrelem - 1;
1177 else if (gimme == G_SCALAR) {
1178 dTARGET;
1179 SP = firstrelem;
ca65944e 1180 SETi(lastrelem - firstrelem + 1 - duplicates);
54310121
PP
1181 }
1182 else {
ca65944e 1183 if (ary)
a0d0e21e 1184 SP = lastrelem;
ca65944e
RGS
1185 else if (hash) {
1186 if (duplicates) {
45960564
DM
1187 /* at this point we have removed the duplicate key/value
1188 * pairs from the stack, but the remaining values may be
1189 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1190 * the (a 2), but the stack now probably contains
1191 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1192 * obliterates the earlier key. So refresh all values. */
ca65944e 1193 lastrelem -= duplicates;
45960564
DM
1194 relem = firsthashrelem;
1195 while (relem < lastrelem) {
1196 HE *he;
1197 sv = *relem++;
1198 he = hv_fetch_ent(hash, sv, 0, 0);
1199 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1200 }
ca65944e
RGS
1201 }
1202 SP = lastrelem;
1203 }
a0d0e21e
LW
1204 else
1205 SP = firstrelem + (lastlelem - firstlelem);
0c8c7a05 1206 lelem = firstlelem + (relem - firstrelem);
5f05dabc 1207 while (relem <= SP)
3280af22 1208 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
a0d0e21e 1209 }
08aeb9f7 1210
54310121 1211 RETURN;
a0d0e21e
LW
1212}
1213
8782bef2
GB
1214PP(pp_qr)
1215{
97aff369 1216 dVAR; dSP;
c4420975 1217 register PMOP * const pm = cPMOP;
fe578d7f 1218 REGEXP * rx = PM_GETRE(pm);
10599a69 1219 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
c4420975 1220 SV * const rv = sv_newmortal();
288b8c02
NC
1221
1222 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
1223 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1224 loathe to use it here, but it seems to be the right fix. Or close.
1225 The key part appears to be that it's essential for pp_qr to return a new
1226 object (SV), which implies that there needs to be an effective way to
1227 generate a new SV from the existing SV that is pre-compiled in the
1228 optree. */
1229 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
1230 SvROK_on(rv);
1231
1232 if (pkg) {
f815daf2 1233 HV *const stash = gv_stashsv(pkg, GV_ADD);
a954f6ee 1234 SvREFCNT_dec(pkg);
288b8c02
NC
1235 (void)sv_bless(rv, stash);
1236 }
1237
9274aefd 1238 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
e08e52cf 1239 SvTAINTED_on(rv);
9274aefd
DM
1240 SvTAINTED_on(SvRV(rv));
1241 }
c8c13c22 1242 XPUSHs(rv);
1243 RETURN;
8782bef2
GB
1244}
1245
a0d0e21e
LW
1246PP(pp_match)
1247{
97aff369 1248 dVAR; dSP; dTARG;
a0d0e21e 1249 register PMOP *pm = cPMOP;
d65afb4b 1250 PMOP *dynpm = pm;
0d46e09a
SP
1251 register const char *t;
1252 register const char *s;
5c144d81 1253 const char *strend;
a0d0e21e 1254 I32 global;
1ed74d04 1255 U8 r_flags = REXEC_CHECKED;
5c144d81 1256 const char *truebase; /* Start of string */
aaa362c4 1257 register REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1258 bool rxtainted;
a3b680e6 1259 const I32 gimme = GIMME;
a0d0e21e 1260 STRLEN len;
748a9306 1261 I32 minmatch = 0;
a3b680e6 1262 const I32 oldsave = PL_savestack_ix;
f86702cc 1263 I32 update_minmatch = 1;
e60df1fa 1264 I32 had_zerolen = 0;
58e23c8d 1265 U32 gpos = 0;
a0d0e21e 1266
533c011a 1267 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1268 TARG = POPs;
59f00321
RGS
1269 else if (PL_op->op_private & OPpTARGET_MY)
1270 GETTARGET;
a0d0e21e 1271 else {
54b9620d 1272 TARG = DEFSV;
a0d0e21e
LW
1273 EXTEND(SP,1);
1274 }
d9f424b2 1275
c277df42 1276 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
1277 /* Skip get-magic if this is a qr// clone, because regcomp has
1278 already done it. */
1279 s = ((struct regexp *)SvANY(rx))->mother_re
1280 ? SvPV_nomg_const(TARG, len)
1281 : SvPV_const(TARG, len);
a0d0e21e 1282 if (!s)
2269b42e 1283 DIE(aTHX_ "panic: pp_match");
890ce7af 1284 strend = s + len;
07bc277f 1285 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
3280af22 1286 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1287 TAINT_NOT;
a0d0e21e 1288
a30b2f1f 1289 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 1290
d65afb4b 1291 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
1292 if (
1293#ifdef USE_ITHREADS
1294 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1295#else
1296 pm->op_pmflags & PMf_USED
1297#endif
1298 ) {
c277df42 1299 failure:
a0d0e21e
LW
1300 if (gimme == G_ARRAY)
1301 RETURN;
1302 RETPUSHNO;
1303 }
1304
c737faaf
YO
1305
1306
d65afb4b 1307 /* empty pattern special-cased to use last successful pattern if possible */
220fc49f 1308 if (!RX_PRELEN(rx) && PL_curpm) {
3280af22 1309 pm = PL_curpm;
aaa362c4 1310 rx = PM_GETRE(pm);
a0d0e21e 1311 }
d65afb4b 1312
07bc277f 1313 if (RX_MINLEN(rx) > (I32)len)
d65afb4b 1314 goto failure;
c277df42 1315
a0d0e21e 1316 truebase = t = s;
ad94a511
IZ
1317
1318 /* XXXX What part of this is needed with true \G-support? */
d65afb4b 1319 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
07bc277f 1320 RX_OFFS(rx)[0].start = -1;
a0d0e21e 1321 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
c445ea15 1322 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
565764a8 1323 if (mg && mg->mg_len >= 0) {
07bc277f
NC
1324 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1325 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1326 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
0ef3e39e 1327 r_flags |= REXEC_IGNOREPOS;
07bc277f
NC
1328 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1329 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
58e23c8d
YO
1330 gpos = mg->mg_len;
1331 else
07bc277f
NC
1332 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1333 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
f86702cc 1334 update_minmatch = 0;
748a9306 1335 }
a0d0e21e
LW
1336 }
1337 }
a229a030 1338 /* XXX: comment out !global get safe $1 vars after a
62e7980d 1339 match, BUT be aware that this leads to dramatic slowdowns on
a229a030
YO
1340 /g matches against large strings. So far a solution to this problem
1341 appears to be quite tricky.
1342 Test for the unsafe vars are TODO for now. */
0d8a731b
DM
1343 if ( (!global && RX_NPARENS(rx))
1344 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1345 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
14977893 1346 r_flags |= REXEC_COPY_STR;
1c846c1f 1347 if (SvSCREAM(TARG))
22e551b9
IZ
1348 r_flags |= REXEC_SCREAM;
1349
d7be1480 1350 play_it_again:
07bc277f
NC
1351 if (global && RX_OFFS(rx)[0].start != -1) {
1352 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1353 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
a0d0e21e 1354 goto nope;
f86702cc 1355 if (update_minmatch++)
e60df1fa 1356 minmatch = had_zerolen;
a0d0e21e 1357 }
07bc277f 1358 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
3c8556c3 1359 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
5c144d81
NC
1360 /* FIXME - can PL_bostr be made const char *? */
1361 PL_bostr = (char *)truebase;
f9f4320a 1362 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
f722798b
IZ
1363
1364 if (!s)
1365 goto nope;
07bc277f 1366 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
14977893 1367 && !PL_sawampersand
07bc277f
NC
1368 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1369 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1370 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
05b4157f
GS
1371 && (r_flags & REXEC_SCREAM)))
1372 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
f722798b 1373 goto yup;
a0d0e21e 1374 }
1f36f092
RB
1375 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1376 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
bbce6d69 1377 {
3280af22 1378 PL_curpm = pm;
c737faaf
YO
1379 if (dynpm->op_pmflags & PMf_ONCE) {
1380#ifdef USE_ITHREADS
1381 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1382#else
1383 dynpm->op_pmflags |= PMf_USED;
1384#endif
1385 }
a0d0e21e
LW
1386 goto gotcha;
1387 }
1388 else
1389 goto ret_no;
1390 /*NOTREACHED*/
1391
1392 gotcha:
72311751
GS
1393 if (rxtainted)
1394 RX_MATCH_TAINTED_on(rx);
1395 TAINT_IF(RX_MATCH_TAINTED(rx));
a0d0e21e 1396 if (gimme == G_ARRAY) {
07bc277f 1397 const I32 nparens = RX_NPARENS(rx);
a3b680e6 1398 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 1399
c277df42 1400 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1401 EXTEND(SP, nparens + i);
1402 EXTEND_MORTAL(nparens + i);
1403 for (i = !i; i <= nparens; i++) {
a0d0e21e 1404 PUSHs(sv_newmortal());
07bc277f
NC
1405 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1406 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1407 s = RX_OFFS(rx)[i].start + truebase;
1408 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
290deeac
A
1409 len < 0 || len > strend - s)
1410 DIE(aTHX_ "panic: pp_match start/end pointers");
a0d0e21e 1411 sv_setpvn(*SP, s, len);
cce850e4 1412 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1413 SvUTF8_on(*SP);
a0d0e21e
LW
1414 }
1415 }
1416 if (global) {
d65afb4b 1417 if (dynpm->op_pmflags & PMf_CONTINUE) {
6136c704 1418 MAGIC* mg = NULL;
0af80b60
HS
1419 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1420 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1421 if (!mg) {
d83f0a82
NC
1422#ifdef PERL_OLD_COPY_ON_WRITE
1423 if (SvIsCOW(TARG))
1424 sv_force_normal_flags(TARG, 0);
1425#endif
1426 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1427 &PL_vtbl_mglob, NULL, 0);
0af80b60 1428 }
07bc277f
NC
1429 if (RX_OFFS(rx)[0].start != -1) {
1430 mg->mg_len = RX_OFFS(rx)[0].end;
1431 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
0af80b60
HS
1432 mg->mg_flags |= MGf_MINMATCH;
1433 else
1434 mg->mg_flags &= ~MGf_MINMATCH;
1435 }
1436 }
07bc277f
NC
1437 had_zerolen = (RX_OFFS(rx)[0].start != -1
1438 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1439 == (UV)RX_OFFS(rx)[0].end));
c277df42 1440 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1441 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1442 goto play_it_again;
1443 }
ffc61ed2 1444 else if (!nparens)
bde848c5 1445 XPUSHs(&PL_sv_yes);
4633a7c4 1446 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1447 RETURN;
1448 }
1449 else {
1450 if (global) {
cbbf8932 1451 MAGIC* mg;
a0d0e21e 1452 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
14befaf4 1453 mg = mg_find(TARG, PERL_MAGIC_regex_global);
cbbf8932
AL
1454 else
1455 mg = NULL;
a0d0e21e 1456 if (!mg) {
d83f0a82
NC
1457#ifdef PERL_OLD_COPY_ON_WRITE
1458 if (SvIsCOW(TARG))
1459 sv_force_normal_flags(TARG, 0);
1460#endif
1461 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1462 &PL_vtbl_mglob, NULL, 0);
a0d0e21e 1463 }
07bc277f
NC
1464 if (RX_OFFS(rx)[0].start != -1) {
1465 mg->mg_len = RX_OFFS(rx)[0].end;
1466 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
748a9306
LW
1467 mg->mg_flags |= MGf_MINMATCH;
1468 else
1469 mg->mg_flags &= ~MGf_MINMATCH;
1470 }
a0d0e21e 1471 }
4633a7c4 1472 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1473 RETPUSHYES;
1474 }
1475
f722798b 1476yup: /* Confirmed by INTUIT */
72311751
GS
1477 if (rxtainted)
1478 RX_MATCH_TAINTED_on(rx);
1479 TAINT_IF(RX_MATCH_TAINTED(rx));
3280af22 1480 PL_curpm = pm;
c737faaf
YO
1481 if (dynpm->op_pmflags & PMf_ONCE) {
1482#ifdef USE_ITHREADS
1483 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1484#else
1485 dynpm->op_pmflags |= PMf_USED;
1486#endif
1487 }
cf93c79d 1488 if (RX_MATCH_COPIED(rx))
07bc277f 1489 Safefree(RX_SUBBEG(rx));
cf93c79d 1490 RX_MATCH_COPIED_off(rx);
07bc277f 1491 RX_SUBBEG(rx) = NULL;
a0d0e21e 1492 if (global) {
5c144d81 1493 /* FIXME - should rx->subbeg be const char *? */
07bc277f
NC
1494 RX_SUBBEG(rx) = (char *) truebase;
1495 RX_OFFS(rx)[0].start = s - truebase;
a30b2f1f 1496 if (RX_MATCH_UTF8(rx)) {
07bc277f
NC
1497 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1498 RX_OFFS(rx)[0].end = t - truebase;
60aeb6fd
NIS
1499 }
1500 else {
07bc277f 1501 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
60aeb6fd 1502 }
07bc277f 1503 RX_SUBLEN(rx) = strend - truebase;
a0d0e21e 1504 goto gotcha;
1c846c1f 1505 }
07bc277f 1506 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
14977893 1507 I32 off;
f8c7b90f 1508#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
1509 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1510 if (DEBUG_C_TEST) {
1511 PerlIO_printf(Perl_debug_log,
1512 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
6c9570dc 1513 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
ed252734
NC
1514 (int)(t-truebase));
1515 }
bdd9a1b1
NC
1516 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1517 RX_SUBBEG(rx)
1518 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1519 assert (SvPOKp(RX_SAVED_COPY(rx)));
ed252734
NC
1520 } else
1521#endif
1522 {
14977893 1523
07bc277f 1524 RX_SUBBEG(rx) = savepvn(t, strend - t);
f8c7b90f 1525#ifdef PERL_OLD_COPY_ON_WRITE
bdd9a1b1 1526 RX_SAVED_COPY(rx) = NULL;
ed252734
NC
1527#endif
1528 }
07bc277f 1529 RX_SUBLEN(rx) = strend - t;
14977893 1530 RX_MATCH_COPIED_on(rx);
07bc277f
NC
1531 off = RX_OFFS(rx)[0].start = s - t;
1532 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
14977893
JH
1533 }
1534 else { /* startp/endp are used by @- @+. */
07bc277f
NC
1535 RX_OFFS(rx)[0].start = s - truebase;
1536 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
14977893 1537 }
07bc277f 1538 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
cde0cee5 1539 -dmq */
07bc277f 1540 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
4633a7c4 1541 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1542 RETPUSHYES;
1543
1544nope:
a0d0e21e 1545ret_no:
d65afb4b 1546 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
a0d0e21e 1547 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
6136c704 1548 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1549 if (mg)
565764a8 1550 mg->mg_len = -1;
a0d0e21e
LW
1551 }
1552 }
4633a7c4 1553 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1554 if (gimme == G_ARRAY)
1555 RETURN;
1556 RETPUSHNO;
1557}
1558
1559OP *
864dbfa3 1560Perl_do_readline(pTHX)
a0d0e21e 1561{
27da23d5 1562 dVAR; dSP; dTARGETSTACKED;
a0d0e21e
LW
1563 register SV *sv;
1564 STRLEN tmplen = 0;
1565 STRLEN offset;
760ac839 1566 PerlIO *fp;
a3b680e6
AL
1567 register IO * const io = GvIO(PL_last_in_gv);
1568 register const I32 type = PL_op->op_type;
1569 const I32 gimme = GIMME_V;
a0d0e21e 1570
6136c704 1571 if (io) {
50db69d8 1572 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 1573 if (mg) {
50db69d8 1574 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 1575 if (gimme == G_SCALAR) {
50db69d8
NC
1576 SPAGAIN;
1577 SvSetSV_nosteal(TARG, TOPs);
1578 SETTARG;
6136c704 1579 }
50db69d8 1580 return NORMAL;
0b7c7b4f 1581 }
e79b0511 1582 }
4608196e 1583 fp = NULL;
a0d0e21e
LW
1584 if (io) {
1585 fp = IoIFP(io);
1586 if (!fp) {
1587 if (IoFLAGS(io) & IOf_ARGV) {
1588 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1589 IoLINES(io) = 0;
3280af22 1590 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1591 IoFLAGS(io) &= ~IOf_START;
4608196e 1592 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
76f68e9b 1593 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3280af22 1594 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
1595 fp = IoIFP(io);
1596 goto have_fp;
a0d0e21e
LW
1597 }
1598 }
3280af22 1599 fp = nextargv(PL_last_in_gv);
a0d0e21e 1600 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1601 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
1602 }
1603 }
0d44d22b
NC
1604 else if (type == OP_GLOB)
1605 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
1606 }
1607 else if (type == OP_GLOB)
1608 SP--;
7716c5c5 1609 else if (IoTYPE(io) == IoTYPE_WRONLY) {
a5390457 1610 report_wrongway_fh(PL_last_in_gv, '>');
a00b5bd3 1611 }
a0d0e21e
LW
1612 }
1613 if (!fp) {
041457d9
DM
1614 if ((!io || !(IoFLAGS(io) & IOf_START))
1615 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1616 {
3f4520fe 1617 if (type == OP_GLOB)
9014280d 1618 Perl_warner(aTHX_ packWARN(WARN_GLOB),
af8c498a
GS
1619 "glob failed (can't start child: %s)",
1620 Strerror(errno));
69282e91 1621 else
831e4cc3 1622 report_evil_fh(PL_last_in_gv);
3f4520fe 1623 }
54310121 1624 if (gimme == G_SCALAR) {
79628082 1625 /* undef TARG, and push that undefined value */
ba92458f
AE
1626 if (type != OP_RCATLINE) {
1627 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1628 SvOK_off(TARG);
ba92458f 1629 }
a0d0e21e
LW
1630 PUSHTARG;
1631 }
1632 RETURN;
1633 }
a2008d6d 1634 have_fp:
54310121 1635 if (gimme == G_SCALAR) {
a0d0e21e 1636 sv = TARG;
0f722b55
RGS
1637 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1638 mg_get(sv);
48de12d9
RGS
1639 if (SvROK(sv)) {
1640 if (type == OP_RCATLINE)
1641 SvPV_force_nolen(sv);
1642 else
1643 sv_unref(sv);
1644 }
f7877b28
NC
1645 else if (isGV_with_GP(sv)) {
1646 SvPV_force_nolen(sv);
1647 }
862a34c6 1648 SvUPGRADE(sv, SVt_PV);
a0d0e21e 1649 tmplen = SvLEN(sv); /* remember if already alloced */
f72e8700
JJ
1650 if (!tmplen && !SvREADONLY(sv)) {
1651 /* try short-buffering it. Please update t/op/readline.t
1652 * if you change the growth length.
1653 */
1654 Sv_Grow(sv, 80);
1655 }
2b5e58c4
AMS
1656 offset = 0;
1657 if (type == OP_RCATLINE && SvOK(sv)) {
1658 if (!SvPOK(sv)) {
8b6b16e7 1659 SvPV_force_nolen(sv);
2b5e58c4 1660 }
a0d0e21e 1661 offset = SvCUR(sv);
2b5e58c4 1662 }
a0d0e21e 1663 }
54310121 1664 else {
561b68a9 1665 sv = sv_2mortal(newSV(80));
54310121
PP
1666 offset = 0;
1667 }
fbad3eb5 1668
3887d568
AP
1669 /* This should not be marked tainted if the fp is marked clean */
1670#define MAYBE_TAINT_LINE(io, sv) \
1671 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1672 TAINT; \
1673 SvTAINTED_on(sv); \
1674 }
1675
684bef36 1676/* delay EOF state for a snarfed empty file */
fbad3eb5 1677#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1678 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1679 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1680
a0d0e21e 1681 for (;;) {
09e8efcc 1682 PUTBACK;
fbad3eb5 1683 if (!sv_gets(sv, fp, offset)
2d726892
TF
1684 && (type == OP_GLOB
1685 || SNARF_EOF(gimme, PL_rs, io, sv)
1686 || PerlIO_error(fp)))
fbad3eb5 1687 {
760ac839 1688 PerlIO_clearerr(fp);
a0d0e21e 1689 if (IoFLAGS(io) & IOf_ARGV) {
3280af22 1690 fp = nextargv(PL_last_in_gv);
a0d0e21e
LW
1691 if (fp)
1692 continue;
3280af22 1693 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
1694 }
1695 else if (type == OP_GLOB) {
a2a5de95
NC
1696 if (!do_close(PL_last_in_gv, FALSE)) {
1697 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1698 "glob failed (child exited with status %d%s)",
1699 (int)(STATUS_CURRENT >> 8),
1700 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1701 }
a0d0e21e 1702 }
54310121 1703 if (gimme == G_SCALAR) {
ba92458f
AE
1704 if (type != OP_RCATLINE) {
1705 SV_CHECK_THINKFIRST_COW_DROP(TARG);
0c34ef67 1706 SvOK_off(TARG);
ba92458f 1707 }
09e8efcc 1708 SPAGAIN;
a0d0e21e
LW
1709 PUSHTARG;
1710 }
3887d568 1711 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
1712 RETURN;
1713 }
3887d568 1714 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1715 IoLINES(io)++;
b9fee9ba 1716 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1717 SvSETMAGIC(sv);
09e8efcc 1718 SPAGAIN;
a0d0e21e 1719 XPUSHs(sv);
a0d0e21e 1720 if (type == OP_GLOB) {
349d4f2f 1721 const char *t1;
a0d0e21e 1722
3280af22 1723 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
6136c704 1724 char * const tmps = SvEND(sv) - 1;
aa07b2f6 1725 if (*tmps == *SvPVX_const(PL_rs)) {
c07a80fd 1726 *tmps = '\0';
b162af07 1727 SvCUR_set(sv, SvCUR(sv) - 1);
c07a80fd
PP
1728 }
1729 }
349d4f2f
NC
1730 for (t1 = SvPVX_const(sv); *t1; t1++)
1731 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1732 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
a0d0e21e 1733 break;
349d4f2f 1734 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1735 (void)POPs; /* Unmatched wildcard? Chuck it... */
1736 continue;
1737 }
2d79bf7f 1738 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
d4c19fe8
AL
1739 if (ckWARN(WARN_UTF8)) {
1740 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1741 const STRLEN len = SvCUR(sv) - offset;
1742 const U8 *f;
1743
1744 if (!is_utf8_string_loc(s, len, &f))
1745 /* Emulate :encoding(utf8) warning in the same case. */
1746 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1747 "utf8 \"\\x%02X\" does not map to Unicode",
1748 f < (U8*)SvEND(sv) ? *f : 0);
1749 }
a0d0e21e 1750 }
54310121 1751 if (gimme == G_ARRAY) {
a0d0e21e 1752 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 1753 SvPV_shrink_to_cur(sv);
a0d0e21e 1754 }
561b68a9 1755 sv = sv_2mortal(newSV(80));
a0d0e21e
LW
1756 continue;
1757 }
54310121 1758 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 1759 /* try to reclaim a bit of scalar space (only on 1st alloc) */
d5b5861b
NC
1760 const STRLEN new_len
1761 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1da4ca5f 1762 SvPV_renew(sv, new_len);
a0d0e21e
LW
1763 }
1764 RETURN;
1765 }
1766}
1767
1768PP(pp_enter)
1769{
27da23d5 1770 dVAR; dSP;
c09156bb 1771 register PERL_CONTEXT *cx;
533c011a 1772 I32 gimme = OP_GIMME(PL_op, -1);
a0d0e21e 1773
54310121 1774 if (gimme == -1) {
e91684bf
VP
1775 if (cxstack_ix >= 0) {
1776 /* If this flag is set, we're just inside a return, so we should
1777 * store the caller's context */
1778 gimme = (PL_op->op_flags & OPf_SPECIAL)
1779 ? block_gimme()
1780 : cxstack[cxstack_ix].blk_gimme;
1781 } else
54310121
PP
1782 gimme = G_SCALAR;
1783 }
a0d0e21e 1784
d343c3ef 1785 ENTER_with_name("block");
a0d0e21e
LW
1786
1787 SAVETMPS;
924508f0 1788 PUSHBLOCK(cx, CXt_BLOCK, SP);
a0d0e21e
LW
1789
1790 RETURN;
1791}
1792
1793PP(pp_helem)
1794{
97aff369 1795 dVAR; dSP;
760ac839 1796 HE* he;
ae77835f 1797 SV **svp;
c445ea15 1798 SV * const keysv = POPs;
85fbaab2 1799 HV * const hv = MUTABLE_HV(POPs);
a3b680e6
AL
1800 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1801 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1802 SV *sv;
c158a4fd 1803 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
92970b93 1804 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 1805 bool preeminent = TRUE;
a0d0e21e 1806
d4c19fe8 1807 if (SvTYPE(hv) != SVt_PVHV)
a0d0e21e 1808 RETPUSHUNDEF;
d4c19fe8 1809
92970b93 1810 if (localizing) {
d4c19fe8
AL
1811 MAGIC *mg;
1812 HV *stash;
d30e492c
VP
1813
1814 /* If we can determine whether the element exist,
1815 * Try to preserve the existenceness of a tied hash
1816 * element by using EXISTS and DELETE if possible.
1817 * Fallback to FETCH and STORE otherwise. */
1818 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1819 preeminent = hv_exists_ent(hv, keysv, 0);
d4c19fe8 1820 }
d30e492c 1821
d4c19fe8
AL
1822 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1823 svp = he ? &HeVAL(he) : NULL;
a0d0e21e 1824 if (lval) {
3280af22 1825 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
1826 SV* lv;
1827 SV* key2;
2d8e6c8d 1828 if (!defer) {
be2597df 1829 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2d8e6c8d 1830 }
68dc0745
PP
1831 lv = sv_newmortal();
1832 sv_upgrade(lv, SVt_PVLV);
1833 LvTYPE(lv) = 'y';
6136c704 1834 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
68dc0745 1835 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
b37c2d43 1836 LvTARG(lv) = SvREFCNT_inc_simple(hv);
68dc0745
PP
1837 LvTARGLEN(lv) = 1;
1838 PUSHs(lv);
1839 RETURN;
1840 }
92970b93 1841 if (localizing) {
bfcb3514 1842 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 1843 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP
1844 else if (preeminent)
1845 save_helem_flags(hv, keysv, svp,
1846 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1847 else
1848 SAVEHDELETE(hv, keysv);
5f05dabc 1849 }
533c011a
NIS
1850 else if (PL_op->op_private & OPpDEREF)
1851 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 1852 }
3280af22 1853 sv = (svp ? *svp : &PL_sv_undef);
fd69380d
DM
1854 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1855 * was to make C<local $tied{foo} = $tied{foo}> possible.
1856 * However, it seems no longer to be needed for that purpose, and
1857 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1858 * would loop endlessly since the pos magic is getting set on the
1859 * mortal copy and lost. However, the copy has the effect of
1860 * triggering the get magic, and losing it altogether made things like
1861 * c<$tied{foo};> in void context no longer do get magic, which some
1862 * code relied on. Also, delayed triggering of magic on @+ and friends
1863 * meant the original regex may be out of scope by now. So as a
1864 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1865 * being called too many times). */
39cf747a 1866 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
fd69380d 1867 mg_get(sv);
be6c24e0 1868 PUSHs(sv);
a0d0e21e
LW
1869 RETURN;
1870}
1871
1872PP(pp_leave)
1873{
27da23d5 1874 dVAR; dSP;
c09156bb 1875 register PERL_CONTEXT *cx;
a0d0e21e
LW
1876 SV **newsp;
1877 PMOP *newpm;
1878 I32 gimme;
1879
533c011a 1880 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1881 cx = &cxstack[cxstack_ix];
3280af22 1882 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
a0d0e21e
LW
1883 }
1884
1885 POPBLOCK(cx,newpm);
1886
e91684bf 1887 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
a0d0e21e 1888
a1f49e72 1889 TAINT_NOT;
54310121
PP
1890 if (gimme == G_VOID)
1891 SP = newsp;
1892 else if (gimme == G_SCALAR) {
a3b680e6 1893 register SV **mark;
54310121 1894 MARK = newsp + 1;
09256e2f 1895 if (MARK <= SP) {
54310121
PP
1896 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1897 *MARK = TOPs;
1898 else
1899 *MARK = sv_mortalcopy(TOPs);
09256e2f 1900 } else {
54310121 1901 MEXTEND(mark,0);
3280af22 1902 *MARK = &PL_sv_undef;
a0d0e21e 1903 }
54310121 1904 SP = MARK;
a0d0e21e 1905 }
54310121 1906 else if (gimme == G_ARRAY) {
a1f49e72 1907 /* in case LEAVE wipes old return values */
a3b680e6 1908 register SV **mark;
a1f49e72
CS
1909 for (mark = newsp + 1; mark <= SP; mark++) {
1910 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 1911 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
1912 TAINT_NOT; /* Each item is independent */
1913 }
1914 }
a0d0e21e 1915 }
3280af22 1916 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 1917
d343c3ef 1918 LEAVE_with_name("block");
a0d0e21e
LW
1919
1920 RETURN;
1921}
1922
1923PP(pp_iter)
1924{
97aff369 1925 dVAR; dSP;
c09156bb 1926 register PERL_CONTEXT *cx;
dc09a129 1927 SV *sv, *oldsv;
1d7c1841 1928 SV **itersvp;
d01136d6
BS
1929 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1930 bool av_is_stack = FALSE;
a0d0e21e 1931
924508f0 1932 EXTEND(SP, 1);
a0d0e21e 1933 cx = &cxstack[cxstack_ix];
3b719c58 1934 if (!CxTYPE_is_LOOP(cx))
cea2e8a9 1935 DIE(aTHX_ "panic: pp_iter");
a0d0e21e 1936
1d7c1841 1937 itersvp = CxITERVAR(cx);
d01136d6 1938 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
89ea2908 1939 /* string increment */
d01136d6
BS
1940 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1941 SV *end = cx->blk_loop.state_u.lazysv.end;
267cc4a8
NC
1942 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1943 It has SvPVX of "" and SvCUR of 0, which is what we want. */
4fe3f0fa 1944 STRLEN maxlen = 0;
d01136d6 1945 const char *max = SvPV_const(end, maxlen);
89ea2908 1946 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1d7c1841 1947 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1948 /* safe to reuse old SV */
1d7c1841 1949 sv_setsv(*itersvp, cur);
eaa5c2d6 1950 }
1c846c1f 1951 else
eaa5c2d6
GA
1952 {
1953 /* we need a fresh SV every time so that loop body sees a
1954 * completely new SV for closures/references to work as
1955 * they used to */
dc09a129 1956 oldsv = *itersvp;
1d7c1841 1957 *itersvp = newSVsv(cur);
dc09a129 1958 SvREFCNT_dec(oldsv);
eaa5c2d6 1959 }
aa07b2f6 1960 if (strEQ(SvPVX_const(cur), max))
89ea2908
GA
1961 sv_setiv(cur, 0); /* terminate next time */
1962 else
1963 sv_inc(cur);
1964 RETPUSHYES;
1965 }
1966 RETPUSHNO;
d01136d6
BS
1967 }
1968 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
89ea2908 1969 /* integer increment */
d01136d6 1970 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
89ea2908 1971 RETPUSHNO;
7f61b687 1972
3db8f154 1973 /* don't risk potential race */
1d7c1841 1974 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1975 /* safe to reuse old SV */
d01136d6 1976 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
eaa5c2d6 1977 }
1c846c1f 1978 else
eaa5c2d6
GA
1979 {
1980 /* we need a fresh SV every time so that loop body sees a
1981 * completely new SV for closures/references to work as they
1982 * used to */
dc09a129 1983 oldsv = *itersvp;
d01136d6 1984 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
dc09a129 1985 SvREFCNT_dec(oldsv);
eaa5c2d6 1986 }
a2309040
JH
1987
1988 /* Handle end of range at IV_MAX */
d01136d6
BS
1989 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1990 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
a2309040 1991 {
d01136d6
BS
1992 cx->blk_loop.state_u.lazyiv.cur++;
1993 cx->blk_loop.state_u.lazyiv.end++;
a2309040
JH
1994 }
1995
89ea2908
GA
1996 RETPUSHYES;
1997 }
1998
1999 /* iterate array */
d01136d6
BS
2000 assert(CxTYPE(cx) == CXt_LOOP_FOR);
2001 av = cx->blk_loop.state_u.ary.ary;
2002 if (!av) {
2003 av_is_stack = TRUE;
2004 av = PL_curstack;
2005 }
ef3e5ea9 2006 if (PL_op->op_private & OPpITER_REVERSED) {
d01136d6
BS
2007 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2008 ? cx->blk_loop.resetsp + 1 : 0))
ef3e5ea9 2009 RETPUSHNO;
a0d0e21e 2010
ef3e5ea9 2011 if (SvMAGICAL(av) || AvREIFY(av)) {
d01136d6 2012 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
a0714e2c 2013 sv = svp ? *svp : NULL;
ef3e5ea9
NC
2014 }
2015 else {
d01136d6 2016 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
ef3e5ea9 2017 }
d42935ef
JH
2018 }
2019 else {
d01136d6 2020 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
ef3e5ea9
NC
2021 AvFILL(av)))
2022 RETPUSHNO;
2023
2024 if (SvMAGICAL(av) || AvREIFY(av)) {
d01136d6 2025 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
a0714e2c 2026 sv = svp ? *svp : NULL;
ef3e5ea9
NC
2027 }
2028 else {
d01136d6 2029 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
ef3e5ea9 2030 }
d42935ef 2031 }
ef3e5ea9 2032
0565a181 2033 if (sv && SvIS_FREED(sv)) {
a0714e2c 2034 *itersvp = NULL;
b6c83531 2035 Perl_croak(aTHX_ "Use of freed value in iteration");
cccede53
DM
2036 }
2037
d01136d6 2038 if (sv) {
a0d0e21e 2039 SvTEMP_off(sv);
d01136d6
BS
2040 SvREFCNT_inc_simple_void_NN(sv);
2041 }
a0d0e21e 2042 else
3280af22 2043 sv = &PL_sv_undef;
d01136d6
BS
2044 if (!av_is_stack && sv == &PL_sv_undef) {
2045 SV *lv = newSV_type(SVt_PVLV);
2046 LvTYPE(lv) = 'y';
2047 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
b37c2d43 2048 LvTARG(lv) = SvREFCNT_inc_simple(av);
d01136d6 2049 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
42718184 2050 LvTARGLEN(lv) = (STRLEN)UV_MAX;
d01136d6 2051 sv = lv;
5f05dabc 2052 }
a0d0e21e 2053
dc09a129 2054 oldsv = *itersvp;
d01136d6 2055 *itersvp = sv;
dc09a129
DM
2056 SvREFCNT_dec(oldsv);
2057
a0d0e21e
LW
2058 RETPUSHYES;
2059}
2060
ef07e810
DM
2061/*
2062A description of how taint works in pattern matching and substitution.
2063
0ab462a6
DM
2064While the pattern is being assembled/concatenated and them compiled,
2065PL_tainted will get set if any component of the pattern is tainted, e.g.
2066/.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
2067is set on the pattern if PL_tainted is set.
ef07e810 2068
0ab462a6
DM
2069When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2070the pattern is marked as tainted. This means that subsequent usage, such
2071as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
ef07e810
DM
2072
2073During execution of a pattern, locale-variant ops such as ALNUML set the
2074local flag RF_tainted. At the end of execution, the engine sets the
0ab462a6
DM
2075RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
2076otherwise.
ef07e810
DM
2077
2078In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
2079of $1 et al to indicate whether the returned value should be tainted.
2080It is the responsibility of the caller of the pattern (i.e. pp_match,
2081pp_subst etc) to set this flag for any other circumstances where $1 needs
2082to be tainted.
2083
2084The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2085
2086There are three possible sources of taint
2087 * the source string
2088 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2089 * the replacement string (or expression under /e)
2090
2091There are four destinations of taint and they are affected by the sources
2092according to the rules below:
2093
2094 * the return value (not including /r):
2095 tainted by the source string and pattern, but only for the
2096 number-of-iterations case; boolean returns aren't tainted;
2097 * the modified string (or modified copy under /r):
2098 tainted by the source string, pattern, and replacement strings;
2099 * $1 et al:
2100 tainted by the pattern, and under 'use re "taint"', by the source
2101 string too;
2102 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2103 should always be unset before executing subsequent code.
2104
2105The overall action of pp_subst is:
2106
2107 * at the start, set bits in rxtainted indicating the taint status of
2108 the various sources.
2109
2110 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2111 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2112 pattern has subsequently become tainted via locale ops.
2113
2114 * If control is being passed to pp_substcont to execute a /e block,
2115 save rxtainted in the CXt_SUBST block, for future use by
2116 pp_substcont.
2117
2118 * Whenever control is being returned to perl code (either by falling
2119 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2120 use the flag bits in rxtainted to make all the appropriate types of
0ab462a6
DM
2121 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2122 et al will appear tainted.
ef07e810
DM
2123
2124pp_match is just a simpler version of the above.
2125
2126*/
2127
a0d0e21e
LW
2128PP(pp_subst)
2129{
97aff369 2130 dVAR; dSP; dTARG;
a0d0e21e
LW
2131 register PMOP *pm = cPMOP;
2132 PMOP *rpm = pm;
a0d0e21e
LW
2133 register char *s;
2134 char *strend;
2135 register char *m;
5c144d81 2136 const char *c;
a0d0e21e
LW
2137 register char *d;
2138 STRLEN clen;
2139 I32 iters = 0;
2140 I32 maxiters;
2141 register I32 i;
2142 bool once;
ef07e810
DM
2143 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2144 See "how taint works" above */
a0d0e21e 2145 char *orig;
1ed74d04 2146 U8 r_flags;
aaa362c4 2147 register REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
2148 STRLEN len;
2149 int force_on_match = 0;
0bcc34c2 2150 const I32 oldsave = PL_savestack_ix;
792b2c16 2151 STRLEN slen;
f272994b 2152 bool doutf8 = FALSE;
f8c7b90f 2153#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2154 bool is_cow;
2155#endif
a0714e2c 2156 SV *nsv = NULL;
b770e143
NC
2157 /* known replacement string? */
2158 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
a0d0e21e 2159
f410a211
NC
2160 PERL_ASYNC_CHECK();
2161
533c011a 2162 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 2163 TARG = POPs;
59f00321
RGS
2164 else if (PL_op->op_private & OPpTARGET_MY)
2165 GETTARGET;
a0d0e21e 2166 else {
54b9620d 2167 TARG = DEFSV;
a0d0e21e 2168 EXTEND(SP,1);
1c846c1f 2169 }
d9f424b2 2170
4f4d7508
DC
2171 /* In non-destructive replacement mode, duplicate target scalar so it
2172 * remains unchanged. */
2173 if (rpm->op_pmflags & PMf_NONDESTRUCT)
4eedab49 2174 TARG = sv_2mortal(newSVsv(TARG));
4f4d7508 2175
f8c7b90f 2176#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2177 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2178 because they make integers such as 256 "false". */
2179 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2180#else
765f542d
NC
2181 if (SvIsCOW(TARG))
2182 sv_force_normal_flags(TARG,0);
ed252734
NC
2183#endif
2184 if (
f8c7b90f 2185#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2186 !is_cow &&
2187#endif
2188 (SvREADONLY(TARG)
cecf5685
NC
2189 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2190 || SvTYPE(TARG) > SVt_PVLV)
4ce457a6 2191 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
6ad8f254 2192 Perl_croak_no_modify(aTHX);
8ec5e241
NIS
2193 PUTBACK;
2194
3e462cdc 2195 setup_match:
d5263905 2196 s = SvPV_mutable(TARG, len);
68dc0745 2197 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
a0d0e21e 2198 force_on_match = 1;
20be6587
DM
2199
2200 /* only replace once? */
2201 once = !(rpm->op_pmflags & PMf_GLOBAL);
2202
ef07e810 2203 /* See "how taint works" above */
20be6587
DM
2204 if (PL_tainting) {
2205 rxtainted = (
2206 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2207 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2208 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2209 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2210 ? SUBST_TAINT_BOOLRET : 0));
2211 TAINT_NOT;
2212 }
a12c0f56 2213
a30b2f1f 2214 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 2215
a0d0e21e
LW
2216 force_it:
2217 if (!pm || !s)
2269b42e 2218 DIE(aTHX_ "panic: pp_subst");
a0d0e21e
LW
2219
2220 strend = s + len;
a30b2f1f 2221 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
792b2c16
JH
2222 maxiters = 2 * slen + 10; /* We can match twice at each
2223 position, once with zero-length,
2224 second time with non-zero. */
a0d0e21e 2225
220fc49f 2226 if (!RX_PRELEN(rx) && PL_curpm) {
3280af22 2227 pm = PL_curpm;
aaa362c4 2228 rx = PM_GETRE(pm);
a0d0e21e 2229 }
07bc277f
NC
2230 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2231 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
ed252734 2232 ? REXEC_COPY_STR : 0;
f722798b 2233 if (SvSCREAM(TARG))
22e551b9 2234 r_flags |= REXEC_SCREAM;
7fba1cd6 2235
a0d0e21e 2236 orig = m = s;
07bc277f 2237 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
ee0b7718 2238 PL_bostr = orig;
f9f4320a 2239 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
f722798b
IZ
2240
2241 if (!s)
df34c13a 2242 goto ret_no;
f722798b 2243 /* How to do it in subst? */
07bc277f 2244/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1c846c1f 2245 && !PL_sawampersand
07bc277f
NC
2246 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2247 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2248 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
f722798b
IZ
2249 && (r_flags & REXEC_SCREAM))))
2250 goto yup;
2251*/
a0d0e21e 2252 }
71be2cbc 2253
8b64c330
DM
2254 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2255 r_flags | REXEC_CHECKED))
2256 {
5e79dfb9
DM
2257 ret_no:
2258 SPAGAIN;
2259 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2260 LEAVE_SCOPE(oldsave);
2261 RETURN;
2262 }
2263
71be2cbc 2264 /* known replacement string? */
f272994b 2265 if (dstr) {
20be6587
DM
2266 if (SvTAINTED(dstr))
2267 rxtainted |= SUBST_TAINT_REPL;
3e462cdc
KW
2268
2269 /* Upgrade the source if the replacement is utf8 but the source is not,
2270 * but only if it matched; see
2271 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2272 */
5e79dfb9 2273 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
c95ca9b8
DM
2274 char * const orig_pvx = SvPVX(TARG);
2275 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
3e462cdc
KW
2276
2277 /* If the lengths are the same, the pattern contains only
2278 * invariants, can keep going; otherwise, various internal markers
2279 * could be off, so redo */
c95ca9b8 2280 if (new_len != len || orig_pvx != SvPVX(TARG)) {
3e462cdc
KW
2281 goto setup_match;
2282 }
2283 }
2284
8514a05a
JH
2285 /* replacement needing upgrading? */
2286 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2287 nsv = sv_newmortal();
4a176938 2288 SvSetSV(nsv, dstr);
8514a05a
JH
2289 if (PL_encoding)
2290 sv_recode_to_utf8(nsv, PL_encoding);
2291 else
2292 sv_utf8_upgrade(nsv);
5c144d81 2293 c = SvPV_const(nsv, clen);
4a176938
JH
2294 doutf8 = TRUE;
2295 }
2296 else {
5c144d81 2297 c = SvPV_const(dstr, clen);
4a176938 2298 doutf8 = DO_UTF8(dstr);
8514a05a 2299 }
f272994b
A
2300 }
2301 else {
6136c704 2302 c = NULL;
f272994b
A
2303 doutf8 = FALSE;
2304 }
2305
71be2cbc 2306 /* can do inplace substitution? */
ed252734 2307 if (c
f8c7b90f 2308#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2309 && !is_cow
2310#endif
07bc277f
NC
2311 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2312 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
8b030b38
DM
2313 && (!doutf8 || SvUTF8(TARG)))
2314 {
ec911639 2315
f8c7b90f 2316#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2317 if (SvIsCOW(TARG)) {
2318 assert (!force_on_match);
2319 goto have_a_cow;
2320 }
2321#endif
71be2cbc
PP
2322 if (force_on_match) {
2323 force_on_match = 0;
2324 s = SvPV_force(TARG, len);
2325 goto force_it;
2326 }
71be2cbc 2327 d = s;
3280af22 2328 PL_curpm = pm;
71be2cbc
PP
2329 SvSCREAM_off(TARG); /* disable possible screamer */
2330 if (once) {
20be6587
DM
2331 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2332 rxtainted |= SUBST_TAINT_PAT;
07bc277f
NC
2333 m = orig + RX_OFFS(rx)[0].start;
2334 d = orig + RX_OFFS(rx)[0].end;
71be2cbc
PP
2335 s = orig;
2336 if (m - s > strend - d) { /* faster to shorten from end */
2337 if (clen) {
2338 Copy(c, m, clen, char);
2339 m += clen;
a0d0e21e 2340 }
71be2cbc
PP
2341 i = strend - d;
2342 if (i > 0) {
2343 Move(d, m, i, char);
2344 m += i;
a0d0e21e 2345 }
71be2cbc
PP
2346 *m = '\0';
2347 SvCUR_set(TARG, m - s);
2348 }
155aba94 2349 else if ((i = m - s)) { /* faster from front */
71be2cbc
PP
2350 d -= clen;
2351 m = d;
0d3c21b0 2352 Move(s, d - i, i, char);
71be2cbc 2353 sv_chop(TARG, d-i);
71be2cbc
PP
2354 if (clen)
2355 Copy(c, m, clen, char);
2356 }
2357 else if (clen) {
2358 d -= clen;
2359 sv_chop(TARG, d);
2360 Copy(c, d, clen, char);
2361 }
2362 else {
2363 sv_chop(TARG, d);
2364 }
8ec5e241 2365 SPAGAIN;
af050d75 2366 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_yes);
71be2cbc
PP
2367 }
2368 else {
71be2cbc
PP
2369 do {
2370 if (iters++ > maxiters)
cea2e8a9 2371 DIE(aTHX_ "Substitution loop");
20be6587
DM
2372 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2373 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2374 m = RX_OFFS(rx)[0].start + orig;
155aba94 2375 if ((i = m - s)) {
71be2cbc
PP
2376 if (s != d)
2377 Move(s, d, i, char);
2378 d += i;
a0d0e21e 2379 }
71be2cbc
PP
2380 if (clen) {
2381 Copy(c, d, clen, char);
2382 d += clen;
2383 }
07bc277f 2384 s = RX_OFFS(rx)[0].end + orig;
f9f4320a 2385 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
f722798b
IZ
2386 TARG, NULL,
2387 /* don't match same null twice */
2388 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc
PP
2389 if (s != d) {
2390 i = strend - s;
aa07b2f6 2391 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
71be2cbc 2392 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2393 }
8ec5e241 2394 SPAGAIN;
4f4d7508
DC
2395 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2396 PUSHs(TARG);
2397 else
2398 mPUSHi((I32)iters);
a0d0e21e
LW
2399 }
2400 }
ff6e92e8 2401 else {
a0d0e21e
LW
2402 if (force_on_match) {
2403 force_on_match = 0;
2404 s = SvPV_force(TARG, len);
2405 goto force_it;
2406 }
f8c7b90f 2407#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2408 have_a_cow:
2409#endif
20be6587
DM
2410 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2411 rxtainted |= SUBST_TAINT_PAT;
740cce10 2412 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
cff085c1 2413 SAVEFREESV(dstr);
3280af22 2414 PL_curpm = pm;
a0d0e21e 2415 if (!c) {
c09156bb 2416 register PERL_CONTEXT *cx;
8ec5e241 2417 SPAGAIN;
20be6587
DM
2418 /* note that a whole bunch of local vars are saved here for
2419 * use by pp_substcont: here's a list of them in case you're
2420 * searching for places in this sub that uses a particular var:
2421 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2422 * s m strend rx once */
a0d0e21e 2423 PUSHSUBST(cx);
20e98b0f 2424 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
a0d0e21e 2425 }
cf93c79d 2426 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
2427 do {
2428 if (iters++ > maxiters)
cea2e8a9 2429 DIE(aTHX_ "Substitution loop");
20be6587
DM
2430 if (RX_MATCH_TAINTED(rx))
2431 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2432 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
a0d0e21e
LW
2433 m = s;
2434 s = orig;
07bc277f 2435 orig = RX_SUBBEG(rx);
a0d0e21e
LW
2436 s = orig + (m - s);
2437 strend = s + (strend - m);
2438 }
07bc277f 2439 m = RX_OFFS(rx)[0].start + orig;
db79b45b
JH
2440 if (doutf8 && !SvUTF8(dstr))
2441 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2442 else
2443 sv_catpvn(dstr, s, m-s);
07bc277f 2444 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e
LW
2445 if (clen)
2446 sv_catpvn(dstr, c, clen);
2447 if (once)
2448 break;
f9f4320a 2449 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
ffc61ed2 2450 TARG, NULL, r_flags));
db79b45b
JH
2451 if (doutf8 && !DO_UTF8(TARG))
2452 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
89afcb60
A
2453 else
2454 sv_catpvn(dstr, s, strend - s);
748a9306 2455
f8c7b90f 2456#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2457 /* The match may make the string COW. If so, brilliant, because that's
2458 just saved us one malloc, copy and free - the regexp has donated
2459 the old buffer, and we malloc an entirely new one, rather than the
2460 regexp malloc()ing a buffer and copying our original, only for
2461 us to throw it away here during the substitution. */
2462 if (SvIsCOW(TARG)) {
2463 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2464 } else
2465#endif
2466 {
8bd4d4c5 2467 SvPV_free(TARG);
ed252734 2468 }
f880fe2f 2469 SvPV_set(TARG, SvPVX(dstr));
748a9306
LW
2470 SvCUR_set(TARG, SvCUR(dstr));
2471 SvLEN_set(TARG, SvLEN(dstr));
f272994b 2472 doutf8 |= DO_UTF8(dstr);
6136c704 2473 SvPV_set(dstr, NULL);
748a9306 2474
f878fbec 2475 SPAGAIN;
4f4d7508
DC
2476 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2477 PUSHs(TARG);
2478 else
2479 mPUSHi((I32)iters);
a0d0e21e 2480 }
f1a76097
DM
2481 (void)SvPOK_only_UTF8(TARG);
2482 if (doutf8)
2483 SvUTF8_on(TARG);
20be6587 2484
ef07e810 2485 /* See "how taint works" above */
20be6587
DM
2486 if (PL_tainting) {
2487 if ((rxtainted & SUBST_TAINT_PAT) ||
2488 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2489 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2490 )
2491 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2492
2493 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2494 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2495 )
2496 SvTAINTED_on(TOPs); /* taint return value */
2497 else
2498 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2499
2500 /* needed for mg_set below */
2501 PL_tainted =
2502 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2503 SvTAINT(TARG);
2504 }
2505 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2506 TAINT_NOT;
f1a76097
DM
2507 LEAVE_SCOPE(oldsave);
2508 RETURN;
a0d0e21e
LW
2509}
2510
2511PP(pp_grepwhile)
2512{
27da23d5 2513 dVAR; dSP;
a0d0e21e
LW
2514
2515 if (SvTRUEx(POPs))
3280af22
NIS
2516 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2517 ++*PL_markstack_ptr;
b2a2a901 2518 FREETMPS;
d343c3ef 2519 LEAVE_with_name("grep_item"); /* exit inner scope */
a0d0e21e
LW
2520
2521 /* All done yet? */
3280af22 2522 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2523 I32 items;
c4420975 2524 const I32 gimme = GIMME_V;
a0d0e21e 2525
d343c3ef 2526 LEAVE_with_name("grep"); /* exit outer scope */
a0d0e21e 2527 (void)POPMARK; /* pop src */
3280af22 2528 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2529 (void)POPMARK; /* pop dst */
3280af22 2530 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2531 if (gimme == G_SCALAR) {
7cc47870 2532 if (PL_op->op_private & OPpGREP_LEX) {
c4420975 2533 SV* const sv = sv_newmortal();
7cc47870
RGS
2534 sv_setiv(sv, items);
2535 PUSHs(sv);
2536 }
2537 else {
2538 dTARGET;
2539 XPUSHi(items);
2540 }
a0d0e21e 2541 }
54310121
PP
2542 else if (gimme == G_ARRAY)
2543 SP += items;
a0d0e21e
LW
2544 RETURN;
2545 }
2546 else {
2547 SV *src;
2548
d343c3ef 2549 ENTER_with_name("grep_item"); /* enter inner scope */
1d7c1841 2550 SAVEVPTR(PL_curpm);
a0d0e21e 2551
3280af22 2552 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2553 SvTEMP_off(src);
59f00321
RGS
2554 if (PL_op->op_private & OPpGREP_LEX)
2555 PAD_SVl(PL_op->op_targ) = src;
2556 else
414bf5ae 2557 DEFSV_set(src);
a0d0e21e
LW
2558
2559 RETURNOP(cLOGOP->op_other);
2560 }
2561}
2562
2563PP(pp_leavesub)
2564{
27da23d5 2565 dVAR; dSP;
a0d0e21e
LW
2566 SV **mark;
2567 SV **newsp;
2568 PMOP *newpm;
2569 I32 gimme;
c09156bb 2570 register PERL_CONTEXT *cx;
b0d9ce38 2571 SV *sv;
a0d0e21e 2572
9850bf21
RH
2573 if (CxMULTICALL(&cxstack[cxstack_ix]))
2574 return 0;
2575
a0d0e21e 2576 POPBLOCK(cx,newpm);
5dd42e15 2577 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2578
a1f49e72 2579 TAINT_NOT;
a0d0e21e
LW
2580 if (gimme == G_SCALAR) {
2581 MARK = newsp + 1;
a29cdaf0 2582 if (MARK <= SP) {
a8bba7fa 2583 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
2584 if (SvTEMP(TOPs)) {
2585 *MARK = SvREFCNT_inc(TOPs);
2586 FREETMPS;
2587 sv_2mortal(*MARK);
cd06dffe
GS
2588 }
2589 else {
959e3673 2590 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2591 FREETMPS;
959e3673
GS
2592 *MARK = sv_mortalcopy(sv);
2593 SvREFCNT_dec(sv);
a29cdaf0 2594 }
cd06dffe
GS
2595 }
2596 else
a29cdaf0 2597 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
cd06dffe
GS
2598 }
2599 else {
f86702cc 2600 MEXTEND(MARK, 0);
3280af22 2601 *MARK = &PL_sv_undef;
a0d0e21e
LW
2602 }
2603 SP = MARK;
2604 }
54310121 2605 else if (gimme == G_ARRAY) {
f86702cc 2606 for (MARK = newsp + 1; MARK <= SP; MARK++) {
a1f49e72 2607 if (!SvTEMP(*MARK)) {
f86702cc 2608 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2609 TAINT_NOT; /* Each item is independent */
2610 }
f86702cc 2611 }
a0d0e21e 2612 }
f86702cc 2613 PUTBACK;
1c846c1f 2614
a57c6685 2615 LEAVE;
5dd42e15 2616 cxstack_ix--;
b0d9ce38 2617 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2618 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2619
b0d9ce38 2620 LEAVESUB(sv);
f39bc417 2621 return cx->blk_sub.retop;
a0d0e21e
LW
2622}
2623
cd06dffe
GS
2624/* This duplicates the above code because the above code must not
2625 * get any slower by more conditions */
2626PP(pp_leavesublv)
2627{
27da23d5 2628 dVAR; dSP;
cd06dffe
GS
2629 SV **mark;
2630 SV **newsp;
2631 PMOP *newpm;
2632 I32 gimme;
2633 register PERL_CONTEXT *cx;
b0d9ce38 2634 SV *sv;
cd06dffe 2635
9850bf21
RH
2636 if (CxMULTICALL(&cxstack[cxstack_ix]))
2637 return 0;
2638
cd06dffe 2639 POPBLOCK(cx,newpm);
5dd42e15 2640 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2641
cd06dffe
GS
2642 TAINT_NOT;
2643
bafb2adc 2644 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
cd06dffe
GS
2645 /* We are an argument to a function or grep().
2646 * This kind of lvalueness was legal before lvalue
2647 * subroutines too, so be backward compatible:
2648 * cannot report errors. */
2649
2650 /* Scalar context *is* possible, on the LHS of -> only,
2651 * as in f()->meth(). But this is not an lvalue. */
2652 if (gimme == G_SCALAR)
2653 goto temporise;
2654 if (gimme == G_ARRAY) {
91e34d82
MP
2655 mark = newsp + 1;
2656 /* We want an array here, but padav will have left us an arrayref for an lvalue,
2657 * so we need to expand it */
2658 if(SvTYPE(*mark) == SVt_PVAV) {
2659 AV *const av = MUTABLE_AV(*mark);
2660 const I32 maxarg = AvFILL(av) + 1;
2661 (void)POPs; /* get rid of the array ref */
2662 EXTEND(SP, maxarg);
2663 if (SvRMAGICAL(av)) {
2664 U32 i;
2665 for (i=0; i < (U32)maxarg; i++) {
2666 SV ** const svp = av_fetch(av, i, FALSE);
2667 SP[i+1] = svp
2668 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
2669 : &PL_sv_undef;
2670 }
2671 }
2672 else {
2673 Copy(AvARRAY(av), SP+1, maxarg, SV*);
2674 }
2675 SP += maxarg;
2676 PUTBACK;
2677 }
a8bba7fa 2678 if (!CvLVALUE(cx->blk_sub.cv))
cd06dffe
GS
2679 goto temporise_array;
2680 EXTEND_MORTAL(SP - newsp);
2681 for (mark = newsp + 1; mark <= SP; mark++) {
2682 if (SvTEMP(*mark))
6f207bd3 2683 NOOP;
cd06dffe
GS
2684 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2685 *mark = sv_mortalcopy(*mark);
2686 else {
2687 /* Can be a localized value subject to deletion. */
2688 PL_tmps_stack[++PL_tmps_ix] = *mark;
b37c2d43 2689 SvREFCNT_inc_void(*mark);
cd06dffe
GS
2690 }
2691 }
2692 }
2693 }
bafb2adc 2694 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
cd06dffe
GS
2695 /* Here we go for robustness, not for speed, so we change all
2696 * the refcounts so the caller gets a live guy. Cannot set
2697 * TEMP, so sv_2mortal is out of question. */
a8bba7fa 2698 if (!CvLVALUE(cx->blk_sub.cv)) {
a57c6685 2699 LEAVE;
5dd42e15 2700 cxstack_ix--;
b0d9ce38 2701 POPSUB(cx,sv);
d470f89e 2702 PL_curpm = newpm;
b0d9ce38 2703 LEAVESUB(sv);
d470f89e
GS
2704 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2705 }
cd06dffe
GS
2706 if (gimme == G_SCALAR) {
2707 MARK = newsp + 1;
2708 EXTEND_MORTAL(1);
2709 if (MARK == SP) {
213f7ada
EB
2710 /* Temporaries are bad unless they happen to have set magic
2711 * attached, such as the elements of a tied hash or array */
f71f472f
FC
2712 if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
2713 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2714 == SVf_READONLY
2715 ) &&
213f7ada 2716 !SvSMAGICAL(TOPs)) {
a57c6685 2717 LEAVE;
5dd42e15 2718 cxstack_ix--;
b0d9ce38 2719 POPSUB(cx,sv);
d470f89e 2720 PL_curpm = newpm;
b0d9ce38 2721 LEAVESUB(sv);
e9f19e3c
HS
2722 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2723 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2724 : "a readonly value" : "a temporary");
d470f89e 2725 }
cd06dffe
GS
2726 else { /* Can be a localized value
2727 * subject to deletion. */
2728 PL_tmps_stack[++PL_tmps_ix] = *mark;
b37c2d43 2729 SvREFCNT_inc_void(*mark);
cd06dffe
GS
2730 }
2731 }
d470f89e 2732 else { /* Should not happen? */
a57c6685 2733 LEAVE;
5dd42e15 2734 cxstack_ix--;
b0d9ce38 2735 POPSUB(cx,sv);
d470f89e 2736 PL_curpm = newpm;
b0d9ce38 2737 LEAVESUB(sv);
d470f89e 2738 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
cd06dffe 2739 (MARK > SP ? "Empty array" : "Array"));
d470f89e 2740 }
cd06dffe
GS
2741 SP = MARK;
2742 }
2743 else if (gimme == G_ARRAY) {
2744 EXTEND_MORTAL(SP - newsp);
2745 for (mark = newsp + 1; mark <= SP; mark++) {
f206cdda
AMS
2746 if (*mark != &PL_sv_undef
2747 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
d470f89e
GS
2748 /* Might be flattened array after $#array = */
2749 PUTBACK;
a57c6685 2750 LEAVE;
5dd42e15 2751 cxstack_ix--;
b0d9ce38 2752 POPSUB(cx,sv);
d470f89e 2753 PL_curpm = newpm;
b0d9ce38 2754 LEAVESUB(sv);
f206cdda
AMS
2755 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2756 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2757 }
cd06dffe 2758 else {
cd06dffe
GS
2759 /* Can be a localized value subject to deletion. */
2760 PL_tmps_stack[++PL_tmps_ix] = *mark;
b37c2d43 2761 SvREFCNT_inc_void(*mark);
cd06dffe
GS
2762 }
2763 }
2764 }
2765 }
2766 else {
2767 if (gimme == G_SCALAR) {
2768 temporise:
2769 MARK = newsp + 1;
2770 if (MARK <= SP) {
a8bba7fa 2771 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
cd06dffe
GS
2772 if (SvTEMP(TOPs)) {
2773 *MARK = SvREFCNT_inc(TOPs);
2774 FREETMPS;
2775 sv_2mortal(*MARK);
2776 }
2777 else {
959e3673 2778 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
cd06dffe 2779 FREETMPS;
959e3673
GS
2780 *MARK = sv_mortalcopy(sv);
2781 SvREFCNT_dec(sv);
cd06dffe
GS
2782 }
2783 }
2784 else
2785 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2786 }
2787 else {
2788 MEXTEND(MARK, 0);
2789 *MARK = &PL_sv_undef;
2790 }
2791 SP = MARK;
2792 }
2793 else if (gimme == G_ARRAY) {
2794 temporise_array:
2795 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2796 if (!SvTEMP(*MARK)) {
2797 *MARK = sv_mortalcopy(*MARK);
2798 TAINT_NOT; /* Each item is independent */
2799 }
2800 }
2801 }
2802 }
2803 PUTBACK;
1c846c1f 2804
a57c6685 2805 LEAVE;
5dd42e15 2806 cxstack_ix--;
b0d9ce38 2807 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
cd06dffe
GS
2808 PL_curpm = newpm; /* ... and pop $1 et al */
2809
b0d9ce38 2810 LEAVESUB(sv);
f39bc417 2811 return cx->blk_sub.retop;
cd06dffe
GS
2812}
2813
a0d0e21e
LW
2814PP(pp_entersub)
2815{
27da23d5 2816 dVAR; dSP; dPOPss;
a0d0e21e 2817 GV *gv;
a0d0e21e 2818 register CV *cv;
c09156bb 2819 register PERL_CONTEXT *cx;
5d94fbed 2820 I32 gimme;
a9c4fd4e 2821 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2822
2823 if (!sv)
cea2e8a9 2824 DIE(aTHX_ "Not a CODE reference");
a0d0e21e 2825 switch (SvTYPE(sv)) {
f1025168
NC
2826 /* This is overwhelming the most common case: */
2827 case SVt_PVGV:
6e592b3a
BM
2828 if (!isGV_with_GP(sv))
2829 DIE(aTHX_ "Not a CODE reference");
13be902c 2830 we_have_a_glob:
159b6efe 2831 if (!(cv = GvCVu((const GV *)sv))) {
f730a42d 2832 HV *stash;
f2c0649b 2833 cv = sv_2cv(sv, &stash, &gv, 0);
f730a42d 2834 }
f1025168 2835 if (!cv) {
a57c6685 2836 ENTER;
f1025168
NC
2837 SAVETMPS;
2838 goto try_autoload;
2839 }
2840 break;
13be902c
FC
2841 case SVt_PVLV:
2842 if(isGV_with_GP(sv)) goto we_have_a_glob;
2843 /*FALLTHROUGH*/
a0d0e21e 2844 default:
7c75014e
DM
2845 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2846 if (hasargs)
2847 SP = PL_stack_base + POPMARK;
4d198de3
DM
2848 else
2849 (void)POPMARK;
7c75014e
DM
2850 RETURN;
2851 }
2852 SvGETMAGIC(sv);
2853 if (SvROK(sv)) {
93d7320b
DM
2854 if (SvAMAGIC(sv)) {
2855 sv = amagic_deref_call(sv, to_cv_amg);
2856 /* Don't SPAGAIN here. */
2857 }
7c75014e
DM
2858 }
2859 else {
a9c4fd4e 2860 const char *sym;
780a5241 2861 STRLEN len;
7c75014e 2862 sym = SvPV_nomg_const(sv, len);
15ff848f 2863 if (!sym)
cea2e8a9 2864 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2865 if (PL_op->op_private & HINT_STRICT_REFS)
973a7615 2866 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
780a5241 2867 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
a0d0e21e
LW
2868 break;
2869 }
ea726b52 2870 cv = MUTABLE_CV(SvRV(sv));
a0d0e21e
LW
2871 if (SvTYPE(cv) == SVt_PVCV)
2872 break;
2873 /* FALL THROUGH */
2874 case SVt_PVHV:
2875 case SVt_PVAV:
cea2e8a9 2876 DIE(aTHX_ "Not a CODE reference");
f1025168 2877 /* This is the second most common case: */
a0d0e21e 2878 case SVt_PVCV:
ea726b52 2879 cv = MUTABLE_CV(sv);
a0d0e21e 2880 break;
a0d0e21e
LW
2881 }
2882
a57c6685 2883 ENTER;
a0d0e21e
LW
2884 SAVETMPS;
2885
2886 retry:
541ed3a9
FC
2887 if (CvCLONE(cv) && ! CvCLONED(cv))
2888 DIE(aTHX_ "Closure prototype called");
a0d0e21e 2889 if (!CvROOT(cv) && !CvXSUB(cv)) {
2f349aa0
NC
2890 GV* autogv;
2891 SV* sub_name;
2892
2893 /* anonymous or undef'd function leaves us no recourse */
2894 if (CvANON(cv) || !(gv = CvGV(cv)))
2895 DIE(aTHX_ "Undefined subroutine called");
2896
2897 /* autoloaded stub? */
2898 if (cv != GvCV(gv)) {
2899 cv = GvCV(gv);
2900 }
2901 /* should call AUTOLOAD now? */
2902 else {
7e623da3 2903try_autoload:
2f349aa0 2904 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
7e623da3 2905 FALSE)))
2f349aa0
NC
2906 {
2907 cv = GvCV(autogv);
2908 }
2909 /* sorry */
2910 else {
2911 sub_name = sv_newmortal();
6136c704 2912 gv_efullname3(sub_name, gv, NULL);
be2597df 2913 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2f349aa0
NC
2914 }
2915 }
2916 if (!cv)
2917 DIE(aTHX_ "Not a CODE reference");
2918 goto retry;
a0d0e21e
LW
2919 }
2920
54310121 2921 gimme = GIMME_V;
67caa1fe 2922 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
005a8a35 2923 Perl_get_db_sub(aTHX_ &sv, cv);
a9ef256d
NC
2924 if (CvISXSUB(cv))
2925 PL_curcopdb = PL_curcop;
1ad62f64 2926 if (CvLVALUE(cv)) {
2927 /* check for lsub that handles lvalue subroutines */
ae5c1e95 2928 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
1ad62f64 2929 /* if lsub not found then fall back to DB::sub */
2930 if (!cv) cv = GvCV(PL_DBsub);
2931 } else {
2932 cv = GvCV(PL_DBsub);
2933 }
a9ef256d 2934
ccafdc96
RGS
2935 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2936 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 2937 }
a0d0e21e 2938
aed2304a 2939 if (!(CvISXSUB(cv))) {
f1025168 2940 /* This path taken at least 75% of the time */
a0d0e21e
LW
2941 dMARK;
2942 register I32 items = SP - MARK;
0bcc34c2 2943 AV* const padlist = CvPADLIST(cv);
a0d0e21e
LW
2944 PUSHBLOCK(cx, CXt_SUB, MARK);
2945 PUSHSUB(cx);
f39bc417 2946 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 2947 CvDEPTH(cv)++;
6b35e009
GS
2948 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2949 * that eval'' ops within this sub know the correct lexical space.
a3985cdc
DM
2950 * Owing the speed considerations, we choose instead to search for
2951 * the cv using find_runcv() when calling doeval().
6b35e009 2952 */
3a76ca88
RGS
2953 if (CvDEPTH(cv) >= 2) {
2954 PERL_STACK_OVERFLOW_CHECK();
2955 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2956 }
3a76ca88
RGS
2957 SAVECOMPPAD();
2958 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2959 if (hasargs) {
10533ace 2960 AV *const av = MUTABLE_AV(PAD_SVl(0));
221373f0
GS
2961 if (AvREAL(av)) {
2962 /* @_ is normally not REAL--this should only ever
2963 * happen when DB::sub() calls things that modify @_ */
2964 av_clear(av);
2965 AvREAL_off(av);
2966 AvREIFY_on(av);
2967 }
3280af22 2968 cx->blk_sub.savearray = GvAV(PL_defgv);
502c6561 2969 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
dd2155a4 2970 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2971 cx->blk_sub.argarray = av;
a0d0e21e
LW
2972 ++MARK;
2973
2974 if (items > AvMAX(av) + 1) {
504618e9 2975 SV **ary = AvALLOC(av);
a0d0e21e
LW
2976 if (AvARRAY(av) != ary) {
2977 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 2978 AvARRAY(av) = ary;
a0d0e21e
LW
2979 }
2980 if (items > AvMAX(av) + 1) {
2981 AvMAX(av) = items - 1;
2982 Renew(ary,items,SV*);
2983 AvALLOC(av) = ary;
9c6bc640 2984 AvARRAY(av) = ary;
a0d0e21e
LW
2985 }
2986 }
2987 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2988 AvFILLp(av) = items - 1;
1c846c1f 2989
a0d0e21e
LW
2990 while (items--) {
2991 if (*MARK)
2992 SvTEMP_off(*MARK);
2993 MARK++;
2994 }
2995 }
4a925ff6
GS
2996 /* warning must come *after* we fully set up the context
2997 * stuff so that __WARN__ handlers can safely dounwind()
2998 * if they want to
2999 */
2b9dff67 3000 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
4a925ff6
GS
3001 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
3002 sub_crush_depth(cv);
a0d0e21e
LW
3003 RETURNOP(CvSTART(cv));
3004 }
f1025168 3005 else {
3a76ca88 3006 I32 markix = TOPMARK;
f1025168 3007
3a76ca88 3008 PUTBACK;
f1025168 3009
3a76ca88
RGS
3010 if (!hasargs) {
3011 /* Need to copy @_ to stack. Alternative may be to
3012 * switch stack to @_, and copy return values
3013 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3014 AV * const av = GvAV(PL_defgv);
3015 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
3016
3017 if (items) {
3018 /* Mark is at the end of the stack. */
3019 EXTEND(SP, items);
3020 Copy(AvARRAY(av), SP + 1, items, SV*);
3021 SP += items;
3022 PUTBACK ;
3023 }
3024 }
3025 /* We assume first XSUB in &DB::sub is the called one. */
3026 if (PL_curcopdb) {
3027 SAVEVPTR(PL_curcop);
3028 PL_curcop = PL_curcopdb;
3029 PL_curcopdb = NULL;
3030 }
3031 /* Do we need to open block here? XXXX */
72df79cf 3032
3033 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3034 assert(CvXSUB(cv));
16c91539 3035 CvXSUB(cv)(aTHX_ cv);
3a76ca88
RGS
3036
3037 /* Enforce some sanity in scalar context. */
3038 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
3039 if (markix > PL_stack_sp - PL_stack_base)
3040 *(PL_stack_base + markix) = &PL_sv_undef;
3041 else
3042 *(PL_stack_base + markix) = *PL_stack_sp;
3043 PL_stack_sp = PL_stack_base + markix;
3044 }
a57c6685 3045 LEAVE;
f1025168
NC
3046 return NORMAL;
3047 }
a0d0e21e
LW
3048}
3049
44a8e56a 3050void
864dbfa3 3051Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 3052{
7918f24d
NC
3053 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3054
44a8e56a 3055 if (CvANON(cv))
9014280d 3056 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 3057 else {
aec46f14 3058 SV* const tmpstr = sv_newmortal();
6136c704 3059 gv_efullname3(tmpstr, CvGV(cv), NULL);
35c1215d 3060 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
be2597df 3061 SVfARG(tmpstr));
44a8e56a
PP
3062 }
3063}
3064
a0d0e21e
LW
3065PP(pp_aelem)
3066{
97aff369 3067 dVAR; dSP;
a0d0e21e 3068 SV** svp;
a3b680e6 3069 SV* const elemsv = POPs;
d804643f 3070 IV elem = SvIV(elemsv);
502c6561 3071 AV *const av = MUTABLE_AV(POPs);
e1ec3a88
AL
3072 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3073 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
4ad10a0b
VP
3074 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3075 bool preeminent = TRUE;
be6c24e0 3076 SV *sv;
a0d0e21e 3077
e35c1634 3078 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
95b63a38
JH
3079 Perl_warner(aTHX_ packWARN(WARN_MISC),
3080 "Use of reference \"%"SVf"\" as array index",
be2597df 3081 SVfARG(elemsv));
748a9306 3082 if (elem > 0)
fc15ae8f 3083 elem -= CopARYBASE_get(PL_curcop);
a0d0e21e
LW
3084 if (SvTYPE(av) != SVt_PVAV)
3085 RETPUSHUNDEF;
4ad10a0b
VP
3086
3087 if (localizing) {
3088 MAGIC *mg;
3089 HV *stash;
3090
3091 /* If we can determine whether the element exist,
3092 * Try to preserve the existenceness of a tied array
3093 * element by using EXISTS and DELETE if possible.
3094 * Fallback to FETCH and STORE otherwise. */
3095 if (SvCANEXISTDELETE(av))
3096 preeminent = av_exists(av, elem);
3097 }
3098
68dc0745 3099 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 3100 if (lval) {
2b573ace 3101#ifdef PERL_MALLOC_WRAP
2b573ace 3102 if (SvUOK(elemsv)) {
a9c4fd4e 3103 const UV uv = SvUV(elemsv);
2b573ace
JH
3104 elem = uv > IV_MAX ? IV_MAX : uv;
3105 }
3106 else if (SvNOK(elemsv))
3107 elem = (IV)SvNV(elemsv);
a3b680e6
AL
3108 if (elem > 0) {
3109 static const char oom_array_extend[] =
3110 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 3111 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 3112 }
2b573ace 3113#endif
3280af22 3114 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
3115 SV* lv;
3116 if (!defer)
cea2e8a9 3117 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
3118 lv = sv_newmortal();
3119 sv_upgrade(lv, SVt_PVLV);
3120 LvTYPE(lv) = 'y';
a0714e2c 3121 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
b37c2d43 3122 LvTARG(lv) = SvREFCNT_inc_simple(av);
68dc0745
PP
3123 LvTARGOFF(lv) = elem;
3124 LvTARGLEN(lv) = 1;
3125 PUSHs(lv);
3126 RETURN;
3127 }
4ad10a0b
VP
3128 if (localizing) {
3129 if (preeminent)
3130 save_aelem(av, elem, svp);
3131 else
3132 SAVEADELETE(av, elem);
3133 }
533c011a
NIS
3134 else if (PL_op->op_private & OPpDEREF)
3135 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 3136 }
3280af22 3137 sv = (svp ? *svp : &PL_sv_undef);
39cf747a 3138 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 3139 mg_get(sv);
be6c24e0 3140 PUSHs(sv);
a0d0e21e
LW
3141 RETURN;
3142}
3143
02a9e968 3144void
864dbfa3 3145Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 3146{
7918f24d
NC
3147 PERL_ARGS_ASSERT_VIVIFY_REF;
3148
5b295bef 3149 SvGETMAGIC(sv);
02a9e968
CS
3150 if (!SvOK(sv)) {
3151 if (SvREADONLY(sv))
6ad8f254 3152 Perl_croak_no_modify(aTHX);
43230e26 3153 prepare_SV_for_RV(sv);
68dc0745 3154 switch (to_what) {
5f05dabc 3155 case OPpDEREF_SV:
561b68a9 3156 SvRV_set(sv, newSV(0));
5f05dabc
PP
3157 break;
3158 case OPpDEREF_AV:
ad64d0ec 3159 SvRV_set(sv, MUTABLE_SV(newAV()));
5f05dabc
PP
3160 break;
3161 case OPpDEREF_HV:
ad64d0ec 3162 SvRV_set(sv, MUTABLE_SV(newHV()));
5f05dabc
PP
3163 break;
3164 }
02a9e968
CS
3165 SvROK_on(sv);
3166 SvSETMAGIC(sv);
3167 }
3168}
3169
a0d0e21e
LW
3170PP(pp_method)
3171{
97aff369 3172 dVAR; dSP;
890ce7af 3173 SV* const sv = TOPs;
f5d5a27c
CS
3174
3175 if (SvROK(sv)) {
890ce7af 3176 SV* const rsv = SvRV(sv);
f5d5a27c
CS
3177 if (SvTYPE(rsv) == SVt_PVCV) {
3178 SETs(rsv);
3179 RETURN;
3180 }
3181 }
3182
4608196e 3183 SETs(method_common(sv, NULL));
f5d5a27c
CS
3184 RETURN;
3185}
3186
3187PP(pp_method_named)
3188{
97aff369 3189 dVAR; dSP;
890ce7af 3190 SV* const sv = cSVOP_sv;
c158a4fd 3191 U32 hash = SvSHARED_HASH(sv);
f5d5a27c
CS
3192
3193 XPUSHs(method_common(sv, &hash));
3194 RETURN;
3195}
3196
3197STATIC SV *
3198S_method_common(pTHX_ SV* meth, U32* hashp)
3199{
97aff369 3200 dVAR;
a0d0e21e
LW
3201 SV* ob;
3202 GV* gv;
56304f61 3203 HV* stash;
6136c704 3204 const char* packname = NULL;
a0714e2c 3205 SV *packsv = NULL;
ac91690f 3206 STRLEN packlen;
46c461b5 3207 SV * const sv = *(PL_stack_base + TOPMARK + 1);
f5d5a27c 3208
7918f24d
NC
3209 PERL_ARGS_ASSERT_METHOD_COMMON;
3210
4f1b7578 3211 if (!sv)
a214957f
VP
3212 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3213 SVfARG(meth));
4f1b7578 3214
5b295bef 3215 SvGETMAGIC(sv);
a0d0e21e 3216 if (SvROK(sv))
ad64d0ec 3217 ob = MUTABLE_SV(SvRV(sv));
a0d0e21e
LW
3218 else {
3219 GV* iogv;
a0d0e21e 3220
af09ea45 3221 /* this isn't a reference */
5c144d81 3222 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
b464bac0 3223 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
081fc587 3224 if (he) {
5e6396ae 3225 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
081fc587
AB
3226 goto fetch;
3227 }
3228 }
3229
a0d0e21e 3230 if (!SvOK(sv) ||
05f5af9a 3231 !(packname) ||
f776e3cd 3232 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
ad64d0ec 3233 !(ob=MUTABLE_SV(GvIO(iogv))))
a0d0e21e 3234 {
af09ea45 3235 /* this isn't the name of a filehandle either */
1c846c1f 3236 if (!packname ||
fd400ab9 3237 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
b86a2fa7 3238 ? !isIDFIRST_utf8((U8*)packname)
834a4ddd
LW
3239 : !isIDFIRST(*packname)
3240 ))
3241 {
a214957f
VP
3242 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3243 SVfARG(meth),
f5d5a27c
CS
3244 SvOK(sv) ? "without a package or object reference"
3245 : "on an undefined value");
834a4ddd 3246 }
af09ea45 3247 /* assume it's a package name */
da51bb9b 3248 stash = gv_stashpvn(packname, packlen, 0);
0dae17bd
GS
3249 if (!stash)
3250 packsv = sv;
081fc587 3251 else {
d4c19fe8 3252 SV* const ref = newSViv(PTR2IV(stash));
04fe65b0 3253 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
7e8961ec 3254 }
ac91690f 3255 goto fetch;
a0d0e21e 3256 }
af09ea45 3257 /* it _is_ a filehandle name -- replace with a reference */
ad64d0ec 3258 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
a0d0e21e
LW
3259 }
3260
af09ea45 3261 /* if we got here, ob should be a reference or a glob */
f0d43078 3262 if (!ob || !(SvOBJECT(ob)
6e592b3a
BM
3263 || (SvTYPE(ob) == SVt_PVGV
3264 && isGV_with_GP(ob)
159b6efe 3265 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
f0d43078
GS
3266 && SvOBJECT(ob))))
3267 {
a214957f 3268 const char * const name = SvPV_nolen_const(meth);
f5d5a27c 3269 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
59e7186f 3270 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
f5d5a27c 3271 name);
f0d43078 3272 }
a0d0e21e 3273
56304f61 3274 stash = SvSTASH(ob);
a0d0e21e 3275
ac91690f 3276 fetch:
af09ea45
IK
3277 /* NOTE: stash may be null, hope hv_fetch_ent and
3278 gv_fetchmethod can cope (it seems they can) */
3279
f5d5a27c
CS
3280 /* shortcut for simple names */
3281 if (hashp) {
b464bac0 3282 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
f5d5a27c 3283 if (he) {
159b6efe 3284 gv = MUTABLE_GV(HeVAL(he));
f5d5a27c 3285 if (isGV(gv) && GvCV(gv) &&
e1a479c5 3286 (!GvCVGEN(gv) || GvCVGEN(gv)
dd69841b 3287 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
ad64d0ec 3288 return MUTABLE_SV(GvCV(gv));
f5d5a27c
CS
3289 }
3290 }
3291
a214957f
VP
3292 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3293 SvPV_nolen_const(meth),
256d1bb2 3294 GV_AUTOLOAD | GV_CROAK);
9b9d0b15 3295
256d1bb2 3296 assert(gv);
9b9d0b15 3297
ad64d0ec 3298 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
a0d0e21e 3299}
241d1a3b
NC
3300
3301/*
3302 * Local variables:
3303 * c-indentation-style: bsd
3304 * c-basic-offset: 4
3305 * indent-tabs-mode: t
3306 * End:
3307 *
37442d52
RGS
3308 * ex: set ts=8 sts=4 sw=4 noet:
3309 */