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