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