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