This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add a new macro SvPV_free() which undoes OOK and free()s the PVX(),
[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{
27da23d5 574 dVAR; 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{
27da23d5 946 dVAR; 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 1446{
27da23d5 1447 dVAR; dSP; dTARGETSTACKED;
a0d0e21e
LW
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{
27da23d5 1645 dVAR; 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{
27da23d5 1755 dVAR; 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 {
8bd4d4c5 2254 SvPV_free(TARG);
ed252734 2255 }
f880fe2f 2256 SvPV_set(TARG, SvPVX(dstr));
748a9306
LW
2257 SvCUR_set(TARG, SvCUR(dstr));
2258 SvLEN_set(TARG, SvLEN(dstr));
f272994b 2259 doutf8 |= DO_UTF8(dstr);
f880fe2f 2260 SvPV_set(dstr, (char*)0);
748a9306
LW
2261 sv_free(dstr);
2262
48c036b1 2263 TAINT_IF(rxtainted & 1);
f878fbec 2264 SPAGAIN;
48c036b1
GS
2265 PUSHs(sv_2mortal(newSViv((I32)iters)));
2266
a0d0e21e 2267 (void)SvPOK_only(TARG);
f272994b 2268 if (doutf8)
60aeb6fd 2269 SvUTF8_on(TARG);
48c036b1 2270 TAINT_IF(rxtainted);
a0d0e21e 2271 SvSETMAGIC(TARG);
9212bbba 2272 SvTAINT(TARG);
4633a7c4 2273 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2274 RETURN;
2275 }
5cd24f17 2276 goto ret_no;
a0d0e21e
LW
2277
2278nope:
1c846c1f 2279ret_no:
8ec5e241 2280 SPAGAIN;
3280af22 2281 PUSHs(&PL_sv_no);
4633a7c4 2282 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2283 RETURN;
2284}
2285
2286PP(pp_grepwhile)
2287{
27da23d5 2288 dVAR; dSP;
a0d0e21e
LW
2289
2290 if (SvTRUEx(POPs))
3280af22
NIS
2291 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2292 ++*PL_markstack_ptr;
a0d0e21e
LW
2293 LEAVE; /* exit inner scope */
2294
2295 /* All done yet? */
3280af22 2296 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2297 I32 items;
54310121 2298 I32 gimme = GIMME_V;
a0d0e21e
LW
2299
2300 LEAVE; /* exit outer scope */
2301 (void)POPMARK; /* pop src */
3280af22 2302 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2303 (void)POPMARK; /* pop dst */
3280af22 2304 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2305 if (gimme == G_SCALAR) {
7cc47870
RGS
2306 if (PL_op->op_private & OPpGREP_LEX) {
2307 SV* sv = sv_newmortal();
2308 sv_setiv(sv, items);
2309 PUSHs(sv);
2310 }
2311 else {
2312 dTARGET;
2313 XPUSHi(items);
2314 }
a0d0e21e 2315 }
54310121
PP
2316 else if (gimme == G_ARRAY)
2317 SP += items;
a0d0e21e
LW
2318 RETURN;
2319 }
2320 else {
2321 SV *src;
2322
2323 ENTER; /* enter inner scope */
1d7c1841 2324 SAVEVPTR(PL_curpm);
a0d0e21e 2325
3280af22 2326 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2327 SvTEMP_off(src);
59f00321
RGS
2328 if (PL_op->op_private & OPpGREP_LEX)
2329 PAD_SVl(PL_op->op_targ) = src;
2330 else
2331 DEFSV = src;
a0d0e21e
LW
2332
2333 RETURNOP(cLOGOP->op_other);
2334 }
2335}
2336
2337PP(pp_leavesub)
2338{
27da23d5 2339 dVAR; dSP;
a0d0e21e
LW
2340 SV **mark;
2341 SV **newsp;
2342 PMOP *newpm;
2343 I32 gimme;
c09156bb 2344 register PERL_CONTEXT *cx;
b0d9ce38 2345 SV *sv;
a0d0e21e
LW
2346
2347 POPBLOCK(cx,newpm);
5dd42e15 2348 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2349
a1f49e72 2350 TAINT_NOT;
a0d0e21e
LW
2351 if (gimme == G_SCALAR) {
2352 MARK = newsp + 1;
a29cdaf0 2353 if (MARK <= SP) {
a8bba7fa 2354 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
2355 if (SvTEMP(TOPs)) {
2356 *MARK = SvREFCNT_inc(TOPs);
2357 FREETMPS;
2358 sv_2mortal(*MARK);
cd06dffe
GS
2359 }
2360 else {
959e3673 2361 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2362 FREETMPS;
959e3673
GS
2363 *MARK = sv_mortalcopy(sv);
2364 SvREFCNT_dec(sv);
a29cdaf0 2365 }
cd06dffe
GS
2366 }
2367 else
a29cdaf0 2368 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
cd06dffe
GS
2369 }
2370 else {
f86702cc 2371 MEXTEND(MARK, 0);
3280af22 2372 *MARK = &PL_sv_undef;
a0d0e21e
LW
2373 }
2374 SP = MARK;
2375 }
54310121 2376 else if (gimme == G_ARRAY) {
f86702cc 2377 for (MARK = newsp + 1; MARK <= SP; MARK++) {
a1f49e72 2378 if (!SvTEMP(*MARK)) {
f86702cc 2379 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2380 TAINT_NOT; /* Each item is independent */
2381 }
f86702cc 2382 }
a0d0e21e 2383 }
f86702cc 2384 PUTBACK;
1c846c1f 2385
5dd42e15
DM
2386 LEAVE;
2387 cxstack_ix--;
b0d9ce38 2388 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2389 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2390
b0d9ce38 2391 LEAVESUB(sv);
f39bc417 2392 return cx->blk_sub.retop;
a0d0e21e
LW
2393}
2394
cd06dffe
GS
2395/* This duplicates the above code because the above code must not
2396 * get any slower by more conditions */
2397PP(pp_leavesublv)
2398{
27da23d5 2399 dVAR; dSP;
cd06dffe
GS
2400 SV **mark;
2401 SV **newsp;
2402 PMOP *newpm;
2403 I32 gimme;
2404 register PERL_CONTEXT *cx;
b0d9ce38 2405 SV *sv;
cd06dffe
GS
2406
2407 POPBLOCK(cx,newpm);
5dd42e15 2408 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2409
cd06dffe
GS
2410 TAINT_NOT;
2411
2412 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2413 /* We are an argument to a function or grep().
2414 * This kind of lvalueness was legal before lvalue
2415 * subroutines too, so be backward compatible:
2416 * cannot report errors. */
2417
2418 /* Scalar context *is* possible, on the LHS of -> only,
2419 * as in f()->meth(). But this is not an lvalue. */
2420 if (gimme == G_SCALAR)
2421 goto temporise;
2422 if (gimme == G_ARRAY) {
a8bba7fa 2423 if (!CvLVALUE(cx->blk_sub.cv))
cd06dffe
GS
2424 goto temporise_array;
2425 EXTEND_MORTAL(SP - newsp);
2426 for (mark = newsp + 1; mark <= SP; mark++) {
2427 if (SvTEMP(*mark))
2428 /* empty */ ;
2429 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2430 *mark = sv_mortalcopy(*mark);
2431 else {
2432 /* Can be a localized value subject to deletion. */
2433 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2434 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2435 }
2436 }
2437 }
2438 }
2439 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2440 /* Here we go for robustness, not for speed, so we change all
2441 * the refcounts so the caller gets a live guy. Cannot set
2442 * TEMP, so sv_2mortal is out of question. */
a8bba7fa 2443 if (!CvLVALUE(cx->blk_sub.cv)) {
5dd42e15
DM
2444 LEAVE;
2445 cxstack_ix--;
b0d9ce38 2446 POPSUB(cx,sv);
d470f89e 2447 PL_curpm = newpm;
b0d9ce38 2448 LEAVESUB(sv);
d470f89e
GS
2449 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2450 }
cd06dffe
GS
2451 if (gimme == G_SCALAR) {
2452 MARK = newsp + 1;
2453 EXTEND_MORTAL(1);
2454 if (MARK == SP) {
d470f89e 2455 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
5dd42e15
DM
2456 LEAVE;
2457 cxstack_ix--;
b0d9ce38 2458 POPSUB(cx,sv);
d470f89e 2459 PL_curpm = newpm;
b0d9ce38 2460 LEAVESUB(sv);
e9f19e3c
HS
2461 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2462 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2463 : "a readonly value" : "a temporary");
d470f89e 2464 }
cd06dffe
GS
2465 else { /* Can be a localized value
2466 * subject to deletion. */
2467 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2468 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2469 }
2470 }
d470f89e 2471 else { /* Should not happen? */
5dd42e15
DM
2472 LEAVE;
2473 cxstack_ix--;
b0d9ce38 2474 POPSUB(cx,sv);
d470f89e 2475 PL_curpm = newpm;
b0d9ce38 2476 LEAVESUB(sv);
d470f89e 2477 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
cd06dffe 2478 (MARK > SP ? "Empty array" : "Array"));
d470f89e 2479 }
cd06dffe
GS
2480 SP = MARK;
2481 }
2482 else if (gimme == G_ARRAY) {
2483 EXTEND_MORTAL(SP - newsp);
2484 for (mark = newsp + 1; mark <= SP; mark++) {
f206cdda
AMS
2485 if (*mark != &PL_sv_undef
2486 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
d470f89e
GS
2487 /* Might be flattened array after $#array = */
2488 PUTBACK;
5dd42e15
DM
2489 LEAVE;
2490 cxstack_ix--;
b0d9ce38 2491 POPSUB(cx,sv);
d470f89e 2492 PL_curpm = newpm;
b0d9ce38 2493 LEAVESUB(sv);
f206cdda
AMS
2494 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2495 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2496 }
cd06dffe 2497 else {
cd06dffe
GS
2498 /* Can be a localized value subject to deletion. */
2499 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2500 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2501 }
2502 }
2503 }
2504 }
2505 else {
2506 if (gimme == G_SCALAR) {
2507 temporise:
2508 MARK = newsp + 1;
2509 if (MARK <= SP) {
a8bba7fa 2510 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
cd06dffe
GS
2511 if (SvTEMP(TOPs)) {
2512 *MARK = SvREFCNT_inc(TOPs);
2513 FREETMPS;
2514 sv_2mortal(*MARK);
2515 }
2516 else {
959e3673 2517 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
cd06dffe 2518 FREETMPS;
959e3673
GS
2519 *MARK = sv_mortalcopy(sv);
2520 SvREFCNT_dec(sv);
cd06dffe
GS
2521 }
2522 }
2523 else
2524 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2525 }
2526 else {
2527 MEXTEND(MARK, 0);
2528 *MARK = &PL_sv_undef;
2529 }
2530 SP = MARK;
2531 }
2532 else if (gimme == G_ARRAY) {
2533 temporise_array:
2534 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2535 if (!SvTEMP(*MARK)) {
2536 *MARK = sv_mortalcopy(*MARK);
2537 TAINT_NOT; /* Each item is independent */
2538 }
2539 }
2540 }
2541 }
2542 PUTBACK;
1c846c1f 2543
5dd42e15
DM
2544 LEAVE;
2545 cxstack_ix--;
b0d9ce38 2546 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
cd06dffe
GS
2547 PL_curpm = newpm; /* ... and pop $1 et al */
2548
b0d9ce38 2549 LEAVESUB(sv);
f39bc417 2550 return cx->blk_sub.retop;
cd06dffe
GS
2551}
2552
2553
76e3520e 2554STATIC CV *
cea2e8a9 2555S_get_db_sub(pTHX_ SV **svp, CV *cv)
3de9ffa1 2556{
3280af22 2557 SV *dbsv = GvSV(PL_DBsub);
491527d0 2558
f398eb67 2559 save_item(dbsv);
491527d0
GS
2560 if (!PERLDB_SUB_NN) {
2561 GV *gv = CvGV(cv);
2562
491527d0 2563 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
1c846c1f 2564 || strEQ(GvNAME(gv), "END")
491527d0
GS
2565 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2566 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2567 && (gv = (GV*)*svp) ))) {
2568 /* Use GV from the stack as a fallback. */
2569 /* GV is potentially non-unique, or contain different CV. */
c2e66d9e
GS
2570 SV *tmp = newRV((SV*)cv);
2571 sv_setsv(dbsv, tmp);
2572 SvREFCNT_dec(tmp);
491527d0
GS
2573 }
2574 else {
2575 gv_efullname3(dbsv, gv, Nullch);
2576 }
3de9ffa1
MB
2577 }
2578 else {
a9c4fd4e 2579 const int type = SvTYPE(dbsv);
f398eb67
NC
2580 if (type < SVt_PVIV && type != SVt_IV)
2581 sv_upgrade(dbsv, SVt_PVIV);
155aba94 2582 (void)SvIOK_on(dbsv);
45977657 2583 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
3de9ffa1 2584 }
491527d0 2585
3de9ffa1 2586 if (CvXSUB(cv))
3280af22
NIS
2587 PL_curcopdb = PL_curcop;
2588 cv = GvCV(PL_DBsub);
3de9ffa1
MB
2589 return cv;
2590}
2591
a0d0e21e
LW
2592PP(pp_entersub)
2593{
27da23d5 2594 dVAR; dSP; dPOPss;
a0d0e21e
LW
2595 GV *gv;
2596 HV *stash;
2597 register CV *cv;
c09156bb 2598 register PERL_CONTEXT *cx;
5d94fbed 2599 I32 gimme;
a9c4fd4e 2600 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2601
2602 if (!sv)
cea2e8a9 2603 DIE(aTHX_ "Not a CODE reference");
a0d0e21e 2604 switch (SvTYPE(sv)) {
f1025168
NC
2605 /* This is overwhelming the most common case: */
2606 case SVt_PVGV:
2607 if (!(cv = GvCVu((GV*)sv)))
2608 cv = sv_2cv(sv, &stash, &gv, FALSE);
2609 if (!cv) {
2610 ENTER;
2611 SAVETMPS;
2612 goto try_autoload;
2613 }
2614 break;
a0d0e21e
LW
2615 default:
2616 if (!SvROK(sv)) {
a9c4fd4e 2617 const char *sym;
3280af22 2618 if (sv == &PL_sv_yes) { /* unfound import, ignore */
fb73857a 2619 if (hasargs)
3280af22 2620 SP = PL_stack_base + POPMARK;
a0d0e21e 2621 RETURN;
fb73857a 2622 }
15ff848f
CS
2623 if (SvGMAGICAL(sv)) {
2624 mg_get(sv);
f5f1d18e
AMS
2625 if (SvROK(sv))
2626 goto got_rv;
15ff848f
CS
2627 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2628 }
a9c4fd4e
AL
2629 else {
2630 STRLEN n_a;
2d8e6c8d 2631 sym = SvPV(sv, n_a);
a9c4fd4e 2632 }
15ff848f 2633 if (!sym)
cea2e8a9 2634 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2635 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 2636 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
864dbfa3 2637 cv = get_cv(sym, TRUE);
a0d0e21e
LW
2638 break;
2639 }
f5f1d18e 2640 got_rv:
f5284f61
IZ
2641 {
2642 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2643 tryAMAGICunDEREF(to_cv);
2644 }
a0d0e21e
LW
2645 cv = (CV*)SvRV(sv);
2646 if (SvTYPE(cv) == SVt_PVCV)
2647 break;
2648 /* FALL THROUGH */
2649 case SVt_PVHV:
2650 case SVt_PVAV:
cea2e8a9 2651 DIE(aTHX_ "Not a CODE reference");
f1025168 2652 /* This is the second most common case: */
a0d0e21e
LW
2653 case SVt_PVCV:
2654 cv = (CV*)sv;
2655 break;
a0d0e21e
LW
2656 }
2657
2658 ENTER;
2659 SAVETMPS;
2660
2661 retry:
a0d0e21e 2662 if (!CvROOT(cv) && !CvXSUB(cv)) {
f1025168 2663 goto fooey;
a0d0e21e
LW
2664 }
2665
54310121 2666 gimme = GIMME_V;
67caa1fe 2667 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
06492da6
SF
2668 if (CvASSERTION(cv) && PL_DBassertion)
2669 sv_setiv(PL_DBassertion, 1);
2670
4f01c5a5 2671 cv = get_db_sub(&sv, cv);
ccafdc96
RGS
2672 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2673 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 2674 }
a0d0e21e 2675
f1025168
NC
2676 if (!(CvXSUB(cv))) {
2677 /* This path taken at least 75% of the time */
a0d0e21e
LW
2678 dMARK;
2679 register I32 items = SP - MARK;
a0d0e21e 2680 AV* padlist = CvPADLIST(cv);
a0d0e21e
LW
2681 PUSHBLOCK(cx, CXt_SUB, MARK);
2682 PUSHSUB(cx);
f39bc417 2683 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 2684 CvDEPTH(cv)++;
6b35e009
GS
2685 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2686 * that eval'' ops within this sub know the correct lexical space.
a3985cdc
DM
2687 * Owing the speed considerations, we choose instead to search for
2688 * the cv using find_runcv() when calling doeval().
6b35e009 2689 */
b36bdeca 2690 if (CvDEPTH(cv) >= 2) {
1d7c1841 2691 PERL_STACK_OVERFLOW_CHECK();
26019298 2692 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2693 }
dd2155a4 2694 PAD_SET_CUR(padlist, CvDEPTH(cv));
6d4ff0d2 2695 if (hasargs)
6d4ff0d2
MB
2696 {
2697 AV* av;
a0d0e21e
LW
2698 SV** ary;
2699
77a005ab 2700#if 0
bf49b057 2701 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2702 "%p entersub preparing @_\n", thr));
77a005ab 2703#endif
dd2155a4 2704 av = (AV*)PAD_SVl(0);
221373f0
GS
2705 if (AvREAL(av)) {
2706 /* @_ is normally not REAL--this should only ever
2707 * happen when DB::sub() calls things that modify @_ */
2708 av_clear(av);
2709 AvREAL_off(av);
2710 AvREIFY_on(av);
2711 }
3280af22
NIS
2712 cx->blk_sub.savearray = GvAV(PL_defgv);
2713 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2714 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2715 cx->blk_sub.argarray = av;
a0d0e21e
LW
2716 ++MARK;
2717
2718 if (items > AvMAX(av) + 1) {
2719 ary = AvALLOC(av);
2720 if (AvARRAY(av) != ary) {
2721 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
f880fe2f 2722 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2723 }
2724 if (items > AvMAX(av) + 1) {
2725 AvMAX(av) = items - 1;
2726 Renew(ary,items,SV*);
2727 AvALLOC(av) = ary;
f880fe2f 2728 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2729 }
2730 }
2731 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2732 AvFILLp(av) = items - 1;
1c846c1f 2733
a0d0e21e
LW
2734 while (items--) {
2735 if (*MARK)
2736 SvTEMP_off(*MARK);
2737 MARK++;
2738 }
2739 }
4a925ff6
GS
2740 /* warning must come *after* we fully set up the context
2741 * stuff so that __WARN__ handlers can safely dounwind()
2742 * if they want to
2743 */
2744 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2745 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2746 sub_crush_depth(cv);
77a005ab 2747#if 0
bf49b057 2748 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2749 "%p entersub returning %p\n", thr, CvSTART(cv)));
77a005ab 2750#endif
a0d0e21e
LW
2751 RETURNOP(CvSTART(cv));
2752 }
f1025168
NC
2753 else {
2754#ifdef PERL_XSUB_OLDSTYLE
2755 if (CvOLDSTYLE(cv)) {
2756 I32 (*fp3)(int,int,int);
2757 dMARK;
2758 register I32 items = SP - MARK;
2759 /* We dont worry to copy from @_. */
2760 while (SP > mark) {
2761 SP[1] = SP[0];
2762 SP--;
2763 }
2764 PL_stack_sp = mark + 1;
2765 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2766 items = (*fp3)(CvXSUBANY(cv).any_i32,
2767 MARK - PL_stack_base + 1,
2768 items);
2769 PL_stack_sp = PL_stack_base + items;
2770 }
2771 else
2772#endif /* PERL_XSUB_OLDSTYLE */
2773 {
2774 I32 markix = TOPMARK;
2775
2776 PUTBACK;
2777
2778 if (!hasargs) {
2779 /* Need to copy @_ to stack. Alternative may be to
2780 * switch stack to @_, and copy return values
2781 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2782 AV* av;
2783 I32 items;
2784 av = GvAV(PL_defgv);
2785 items = AvFILLp(av) + 1; /* @_ is not tieable */
2786
2787 if (items) {
2788 /* Mark is at the end of the stack. */
2789 EXTEND(SP, items);
2790 Copy(AvARRAY(av), SP + 1, items, SV*);
2791 SP += items;
2792 PUTBACK ;
2793 }
2794 }
2795 /* We assume first XSUB in &DB::sub is the called one. */
2796 if (PL_curcopdb) {
2797 SAVEVPTR(PL_curcop);
2798 PL_curcop = PL_curcopdb;
2799 PL_curcopdb = NULL;
2800 }
2801 /* Do we need to open block here? XXXX */
2802 (void)(*CvXSUB(cv))(aTHX_ cv);
2803
2804 /* Enforce some sanity in scalar context. */
2805 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2806 if (markix > PL_stack_sp - PL_stack_base)
2807 *(PL_stack_base + markix) = &PL_sv_undef;
2808 else
2809 *(PL_stack_base + markix) = *PL_stack_sp;
2810 PL_stack_sp = PL_stack_base + markix;
2811 }
2812 }
2813 LEAVE;
2814 return NORMAL;
2815 }
2816
2817 assert (0); /* Cannot get here. */
2818 /* This is deliberately moved here as spaghetti code to keep it out of the
2819 hot path. */
2820 {
2821 GV* autogv;
2822 SV* sub_name;
2823
2824 fooey:
2825 /* anonymous or undef'd function leaves us no recourse */
2826 if (CvANON(cv) || !(gv = CvGV(cv)))
2827 DIE(aTHX_ "Undefined subroutine called");
2828
2829 /* autoloaded stub? */
2830 if (cv != GvCV(gv)) {
2831 cv = GvCV(gv);
2832 }
2833 /* should call AUTOLOAD now? */
2834 else {
2835try_autoload:
2836 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2837 FALSE)))
2838 {
2839 cv = GvCV(autogv);
2840 }
2841 /* sorry */
2842 else {
2843 sub_name = sv_newmortal();
2844 gv_efullname3(sub_name, gv, Nullch);
35c1215d 2845 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
f1025168
NC
2846 }
2847 }
2848 if (!cv)
2849 DIE(aTHX_ "Not a CODE reference");
2850 goto retry;
2851 }
a0d0e21e
LW
2852}
2853
44a8e56a 2854void
864dbfa3 2855Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a
PP
2856{
2857 if (CvANON(cv))
9014280d 2858 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a
PP
2859 else {
2860 SV* tmpstr = sv_newmortal();
2861 gv_efullname3(tmpstr, CvGV(cv), Nullch);
35c1215d
NC
2862 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2863 tmpstr);
44a8e56a
PP
2864 }
2865}
2866
a0d0e21e
LW
2867PP(pp_aelem)
2868{
39644a26 2869 dSP;
a0d0e21e 2870 SV** svp;
d804643f
SC
2871 SV* elemsv = POPs;
2872 IV elem = SvIV(elemsv);
68dc0745 2873 AV* av = (AV*)POPs;
e1ec3a88
AL
2874 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2875 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
be6c24e0 2876 SV *sv;
a0d0e21e 2877
e35c1634 2878 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
35c1215d 2879 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
748a9306 2880 if (elem > 0)
3280af22 2881 elem -= PL_curcop->cop_arybase;
a0d0e21e
LW
2882 if (SvTYPE(av) != SVt_PVAV)
2883 RETPUSHUNDEF;
68dc0745 2884 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2885 if (lval) {
2b573ace
JH
2886#ifdef PERL_MALLOC_WRAP
2887 static const char oom_array_extend[] =
2888 "Out of memory during array extend"; /* Duplicated in av.c */
2889 if (SvUOK(elemsv)) {
a9c4fd4e 2890 const UV uv = SvUV(elemsv);
2b573ace
JH
2891 elem = uv > IV_MAX ? IV_MAX : uv;
2892 }
2893 else if (SvNOK(elemsv))
2894 elem = (IV)SvNV(elemsv);
2895 if (elem > 0)
2896 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2897#endif
3280af22 2898 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
2899 SV* lv;
2900 if (!defer)
cea2e8a9 2901 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
2902 lv = sv_newmortal();
2903 sv_upgrade(lv, SVt_PVLV);
2904 LvTYPE(lv) = 'y';
14befaf4 2905 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
68dc0745
PP
2906 LvTARG(lv) = SvREFCNT_inc(av);
2907 LvTARGOFF(lv) = elem;
2908 LvTARGLEN(lv) = 1;
2909 PUSHs(lv);
2910 RETURN;
2911 }
bfc4de9f 2912 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2913 save_aelem(av, elem, svp);
533c011a
NIS
2914 else if (PL_op->op_private & OPpDEREF)
2915 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 2916 }
3280af22 2917 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
2918 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2919 sv = sv_mortalcopy(sv);
2920 PUSHs(sv);
a0d0e21e
LW
2921 RETURN;
2922}
2923
02a9e968 2924void
864dbfa3 2925Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968
CS
2926{
2927 if (SvGMAGICAL(sv))
2928 mg_get(sv);
2929 if (!SvOK(sv)) {
2930 if (SvREADONLY(sv))
cea2e8a9 2931 Perl_croak(aTHX_ PL_no_modify);
5f05dabc
PP
2932 if (SvTYPE(sv) < SVt_RV)
2933 sv_upgrade(sv, SVt_RV);
2934 else if (SvTYPE(sv) >= SVt_PV) {
8bd4d4c5 2935 SvPV_free(sv);
b162af07
SP
2936 SvLEN_set(sv, 0);
2937 SvCUR_set(sv, 0);
5f05dabc 2938 }
68dc0745 2939 switch (to_what) {
5f05dabc 2940 case OPpDEREF_SV:
b162af07 2941 SvRV_set(sv, NEWSV(355,0));
5f05dabc
PP
2942 break;
2943 case OPpDEREF_AV:
b162af07 2944 SvRV_set(sv, (SV*)newAV());
5f05dabc
PP
2945 break;
2946 case OPpDEREF_HV:
b162af07 2947 SvRV_set(sv, (SV*)newHV());
5f05dabc
PP
2948 break;
2949 }
02a9e968
CS
2950 SvROK_on(sv);
2951 SvSETMAGIC(sv);
2952 }
2953}
2954
a0d0e21e
LW
2955PP(pp_method)
2956{
39644a26 2957 dSP;
f5d5a27c
CS
2958 SV* sv = TOPs;
2959
2960 if (SvROK(sv)) {
eda383f2 2961 SV* rsv = SvRV(sv);
f5d5a27c
CS
2962 if (SvTYPE(rsv) == SVt_PVCV) {
2963 SETs(rsv);
2964 RETURN;
2965 }
2966 }
2967
2968 SETs(method_common(sv, Null(U32*)));
2969 RETURN;
2970}
2971
2972PP(pp_method_named)
2973{
39644a26 2974 dSP;
3848b962 2975 SV* sv = cSVOP_sv;
f5d5a27c
CS
2976 U32 hash = SvUVX(sv);
2977
2978 XPUSHs(method_common(sv, &hash));
2979 RETURN;
2980}
2981
2982STATIC SV *
2983S_method_common(pTHX_ SV* meth, U32* hashp)
2984{
a0d0e21e
LW
2985 SV* sv;
2986 SV* ob;
2987 GV* gv;
56304f61 2988 HV* stash;
f5d5a27c 2989 STRLEN namelen;
a9c4fd4e 2990 const char* packname = 0;
0dae17bd 2991 SV *packsv = Nullsv;
ac91690f 2992 STRLEN packlen;
a9c4fd4e 2993 const char *name = SvPV(meth, namelen);
a0d0e21e 2994
3280af22 2995 sv = *(PL_stack_base + TOPMARK + 1);
f5d5a27c 2996
4f1b7578
SC
2997 if (!sv)
2998 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2999
16d20bd9 3000 if (SvGMAGICAL(sv))
af09ea45 3001 mg_get(sv);
a0d0e21e 3002 if (SvROK(sv))
16d20bd9 3003 ob = (SV*)SvRV(sv);
a0d0e21e
LW
3004 else {
3005 GV* iogv;
a0d0e21e 3006
af09ea45 3007 /* this isn't a reference */
56304f61 3008 packname = Nullch;
081fc587
AB
3009
3010 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
7e8961ec
AB
3011 HE* he;
3012 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
081fc587 3013 if (he) {
5e6396ae 3014 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
081fc587
AB
3015 goto fetch;
3016 }
3017 }
3018
a0d0e21e 3019 if (!SvOK(sv) ||
05f5af9a 3020 !(packname) ||
7a5fd60d 3021 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
a0d0e21e
LW
3022 !(ob=(SV*)GvIO(iogv)))
3023 {
af09ea45 3024 /* this isn't the name of a filehandle either */
1c846c1f 3025 if (!packname ||
fd400ab9 3026 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
b86a2fa7 3027 ? !isIDFIRST_utf8((U8*)packname)
834a4ddd
LW
3028 : !isIDFIRST(*packname)
3029 ))
3030 {
f5d5a27c
CS
3031 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3032 SvOK(sv) ? "without a package or object reference"
3033 : "on an undefined value");
834a4ddd 3034 }
af09ea45
IK
3035 /* assume it's a package name */
3036 stash = gv_stashpvn(packname, packlen, FALSE);
0dae17bd
GS
3037 if (!stash)
3038 packsv = sv;
081fc587 3039 else {
5e6396ae 3040 SV* ref = newSViv(PTR2IV(stash));
7e8961ec
AB
3041 hv_store(PL_stashcache, packname, packlen, ref, 0);
3042 }
ac91690f 3043 goto fetch;
a0d0e21e 3044 }
af09ea45 3045 /* it _is_ a filehandle name -- replace with a reference */
3280af22 3046 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
a0d0e21e
LW
3047 }
3048
af09ea45 3049 /* if we got here, ob should be a reference or a glob */
f0d43078
GS
3050 if (!ob || !(SvOBJECT(ob)
3051 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3052 && SvOBJECT(ob))))
3053 {
f5d5a27c
CS
3054 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3055 name);
f0d43078 3056 }
a0d0e21e 3057
56304f61 3058 stash = SvSTASH(ob);
a0d0e21e 3059
ac91690f 3060 fetch:
af09ea45
IK
3061 /* NOTE: stash may be null, hope hv_fetch_ent and
3062 gv_fetchmethod can cope (it seems they can) */
3063
f5d5a27c
CS
3064 /* shortcut for simple names */
3065 if (hashp) {
3066 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3067 if (he) {
3068 gv = (GV*)HeVAL(he);
3069 if (isGV(gv) && GvCV(gv) &&
3070 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3071 return (SV*)GvCV(gv);
3072 }
3073 }
3074
0dae17bd 3075 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
af09ea45 3076
56304f61 3077 if (!gv) {
af09ea45
IK
3078 /* This code tries to figure out just what went wrong with
3079 gv_fetchmethod. It therefore needs to duplicate a lot of
3080 the internals of that function. We can't move it inside
3081 Perl_gv_fetchmethod_autoload(), however, since that would
3082 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3083 don't want that.
3084 */
a9c4fd4e
AL
3085 const char* leaf = name;
3086 const char* sep = Nullch;
3087 const char* p;
56304f61
CS
3088
3089 for (p = name; *p; p++) {
3090 if (*p == '\'')
3091 sep = p, leaf = p + 1;
3092 else if (*p == ':' && *(p + 1) == ':')
3093 sep = p, leaf = p + 2;
3094 }
3095 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
af09ea45
IK
3096 /* the method name is unqualified or starts with SUPER:: */
3097 packname = sep ? CopSTASHPV(PL_curcop) :
3098 stash ? HvNAME(stash) : packname;
e27ad1f2
AV
3099 if (!packname)
3100 Perl_croak(aTHX_
3101 "Can't use anonymous symbol table for method lookup");
3102 else
3103 packlen = strlen(packname);
56304f61
CS
3104 }
3105 else {
af09ea45 3106 /* the method name is qualified */
56304f61
CS
3107 packname = name;
3108 packlen = sep - name;
3109 }
af09ea45
IK
3110
3111 /* we're relying on gv_fetchmethod not autovivifying the stash */
3112 if (gv_stashpvn(packname, packlen, FALSE)) {
c1899e02 3113 Perl_croak(aTHX_
af09ea45
IK
3114 "Can't locate object method \"%s\" via package \"%.*s\"",
3115 leaf, (int)packlen, packname);
c1899e02
GS
3116 }
3117 else {
3118 Perl_croak(aTHX_
af09ea45
IK
3119 "Can't locate object method \"%s\" via package \"%.*s\""
3120 " (perhaps you forgot to load \"%.*s\"?)",
3121 leaf, (int)packlen, packname, (int)packlen, packname);
c1899e02 3122 }
56304f61 3123 }
f5d5a27c 3124 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
a0d0e21e 3125}
241d1a3b
NC
3126
3127/*
3128 * Local variables:
3129 * c-indentation-style: bsd
3130 * c-basic-offset: 4
3131 * indent-tabs-mode: t
3132 * End:
3133 *
edf815fd 3134 * vim: shiftwidth=4:
241d1a3b 3135*/