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