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