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