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