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