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