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