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