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