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