This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Tests for XS lvalue functions
[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 }
8fe85e3f
FC
200 if (
201 SvTEMP(right) && !SvSMAGICAL(right) && SvREFCNT(right) == 1 &&
202 (!isGV_with_GP(right) || SvFAKE(right)) && ckWARN(WARN_MISC)
203 )
204 Perl_warner(aTHX_
205 packWARN(WARN_MISC), "Useless assignment to a temporary"
206 );
54310121 207 SvSetMagicSV(right, left);
a0d0e21e
LW
208 SETs(right);
209 RETURN;
210}
211
212PP(pp_cond_expr)
213{
97aff369 214 dVAR; dSP;
f410a211 215 PERL_ASYNC_CHECK();
a0d0e21e 216 if (SvTRUEx(POPs))
1a67a97c 217 RETURNOP(cLOGOP->op_other);
a0d0e21e 218 else
1a67a97c 219 RETURNOP(cLOGOP->op_next);
a0d0e21e
LW
220}
221
222PP(pp_unstack)
223{
97aff369 224 dVAR;
8f3964af 225 PERL_ASYNC_CHECK();
a0d0e21e 226 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 227 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 228 FREETMPS;
eae48c89
Z
229 if (!(PL_op->op_flags & OPf_SPECIAL)) {
230 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
231 LEAVE_SCOPE(oldsave);
232 }
a0d0e21e
LW
233 return NORMAL;
234}
235
a0d0e21e
LW
236PP(pp_concat)
237{
6f1401dc 238 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
748a9306
LW
239 {
240 dPOPTOPssrl;
8d6d96c1
HS
241 bool lbyte;
242 STRLEN rlen;
d4c19fe8 243 const char *rpv = NULL;
a6b599c7 244 bool rbyte = FALSE;
a9c4fd4e 245 bool rcopied = FALSE;
8d6d96c1 246
6f1401dc
DM
247 if (TARG == right && right != left) { /* $r = $l.$r */
248 rpv = SvPV_nomg_const(right, rlen);
c75ab21a 249 rbyte = !DO_UTF8(right);
59cd0e26 250 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
349d4f2f 251 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
db79b45b 252 rcopied = TRUE;
8d6d96c1 253 }
7889fe52 254
89734059 255 if (TARG != left) { /* not $l .= $r */
a9c4fd4e 256 STRLEN llen;
6f1401dc 257 const char* const lpv = SvPV_nomg_const(left, llen);
90f5826e 258 lbyte = !DO_UTF8(left);
8d6d96c1
HS
259 sv_setpvn(TARG, lpv, llen);
260 if (!lbyte)
261 SvUTF8_on(TARG);
262 else
263 SvUTF8_off(TARG);
264 }
89734059 265 else { /* $l .= $r */
c75ab21a 266 if (!SvOK(TARG)) {
89734059 267 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
c75ab21a 268 report_uninit(right);
76f68e9b 269 sv_setpvs(left, "");
c75ab21a 270 }
c5aa2872
DM
271 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
272 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
90f5826e
ST
273 if (IN_BYTES)
274 SvUTF8_off(TARG);
8d6d96c1 275 }
a12c0f56 276
c75ab21a 277 if (!rcopied) {
6f1401dc 278 if (left == right)
89734059 279 /* $r.$r: do magic twice: tied might return different 2nd time */
6f1401dc
DM
280 SvGETMAGIC(right);
281 rpv = SvPV_nomg_const(right, rlen);
c75ab21a
RH
282 rbyte = !DO_UTF8(right);
283 }
8d6d96c1 284 if (lbyte != rbyte) {
e3393f51
NT
285 /* sv_utf8_upgrade_nomg() may reallocate the stack */
286 PUTBACK;
8d6d96c1
HS
287 if (lbyte)
288 sv_utf8_upgrade_nomg(TARG);
289 else {
db79b45b 290 if (!rcopied)
59cd0e26 291 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
8d6d96c1 292 sv_utf8_upgrade_nomg(right);
6f1401dc 293 rpv = SvPV_nomg_const(right, rlen);
69b47968 294 }
e3393f51 295 SPAGAIN;
a0d0e21e 296 }
8d6d96c1 297 sv_catpvn_nomg(TARG, rpv, rlen);
43ebc500 298
a0d0e21e
LW
299 SETTARG;
300 RETURN;
748a9306 301 }
a0d0e21e
LW
302}
303
304PP(pp_padsv)
305{
97aff369 306 dVAR; dSP; dTARGET;
a0d0e21e 307 XPUSHs(TARG);
533c011a
NIS
308 if (PL_op->op_flags & OPf_MOD) {
309 if (PL_op->op_private & OPpLVAL_INTRO)
952306ac
RGS
310 if (!(PL_op->op_private & OPpPAD_STATE))
311 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
a62b51b8 312 if (PL_op->op_private & OPpDEREF) {
8ec5e241 313 PUTBACK;
dd2155a4 314 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
8ec5e241
NIS
315 SPAGAIN;
316 }
4633a7c4 317 }
a0d0e21e
LW
318 RETURN;
319}
320
321PP(pp_readline)
322{
97aff369 323 dVAR;
9e27fd70 324 dSP; SvGETMAGIC(TOPs);
9426e1a5 325 tryAMAGICunTARGET(iter_amg, 0, 0);
159b6efe 326 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
6e592b3a
BM
327 if (!isGV_with_GP(PL_last_in_gv)) {
328 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
159b6efe 329 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
8efb3254 330 else {
f5284f61 331 dSP;
ad64d0ec 332 XPUSHs(MUTABLE_SV(PL_last_in_gv));
f5284f61 333 PUTBACK;
897d3989 334 Perl_pp_rv2gv(aTHX);
159b6efe 335 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
f5284f61
IZ
336 }
337 }
a0d0e21e
LW
338 return do_readline();
339}
340
341PP(pp_eq)
342{
6f1401dc 343 dVAR; dSP;
a42d0242 344 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
4c9fe80f 345#ifndef NV_PRESERVES_UV
ed3b9b3c 346 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
e61d22ef
NC
347 SP--;
348 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
4c9fe80f
AS
349 RETURN;
350 }
351#endif
28e5dec8 352#ifdef PERL_PRESERVE_IVUV
6f1401dc 353 SvIV_please_nomg(TOPs);
28e5dec8 354 if (SvIOK(TOPs)) {
4c9fe80f
AS
355 /* Unless the left argument is integer in range we are going
356 to have to use NV maths. Hence only attempt to coerce the
357 right argument if we know the left is integer. */
6f1401dc 358 SvIV_please_nomg(TOPm1s);
28e5dec8 359 if (SvIOK(TOPm1s)) {
0bd48802
AL
360 const bool auvok = SvUOK(TOPm1s);
361 const bool buvok = SvUOK(TOPs);
a12c0f56 362
1605159e
NC
363 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
364 /* Casting IV to UV before comparison isn't going to matter
365 on 2s complement. On 1s complement or sign&magnitude
366 (if we have any of them) it could to make negative zero
367 differ from normal zero. As I understand it. (Need to
368 check - is negative zero implementation defined behaviour
369 anyway?). NWC */
0bd48802
AL
370 const UV buv = SvUVX(POPs);
371 const UV auv = SvUVX(TOPs);
28e5dec8 372
28e5dec8
JH
373 SETs(boolSV(auv == buv));
374 RETURN;
375 }
376 { /* ## Mixed IV,UV ## */
1605159e 377 SV *ivp, *uvp;
28e5dec8 378 IV iv;
28e5dec8 379
1605159e 380 /* == is commutative so doesn't matter which is left or right */
28e5dec8 381 if (auvok) {
1605159e
NC
382 /* top of stack (b) is the iv */
383 ivp = *SP;
384 uvp = *--SP;
385 } else {
386 uvp = *SP;
387 ivp = *--SP;
388 }
389 iv = SvIVX(ivp);
d4c19fe8 390 if (iv < 0)
1605159e
NC
391 /* As uv is a UV, it's >0, so it cannot be == */
392 SETs(&PL_sv_no);
d4c19fe8
AL
393 else
394 /* we know iv is >= 0 */
395 SETs(boolSV((UV)iv == SvUVX(uvp)));
28e5dec8
JH
396 RETURN;
397 }
398 }
399 }
400#endif
a0d0e21e 401 {
cab190d4 402#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
6f1401dc 403 dPOPTOPnnrl_nomg;
cab190d4
JD
404 if (Perl_isnan(left) || Perl_isnan(right))
405 RETSETNO;
406 SETs(boolSV(left == right));
407#else
6f1401dc
DM
408 dPOPnv_nomg;
409 SETs(boolSV(SvNV_nomg(TOPs) == value));
cab190d4 410#endif
a0d0e21e
LW
411 RETURN;
412 }
413}
414
415PP(pp_preinc)
416{
97aff369 417 dVAR; dSP;
6e592b3a 418 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
6ad8f254 419 Perl_croak_no_modify(aTHX);
3510b4a1
NC
420 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
421 && SvIVX(TOPs) != IV_MAX)
55497cff 422 {
45977657 423 SvIV_set(TOPs, SvIVX(TOPs) + 1);
55497cff 424 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 425 }
28e5dec8 426 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
748a9306 427 sv_inc(TOPs);
a0d0e21e
LW
428 SvSETMAGIC(TOPs);
429 return NORMAL;
430}
431
432PP(pp_or)
433{
97aff369 434 dVAR; dSP;
f410a211 435 PERL_ASYNC_CHECK();
a0d0e21e
LW
436 if (SvTRUE(TOPs))
437 RETURN;
438 else {
c960fc3b
SP
439 if (PL_op->op_type == OP_OR)
440 --SP;
a0d0e21e
LW
441 RETURNOP(cLOGOP->op_other);
442 }
443}
444
25a55bd7 445PP(pp_defined)
c963b151 446{
97aff369 447 dVAR; dSP;
6136c704
AL
448 register SV* sv;
449 bool defined;
25a55bd7 450 const int op_type = PL_op->op_type;
ea5195b7 451 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
c963b151 452
6136c704 453 if (is_dor) {
f410a211 454 PERL_ASYNC_CHECK();
25a55bd7
SP
455 sv = TOPs;
456 if (!sv || !SvANY(sv)) {
2bd49cfc
NC
457 if (op_type == OP_DOR)
458 --SP;
25a55bd7
SP
459 RETURNOP(cLOGOP->op_other);
460 }
b7c44293
RGS
461 }
462 else {
463 /* OP_DEFINED */
25a55bd7
SP
464 sv = POPs;
465 if (!sv || !SvANY(sv))
466 RETPUSHNO;
b7c44293 467 }
25a55bd7 468
6136c704 469 defined = FALSE;
c963b151
BD
470 switch (SvTYPE(sv)) {
471 case SVt_PVAV:
472 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 473 defined = TRUE;
c963b151
BD
474 break;
475 case SVt_PVHV:
476 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
25a55bd7 477 defined = TRUE;
c963b151
BD
478 break;
479 case SVt_PVCV:
480 if (CvROOT(sv) || CvXSUB(sv))
25a55bd7 481 defined = TRUE;
c963b151
BD
482 break;
483 default:
5b295bef 484 SvGETMAGIC(sv);
c963b151 485 if (SvOK(sv))
25a55bd7 486 defined = TRUE;
6136c704 487 break;
c963b151 488 }
6136c704
AL
489
490 if (is_dor) {
c960fc3b
SP
491 if(defined)
492 RETURN;
493 if(op_type == OP_DOR)
494 --SP;
25a55bd7 495 RETURNOP(cLOGOP->op_other);
25a55bd7 496 }
d9aa96a4
SP
497 /* assuming OP_DEFINED */
498 if(defined)
499 RETPUSHYES;
500 RETPUSHNO;
c963b151
BD
501}
502
a0d0e21e
LW
503PP(pp_add)
504{
800401ee 505 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
506 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
507 svr = TOPs;
508 svl = TOPm1s;
509
800401ee 510 useleft = USE_LEFT(svl);
28e5dec8
JH
511#ifdef PERL_PRESERVE_IVUV
512 /* We must see if we can perform the addition with integers if possible,
513 as the integer code detects overflow while the NV code doesn't.
514 If either argument hasn't had a numeric conversion yet attempt to get
515 the IV. It's important to do this now, rather than just assuming that
516 it's not IOK as a PV of "9223372036854775806" may not take well to NV
517 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
518 integer in case the second argument is IV=9223372036854775806
519 We can (now) rely on sv_2iv to do the right thing, only setting the
520 public IOK flag if the value in the NV (or PV) slot is truly integer.
521
522 A side effect is that this also aggressively prefers integer maths over
7dca457a
NC
523 fp maths for integer values.
524
a00b5bd3 525 How to detect overflow?
7dca457a
NC
526
527 C 99 section 6.2.6.1 says
528
529 The range of nonnegative values of a signed integer type is a subrange
530 of the corresponding unsigned integer type, and the representation of
531 the same value in each type is the same. A computation involving
532 unsigned operands can never overflow, because a result that cannot be
533 represented by the resulting unsigned integer type is reduced modulo
534 the number that is one greater than the largest value that can be
535 represented by the resulting type.
536
537 (the 9th paragraph)
538
539 which I read as "unsigned ints wrap."
540
541 signed integer overflow seems to be classed as "exception condition"
542
543 If an exceptional condition occurs during the evaluation of an
544 expression (that is, if the result is not mathematically defined or not
545 in the range of representable values for its type), the behavior is
546 undefined.
547
548 (6.5, the 5th paragraph)
549
550 I had assumed that on 2s complement machines signed arithmetic would
551 wrap, hence coded pp_add and pp_subtract on the assumption that
552 everything perl builds on would be happy. After much wailing and
553 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
554 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
555 unsigned code below is actually shorter than the old code. :-)
556 */
557
6f1401dc
DM
558 SvIV_please_nomg(svr);
559
800401ee 560 if (SvIOK(svr)) {
28e5dec8
JH
561 /* Unless the left argument is integer in range we are going to have to
562 use NV maths. Hence only attempt to coerce the right argument if
563 we know the left is integer. */
9c5ffd7c
JH
564 register UV auv = 0;
565 bool auvok = FALSE;
7dca457a
NC
566 bool a_valid = 0;
567
28e5dec8 568 if (!useleft) {
7dca457a
NC
569 auv = 0;
570 a_valid = auvok = 1;
571 /* left operand is undef, treat as zero. + 0 is identity,
572 Could SETi or SETu right now, but space optimise by not adding
573 lots of code to speed up what is probably a rarish case. */
574 } else {
575 /* Left operand is defined, so is it IV? */
6f1401dc 576 SvIV_please_nomg(svl);
800401ee
JH
577 if (SvIOK(svl)) {
578 if ((auvok = SvUOK(svl)))
579 auv = SvUVX(svl);
7dca457a 580 else {
800401ee 581 register const IV aiv = SvIVX(svl);
7dca457a
NC
582 if (aiv >= 0) {
583 auv = aiv;
584 auvok = 1; /* Now acting as a sign flag. */
585 } else { /* 2s complement assumption for IV_MIN */
586 auv = (UV)-aiv;
587 }
588 }
589 a_valid = 1;
28e5dec8
JH
590 }
591 }
7dca457a
NC
592 if (a_valid) {
593 bool result_good = 0;
594 UV result;
595 register UV buv;
800401ee 596 bool buvok = SvUOK(svr);
a00b5bd3 597
7dca457a 598 if (buvok)
800401ee 599 buv = SvUVX(svr);
7dca457a 600 else {
800401ee 601 register const IV biv = SvIVX(svr);
7dca457a
NC
602 if (biv >= 0) {
603 buv = biv;
604 buvok = 1;
605 } else
606 buv = (UV)-biv;
607 }
608 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 609 else "IV" now, independent of how it came in.
7dca457a
NC
610 if a, b represents positive, A, B negative, a maps to -A etc
611 a + b => (a + b)
612 A + b => -(a - b)
613 a + B => (a - b)
614 A + B => -(a + b)
615 all UV maths. negate result if A negative.
616 add if signs same, subtract if signs differ. */
617
618 if (auvok ^ buvok) {
619 /* Signs differ. */
620 if (auv >= buv) {
621 result = auv - buv;
622 /* Must get smaller */
623 if (result <= auv)
624 result_good = 1;
625 } else {
626 result = buv - auv;
627 if (result <= buv) {
628 /* result really should be -(auv-buv). as its negation
629 of true value, need to swap our result flag */
630 auvok = !auvok;
631 result_good = 1;
28e5dec8
JH
632 }
633 }
7dca457a
NC
634 } else {
635 /* Signs same */
636 result = auv + buv;
637 if (result >= auv)
638 result_good = 1;
639 }
640 if (result_good) {
641 SP--;
642 if (auvok)
28e5dec8 643 SETu( result );
7dca457a
NC
644 else {
645 /* Negate result */
646 if (result <= (UV)IV_MIN)
647 SETi( -(IV)result );
648 else {
649 /* result valid, but out of range for IV. */
650 SETn( -(NV)result );
28e5dec8
JH
651 }
652 }
7dca457a
NC
653 RETURN;
654 } /* Overflow, drop through to NVs. */
28e5dec8
JH
655 }
656 }
657#endif
a0d0e21e 658 {
6f1401dc 659 NV value = SvNV_nomg(svr);
4efa5a16 660 (void)POPs;
28e5dec8
JH
661 if (!useleft) {
662 /* left operand is undef, treat as zero. + 0.0 is identity. */
663 SETn(value);
664 RETURN;
665 }
6f1401dc 666 SETn( value + SvNV_nomg(svl) );
28e5dec8 667 RETURN;
a0d0e21e
LW
668 }
669}
670
671PP(pp_aelemfast)
672{
97aff369 673 dVAR; dSP;
502c6561 674 AV * const av = PL_op->op_flags & OPf_SPECIAL
8f878375 675 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
a3b680e6 676 const U32 lval = PL_op->op_flags & OPf_MOD;
0bd48802 677 SV** const svp = av_fetch(av, PL_op->op_private, lval);
3280af22 678 SV *sv = (svp ? *svp : &PL_sv_undef);
6ff81951 679 EXTEND(SP, 1);
39cf747a 680 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 681 mg_get(sv);
be6c24e0 682 PUSHs(sv);
a0d0e21e
LW
683 RETURN;
684}
685
686PP(pp_join)
687{
97aff369 688 dVAR; dSP; dMARK; dTARGET;
a0d0e21e
LW
689 MARK++;
690 do_join(TARG, *MARK, MARK, SP);
691 SP = MARK;
692 SETs(TARG);
693 RETURN;
694}
695
696PP(pp_pushre)
697{
97aff369 698 dVAR; dSP;
44a8e56a
PP
699#ifdef DEBUGGING
700 /*
701 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
702 * will be enough to hold an OP*.
703 */
c4420975 704 SV* const sv = sv_newmortal();
44a8e56a
PP
705 sv_upgrade(sv, SVt_PVLV);
706 LvTYPE(sv) = '/';
533c011a 707 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
44a8e56a
PP
708 XPUSHs(sv);
709#else
ad64d0ec 710 XPUSHs(MUTABLE_SV(PL_op));
44a8e56a 711#endif
a0d0e21e
LW
712 RETURN;
713}
714
715/* Oversized hot code. */
716
717PP(pp_print)
718{
27da23d5 719 dVAR; dSP; dMARK; dORIGMARK;
760ac839 720 register PerlIO *fp;
236988e4 721 MAGIC *mg;
159b6efe
NC
722 GV * const gv
723 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 724 IO *io = GvIO(gv);
5b468f54 725
9c9f25b8 726 if (io
ad64d0ec 727 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
5b468f54 728 {
01bb7c6d 729 had_magic:
68dc0745 730 if (MARK == ORIGMARK) {
1c846c1f 731 /* If using default handle then we need to make space to
a60c0954
NIS
732 * pass object as 1st arg, so move other args up ...
733 */
4352c267 734 MEXTEND(SP, 1);
68dc0745
PP
735 ++MARK;
736 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
737 ++SP;
738 }
94bc412f
NC
739 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
740 mg,
741 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
742 | (PL_op->op_type == OP_SAY
743 ? TIED_METHOD_SAY : 0)), sp - mark);
236988e4 744 }
9c9f25b8 745 if (!io) {
68b590d9 746 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
ad64d0ec 747 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
01bb7c6d 748 goto had_magic;
51087808 749 report_evil_fh(gv);
93189314 750 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
751 goto just_say_no;
752 }
753 else if (!(fp = IoOFP(io))) {
7716c5c5
NC
754 if (IoIFP(io))
755 report_wrongway_fh(gv, '<');
51087808 756 else
7716c5c5 757 report_evil_fh(gv);
93189314 758 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW
759 goto just_say_no;
760 }
761 else {
e23d9e2f 762 SV * const ofs = GvSV(PL_ofsgv); /* $, */
a0d0e21e 763 MARK++;
e23d9e2f 764 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
a0d0e21e
LW
765 while (MARK <= SP) {
766 if (!do_print(*MARK, fp))
767 break;
768 MARK++;
769 if (MARK <= SP) {
e23d9e2f
CS
770 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
771 if (!do_print(GvSV(PL_ofsgv), fp)) {
a0d0e21e
LW
772 MARK--;
773 break;
774 }
775 }
776 }
777 }
778 else {
779 while (MARK <= SP) {
780 if (!do_print(*MARK, fp))
781 break;
782 MARK++;
783 }
784 }
785 if (MARK <= SP)
786 goto just_say_no;
787 else {
cfc4a7da
GA
788 if (PL_op->op_type == OP_SAY) {
789 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
790 goto just_say_no;
791 }
792 else if (PL_ors_sv && SvOK(PL_ors_sv))
7889fe52 793 if (!do_print(PL_ors_sv, fp)) /* $\ */
a0d0e21e
LW
794 goto just_say_no;
795
796 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 797 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
798 goto just_say_no;
799 }
800 }
801 SP = ORIGMARK;
e52fd6f4 802 XPUSHs(&PL_sv_yes);
a0d0e21e
LW
803 RETURN;
804
805 just_say_no:
806 SP = ORIGMARK;
e52fd6f4 807 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
808 RETURN;
809}
810
811PP(pp_rv2av)
812{
97aff369 813 dVAR; dSP; dTOPss;
cde874ca 814 const I32 gimme = GIMME_V;
17ab7946
NC
815 static const char an_array[] = "an ARRAY";
816 static const char a_hash[] = "a HASH";
817 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
d83b45b8 818 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
a0d0e21e 819
0824d667
DM
820 if (!(PL_op->op_private & OPpDEREFed))
821 SvGETMAGIC(sv);
a0d0e21e 822 if (SvROK(sv)) {
93d7320b
DM
823 if (SvAMAGIC(sv)) {
824 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
825 SPAGAIN;
826 }
17ab7946
NC
827 sv = SvRV(sv);
828 if (SvTYPE(sv) != type)
829 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
533c011a 830 if (PL_op->op_flags & OPf_REF) {
17ab7946 831 SETs(sv);
a0d0e21e
LW
832 RETURN;
833 }
78f9721b 834 else if (LVRET) {
cde874ca 835 if (gimme != G_ARRAY)
042560a6 836 goto croak_cant_return;
17ab7946 837 SETs(sv);
78f9721b
SM
838 RETURN;
839 }
82d03984
RGS
840 else if (PL_op->op_flags & OPf_MOD
841 && PL_op->op_private & OPpLVAL_INTRO)
f1f66076 842 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
a0d0e21e
LW
843 }
844 else {
17ab7946 845 if (SvTYPE(sv) == type) {
533c011a 846 if (PL_op->op_flags & OPf_REF) {
17ab7946 847 SETs(sv);
a0d0e21e
LW
848 RETURN;
849 }
78f9721b 850 else if (LVRET) {
cde874ca 851 if (gimme != G_ARRAY)
042560a6 852 goto croak_cant_return;
17ab7946 853 SETs(sv);
78f9721b
SM
854 RETURN;
855 }
a0d0e21e
LW
856 }
857 else {
67955e0c 858 GV *gv;
1c846c1f 859
6e592b3a 860 if (!isGV_with_GP(sv)) {
dc3c76f8
NC
861 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
862 type, &sp);
863 if (!gv)
864 RETURN;
35cd451c
GS
865 }
866 else {
159b6efe 867 gv = MUTABLE_GV(sv);
a0d0e21e 868 }
ad64d0ec 869 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
533c011a 870 if (PL_op->op_private & OPpLVAL_INTRO)
ad64d0ec 871 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
533c011a 872 if (PL_op->op_flags & OPf_REF) {
17ab7946 873 SETs(sv);
a0d0e21e
LW
874 RETURN;
875 }
78f9721b 876 else if (LVRET) {
cde874ca 877 if (gimme != G_ARRAY)
042560a6 878 goto croak_cant_return;
17ab7946 879 SETs(sv);
78f9721b
SM
880 RETURN;
881 }
a0d0e21e
LW
882 }
883 }
884
17ab7946 885 if (is_pp_rv2av) {
502c6561 886 AV *const av = MUTABLE_AV(sv);
486ec47a 887 /* The guts of pp_rv2av, with no intending change to preserve history
17ab7946
NC
888 (until such time as we get tools that can do blame annotation across
889 whitespace changes. */
96913b52
VP
890 if (gimme == G_ARRAY) {
891 const I32 maxarg = AvFILL(av) + 1;
892 (void)POPs; /* XXXX May be optimized away? */
893 EXTEND(SP, maxarg);
894 if (SvRMAGICAL(av)) {
895 U32 i;
896 for (i=0; i < (U32)maxarg; i++) {
897 SV ** const svp = av_fetch(av, i, FALSE);
898 /* See note in pp_helem, and bug id #27839 */
899 SP[i+1] = svp
900 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
901 : &PL_sv_undef;
902 }
903 }
904 else {
905 Copy(AvARRAY(av), SP+1, maxarg, SV*);
93965878 906 }
96913b52 907 SP += maxarg;
1c846c1f 908 }
96913b52
VP
909 else if (gimme == G_SCALAR) {
910 dTARGET;
911 const I32 maxarg = AvFILL(av) + 1;
912 SETi(maxarg);
93965878 913 }
17ab7946
NC
914 } else {
915 /* The guts of pp_rv2hv */
96913b52
VP
916 if (gimme == G_ARRAY) { /* array wanted */
917 *PL_stack_sp = sv;
981b7185 918 return Perl_do_kv(aTHX);
96913b52
VP
919 }
920 else if (gimme == G_SCALAR) {
921 dTARGET;
922 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
923 SPAGAIN;
924 SETTARG;
925 }
17ab7946 926 }
be85d344 927 RETURN;
042560a6
NC
928
929 croak_cant_return:
930 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
931 is_pp_rv2av ? "array" : "hash");
77e217c6 932 RETURN;
a0d0e21e
LW
933}
934
10c8fecd
GS
935STATIC void
936S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
937{
97aff369 938 dVAR;
7918f24d
NC
939
940 PERL_ARGS_ASSERT_DO_ODDBALL;
941
10c8fecd
GS
942 if (*relem) {
943 SV *tmpstr;
b464bac0 944 const HE *didstore;
6d822dc4
MS
945
946 if (ckWARN(WARN_MISC)) {
a3b680e6 947 const char *err;
10c8fecd
GS
948 if (relem == firstrelem &&
949 SvROK(*relem) &&
950 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
951 SvTYPE(SvRV(*relem)) == SVt_PVHV))
952 {
a3b680e6 953 err = "Reference found where even-sized list expected";
10c8fecd
GS
954 }
955 else
a3b680e6 956 err = "Odd number of elements in hash assignment";
f1f66076 957 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
10c8fecd 958 }
6d822dc4 959
561b68a9 960 tmpstr = newSV(0);
6d822dc4
MS
961 didstore = hv_store_ent(hash,*relem,tmpstr,0);
962 if (SvMAGICAL(hash)) {
963 if (SvSMAGICAL(tmpstr))
964 mg_set(tmpstr);
965 if (!didstore)
966 sv_2mortal(tmpstr);
967 }
968 TAINT_NOT;
10c8fecd
GS
969 }
970}
971
a0d0e21e
LW
972PP(pp_aassign)
973{
27da23d5 974 dVAR; dSP;
3280af22
NIS
975 SV **lastlelem = PL_stack_sp;
976 SV **lastrelem = PL_stack_base + POPMARK;
977 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
978 SV **firstlelem = lastrelem + 1;
979
980 register SV **relem;
981 register SV **lelem;
982
983 register SV *sv;
984 register AV *ary;
985
54310121 986 I32 gimme;
a0d0e21e
LW
987 HV *hash;
988 I32 i;
989 int magic;
ca65944e 990 int duplicates = 0;
cbbf8932 991 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
5637b936 992
3280af22 993 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
ca65944e 994 gimme = GIMME_V;
a0d0e21e
LW
995
996 /* If there's a common identifier on both sides we have to take
997 * special care that assigning the identifier on the left doesn't
998 * clobber a value on the right that's used later in the list.
acdea6f0 999 * Don't bother if LHS is just an empty hash or array.
a0d0e21e 1000 */
acdea6f0
DM
1001
1002 if ( (PL_op->op_private & OPpASSIGN_COMMON)
1003 && (
1004 firstlelem != lastlelem
1005 || ! ((sv = *firstlelem))
1006 || SvMAGICAL(sv)
1007 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1008 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1b95d04f 1009 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
acdea6f0
DM
1010 )
1011 ) {
cc5e57d2 1012 EXTEND_MORTAL(lastrelem - firstrelem + 1);
10c8fecd 1013 for (relem = firstrelem; relem <= lastrelem; relem++) {
155aba94 1014 if ((sv = *relem)) {
a1f49e72 1015 TAINT_NOT; /* Each item is independent */
61e5f455
NC
1016
1017 /* Dear TODO test in t/op/sort.t, I love you.
1018 (It's relying on a panic, not a "semi-panic" from newSVsv()
1019 and then an assertion failure below.) */
1020 if (SvIS_FREED(sv)) {
1021 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1022 (void*)sv);
1023 }
1024 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1025 and we need a second copy of a temp here. */
1026 *relem = sv_2mortal(newSVsv(sv));
a1f49e72 1027 }
10c8fecd 1028 }
a0d0e21e
LW
1029 }
1030
1031 relem = firstrelem;
1032 lelem = firstlelem;
4608196e
RGS
1033 ary = NULL;
1034 hash = NULL;
10c8fecd 1035
a0d0e21e 1036 while (lelem <= lastlelem) {
bbce6d69 1037 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e
LW
1038 sv = *lelem++;
1039 switch (SvTYPE(sv)) {
1040 case SVt_PVAV:
502c6561 1041 ary = MUTABLE_AV(sv);
748a9306 1042 magic = SvMAGICAL(ary) != 0;
a0d0e21e 1043 av_clear(ary);
7e42bd57 1044 av_extend(ary, lastrelem - relem);
a0d0e21e
LW
1045 i = 0;
1046 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 1047 SV **didstore;
a0d0e21e 1048 assert(*relem);
4f0556e9
NC
1049 sv = newSV(0);
1050 sv_setsv(sv, *relem);
a0d0e21e 1051 *(relem++) = sv;
5117ca91
GS
1052 didstore = av_store(ary,i++,sv);
1053 if (magic) {
8ef24240 1054 if (SvSMAGICAL(sv))
fb73857a 1055 mg_set(sv);
5117ca91 1056 if (!didstore)
8127e0e3 1057 sv_2mortal(sv);
5117ca91 1058 }
bbce6d69 1059 TAINT_NOT;
a0d0e21e 1060 }
354b0578 1061 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 1062 SvSETMAGIC(MUTABLE_SV(ary));
a0d0e21e 1063 break;
10c8fecd 1064 case SVt_PVHV: { /* normal hash */
a0d0e21e 1065 SV *tmpstr;
45960564 1066 SV** topelem = relem;
a0d0e21e 1067
85fbaab2 1068 hash = MUTABLE_HV(sv);
748a9306 1069 magic = SvMAGICAL(hash) != 0;
a0d0e21e 1070 hv_clear(hash);
ca65944e 1071 firsthashrelem = relem;
a0d0e21e
LW
1072
1073 while (relem < lastrelem) { /* gobble up all the rest */
5117ca91 1074 HE *didstore;
6136c704
AL
1075 sv = *relem ? *relem : &PL_sv_no;
1076 relem++;
561b68a9 1077 tmpstr = newSV(0);
a0d0e21e
LW
1078 if (*relem)
1079 sv_setsv(tmpstr,*relem); /* value */
45960564
DM
1080 relem++;
1081 if (gimme != G_VOID) {
1082 if (hv_exists_ent(hash, sv, 0))
1083 /* key overwrites an existing entry */
1084 duplicates += 2;
1085 else
1086 if (gimme == G_ARRAY) {
1087 /* copy element back: possibly to an earlier
1088 * stack location if we encountered dups earlier */
1089 *topelem++ = sv;
1090 *topelem++ = tmpstr;
1091 }
1092 }
5117ca91
GS
1093 didstore = hv_store_ent(hash,sv,tmpstr,0);
1094 if (magic) {
8ef24240 1095 if (SvSMAGICAL(tmpstr))
fb73857a 1096 mg_set(tmpstr);
5117ca91 1097 if (!didstore)
8127e0e3 1098 sv_2mortal(tmpstr);
5117ca91 1099 }
bbce6d69 1100 TAINT_NOT;
8e07c86e 1101 }
6a0deba8 1102 if (relem == lastrelem) {
10c8fecd 1103 do_oddball(hash, relem, firstrelem);
6a0deba8 1104 relem++;
1930e939 1105 }
a0d0e21e
LW
1106 }
1107 break;
1108 default:
6fc92669
GS
1109 if (SvIMMORTAL(sv)) {
1110 if (relem <= lastrelem)
1111 relem++;
1112 break;
a0d0e21e
LW
1113 }
1114 if (relem <= lastrelem) {
1115 sv_setsv(sv, *relem);
1116 *(relem++) = sv;
1117 }
1118 else
3280af22 1119 sv_setsv(sv, &PL_sv_undef);
8ef24240 1120 SvSETMAGIC(sv);
a0d0e21e
LW
1121 break;
1122 }
1123 }
3280af22
NIS
1124 if (PL_delaymagic & ~DM_DELAY) {
1125 if (PL_delaymagic & DM_UID) {
a0d0e21e 1126#ifdef HAS_SETRESUID
fb934a90
RD
1127 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1128 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1129 (Uid_t)-1);
56febc5e
AD
1130#else
1131# ifdef HAS_SETREUID
fb934a90
RD
1132 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1133 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
56febc5e
AD
1134# else
1135# ifdef HAS_SETRUID
b28d0864
NIS
1136 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1137 (void)setruid(PL_uid);
1138 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1139 }
56febc5e
AD
1140# endif /* HAS_SETRUID */
1141# ifdef HAS_SETEUID
b28d0864 1142 if ((PL_delaymagic & DM_UID) == DM_EUID) {
fb934a90 1143 (void)seteuid(PL_euid);
b28d0864 1144 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1145 }
56febc5e 1146# endif /* HAS_SETEUID */
b28d0864
NIS
1147 if (PL_delaymagic & DM_UID) {
1148 if (PL_uid != PL_euid)
cea2e8a9 1149 DIE(aTHX_ "No setreuid available");
b28d0864 1150 (void)PerlProc_setuid(PL_uid);
a0d0e21e 1151 }
56febc5e
AD
1152# endif /* HAS_SETREUID */
1153#endif /* HAS_SETRESUID */
d8eceb89
JH
1154 PL_uid = PerlProc_getuid();
1155 PL_euid = PerlProc_geteuid();
a0d0e21e 1156 }
3280af22 1157 if (PL_delaymagic & DM_GID) {
a0d0e21e 1158#ifdef HAS_SETRESGID
fb934a90
RD
1159 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1160 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1161 (Gid_t)-1);
56febc5e
AD
1162#else
1163# ifdef HAS_SETREGID
fb934a90
RD
1164 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1165 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
56febc5e
AD
1166# else
1167# ifdef HAS_SETRGID
b28d0864
NIS
1168 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1169 (void)setrgid(PL_gid);
1170 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1171 }
56febc5e
AD
1172# endif /* HAS_SETRGID */
1173# ifdef HAS_SETEGID
b28d0864 1174 if ((PL_delaymagic & DM_GID) == DM_EGID) {
fb934a90 1175 (void)setegid(PL_egid);
b28d0864 1176 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1177 }
56febc5e 1178# endif /* HAS_SETEGID */
b28d0864
NIS
1179 if (PL_delaymagic & DM_GID) {
1180 if (PL_gid != PL_egid)
cea2e8a9 1181 DIE(aTHX_ "No setregid available");
b28d0864 1182 (void)PerlProc_setgid(PL_gid);
a0d0e21e 1183 }
56febc5e
AD
1184# endif /* HAS_SETREGID */
1185#endif /* HAS_SETRESGID */
d8eceb89
JH
1186 PL_gid = PerlProc_getgid();
1187 PL_egid = PerlProc_getegid();
a0d0e21e 1188 }
3280af22 1189 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
a0d0e21e 1190 }
3280af22 1191 PL_delaymagic = 0;
54310121 1192
54310121
PP
1193 if (gimme == G_VOID)
1194 SP = firstrelem - 1;
1195 else if (gimme == G_SCALAR) {
1196 dTARGET;
1197 SP = firstrelem;
ca65944e 1198 SETi(lastrelem - firstrelem + 1 - duplicates);
54310121
PP
1199 }
1200 else {
ca65944e 1201 if (ary)
a0d0e21e 1202 SP = lastrelem;
ca65944e
RGS
1203 else if (hash) {
1204 if (duplicates) {
45960564
DM
1205 /* at this point we have removed the duplicate key/value
1206 * pairs from the stack, but the remaining values may be
1207 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1208 * the (a 2), but the stack now probably contains
1209 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1210 * obliterates the earlier key. So refresh all values. */
ca65944e 1211 lastrelem -= duplicates;
45960564
DM
1212 relem = firsthashrelem;
1213 while (relem < lastrelem) {
1214 HE *he;
1215 sv = *relem++;
1216 he = hv_fetch_ent(hash, sv, 0, 0);
1217 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1218 }
ca65944e
RGS
1219 }
1220 SP = lastrelem;
1221 }
a0d0e21e
LW
1222 else
1223 SP = firstrelem + (lastlelem - firstlelem);
0c8c7a05 1224 lelem = firstlelem + (relem - firstrelem);
5f05dabc 1225 while (relem <= SP)
3280af22 1226 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
a0d0e21e 1227 }
08aeb9f7 1228
54310121 1229 RETURN;
a0d0e21e
LW
1230}
1231
8782bef2
GB
1232PP(pp_qr)
1233{
97aff369 1234 dVAR; dSP;
c4420975 1235 register PMOP * const pm = cPMOP;
fe578d7f 1236 REGEXP * rx = PM_GETRE(pm);
10599a69 1237 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
c4420975 1238 SV * const rv = sv_newmortal();
288b8c02
NC
1239
1240 SvUPGRADE(rv, SVt_IV);
c2123ae3
NC
1241 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1242 loathe to use it here, but it seems to be the right fix. Or close.
1243 The key part appears to be that it's essential for pp_qr to return a new
1244 object (SV), which implies that there needs to be an effective way to
1245 generate a new SV from the existing SV that is pre-compiled in the
1246 optree. */
1247 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
288b8c02
NC
1248 SvROK_on(rv);
1249
1250 if (pkg) {
f815daf2 1251 HV *const stash = gv_stashsv(pkg, GV_ADD);
a954f6ee 1252 SvREFCNT_dec(pkg);
288b8c02
NC
1253 (void)sv_bless(rv, stash);
1254 }
1255
9274aefd 1256 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
e08e52cf 1257 SvTAINTED_on(rv);
9274aefd
DM
1258 SvTAINTED_on(SvRV(rv));
1259 }
c8c13c22 1260 XPUSHs(rv);
1261 RETURN;
8782bef2
GB
1262}
1263
a0d0e21e
LW
1264PP(pp_match)
1265{
97aff369 1266 dVAR; dSP; dTARG;
a0d0e21e 1267 register PMOP *pm = cPMOP;
d65afb4b 1268 PMOP *dynpm = pm;
0d46e09a
SP
1269 register const char *t;
1270 register const char *s;
5c144d81 1271 const char *strend;
a0d0e21e 1272 I32 global;
1ed74d04 1273 U8 r_flags = REXEC_CHECKED;
5c144d81 1274 const char *truebase; /* Start of string */
aaa362c4 1275 register REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1276 bool rxtainted;
a3b680e6 1277 const I32 gimme = GIMME;
a0d0e21e 1278 STRLEN len;
748a9306 1279 I32 minmatch = 0;
a3b680e6 1280 const I32 oldsave = PL_savestack_ix;
f86702cc 1281 I32 update_minmatch = 1;
e60df1fa 1282 I32 had_zerolen = 0;
58e23c8d 1283 U32 gpos = 0;
a0d0e21e 1284
533c011a 1285 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1286 TARG = POPs;
59f00321
RGS
1287 else if (PL_op->op_private & OPpTARGET_MY)
1288 GETTARGET;
a0d0e21e 1289 else {
54b9620d 1290 TARG = DEFSV;
a0d0e21e
LW
1291 EXTEND(SP,1);
1292 }
d9f424b2 1293
c277df42 1294 PUTBACK; /* EVAL blocks need stack_sp. */
69dc4b30
FC
1295 /* Skip get-magic if this is a qr// clone, because regcomp has
1296 already done it. */
1297 s = ((struct regexp *)SvANY(rx))->mother_re
1298 ? SvPV_nomg_const(TARG, len)
1299 : SvPV_const(TARG, len);
a0d0e21e 1300 if (!s)
2269b42e 1301 DIE(aTHX_ "panic: pp_match");
890ce7af 1302 strend = s + len;
07bc277f 1303 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
3280af22 1304 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1305 TAINT_NOT;
a0d0e21e 1306
a30b2f1f 1307 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 1308
d65afb4b 1309 /* PMdf_USED is set after a ?? matches once */
c737faaf
YO
1310 if (
1311#ifdef USE_ITHREADS
1312 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1313#else
1314 pm->op_pmflags & PMf_USED
1315#endif
1316 ) {
c277df42 1317 failure:
a0d0e21e
LW
1318 if (gimme == G_ARRAY)
1319 RETURN;
1320 RETPUSHNO;
1321 }
1322
c737faaf
YO
1323
1324
d65afb4b 1325 /* empty pattern special-cased to use last successful pattern if possible */
220fc49f 1326 if (!RX_PRELEN(rx) && PL_curpm) {
3280af22 1327 pm = PL_curpm;
aaa362c4 1328 rx = PM_GETRE(pm);
a0d0e21e 1329 }
d65afb4b 1330
07bc277f 1331 if (RX_MINLEN(rx) > (I32)len)
d65afb4b 1332 goto failure;
c277df42 1333
a0d0e21e 1334 truebase = t = s;
ad94a511
IZ
1335
1336 /* XXXX What part of this is needed with true \G-support? */
d65afb4b 1337 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
07bc277f 1338 RX_OFFS(rx)[0].start = -1;
a0d0e21e 1339 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
c445ea15 1340 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
565764a8 1341 if (mg && mg->mg_len >= 0) {
07bc277f
NC
1342 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1343 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1344 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
0ef3e39e 1345 r_flags |= REXEC_IGNOREPOS;
07bc277f
NC
1346 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1347 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
58e23c8d
YO
1348 gpos = mg->mg_len;
1349 else
07bc277f
NC
1350 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1351 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
f86702cc 1352 update_minmatch = 0;
748a9306 1353 }
a0d0e21e
LW
1354 }
1355 }
a229a030 1356 /* XXX: comment out !global get safe $1 vars after a
62e7980d 1357 match, BUT be aware that this leads to dramatic slowdowns on
a229a030
YO
1358 /g matches against large strings. So far a solution to this problem
1359 appears to be quite tricky.
1360 Test for the unsafe vars are TODO for now. */
0d8a731b
DM
1361 if ( (!global && RX_NPARENS(rx))
1362 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1363 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
14977893 1364 r_flags |= REXEC_COPY_STR;
1c846c1f 1365 if (SvSCREAM(TARG))
22e551b9
IZ
1366 r_flags |= REXEC_SCREAM;
1367
d7be1480 1368 play_it_again:
07bc277f
NC
1369 if (global && RX_OFFS(rx)[0].start != -1) {
1370 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1371 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
a0d0e21e 1372 goto nope;
f86702cc 1373 if (update_minmatch++)
e60df1fa 1374 minmatch = had_zerolen;
a0d0e21e 1375 }
07bc277f 1376 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
3c8556c3 1377 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
5c144d81
NC
1378 /* FIXME - can PL_bostr be made const char *? */
1379 PL_bostr = (char *)truebase;
f9f4320a 1380 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
f722798b
IZ
1381
1382 if (!s)
1383 goto nope;
07bc277f 1384 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
14977893 1385 && !PL_sawampersand
07bc277f
NC
1386 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1387 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1388 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
05b4157f
GS
1389 && (r_flags & REXEC_SCREAM)))
1390 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
f722798b 1391 goto yup;
a0d0e21e 1392 }
1f36f092
RB
1393 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1394 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
bbce6d69 1395 {
3280af22 1396 PL_curpm = pm;
c737faaf
YO
1397 if (dynpm->op_pmflags & PMf_ONCE) {
1398#ifdef USE_ITHREADS
1399 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1400#else
1401 dynpm->op_pmflags |= PMf_USED;
1402#endif
1403 }
a0d0e21e
LW
1404 goto gotcha;
1405 }
1406 else
1407 goto ret_no;
1408 /*NOTREACHED*/
1409
1410 gotcha:
72311751
GS
1411 if (rxtainted)
1412 RX_MATCH_TAINTED_on(rx);
1413 TAINT_IF(RX_MATCH_TAINTED(rx));
a0d0e21e 1414 if (gimme == G_ARRAY) {
07bc277f 1415 const I32 nparens = RX_NPARENS(rx);
a3b680e6 1416 I32 i = (global && !nparens) ? 1 : 0;
a0d0e21e 1417
c277df42 1418 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1419 EXTEND(SP, nparens + i);
1420 EXTEND_MORTAL(nparens + i);
1421 for (i = !i; i <= nparens; i++) {
a0d0e21e 1422 PUSHs(sv_newmortal());
07bc277f
NC
1423 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1424 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1425 s = RX_OFFS(rx)[i].start + truebase;
1426 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
290deeac
A
1427 len < 0 || len > strend - s)
1428 DIE(aTHX_ "panic: pp_match start/end pointers");
a0d0e21e 1429 sv_setpvn(*SP, s, len);
cce850e4 1430 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1431 SvUTF8_on(*SP);
a0d0e21e
LW
1432 }
1433 }
1434 if (global) {
d65afb4b 1435 if (dynpm->op_pmflags & PMf_CONTINUE) {
6136c704 1436 MAGIC* mg = NULL;
0af80b60
HS
1437 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1438 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1439 if (!mg) {
d83f0a82
NC
1440#ifdef PERL_OLD_COPY_ON_WRITE
1441 if (SvIsCOW(TARG))
1442 sv_force_normal_flags(TARG, 0);
1443#endif
1444 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1445 &PL_vtbl_mglob, NULL, 0);
0af80b60 1446 }
07bc277f
NC
1447 if (RX_OFFS(rx)[0].start != -1) {
1448 mg->mg_len = RX_OFFS(rx)[0].end;
1449 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
0af80b60
HS
1450 mg->mg_flags |= MGf_MINMATCH;
1451 else
1452 mg->mg_flags &= ~MGf_MINMATCH;
1453 }
1454 }
07bc277f
NC
1455 had_zerolen = (RX_OFFS(rx)[0].start != -1
1456 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1457 == (UV)RX_OFFS(rx)[0].end));
c277df42 1458 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1459 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1460 goto play_it_again;
1461 }
ffc61ed2 1462 else if (!nparens)
bde848c5 1463 XPUSHs(&PL_sv_yes);
4633a7c4 1464 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1465 RETURN;
1466 }
1467 else {
1468 if (global) {
cbbf8932 1469 MAGIC* mg;
a0d0e21e 1470 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
14befaf4 1471 mg = mg_find(TARG, PERL_MAGIC_regex_global);
cbbf8932
AL
1472 else
1473 mg = NULL;
a0d0e21e 1474 if (!mg) {
d83f0a82
NC
1475#ifdef PERL_OLD_COPY_ON_WRITE
1476 if (SvIsCOW(TARG))
1477 sv_force_normal_flags(TARG, 0);
1478#endif
1479 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1480 &PL_vtbl_mglob, NULL, 0);
a0d0e21e 1481 }
07bc277f
NC
1482 if (RX_OFFS(rx)[0].start != -1) {
1483 mg->mg_len = RX_OFFS(rx)[0].end;
1484 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
748a9306
LW
1485 mg->mg_flags |= MGf_MINMATCH;
1486 else
1487 mg->mg_flags &= ~MGf_MINMATCH;
1488 }
a0d0e21e 1489 }
4633a7c4 1490 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1491 RETPUSHYES;
1492 }
1493
f722798b 1494yup: /* Confirmed by INTUIT */
72311751
GS
1495 if (rxtainted)
1496 RX_MATCH_TAINTED_on(rx);
1497 TAINT_IF(RX_MATCH_TAINTED(rx));
3280af22 1498 PL_curpm = pm;
c737faaf
YO
1499 if (dynpm->op_pmflags & PMf_ONCE) {
1500#ifdef USE_ITHREADS
1501 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1502#else
1503 dynpm->op_pmflags |= PMf_USED;
1504#endif
1505 }
cf93c79d 1506 if (RX_MATCH_COPIED(rx))
07bc277f 1507 Safefree(RX_SUBBEG(rx));
cf93c79d 1508 RX_MATCH_COPIED_off(rx);
07bc277f 1509 RX_SUBBEG(rx) = NULL;
a0d0e21e 1510 if (global) {
5c144d81 1511 /* FIXME - should rx->subbeg be const char *? */
07bc277f
NC
1512 RX_SUBBEG(rx) = (char *) truebase;
1513 RX_OFFS(rx)[0].start = s - truebase;
a30b2f1f 1514 if (RX_MATCH_UTF8(rx)) {
07bc277f
NC
1515 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1516 RX_OFFS(rx)[0].end = t - truebase;
60aeb6fd
NIS
1517 }
1518 else {
07bc277f 1519 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
60aeb6fd 1520 }
07bc277f 1521 RX_SUBLEN(rx) = strend - truebase;
a0d0e21e 1522 goto gotcha;
1c846c1f 1523 }
07bc277f 1524 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
14977893 1525 I32 off;
f8c7b90f 1526#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
1527 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1528 if (DEBUG_C_TEST) {
1529 PerlIO_printf(Perl_debug_log,
1530 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
6c9570dc 1531 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
ed252734
NC
1532 (int)(t-truebase));
1533 }
bdd9a1b1
NC
1534 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1535 RX_SUBBEG(rx)
1536 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1537 assert (SvPOKp(RX_SAVED_COPY(rx)));
ed252734
NC
1538 } else
1539#endif
1540 {
14977893 1541
07bc277f 1542 RX_SUBBEG(rx) = savepvn(t, strend - t);
f8c7b90f 1543#ifdef PERL_OLD_COPY_ON_WRITE
bdd9a1b1 1544 RX_SAVED_COPY(rx) = NULL;
ed252734
NC
1545#endif
1546 }
07bc277f 1547 RX_SUBLEN(rx) = strend - t;
14977893 1548 RX_MATCH_COPIED_on(rx);
07bc277f
NC
1549 off = RX_OFFS(rx)[0].start = s - t;
1550 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
14977893
JH
1551 }
1552 else { /* startp/endp are used by @- @+. */
07bc277f
NC
1553 RX_OFFS(rx)[0].start = s - truebase;
1554 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
14977893 1555 }
07bc277f 1556 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
cde0cee5 1557 -dmq */
07bc277f 1558 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
4633a7c4 1559 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1560 RETPUSHYES;
1561
1562nope:
a0d0e21e 1563ret_no:
d65afb4b 1564 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
a0d0e21e 1565 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
6136c704 1566 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1567 if (mg)
565764a8 1568 mg->mg_len = -1;
a0d0e21e
LW
1569 }
1570 }
4633a7c4 1571 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1572 if (gimme == G_ARRAY)
1573 RETURN;
1574 RETPUSHNO;
1575}
1576
1577OP *
864dbfa3 1578Perl_do_readline(pTHX)
a0d0e21e 1579{
27da23d5 1580 dVAR; dSP; dTARGETSTACKED;
a0d0e21e
LW
1581 register SV *sv;
1582 STRLEN tmplen = 0;
1583 STRLEN offset;
760ac839 1584 PerlIO *fp;
a3b680e6
AL
1585 register IO * const io = GvIO(PL_last_in_gv);
1586 register const I32 type = PL_op->op_type;
1587 const I32 gimme = GIMME_V;
a0d0e21e 1588
6136c704 1589 if (io) {
50db69d8 1590 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
6136c704 1591 if (mg) {
50db69d8 1592 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
6136c704 1593 if (gimme == G_SCALAR) {
50db69d8
NC
1594 SPAGAIN;
1595 SvSetSV_nosteal(TARG, TOPs);
1596 SETTARG;
6136c704 1597 }
50db69d8 1598 return NORMAL;
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--;
7716c5c5 1627 else if (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
ef07e810
DM
2079/*
2080A description of how taint works in pattern matching and substitution.
2081
0ab462a6
DM
2082While the pattern is being assembled/concatenated and them compiled,
2083PL_tainted will get set if any component of the pattern is tainted, e.g.
2084/.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
2085is set on the pattern if PL_tainted is set.
ef07e810 2086
0ab462a6
DM
2087When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2088the pattern is marked as tainted. This means that subsequent usage, such
2089as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
ef07e810
DM
2090
2091During execution of a pattern, locale-variant ops such as ALNUML set the
2092local flag RF_tainted. At the end of execution, the engine sets the
0ab462a6
DM
2093RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
2094otherwise.
ef07e810
DM
2095
2096In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
2097of $1 et al to indicate whether the returned value should be tainted.
2098It is the responsibility of the caller of the pattern (i.e. pp_match,
2099pp_subst etc) to set this flag for any other circumstances where $1 needs
2100to be tainted.
2101
2102The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2103
2104There are three possible sources of taint
2105 * the source string
2106 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2107 * the replacement string (or expression under /e)
2108
2109There are four destinations of taint and they are affected by the sources
2110according to the rules below:
2111
2112 * the return value (not including /r):
2113 tainted by the source string and pattern, but only for the
2114 number-of-iterations case; boolean returns aren't tainted;
2115 * the modified string (or modified copy under /r):
2116 tainted by the source string, pattern, and replacement strings;
2117 * $1 et al:
2118 tainted by the pattern, and under 'use re "taint"', by the source
2119 string too;
2120 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2121 should always be unset before executing subsequent code.
2122
2123The overall action of pp_subst is:
2124
2125 * at the start, set bits in rxtainted indicating the taint status of
2126 the various sources.
2127
2128 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2129 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2130 pattern has subsequently become tainted via locale ops.
2131
2132 * If control is being passed to pp_substcont to execute a /e block,
2133 save rxtainted in the CXt_SUBST block, for future use by
2134 pp_substcont.
2135
2136 * Whenever control is being returned to perl code (either by falling
2137 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2138 use the flag bits in rxtainted to make all the appropriate types of
0ab462a6
DM
2139 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2140 et al will appear tainted.
ef07e810
DM
2141
2142pp_match is just a simpler version of the above.
2143
2144*/
2145
a0d0e21e
LW
2146PP(pp_subst)
2147{
97aff369 2148 dVAR; dSP; dTARG;
a0d0e21e
LW
2149 register PMOP *pm = cPMOP;
2150 PMOP *rpm = pm;
a0d0e21e
LW
2151 register char *s;
2152 char *strend;
2153 register char *m;
5c144d81 2154 const char *c;
a0d0e21e
LW
2155 register char *d;
2156 STRLEN clen;
2157 I32 iters = 0;
2158 I32 maxiters;
2159 register I32 i;
2160 bool once;
ef07e810
DM
2161 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2162 See "how taint works" above */
a0d0e21e 2163 char *orig;
1ed74d04 2164 U8 r_flags;
aaa362c4 2165 register REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
2166 STRLEN len;
2167 int force_on_match = 0;
0bcc34c2 2168 const I32 oldsave = PL_savestack_ix;
792b2c16 2169 STRLEN slen;
f272994b 2170 bool doutf8 = FALSE;
f8c7b90f 2171#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2172 bool is_cow;
2173#endif
a0714e2c 2174 SV *nsv = NULL;
b770e143
NC
2175 /* known replacement string? */
2176 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
a0d0e21e 2177
f410a211
NC
2178 PERL_ASYNC_CHECK();
2179
533c011a 2180 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 2181 TARG = POPs;
59f00321
RGS
2182 else if (PL_op->op_private & OPpTARGET_MY)
2183 GETTARGET;
a0d0e21e 2184 else {
54b9620d 2185 TARG = DEFSV;
a0d0e21e 2186 EXTEND(SP,1);
1c846c1f 2187 }
d9f424b2 2188
4f4d7508
DC
2189 /* In non-destructive replacement mode, duplicate target scalar so it
2190 * remains unchanged. */
2191 if (rpm->op_pmflags & PMf_NONDESTRUCT)
4eedab49 2192 TARG = sv_2mortal(newSVsv(TARG));
4f4d7508 2193
f8c7b90f 2194#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2195 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2196 because they make integers such as 256 "false". */
2197 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2198#else
765f542d
NC
2199 if (SvIsCOW(TARG))
2200 sv_force_normal_flags(TARG,0);
ed252734
NC
2201#endif
2202 if (
f8c7b90f 2203#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2204 !is_cow &&
2205#endif
2206 (SvREADONLY(TARG)
cecf5685
NC
2207 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2208 || SvTYPE(TARG) > SVt_PVLV)
4ce457a6 2209 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
6ad8f254 2210 Perl_croak_no_modify(aTHX);
8ec5e241
NIS
2211 PUTBACK;
2212
3e462cdc 2213 setup_match:
d5263905 2214 s = SvPV_mutable(TARG, len);
68dc0745 2215 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
a0d0e21e 2216 force_on_match = 1;
20be6587
DM
2217
2218 /* only replace once? */
2219 once = !(rpm->op_pmflags & PMf_GLOBAL);
2220
ef07e810 2221 /* See "how taint works" above */
20be6587
DM
2222 if (PL_tainting) {
2223 rxtainted = (
2224 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2225 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2226 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2227 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2228 ? SUBST_TAINT_BOOLRET : 0));
2229 TAINT_NOT;
2230 }
a12c0f56 2231
a30b2f1f 2232 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 2233
a0d0e21e
LW
2234 force_it:
2235 if (!pm || !s)
2269b42e 2236 DIE(aTHX_ "panic: pp_subst");
a0d0e21e
LW
2237
2238 strend = s + len;
a30b2f1f 2239 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
792b2c16
JH
2240 maxiters = 2 * slen + 10; /* We can match twice at each
2241 position, once with zero-length,
2242 second time with non-zero. */
a0d0e21e 2243
220fc49f 2244 if (!RX_PRELEN(rx) && PL_curpm) {
3280af22 2245 pm = PL_curpm;
aaa362c4 2246 rx = PM_GETRE(pm);
a0d0e21e 2247 }
07bc277f
NC
2248 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2249 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
ed252734 2250 ? REXEC_COPY_STR : 0;
f722798b 2251 if (SvSCREAM(TARG))
22e551b9 2252 r_flags |= REXEC_SCREAM;
7fba1cd6 2253
a0d0e21e 2254 orig = m = s;
07bc277f 2255 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
ee0b7718 2256 PL_bostr = orig;
f9f4320a 2257 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
f722798b
IZ
2258
2259 if (!s)
df34c13a 2260 goto ret_no;
f722798b 2261 /* How to do it in subst? */
07bc277f 2262/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1c846c1f 2263 && !PL_sawampersand
07bc277f
NC
2264 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2265 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2266 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
f722798b
IZ
2267 && (r_flags & REXEC_SCREAM))))
2268 goto yup;
2269*/
a0d0e21e 2270 }
71be2cbc 2271
8b64c330
DM
2272 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2273 r_flags | REXEC_CHECKED))
2274 {
5e79dfb9
DM
2275 ret_no:
2276 SPAGAIN;
2277 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2278 LEAVE_SCOPE(oldsave);
2279 RETURN;
2280 }
2281
71be2cbc 2282 /* known replacement string? */
f272994b 2283 if (dstr) {
20be6587
DM
2284 if (SvTAINTED(dstr))
2285 rxtainted |= SUBST_TAINT_REPL;
3e462cdc
KW
2286
2287 /* Upgrade the source if the replacement is utf8 but the source is not,
2288 * but only if it matched; see
2289 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2290 */
5e79dfb9 2291 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
c95ca9b8
DM
2292 char * const orig_pvx = SvPVX(TARG);
2293 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
3e462cdc
KW
2294
2295 /* If the lengths are the same, the pattern contains only
2296 * invariants, can keep going; otherwise, various internal markers
2297 * could be off, so redo */
c95ca9b8 2298 if (new_len != len || orig_pvx != SvPVX(TARG)) {
3e462cdc
KW
2299 goto setup_match;
2300 }
2301 }
2302
8514a05a
JH
2303 /* replacement needing upgrading? */
2304 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2305 nsv = sv_newmortal();
4a176938 2306 SvSetSV(nsv, dstr);
8514a05a
JH
2307 if (PL_encoding)
2308 sv_recode_to_utf8(nsv, PL_encoding);
2309 else
2310 sv_utf8_upgrade(nsv);
5c144d81 2311 c = SvPV_const(nsv, clen);
4a176938
JH
2312 doutf8 = TRUE;
2313 }
2314 else {
5c144d81 2315 c = SvPV_const(dstr, clen);
4a176938 2316 doutf8 = DO_UTF8(dstr);
8514a05a 2317 }
f272994b
A
2318 }
2319 else {
6136c704 2320 c = NULL;
f272994b
A
2321 doutf8 = FALSE;
2322 }
2323
71be2cbc 2324 /* can do inplace substitution? */
ed252734 2325 if (c
f8c7b90f 2326#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2327 && !is_cow
2328#endif
07bc277f
NC
2329 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2330 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
8b030b38
DM
2331 && (!doutf8 || SvUTF8(TARG)))
2332 {
ec911639 2333
f8c7b90f 2334#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2335 if (SvIsCOW(TARG)) {
2336 assert (!force_on_match);
2337 goto have_a_cow;
2338 }
2339#endif
71be2cbc
PP
2340 if (force_on_match) {
2341 force_on_match = 0;
2342 s = SvPV_force(TARG, len);
2343 goto force_it;
2344 }
71be2cbc 2345 d = s;
3280af22 2346 PL_curpm = pm;
71be2cbc
PP
2347 SvSCREAM_off(TARG); /* disable possible screamer */
2348 if (once) {
20be6587
DM
2349 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2350 rxtainted |= SUBST_TAINT_PAT;
07bc277f
NC
2351 m = orig + RX_OFFS(rx)[0].start;
2352 d = orig + RX_OFFS(rx)[0].end;
71be2cbc
PP
2353 s = orig;
2354 if (m - s > strend - d) { /* faster to shorten from end */
2355 if (clen) {
2356 Copy(c, m, clen, char);
2357 m += clen;
a0d0e21e 2358 }
71be2cbc
PP
2359 i = strend - d;
2360 if (i > 0) {
2361 Move(d, m, i, char);
2362 m += i;
a0d0e21e 2363 }
71be2cbc
PP
2364 *m = '\0';
2365 SvCUR_set(TARG, m - s);
2366 }
155aba94 2367 else if ((i = m - s)) { /* faster from front */
71be2cbc
PP
2368 d -= clen;
2369 m = d;
0d3c21b0 2370 Move(s, d - i, i, char);
71be2cbc 2371 sv_chop(TARG, d-i);
71be2cbc
PP
2372 if (clen)
2373 Copy(c, m, clen, char);
2374 }
2375 else if (clen) {
2376 d -= clen;
2377 sv_chop(TARG, d);
2378 Copy(c, d, clen, char);
2379 }
2380 else {
2381 sv_chop(TARG, d);
2382 }
8ec5e241 2383 SPAGAIN;
af050d75 2384 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_yes);
71be2cbc
PP
2385 }
2386 else {
71be2cbc
PP
2387 do {
2388 if (iters++ > maxiters)
cea2e8a9 2389 DIE(aTHX_ "Substitution loop");
20be6587
DM
2390 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2391 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2392 m = RX_OFFS(rx)[0].start + orig;
155aba94 2393 if ((i = m - s)) {
71be2cbc
PP
2394 if (s != d)
2395 Move(s, d, i, char);
2396 d += i;
a0d0e21e 2397 }
71be2cbc
PP
2398 if (clen) {
2399 Copy(c, d, clen, char);
2400 d += clen;
2401 }
07bc277f 2402 s = RX_OFFS(rx)[0].end + orig;
f9f4320a 2403 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
f722798b
IZ
2404 TARG, NULL,
2405 /* don't match same null twice */
2406 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc
PP
2407 if (s != d) {
2408 i = strend - s;
aa07b2f6 2409 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
71be2cbc 2410 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2411 }
8ec5e241 2412 SPAGAIN;
4f4d7508
DC
2413 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2414 PUSHs(TARG);
2415 else
2416 mPUSHi((I32)iters);
a0d0e21e
LW
2417 }
2418 }
ff6e92e8 2419 else {
a0d0e21e
LW
2420 if (force_on_match) {
2421 force_on_match = 0;
2422 s = SvPV_force(TARG, len);
2423 goto force_it;
2424 }
f8c7b90f 2425#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2426 have_a_cow:
2427#endif
20be6587
DM
2428 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2429 rxtainted |= SUBST_TAINT_PAT;
740cce10 2430 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
cff085c1 2431 SAVEFREESV(dstr);
3280af22 2432 PL_curpm = pm;
a0d0e21e 2433 if (!c) {
c09156bb 2434 register PERL_CONTEXT *cx;
8ec5e241 2435 SPAGAIN;
20be6587
DM
2436 /* note that a whole bunch of local vars are saved here for
2437 * use by pp_substcont: here's a list of them in case you're
2438 * searching for places in this sub that uses a particular var:
2439 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2440 * s m strend rx once */
a0d0e21e 2441 PUSHSUBST(cx);
20e98b0f 2442 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
a0d0e21e 2443 }
cf93c79d 2444 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
2445 do {
2446 if (iters++ > maxiters)
cea2e8a9 2447 DIE(aTHX_ "Substitution loop");
20be6587
DM
2448 if (RX_MATCH_TAINTED(rx))
2449 rxtainted |= SUBST_TAINT_PAT;
07bc277f 2450 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
a0d0e21e
LW
2451 m = s;
2452 s = orig;
07bc277f 2453 orig = RX_SUBBEG(rx);
a0d0e21e
LW
2454 s = orig + (m - s);
2455 strend = s + (strend - m);
2456 }
07bc277f 2457 m = RX_OFFS(rx)[0].start + orig;
db79b45b
JH
2458 if (doutf8 && !SvUTF8(dstr))
2459 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2460 else
2461 sv_catpvn(dstr, s, m-s);
07bc277f 2462 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e
LW
2463 if (clen)
2464 sv_catpvn(dstr, c, clen);
2465 if (once)
2466 break;
f9f4320a 2467 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
ffc61ed2 2468 TARG, NULL, r_flags));
db79b45b
JH
2469 if (doutf8 && !DO_UTF8(TARG))
2470 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
89afcb60
A
2471 else
2472 sv_catpvn(dstr, s, strend - s);
748a9306 2473
f8c7b90f 2474#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2475 /* The match may make the string COW. If so, brilliant, because that's
2476 just saved us one malloc, copy and free - the regexp has donated
2477 the old buffer, and we malloc an entirely new one, rather than the
2478 regexp malloc()ing a buffer and copying our original, only for
2479 us to throw it away here during the substitution. */
2480 if (SvIsCOW(TARG)) {
2481 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2482 } else
2483#endif
2484 {
8bd4d4c5 2485 SvPV_free(TARG);
ed252734 2486 }
f880fe2f 2487 SvPV_set(TARG, SvPVX(dstr));
748a9306
LW
2488 SvCUR_set(TARG, SvCUR(dstr));
2489 SvLEN_set(TARG, SvLEN(dstr));
f272994b 2490 doutf8 |= DO_UTF8(dstr);
6136c704 2491 SvPV_set(dstr, NULL);
748a9306 2492
f878fbec 2493 SPAGAIN;
4f4d7508
DC
2494 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2495 PUSHs(TARG);
2496 else
2497 mPUSHi((I32)iters);
a0d0e21e 2498 }
f1a76097
DM
2499 (void)SvPOK_only_UTF8(TARG);
2500 if (doutf8)
2501 SvUTF8_on(TARG);
20be6587 2502
ef07e810 2503 /* See "how taint works" above */
20be6587
DM
2504 if (PL_tainting) {
2505 if ((rxtainted & SUBST_TAINT_PAT) ||
2506 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2507 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2508 )
2509 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2510
2511 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2512 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2513 )
2514 SvTAINTED_on(TOPs); /* taint return value */
2515 else
2516 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2517
2518 /* needed for mg_set below */
2519 PL_tainted =
2520 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2521 SvTAINT(TARG);
2522 }
2523 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2524 TAINT_NOT;
f1a76097
DM
2525 LEAVE_SCOPE(oldsave);
2526 RETURN;
a0d0e21e
LW
2527}
2528
2529PP(pp_grepwhile)
2530{
27da23d5 2531 dVAR; dSP;
a0d0e21e
LW
2532
2533 if (SvTRUEx(POPs))
3280af22
NIS
2534 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2535 ++*PL_markstack_ptr;
b2a2a901 2536 FREETMPS;
d343c3ef 2537 LEAVE_with_name("grep_item"); /* exit inner scope */
a0d0e21e
LW
2538
2539 /* All done yet? */
3280af22 2540 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2541 I32 items;
c4420975 2542 const I32 gimme = GIMME_V;
a0d0e21e 2543
d343c3ef 2544 LEAVE_with_name("grep"); /* exit outer scope */
a0d0e21e 2545 (void)POPMARK; /* pop src */
3280af22 2546 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2547 (void)POPMARK; /* pop dst */
3280af22 2548 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2549 if (gimme == G_SCALAR) {
7cc47870 2550 if (PL_op->op_private & OPpGREP_LEX) {
c4420975 2551 SV* const sv = sv_newmortal();
7cc47870
RGS
2552 sv_setiv(sv, items);
2553 PUSHs(sv);
2554 }
2555 else {
2556 dTARGET;
2557 XPUSHi(items);
2558 }
a0d0e21e 2559 }
54310121
PP
2560 else if (gimme == G_ARRAY)
2561 SP += items;
a0d0e21e
LW
2562 RETURN;
2563 }
2564 else {
2565 SV *src;
2566
d343c3ef 2567 ENTER_with_name("grep_item"); /* enter inner scope */
1d7c1841 2568 SAVEVPTR(PL_curpm);
a0d0e21e 2569
3280af22 2570 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2571 SvTEMP_off(src);
59f00321
RGS
2572 if (PL_op->op_private & OPpGREP_LEX)
2573 PAD_SVl(PL_op->op_targ) = src;
2574 else
414bf5ae 2575 DEFSV_set(src);
a0d0e21e
LW
2576
2577 RETURNOP(cLOGOP->op_other);
2578 }
2579}
2580
2581PP(pp_leavesub)
2582{
27da23d5 2583 dVAR; dSP;
a0d0e21e
LW
2584 SV **mark;
2585 SV **newsp;
2586 PMOP *newpm;
2587 I32 gimme;
c09156bb 2588 register PERL_CONTEXT *cx;
b0d9ce38 2589 SV *sv;
a0d0e21e 2590
9850bf21
RH
2591 if (CxMULTICALL(&cxstack[cxstack_ix]))
2592 return 0;
2593
a0d0e21e 2594 POPBLOCK(cx,newpm);
5dd42e15 2595 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2596
a1f49e72 2597 TAINT_NOT;
a0d0e21e
LW
2598 if (gimme == G_SCALAR) {
2599 MARK = newsp + 1;
a29cdaf0 2600 if (MARK <= SP) {
a8bba7fa 2601 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
2602 if (SvTEMP(TOPs)) {
2603 *MARK = SvREFCNT_inc(TOPs);
2604 FREETMPS;
2605 sv_2mortal(*MARK);
cd06dffe
GS
2606 }
2607 else {
959e3673 2608 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2609 FREETMPS;
959e3673
GS
2610 *MARK = sv_mortalcopy(sv);
2611 SvREFCNT_dec(sv);
a29cdaf0 2612 }
cd06dffe
GS
2613 }
2614 else
a29cdaf0 2615 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
cd06dffe
GS
2616 }
2617 else {
f86702cc 2618 MEXTEND(MARK, 0);
3280af22 2619 *MARK = &PL_sv_undef;
a0d0e21e
LW
2620 }
2621 SP = MARK;
2622 }
54310121 2623 else if (gimme == G_ARRAY) {
f86702cc 2624 for (MARK = newsp + 1; MARK <= SP; MARK++) {
a1f49e72 2625 if (!SvTEMP(*MARK)) {
f86702cc 2626 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2627 TAINT_NOT; /* Each item is independent */
2628 }
f86702cc 2629 }
a0d0e21e 2630 }
f86702cc 2631 PUTBACK;
1c846c1f 2632
a57c6685 2633 LEAVE;
5dd42e15 2634 cxstack_ix--;
b0d9ce38 2635 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2636 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2637
b0d9ce38 2638 LEAVESUB(sv);
f39bc417 2639 return cx->blk_sub.retop;
a0d0e21e
LW
2640}
2641
cd06dffe
GS
2642/* This duplicates the above code because the above code must not
2643 * get any slower by more conditions */
2644PP(pp_leavesublv)
2645{
27da23d5 2646 dVAR; dSP;
cd06dffe
GS
2647 SV **mark;
2648 SV **newsp;
2649 PMOP *newpm;
2650 I32 gimme;
2651 register PERL_CONTEXT *cx;
b0d9ce38 2652 SV *sv;
cd06dffe 2653
9850bf21
RH
2654 if (CxMULTICALL(&cxstack[cxstack_ix]))
2655 return 0;
2656
cd06dffe 2657 POPBLOCK(cx,newpm);
5dd42e15 2658 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2659
cd06dffe
GS
2660 TAINT_NOT;
2661
bafb2adc 2662 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
cd06dffe
GS
2663 /* We are an argument to a function or grep().
2664 * This kind of lvalueness was legal before lvalue
2665 * subroutines too, so be backward compatible:
2666 * cannot report errors. */
2667
2668 /* Scalar context *is* possible, on the LHS of -> only,
2669 * as in f()->meth(). But this is not an lvalue. */
2670 if (gimme == G_SCALAR)
2671 goto temporise;
2672 if (gimme == G_ARRAY) {
91e34d82
MP
2673 mark = newsp + 1;
2674 /* We want an array here, but padav will have left us an arrayref for an lvalue,
2675 * so we need to expand it */
2676 if(SvTYPE(*mark) == SVt_PVAV) {
2677 AV *const av = MUTABLE_AV(*mark);
2678 const I32 maxarg = AvFILL(av) + 1;
2679 (void)POPs; /* get rid of the array ref */
2680 EXTEND(SP, maxarg);
2681 if (SvRMAGICAL(av)) {
2682 U32 i;
2683 for (i=0; i < (U32)maxarg; i++) {
2684 SV ** const svp = av_fetch(av, i, FALSE);
2685 SP[i+1] = svp
2686 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
2687 : &PL_sv_undef;
2688 }
2689 }
2690 else {
2691 Copy(AvARRAY(av), SP+1, maxarg, SV*);
2692 }
2693 SP += maxarg;
2694 PUTBACK;
2695 }
a8bba7fa 2696 if (!CvLVALUE(cx->blk_sub.cv))
cd06dffe
GS
2697 goto temporise_array;
2698 EXTEND_MORTAL(SP - newsp);
2699 for (mark = newsp + 1; mark <= SP; mark++) {
2700 if (SvTEMP(*mark))
6f207bd3 2701 NOOP;
cd06dffe
GS
2702 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2703 *mark = sv_mortalcopy(*mark);
2704 else {
2705 /* Can be a localized value subject to deletion. */
2706 PL_tmps_stack[++PL_tmps_ix] = *mark;
b37c2d43 2707 SvREFCNT_inc_void(*mark);
cd06dffe
GS
2708 }
2709 }
2710 }
2711 }
bafb2adc 2712 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
cd06dffe
GS
2713 /* Here we go for robustness, not for speed, so we change all
2714 * the refcounts so the caller gets a live guy. Cannot set
2715 * TEMP, so sv_2mortal is out of question. */
a8bba7fa 2716 if (!CvLVALUE(cx->blk_sub.cv)) {
a57c6685 2717 LEAVE;
5dd42e15 2718 cxstack_ix--;
b0d9ce38 2719 POPSUB(cx,sv);
d470f89e 2720 PL_curpm = newpm;
b0d9ce38 2721 LEAVESUB(sv);
d470f89e
GS
2722 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2723 }
cd06dffe
GS
2724 if (gimme == G_SCALAR) {
2725 MARK = newsp + 1;
2726 EXTEND_MORTAL(1);
2727 if (MARK == SP) {
fd6c41ce 2728 if ((SvPADTMP(TOPs) ||
c73030b8
FC
2729 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2730 == SVf_READONLY
2731 ) &&
2732 !SvSMAGICAL(TOPs)) {
2733 LEAVE;
2734 cxstack_ix--;
2735 POPSUB(cx,sv);
2736 PL_curpm = newpm;
2737 LEAVESUB(sv);
2738 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2739 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2740 : "a readonly value" : "a temporary");
2741 }
2742 else { /* Can be a localized value
2743 * subject to deletion. */
cd06dffe 2744 PL_tmps_stack[++PL_tmps_ix] = *mark;
b37c2d43 2745 SvREFCNT_inc_void(*mark);
c73030b8 2746 }
cd06dffe 2747 }
69b22cd1
FC
2748 else {
2749 /* sub:lvalue{} will take us here.
2750 Presumably the case of a non-empty array never happens.
2751 */
a57c6685 2752 LEAVE;
5dd42e15 2753 cxstack_ix--;
b0d9ce38 2754 POPSUB(cx,sv);
d470f89e 2755 PL_curpm = newpm;
b0d9ce38 2756 LEAVESUB(sv);
69b22cd1
FC
2757 DIE(aTHX_ "%s",
2758 (MARK > SP
2759 ? "Can't return undef from lvalue subroutine"
2760 : "Array returned from lvalue subroutine in scalar "
2761 "context"
2762 )
2763 );
d470f89e 2764 }
cd06dffe
GS
2765 SP = MARK;
2766 }
2767 else if (gimme == G_ARRAY) {
2768 EXTEND_MORTAL(SP - newsp);
2769 for (mark = newsp + 1; mark <= SP; mark++) {
f206cdda 2770 if (*mark != &PL_sv_undef
fd6c41ce 2771 && (SvPADTMP(*mark)
a0aa6076
FC
2772 || (SvFLAGS(*mark) & (SVf_READONLY|SVf_FAKE))
2773 == SVf_READONLY
2774 )
2775 ) {
d470f89e
GS
2776 /* Might be flattened array after $#array = */
2777 PUTBACK;
a57c6685 2778 LEAVE;
5dd42e15 2779 cxstack_ix--;
b0d9ce38 2780 POPSUB(cx,sv);
d470f89e 2781 PL_curpm = newpm;
b0d9ce38 2782 LEAVESUB(sv);
f206cdda
AMS
2783 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2784 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2785 }
cd06dffe 2786 else {
cd06dffe
GS
2787 /* Can be a localized value subject to deletion. */
2788 PL_tmps_stack[++PL_tmps_ix] = *mark;
b37c2d43 2789 SvREFCNT_inc_void(*mark);
cd06dffe
GS
2790 }
2791 }
2792 }
2793 }
2794 else {
2795 if (gimme == G_SCALAR) {
2796 temporise:
2797 MARK = newsp + 1;
2798 if (MARK <= SP) {
a8bba7fa 2799 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
cd06dffe
GS
2800 if (SvTEMP(TOPs)) {
2801 *MARK = SvREFCNT_inc(TOPs);
2802 FREETMPS;
2803 sv_2mortal(*MARK);
2804 }
2805 else {
959e3673 2806 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
cd06dffe 2807 FREETMPS;
959e3673
GS
2808 *MARK = sv_mortalcopy(sv);
2809 SvREFCNT_dec(sv);
cd06dffe
GS
2810 }
2811 }
2812 else
2813 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2814 }
2815 else {
2816 MEXTEND(MARK, 0);
2817 *MARK = &PL_sv_undef;
2818 }
2819 SP = MARK;
2820 }
2821 else if (gimme == G_ARRAY) {
2822 temporise_array:
2823 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2824 if (!SvTEMP(*MARK)) {
2825 *MARK = sv_mortalcopy(*MARK);
2826 TAINT_NOT; /* Each item is independent */
2827 }
2828 }
2829 }
2830 }
2831 PUTBACK;
1c846c1f 2832
a57c6685 2833 LEAVE;
5dd42e15 2834 cxstack_ix--;
b0d9ce38 2835 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
cd06dffe
GS
2836 PL_curpm = newpm; /* ... and pop $1 et al */
2837
b0d9ce38 2838 LEAVESUB(sv);
f39bc417 2839 return cx->blk_sub.retop;
cd06dffe
GS
2840}
2841
a0d0e21e
LW
2842PP(pp_entersub)
2843{
27da23d5 2844 dVAR; dSP; dPOPss;
a0d0e21e 2845 GV *gv;
a0d0e21e 2846 register CV *cv;
c09156bb 2847 register PERL_CONTEXT *cx;
5d94fbed 2848 I32 gimme;
a9c4fd4e 2849 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2850
2851 if (!sv)
cea2e8a9 2852 DIE(aTHX_ "Not a CODE reference");
a0d0e21e 2853 switch (SvTYPE(sv)) {
f1025168
NC
2854 /* This is overwhelming the most common case: */
2855 case SVt_PVGV:
6e592b3a
BM
2856 if (!isGV_with_GP(sv))
2857 DIE(aTHX_ "Not a CODE reference");
13be902c 2858 we_have_a_glob:
159b6efe 2859 if (!(cv = GvCVu((const GV *)sv))) {
f730a42d 2860 HV *stash;
f2c0649b 2861 cv = sv_2cv(sv, &stash, &gv, 0);
f730a42d 2862 }
f1025168 2863 if (!cv) {
a57c6685 2864 ENTER;
f1025168
NC
2865 SAVETMPS;
2866 goto try_autoload;
2867 }
2868 break;
13be902c
FC
2869 case SVt_PVLV:
2870 if(isGV_with_GP(sv)) goto we_have_a_glob;
2871 /*FALLTHROUGH*/
a0d0e21e 2872 default:
7c75014e
DM
2873 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2874 if (hasargs)
2875 SP = PL_stack_base + POPMARK;
4d198de3
DM
2876 else
2877 (void)POPMARK;
7c75014e
DM
2878 RETURN;
2879 }
2880 SvGETMAGIC(sv);
2881 if (SvROK(sv)) {
93d7320b
DM
2882 if (SvAMAGIC(sv)) {
2883 sv = amagic_deref_call(sv, to_cv_amg);
2884 /* Don't SPAGAIN here. */
2885 }
7c75014e
DM
2886 }
2887 else {
a9c4fd4e 2888 const char *sym;
780a5241 2889 STRLEN len;
7c75014e 2890 sym = SvPV_nomg_const(sv, len);
15ff848f 2891 if (!sym)
cea2e8a9 2892 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2893 if (PL_op->op_private & HINT_STRICT_REFS)
973a7615 2894 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
780a5241 2895 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
a0d0e21e
LW
2896 break;
2897 }
ea726b52 2898 cv = MUTABLE_CV(SvRV(sv));
a0d0e21e
LW
2899 if (SvTYPE(cv) == SVt_PVCV)
2900 break;
2901 /* FALL THROUGH */
2902 case SVt_PVHV:
2903 case SVt_PVAV:
cea2e8a9 2904 DIE(aTHX_ "Not a CODE reference");
f1025168 2905 /* This is the second most common case: */
a0d0e21e 2906 case SVt_PVCV:
ea726b52 2907 cv = MUTABLE_CV(sv);
a0d0e21e 2908 break;
a0d0e21e
LW
2909 }
2910
a57c6685 2911 ENTER;
a0d0e21e
LW
2912 SAVETMPS;
2913
2914 retry:
541ed3a9
FC
2915 if (CvCLONE(cv) && ! CvCLONED(cv))
2916 DIE(aTHX_ "Closure prototype called");
a0d0e21e 2917 if (!CvROOT(cv) && !CvXSUB(cv)) {
2f349aa0
NC
2918 GV* autogv;
2919 SV* sub_name;
2920
2921 /* anonymous or undef'd function leaves us no recourse */
2922 if (CvANON(cv) || !(gv = CvGV(cv)))
2923 DIE(aTHX_ "Undefined subroutine called");
2924
2925 /* autoloaded stub? */
2926 if (cv != GvCV(gv)) {
2927 cv = GvCV(gv);
2928 }
2929 /* should call AUTOLOAD now? */
2930 else {
7e623da3 2931try_autoload:
2f349aa0 2932 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
7e623da3 2933 FALSE)))
2f349aa0
NC
2934 {
2935 cv = GvCV(autogv);
2936 }
2937 /* sorry */
2938 else {
2939 sub_name = sv_newmortal();
6136c704 2940 gv_efullname3(sub_name, gv, NULL);
be2597df 2941 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2f349aa0
NC
2942 }
2943 }
2944 if (!cv)
2945 DIE(aTHX_ "Not a CODE reference");
2946 goto retry;
a0d0e21e
LW
2947 }
2948
54310121 2949 gimme = GIMME_V;
67caa1fe 2950 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
005a8a35 2951 Perl_get_db_sub(aTHX_ &sv, cv);
a9ef256d
NC
2952 if (CvISXSUB(cv))
2953 PL_curcopdb = PL_curcop;
1ad62f64 2954 if (CvLVALUE(cv)) {
2955 /* check for lsub that handles lvalue subroutines */
ae5c1e95 2956 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
1ad62f64 2957 /* if lsub not found then fall back to DB::sub */
2958 if (!cv) cv = GvCV(PL_DBsub);
2959 } else {
2960 cv = GvCV(PL_DBsub);
2961 }
a9ef256d 2962
ccafdc96
RGS
2963 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2964 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 2965 }
a0d0e21e 2966
aed2304a 2967 if (!(CvISXSUB(cv))) {
f1025168 2968 /* This path taken at least 75% of the time */
a0d0e21e
LW
2969 dMARK;
2970 register I32 items = SP - MARK;
0bcc34c2 2971 AV* const padlist = CvPADLIST(cv);
a0d0e21e
LW
2972 PUSHBLOCK(cx, CXt_SUB, MARK);
2973 PUSHSUB(cx);
f39bc417 2974 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 2975 CvDEPTH(cv)++;
6b35e009
GS
2976 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2977 * that eval'' ops within this sub know the correct lexical space.
a3985cdc
DM
2978 * Owing the speed considerations, we choose instead to search for
2979 * the cv using find_runcv() when calling doeval().
6b35e009 2980 */
3a76ca88
RGS
2981 if (CvDEPTH(cv) >= 2) {
2982 PERL_STACK_OVERFLOW_CHECK();
2983 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2984 }
3a76ca88
RGS
2985 SAVECOMPPAD();
2986 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2987 if (hasargs) {
10533ace 2988 AV *const av = MUTABLE_AV(PAD_SVl(0));
221373f0
GS
2989 if (AvREAL(av)) {
2990 /* @_ is normally not REAL--this should only ever
2991 * happen when DB::sub() calls things that modify @_ */
2992 av_clear(av);
2993 AvREAL_off(av);
2994 AvREIFY_on(av);
2995 }
3280af22 2996 cx->blk_sub.savearray = GvAV(PL_defgv);
502c6561 2997 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
dd2155a4 2998 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2999 cx->blk_sub.argarray = av;
a0d0e21e
LW
3000 ++MARK;
3001
3002 if (items > AvMAX(av) + 1) {
504618e9 3003 SV **ary = AvALLOC(av);
a0d0e21e
LW
3004 if (AvARRAY(av) != ary) {
3005 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 3006 AvARRAY(av) = ary;
a0d0e21e
LW
3007 }
3008 if (items > AvMAX(av) + 1) {
3009 AvMAX(av) = items - 1;
3010 Renew(ary,items,SV*);
3011 AvALLOC(av) = ary;
9c6bc640 3012 AvARRAY(av) = ary;
a0d0e21e
LW
3013 }
3014 }
3015 Copy(MARK,AvARRAY(av),items,SV*);
93965878 3016 AvFILLp(av) = items - 1;
1c846c1f 3017
a0d0e21e
LW
3018 while (items--) {
3019 if (*MARK)
3020 SvTEMP_off(*MARK);
3021 MARK++;
3022 }
3023 }
4a925ff6
GS
3024 /* warning must come *after* we fully set up the context
3025 * stuff so that __WARN__ handlers can safely dounwind()
3026 * if they want to
3027 */
2b9dff67 3028 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
4a925ff6
GS
3029 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
3030 sub_crush_depth(cv);
a0d0e21e
LW
3031 RETURNOP(CvSTART(cv));
3032 }
f1025168 3033 else {
3a76ca88 3034 I32 markix = TOPMARK;
f1025168 3035
3a76ca88 3036 PUTBACK;
f1025168 3037
3a76ca88
RGS
3038 if (!hasargs) {
3039 /* Need to copy @_ to stack. Alternative may be to
3040 * switch stack to @_, and copy return values
3041 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3042 AV * const av = GvAV(PL_defgv);
3043 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
3044
3045 if (items) {
3046 /* Mark is at the end of the stack. */
3047 EXTEND(SP, items);
3048 Copy(AvARRAY(av), SP + 1, items, SV*);
3049 SP += items;
3050 PUTBACK ;
3051 }
3052 }
3053 /* We assume first XSUB in &DB::sub is the called one. */
3054 if (PL_curcopdb) {
3055 SAVEVPTR(PL_curcop);
3056 PL_curcop = PL_curcopdb;
3057 PL_curcopdb = NULL;
3058 }
3059 /* Do we need to open block here? XXXX */
72df79cf 3060
3061 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3062 assert(CvXSUB(cv));
16c91539 3063 CvXSUB(cv)(aTHX_ cv);
3a76ca88
RGS
3064
3065 /* Enforce some sanity in scalar context. */
3066 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
3067 if (markix > PL_stack_sp - PL_stack_base)
3068 *(PL_stack_base + markix) = &PL_sv_undef;
3069 else
3070 *(PL_stack_base + markix) = *PL_stack_sp;
3071 PL_stack_sp = PL_stack_base + markix;
3072 }
a57c6685 3073 LEAVE;
f1025168
NC
3074 return NORMAL;
3075 }
a0d0e21e
LW
3076}
3077
44a8e56a 3078void
864dbfa3 3079Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 3080{
7918f24d
NC
3081 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3082
44a8e56a 3083 if (CvANON(cv))
9014280d 3084 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a 3085 else {
aec46f14 3086 SV* const tmpstr = sv_newmortal();
6136c704 3087 gv_efullname3(tmpstr, CvGV(cv), NULL);
35c1215d 3088 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
be2597df 3089 SVfARG(tmpstr));
44a8e56a
PP
3090 }
3091}
3092
a0d0e21e
LW
3093PP(pp_aelem)
3094{
97aff369 3095 dVAR; dSP;
a0d0e21e 3096 SV** svp;
a3b680e6 3097 SV* const elemsv = POPs;
d804643f 3098 IV elem = SvIV(elemsv);
502c6561 3099 AV *const av = MUTABLE_AV(POPs);
e1ec3a88
AL
3100 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3101 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
4ad10a0b
VP
3102 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3103 bool preeminent = TRUE;
be6c24e0 3104 SV *sv;
a0d0e21e 3105
e35c1634 3106 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
95b63a38
JH
3107 Perl_warner(aTHX_ packWARN(WARN_MISC),
3108 "Use of reference \"%"SVf"\" as array index",
be2597df 3109 SVfARG(elemsv));
748a9306 3110 if (elem > 0)
fc15ae8f 3111 elem -= CopARYBASE_get(PL_curcop);
a0d0e21e
LW
3112 if (SvTYPE(av) != SVt_PVAV)
3113 RETPUSHUNDEF;
4ad10a0b
VP
3114
3115 if (localizing) {
3116 MAGIC *mg;
3117 HV *stash;
3118
3119 /* If we can determine whether the element exist,
3120 * Try to preserve the existenceness of a tied array
3121 * element by using EXISTS and DELETE if possible.
3122 * Fallback to FETCH and STORE otherwise. */
3123 if (SvCANEXISTDELETE(av))
3124 preeminent = av_exists(av, elem);
3125 }
3126
68dc0745 3127 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 3128 if (lval) {
2b573ace 3129#ifdef PERL_MALLOC_WRAP
2b573ace 3130 if (SvUOK(elemsv)) {
a9c4fd4e 3131 const UV uv = SvUV(elemsv);
2b573ace
JH
3132 elem = uv > IV_MAX ? IV_MAX : uv;
3133 }
3134 else if (SvNOK(elemsv))
3135 elem = (IV)SvNV(elemsv);
a3b680e6
AL
3136 if (elem > 0) {
3137 static const char oom_array_extend[] =
3138 "Out of memory during array extend"; /* Duplicated in av.c */
2b573ace 3139 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
a3b680e6 3140 }
2b573ace 3141#endif
3280af22 3142 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
3143 SV* lv;
3144 if (!defer)
cea2e8a9 3145 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
3146 lv = sv_newmortal();
3147 sv_upgrade(lv, SVt_PVLV);
3148 LvTYPE(lv) = 'y';
a0714e2c 3149 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
b37c2d43 3150 LvTARG(lv) = SvREFCNT_inc_simple(av);
68dc0745
PP
3151 LvTARGOFF(lv) = elem;
3152 LvTARGLEN(lv) = 1;
3153 PUSHs(lv);
3154 RETURN;
3155 }
4ad10a0b
VP
3156 if (localizing) {
3157 if (preeminent)
3158 save_aelem(av, elem, svp);
3159 else
3160 SAVEADELETE(av, elem);
3161 }
533c011a
NIS
3162 else if (PL_op->op_private & OPpDEREF)
3163 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 3164 }
3280af22 3165 sv = (svp ? *svp : &PL_sv_undef);
39cf747a 3166 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
fd69380d 3167 mg_get(sv);
be6c24e0 3168 PUSHs(sv);
a0d0e21e
LW
3169 RETURN;
3170}
3171
02a9e968 3172void
864dbfa3 3173Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 3174{
7918f24d
NC
3175 PERL_ARGS_ASSERT_VIVIFY_REF;
3176
5b295bef 3177 SvGETMAGIC(sv);
02a9e968
CS
3178 if (!SvOK(sv)) {
3179 if (SvREADONLY(sv))
6ad8f254 3180 Perl_croak_no_modify(aTHX);
43230e26 3181 prepare_SV_for_RV(sv);
68dc0745 3182 switch (to_what) {
5f05dabc 3183 case OPpDEREF_SV:
561b68a9 3184 SvRV_set(sv, newSV(0));
5f05dabc
PP
3185 break;
3186 case OPpDEREF_AV:
ad64d0ec 3187 SvRV_set(sv, MUTABLE_SV(newAV()));
5f05dabc
PP
3188 break;
3189 case OPpDEREF_HV:
ad64d0ec 3190 SvRV_set(sv, MUTABLE_SV(newHV()));
5f05dabc
PP
3191 break;
3192 }
02a9e968
CS
3193 SvROK_on(sv);
3194 SvSETMAGIC(sv);
3195 }
3196}
3197
a0d0e21e
LW
3198PP(pp_method)
3199{
97aff369 3200 dVAR; dSP;
890ce7af 3201 SV* const sv = TOPs;
f5d5a27c
CS
3202
3203 if (SvROK(sv)) {
890ce7af 3204 SV* const rsv = SvRV(sv);
f5d5a27c
CS
3205 if (SvTYPE(rsv) == SVt_PVCV) {
3206 SETs(rsv);
3207 RETURN;
3208 }
3209 }
3210
4608196e 3211 SETs(method_common(sv, NULL));
f5d5a27c
CS
3212 RETURN;
3213}
3214
3215PP(pp_method_named)
3216{
97aff369 3217 dVAR; dSP;
890ce7af 3218 SV* const sv = cSVOP_sv;
c158a4fd 3219 U32 hash = SvSHARED_HASH(sv);
f5d5a27c
CS
3220
3221 XPUSHs(method_common(sv, &hash));
3222 RETURN;
3223}
3224
3225STATIC SV *
3226S_method_common(pTHX_ SV* meth, U32* hashp)
3227{
97aff369 3228 dVAR;
a0d0e21e
LW
3229 SV* ob;
3230 GV* gv;
56304f61 3231 HV* stash;
6136c704 3232 const char* packname = NULL;
a0714e2c 3233 SV *packsv = NULL;
ac91690f 3234 STRLEN packlen;
46c461b5 3235 SV * const sv = *(PL_stack_base + TOPMARK + 1);
f5d5a27c 3236
7918f24d
NC
3237 PERL_ARGS_ASSERT_METHOD_COMMON;
3238
4f1b7578 3239 if (!sv)
a214957f
VP
3240 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3241 SVfARG(meth));
4f1b7578 3242
5b295bef 3243 SvGETMAGIC(sv);
a0d0e21e 3244 if (SvROK(sv))
ad64d0ec 3245 ob = MUTABLE_SV(SvRV(sv));
a0d0e21e
LW
3246 else {
3247 GV* iogv;
a0d0e21e 3248
af09ea45 3249 /* this isn't a reference */
5c144d81 3250 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
b464bac0 3251 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
081fc587 3252 if (he) {
5e6396ae 3253 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
081fc587
AB
3254 goto fetch;
3255 }
3256 }
3257
a0d0e21e 3258 if (!SvOK(sv) ||
05f5af9a 3259 !(packname) ||
f776e3cd 3260 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
ad64d0ec 3261 !(ob=MUTABLE_SV(GvIO(iogv))))
a0d0e21e 3262 {
af09ea45 3263 /* this isn't the name of a filehandle either */
1c846c1f 3264 if (!packname ||
fd400ab9 3265 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
b86a2fa7 3266 ? !isIDFIRST_utf8((U8*)packname)
834a4ddd
LW
3267 : !isIDFIRST(*packname)
3268 ))
3269 {
a214957f
VP
3270 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3271 SVfARG(meth),
f5d5a27c
CS
3272 SvOK(sv) ? "without a package or object reference"
3273 : "on an undefined value");
834a4ddd 3274 }
af09ea45 3275 /* assume it's a package name */
da51bb9b 3276 stash = gv_stashpvn(packname, packlen, 0);
0dae17bd
GS
3277 if (!stash)
3278 packsv = sv;
081fc587 3279 else {
d4c19fe8 3280 SV* const ref = newSViv(PTR2IV(stash));
04fe65b0 3281 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
7e8961ec 3282 }
ac91690f 3283 goto fetch;
a0d0e21e 3284 }
af09ea45 3285 /* it _is_ a filehandle name -- replace with a reference */
ad64d0ec 3286 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
a0d0e21e
LW
3287 }
3288
af09ea45 3289 /* if we got here, ob should be a reference or a glob */
f0d43078 3290 if (!ob || !(SvOBJECT(ob)
6e592b3a
BM
3291 || (SvTYPE(ob) == SVt_PVGV
3292 && isGV_with_GP(ob)
159b6efe 3293 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
f0d43078
GS
3294 && SvOBJECT(ob))))
3295 {
a214957f 3296 const char * const name = SvPV_nolen_const(meth);
f5d5a27c 3297 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
59e7186f 3298 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
f5d5a27c 3299 name);
f0d43078 3300 }
a0d0e21e 3301
56304f61 3302 stash = SvSTASH(ob);
a0d0e21e 3303
ac91690f 3304 fetch:
af09ea45
IK
3305 /* NOTE: stash may be null, hope hv_fetch_ent and
3306 gv_fetchmethod can cope (it seems they can) */
3307
f5d5a27c
CS
3308 /* shortcut for simple names */
3309 if (hashp) {
b464bac0 3310 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
f5d5a27c 3311 if (he) {
159b6efe 3312 gv = MUTABLE_GV(HeVAL(he));
f5d5a27c 3313 if (isGV(gv) && GvCV(gv) &&
e1a479c5 3314 (!GvCVGEN(gv) || GvCVGEN(gv)
dd69841b 3315 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
ad64d0ec 3316 return MUTABLE_SV(GvCV(gv));
f5d5a27c
CS
3317 }
3318 }
3319
a214957f
VP
3320 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3321 SvPV_nolen_const(meth),
256d1bb2 3322 GV_AUTOLOAD | GV_CROAK);
9b9d0b15 3323
256d1bb2 3324 assert(gv);
9b9d0b15 3325
ad64d0ec 3326 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
a0d0e21e 3327}
241d1a3b
NC
3328
3329/*
3330 * Local variables:
3331 * c-indentation-style: bsd
3332 * c-basic-offset: 4
3333 * indent-tabs-mode: t
3334 * End:
3335 *
37442d52
RGS
3336 * ex: set ts=8 sts=4 sw=4 noet:
3337 */