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