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