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