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