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