This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Bump the version number on Win32::Win32
[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))
c69006e4 175 sv_setpvn(left, "", 0);
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 1711 if (!defer) {
ce5030a2 1712 DIE(aTHX_ PL_no_helem_sv, keysv);
2d8e6c8d 1713 }
68dc0745
PP
1714 lv = sv_newmortal();
1715 sv_upgrade(lv, SVt_PVLV);
1716 LvTYPE(lv) = 'y';
14befaf4 1717 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
68dc0745
PP
1718 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1719 LvTARG(lv) = SvREFCNT_inc(hv);
1720 LvTARGLEN(lv) = 1;
1721 PUSHs(lv);
1722 RETURN;
1723 }
533c011a 1724 if (PL_op->op_private & OPpLVAL_INTRO) {
ae77835f 1725 if (HvNAME(hv) && isGV(*svp))
533c011a 1726 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1f5346dc
SC
1727 else {
1728 if (!preeminent) {
1729 STRLEN keylen;
1730 char *key = SvPV(keysv, keylen);
57813020 1731 SAVEDELETE(hv, savepvn(key,keylen), keylen);
bfc4de9f 1732 } else
1f5346dc
SC
1733 save_helem(hv, keysv, svp);
1734 }
5f05dabc 1735 }
533c011a
NIS
1736 else if (PL_op->op_private & OPpDEREF)
1737 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 1738 }
3280af22 1739 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
1740 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1741 * Pushing the magical RHS on to the stack is useless, since
1742 * that magic is soon destined to be misled by the local(),
1743 * and thus the later pp_sassign() will fail to mg_get() the
1744 * old value. This should also cure problems with delayed
1745 * mg_get()s. GSAR 98-07-03 */
1746 if (!lval && SvGMAGICAL(sv))
1747 sv = sv_mortalcopy(sv);
1748 PUSHs(sv);
a0d0e21e
LW
1749 RETURN;
1750}
1751
1752PP(pp_leave)
1753{
27da23d5 1754 dVAR; dSP;
c09156bb 1755 register PERL_CONTEXT *cx;
a0d0e21e
LW
1756 register SV **mark;
1757 SV **newsp;
1758 PMOP *newpm;
1759 I32 gimme;
1760
533c011a 1761 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1762 cx = &cxstack[cxstack_ix];
3280af22 1763 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
a0d0e21e
LW
1764 }
1765
1766 POPBLOCK(cx,newpm);
1767
533c011a 1768 gimme = OP_GIMME(PL_op, -1);
54310121
PP
1769 if (gimme == -1) {
1770 if (cxstack_ix >= 0)
1771 gimme = cxstack[cxstack_ix].blk_gimme;
1772 else
1773 gimme = G_SCALAR;
1774 }
a0d0e21e 1775
a1f49e72 1776 TAINT_NOT;
54310121
PP
1777 if (gimme == G_VOID)
1778 SP = newsp;
1779 else if (gimme == G_SCALAR) {
1780 MARK = newsp + 1;
09256e2f 1781 if (MARK <= SP) {
54310121
PP
1782 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1783 *MARK = TOPs;
1784 else
1785 *MARK = sv_mortalcopy(TOPs);
09256e2f 1786 } else {
54310121 1787 MEXTEND(mark,0);
3280af22 1788 *MARK = &PL_sv_undef;
a0d0e21e 1789 }
54310121 1790 SP = MARK;
a0d0e21e 1791 }
54310121 1792 else if (gimme == G_ARRAY) {
a1f49e72
CS
1793 /* in case LEAVE wipes old return values */
1794 for (mark = newsp + 1; mark <= SP; mark++) {
1795 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 1796 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
1797 TAINT_NOT; /* Each item is independent */
1798 }
1799 }
a0d0e21e 1800 }
3280af22 1801 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW
1802
1803 LEAVE;
1804
1805 RETURN;
1806}
1807
1808PP(pp_iter)
1809{
39644a26 1810 dSP;
c09156bb 1811 register PERL_CONTEXT *cx;
dc09a129 1812 SV *sv, *oldsv;
4633a7c4 1813 AV* av;
1d7c1841 1814 SV **itersvp;
a0d0e21e 1815
924508f0 1816 EXTEND(SP, 1);
a0d0e21e 1817 cx = &cxstack[cxstack_ix];
6b35e009 1818 if (CxTYPE(cx) != CXt_LOOP)
cea2e8a9 1819 DIE(aTHX_ "panic: pp_iter");
a0d0e21e 1820
1d7c1841 1821 itersvp = CxITERVAR(cx);
4633a7c4 1822 av = cx->blk_loop.iterary;
89ea2908
GA
1823 if (SvTYPE(av) != SVt_PVAV) {
1824 /* iterate ($min .. $max) */
1825 if (cx->blk_loop.iterlval) {
1826 /* string increment */
1827 register SV* cur = cx->blk_loop.iterlval;
4fe3f0fa 1828 STRLEN maxlen = 0;
e1ec3a88 1829 const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
89ea2908 1830 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1d7c1841 1831 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1832 /* safe to reuse old SV */
1d7c1841 1833 sv_setsv(*itersvp, cur);
eaa5c2d6 1834 }
1c846c1f 1835 else
eaa5c2d6
GA
1836 {
1837 /* we need a fresh SV every time so that loop body sees a
1838 * completely new SV for closures/references to work as
1839 * they used to */
dc09a129 1840 oldsv = *itersvp;
1d7c1841 1841 *itersvp = newSVsv(cur);
dc09a129 1842 SvREFCNT_dec(oldsv);
eaa5c2d6 1843 }
89ea2908
GA
1844 if (strEQ(SvPVX(cur), max))
1845 sv_setiv(cur, 0); /* terminate next time */
1846 else
1847 sv_inc(cur);
1848 RETPUSHYES;
1849 }
1850 RETPUSHNO;
1851 }
1852 /* integer increment */
1853 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1854 RETPUSHNO;
7f61b687 1855
3db8f154 1856 /* don't risk potential race */
1d7c1841 1857 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1858 /* safe to reuse old SV */
1d7c1841 1859 sv_setiv(*itersvp, cx->blk_loop.iterix++);
eaa5c2d6 1860 }
1c846c1f 1861 else
eaa5c2d6
GA
1862 {
1863 /* we need a fresh SV every time so that loop body sees a
1864 * completely new SV for closures/references to work as they
1865 * used to */
dc09a129 1866 oldsv = *itersvp;
1d7c1841 1867 *itersvp = newSViv(cx->blk_loop.iterix++);
dc09a129 1868 SvREFCNT_dec(oldsv);
eaa5c2d6 1869 }
89ea2908
GA
1870 RETPUSHYES;
1871 }
1872
1873 /* iterate array */
ef3e5ea9
NC
1874 if (PL_op->op_private & OPpITER_REVERSED) {
1875 /* In reverse, use itermax as the min :-) */
c491ecac 1876 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
ef3e5ea9 1877 RETPUSHNO;
a0d0e21e 1878
ef3e5ea9
NC
1879 if (SvMAGICAL(av) || AvREIFY(av)) {
1880 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1881 if (svp)
1882 sv = *svp;
1883 else
1884 sv = Nullsv;
1885 }
1886 else {
1887 sv = AvARRAY(av)[cx->blk_loop.iterix--];
1888 }
d42935ef
JH
1889 }
1890 else {
ef3e5ea9
NC
1891 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1892 AvFILL(av)))
1893 RETPUSHNO;
1894
1895 if (SvMAGICAL(av) || AvREIFY(av)) {
1896 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1897 if (svp)
1898 sv = *svp;
1899 else
1900 sv = Nullsv;
1901 }
1902 else {
1903 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1904 }
d42935ef 1905 }
ef3e5ea9 1906
cccede53
DM
1907 if (sv && SvREFCNT(sv) == 0) {
1908 *itersvp = Nullsv;
b6c83531 1909 Perl_croak(aTHX_ "Use of freed value in iteration");
cccede53
DM
1910 }
1911
d42935ef 1912 if (sv)
a0d0e21e 1913 SvTEMP_off(sv);
a0d0e21e 1914 else
3280af22 1915 sv = &PL_sv_undef;
8b530633 1916 if (av != PL_curstack && sv == &PL_sv_undef) {
5f05dabc 1917 SV *lv = cx->blk_loop.iterlval;
71be2cbc
PP
1918 if (lv && SvREFCNT(lv) > 1) {
1919 SvREFCNT_dec(lv);
1920 lv = Nullsv;
1921 }
5f05dabc
PP
1922 if (lv)
1923 SvREFCNT_dec(LvTARG(lv));
1924 else {
68dc0745 1925 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
5f05dabc 1926 sv_upgrade(lv, SVt_PVLV);
5f05dabc 1927 LvTYPE(lv) = 'y';
14befaf4 1928 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
5f05dabc
PP
1929 }
1930 LvTARG(lv) = SvREFCNT_inc(av);
1931 LvTARGOFF(lv) = cx->blk_loop.iterix;
42718184 1932 LvTARGLEN(lv) = (STRLEN)UV_MAX;
5f05dabc
PP
1933 sv = (SV*)lv;
1934 }
a0d0e21e 1935
dc09a129 1936 oldsv = *itersvp;
1d7c1841 1937 *itersvp = SvREFCNT_inc(sv);
dc09a129
DM
1938 SvREFCNT_dec(oldsv);
1939
a0d0e21e
LW
1940 RETPUSHYES;
1941}
1942
1943PP(pp_subst)
1944{
39644a26 1945 dSP; dTARG;
a0d0e21e
LW
1946 register PMOP *pm = cPMOP;
1947 PMOP *rpm = pm;
1948 register SV *dstr;
1949 register char *s;
1950 char *strend;
1951 register char *m;
1952 char *c;
1953 register char *d;
1954 STRLEN clen;
1955 I32 iters = 0;
1956 I32 maxiters;
1957 register I32 i;
1958 bool once;
71be2cbc 1959 bool rxtainted;
a0d0e21e 1960 char *orig;
22e551b9 1961 I32 r_flags;
aaa362c4 1962 register REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
1963 STRLEN len;
1964 int force_on_match = 0;
3280af22 1965 I32 oldsave = PL_savestack_ix;
792b2c16 1966 STRLEN slen;
f272994b 1967 bool doutf8 = FALSE;
ed252734
NC
1968#ifdef PERL_COPY_ON_WRITE
1969 bool is_cow;
1970#endif
db79b45b 1971 SV *nsv = Nullsv;
a0d0e21e 1972
5cd24f17
PP
1973 /* known replacement string? */
1974 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
533c011a 1975 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1976 TARG = POPs;
59f00321
RGS
1977 else if (PL_op->op_private & OPpTARGET_MY)
1978 GETTARGET;
a0d0e21e 1979 else {
54b9620d 1980 TARG = DEFSV;
a0d0e21e 1981 EXTEND(SP,1);
1c846c1f 1982 }
d9f424b2 1983
ed252734
NC
1984#ifdef PERL_COPY_ON_WRITE
1985 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1986 because they make integers such as 256 "false". */
1987 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1988#else
765f542d
NC
1989 if (SvIsCOW(TARG))
1990 sv_force_normal_flags(TARG,0);
ed252734
NC
1991#endif
1992 if (
1993#ifdef PERL_COPY_ON_WRITE
1994 !is_cow &&
1995#endif
1996 (SvREADONLY(TARG)
4ce457a6
TP
1997 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1998 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
d470f89e 1999 DIE(aTHX_ PL_no_modify);
8ec5e241
NIS
2000 PUTBACK;
2001
a0d0e21e 2002 s = SvPV(TARG, len);
68dc0745 2003 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
a0d0e21e 2004 force_on_match = 1;
b3eb6a9b 2005 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
3280af22
NIS
2006 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2007 if (PL_tainted)
b3eb6a9b 2008 rxtainted |= 2;
9212bbba 2009 TAINT_NOT;
a12c0f56 2010
a30b2f1f 2011 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
d9f424b2 2012
a0d0e21e
LW
2013 force_it:
2014 if (!pm || !s)
2269b42e 2015 DIE(aTHX_ "panic: pp_subst");
a0d0e21e
LW
2016
2017 strend = s + len;
a30b2f1f 2018 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
792b2c16
JH
2019 maxiters = 2 * slen + 10; /* We can match twice at each
2020 position, once with zero-length,
2021 second time with non-zero. */
a0d0e21e 2022
3280af22
NIS
2023 if (!rx->prelen && PL_curpm) {
2024 pm = PL_curpm;
aaa362c4 2025 rx = PM_GETRE(pm);
a0d0e21e 2026 }
22e551b9 2027 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
ed252734 2028 ? REXEC_COPY_STR : 0;
f722798b 2029 if (SvSCREAM(TARG))
22e551b9 2030 r_flags |= REXEC_SCREAM;
7fba1cd6 2031
a0d0e21e 2032 orig = m = s;
f722798b 2033 if (rx->reganch & RE_USE_INTUIT) {
ee0b7718 2034 PL_bostr = orig;
f722798b
IZ
2035 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2036
2037 if (!s)
2038 goto nope;
2039 /* How to do it in subst? */
2040/* if ( (rx->reganch & ROPT_CHECK_ALL)
1c846c1f 2041 && !PL_sawampersand
f722798b
IZ
2042 && ((rx->reganch & ROPT_NOSCAN)
2043 || !((rx->reganch & RE_INTUIT_TAIL)
2044 && (r_flags & REXEC_SCREAM))))
2045 goto yup;
2046*/
a0d0e21e 2047 }
71be2cbc
PP
2048
2049 /* only replace once? */
a0d0e21e 2050 once = !(rpm->op_pmflags & PMf_GLOBAL);
71be2cbc
PP
2051
2052 /* known replacement string? */
f272994b 2053 if (dstr) {
8514a05a
JH
2054 /* replacement needing upgrading? */
2055 if (DO_UTF8(TARG) && !doutf8) {
db79b45b 2056 nsv = sv_newmortal();
4a176938 2057 SvSetSV(nsv, dstr);
8514a05a
JH
2058 if (PL_encoding)
2059 sv_recode_to_utf8(nsv, PL_encoding);
2060 else
2061 sv_utf8_upgrade(nsv);
2062 c = SvPV(nsv, clen);
4a176938
JH
2063 doutf8 = TRUE;
2064 }
2065 else {
2066 c = SvPV(dstr, clen);
2067 doutf8 = DO_UTF8(dstr);
8514a05a 2068 }
f272994b
A
2069 }
2070 else {
2071 c = Nullch;
2072 doutf8 = FALSE;
2073 }
2074
71be2cbc 2075 /* can do inplace substitution? */
ed252734
NC
2076 if (c
2077#ifdef PERL_COPY_ON_WRITE
2078 && !is_cow
2079#endif
2080 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
db79b45b
JH
2081 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2082 && (!doutf8 || SvUTF8(TARG))) {
f722798b
IZ
2083 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2084 r_flags | REXEC_CHECKED))
2085 {
8ec5e241 2086 SPAGAIN;
3280af22 2087 PUSHs(&PL_sv_no);
71be2cbc
PP
2088 LEAVE_SCOPE(oldsave);
2089 RETURN;
2090 }
ed252734
NC
2091#ifdef PERL_COPY_ON_WRITE
2092 if (SvIsCOW(TARG)) {
2093 assert (!force_on_match);
2094 goto have_a_cow;
2095 }
2096#endif
71be2cbc
PP
2097 if (force_on_match) {
2098 force_on_match = 0;
2099 s = SvPV_force(TARG, len);
2100 goto force_it;
2101 }
71be2cbc 2102 d = s;
3280af22 2103 PL_curpm = pm;
71be2cbc
PP
2104 SvSCREAM_off(TARG); /* disable possible screamer */
2105 if (once) {
48c036b1 2106 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d
IZ
2107 m = orig + rx->startp[0];
2108 d = orig + rx->endp[0];
71be2cbc
PP
2109 s = orig;
2110 if (m - s > strend - d) { /* faster to shorten from end */
2111 if (clen) {
2112 Copy(c, m, clen, char);
2113 m += clen;
a0d0e21e 2114 }
71be2cbc
PP
2115 i = strend - d;
2116 if (i > 0) {
2117 Move(d, m, i, char);
2118 m += i;
a0d0e21e 2119 }
71be2cbc
PP
2120 *m = '\0';
2121 SvCUR_set(TARG, m - s);
2122 }
2123 /*SUPPRESS 560*/
155aba94 2124 else if ((i = m - s)) { /* faster from front */
71be2cbc
PP
2125 d -= clen;
2126 m = d;
2127 sv_chop(TARG, d-i);
2128 s += i;
2129 while (i--)
2130 *--d = *--s;
2131 if (clen)
2132 Copy(c, m, clen, char);
2133 }
2134 else if (clen) {
2135 d -= clen;
2136 sv_chop(TARG, d);
2137 Copy(c, d, clen, char);
2138 }
2139 else {
2140 sv_chop(TARG, d);
2141 }
48c036b1 2142 TAINT_IF(rxtainted & 1);
8ec5e241 2143 SPAGAIN;
3280af22 2144 PUSHs(&PL_sv_yes);
71be2cbc
PP
2145 }
2146 else {
71be2cbc
PP
2147 do {
2148 if (iters++ > maxiters)
cea2e8a9 2149 DIE(aTHX_ "Substitution loop");
d9f97599 2150 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 2151 m = rx->startp[0] + orig;
71be2cbc 2152 /*SUPPRESS 560*/
155aba94 2153 if ((i = m - s)) {
71be2cbc
PP
2154 if (s != d)
2155 Move(s, d, i, char);
2156 d += i;
a0d0e21e 2157 }
71be2cbc
PP
2158 if (clen) {
2159 Copy(c, d, clen, char);
2160 d += clen;
2161 }
cf93c79d 2162 s = rx->endp[0] + orig;
cea2e8a9 2163 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
f722798b
IZ
2164 TARG, NULL,
2165 /* don't match same null twice */
2166 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc
PP
2167 if (s != d) {
2168 i = strend - s;
2169 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2170 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2171 }
48c036b1 2172 TAINT_IF(rxtainted & 1);
8ec5e241 2173 SPAGAIN;
71be2cbc 2174 PUSHs(sv_2mortal(newSViv((I32)iters)));
a0d0e21e 2175 }
80b498e0 2176 (void)SvPOK_only_UTF8(TARG);
48c036b1 2177 TAINT_IF(rxtainted);
8ec5e241
NIS
2178 if (SvSMAGICAL(TARG)) {
2179 PUTBACK;
2180 mg_set(TARG);
2181 SPAGAIN;
2182 }
9212bbba 2183 SvTAINT(TARG);
aefe6dfc
JH
2184 if (doutf8)
2185 SvUTF8_on(TARG);
71be2cbc
PP
2186 LEAVE_SCOPE(oldsave);
2187 RETURN;
a0d0e21e 2188 }
71be2cbc 2189
f722798b
IZ
2190 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2191 r_flags | REXEC_CHECKED))
2192 {
a0d0e21e
LW
2193 if (force_on_match) {
2194 force_on_match = 0;
2195 s = SvPV_force(TARG, len);
2196 goto force_it;
2197 }
ed252734
NC
2198#ifdef PERL_COPY_ON_WRITE
2199 have_a_cow:
2200#endif
48c036b1 2201 rxtainted |= RX_MATCH_TAINTED(rx);
f2b990bf 2202 dstr = newSVpvn(m, s-m);
ffc61ed2
JH
2203 if (DO_UTF8(TARG))
2204 SvUTF8_on(dstr);
3280af22 2205 PL_curpm = pm;
a0d0e21e 2206 if (!c) {
c09156bb 2207 register PERL_CONTEXT *cx;
8ec5e241 2208 SPAGAIN;
d8f2cf8a 2209 ReREFCNT_inc(rx);
a0d0e21e
LW
2210 PUSHSUBST(cx);
2211 RETURNOP(cPMOP->op_pmreplroot);
2212 }
cf93c79d 2213 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
2214 do {
2215 if (iters++ > maxiters)
cea2e8a9 2216 DIE(aTHX_ "Substitution loop");
d9f97599 2217 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 2218 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW
2219 m = s;
2220 s = orig;
cf93c79d 2221 orig = rx->subbeg;
a0d0e21e
LW
2222 s = orig + (m - s);
2223 strend = s + (strend - m);
2224 }
cf93c79d 2225 m = rx->startp[0] + orig;
db79b45b
JH
2226 if (doutf8 && !SvUTF8(dstr))
2227 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2228 else
2229 sv_catpvn(dstr, s, m-s);
cf93c79d 2230 s = rx->endp[0] + orig;
a0d0e21e
LW
2231 if (clen)
2232 sv_catpvn(dstr, c, clen);
2233 if (once)
2234 break;
ffc61ed2
JH
2235 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2236 TARG, NULL, r_flags));
db79b45b
JH
2237 if (doutf8 && !DO_UTF8(TARG))
2238 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
89afcb60
A
2239 else
2240 sv_catpvn(dstr, s, strend - s);
748a9306 2241
ed252734
NC
2242#ifdef PERL_COPY_ON_WRITE
2243 /* The match may make the string COW. If so, brilliant, because that's
2244 just saved us one malloc, copy and free - the regexp has donated
2245 the old buffer, and we malloc an entirely new one, rather than the
2246 regexp malloc()ing a buffer and copying our original, only for
2247 us to throw it away here during the substitution. */
2248 if (SvIsCOW(TARG)) {
2249 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2250 } else
2251#endif
2252 {
8bd4d4c5 2253 SvPV_free(TARG);
ed252734 2254 }
f880fe2f 2255 SvPV_set(TARG, SvPVX(dstr));
748a9306
LW
2256 SvCUR_set(TARG, SvCUR(dstr));
2257 SvLEN_set(TARG, SvLEN(dstr));
f272994b 2258 doutf8 |= DO_UTF8(dstr);
f880fe2f 2259 SvPV_set(dstr, (char*)0);
748a9306
LW
2260 sv_free(dstr);
2261
48c036b1 2262 TAINT_IF(rxtainted & 1);
f878fbec 2263 SPAGAIN;
48c036b1
GS
2264 PUSHs(sv_2mortal(newSViv((I32)iters)));
2265
a0d0e21e 2266 (void)SvPOK_only(TARG);
f272994b 2267 if (doutf8)
60aeb6fd 2268 SvUTF8_on(TARG);
48c036b1 2269 TAINT_IF(rxtainted);
a0d0e21e 2270 SvSETMAGIC(TARG);
9212bbba 2271 SvTAINT(TARG);
4633a7c4 2272 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2273 RETURN;
2274 }
5cd24f17 2275 goto ret_no;
a0d0e21e
LW
2276
2277nope:
1c846c1f 2278ret_no:
8ec5e241 2279 SPAGAIN;
3280af22 2280 PUSHs(&PL_sv_no);
4633a7c4 2281 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2282 RETURN;
2283}
2284
2285PP(pp_grepwhile)
2286{
27da23d5 2287 dVAR; dSP;
a0d0e21e
LW
2288
2289 if (SvTRUEx(POPs))
3280af22
NIS
2290 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2291 ++*PL_markstack_ptr;
a0d0e21e
LW
2292 LEAVE; /* exit inner scope */
2293
2294 /* All done yet? */
3280af22 2295 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2296 I32 items;
54310121 2297 I32 gimme = GIMME_V;
a0d0e21e
LW
2298
2299 LEAVE; /* exit outer scope */
2300 (void)POPMARK; /* pop src */
3280af22 2301 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2302 (void)POPMARK; /* pop dst */
3280af22 2303 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2304 if (gimme == G_SCALAR) {
7cc47870
RGS
2305 if (PL_op->op_private & OPpGREP_LEX) {
2306 SV* sv = sv_newmortal();
2307 sv_setiv(sv, items);
2308 PUSHs(sv);
2309 }
2310 else {
2311 dTARGET;
2312 XPUSHi(items);
2313 }
a0d0e21e 2314 }
54310121
PP
2315 else if (gimme == G_ARRAY)
2316 SP += items;
a0d0e21e
LW
2317 RETURN;
2318 }
2319 else {
2320 SV *src;
2321
2322 ENTER; /* enter inner scope */
1d7c1841 2323 SAVEVPTR(PL_curpm);
a0d0e21e 2324
3280af22 2325 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2326 SvTEMP_off(src);
59f00321
RGS
2327 if (PL_op->op_private & OPpGREP_LEX)
2328 PAD_SVl(PL_op->op_targ) = src;
2329 else
2330 DEFSV = src;
a0d0e21e
LW
2331
2332 RETURNOP(cLOGOP->op_other);
2333 }
2334}
2335
2336PP(pp_leavesub)
2337{
27da23d5 2338 dVAR; dSP;
a0d0e21e
LW
2339 SV **mark;
2340 SV **newsp;
2341 PMOP *newpm;
2342 I32 gimme;
c09156bb 2343 register PERL_CONTEXT *cx;
b0d9ce38 2344 SV *sv;
a0d0e21e
LW
2345
2346 POPBLOCK(cx,newpm);
5dd42e15 2347 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2348
a1f49e72 2349 TAINT_NOT;
a0d0e21e
LW
2350 if (gimme == G_SCALAR) {
2351 MARK = newsp + 1;
a29cdaf0 2352 if (MARK <= SP) {
a8bba7fa 2353 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
2354 if (SvTEMP(TOPs)) {
2355 *MARK = SvREFCNT_inc(TOPs);
2356 FREETMPS;
2357 sv_2mortal(*MARK);
cd06dffe
GS
2358 }
2359 else {
959e3673 2360 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2361 FREETMPS;
959e3673
GS
2362 *MARK = sv_mortalcopy(sv);
2363 SvREFCNT_dec(sv);
a29cdaf0 2364 }
cd06dffe
GS
2365 }
2366 else
a29cdaf0 2367 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
cd06dffe
GS
2368 }
2369 else {
f86702cc 2370 MEXTEND(MARK, 0);
3280af22 2371 *MARK = &PL_sv_undef;
a0d0e21e
LW
2372 }
2373 SP = MARK;
2374 }
54310121 2375 else if (gimme == G_ARRAY) {
f86702cc 2376 for (MARK = newsp + 1; MARK <= SP; MARK++) {
a1f49e72 2377 if (!SvTEMP(*MARK)) {
f86702cc 2378 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2379 TAINT_NOT; /* Each item is independent */
2380 }
f86702cc 2381 }
a0d0e21e 2382 }
f86702cc 2383 PUTBACK;
1c846c1f 2384
5dd42e15
DM
2385 LEAVE;
2386 cxstack_ix--;
b0d9ce38 2387 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2388 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2389
b0d9ce38 2390 LEAVESUB(sv);
f39bc417 2391 return cx->blk_sub.retop;
a0d0e21e
LW
2392}
2393
cd06dffe
GS
2394/* This duplicates the above code because the above code must not
2395 * get any slower by more conditions */
2396PP(pp_leavesublv)
2397{
27da23d5 2398 dVAR; dSP;
cd06dffe
GS
2399 SV **mark;
2400 SV **newsp;
2401 PMOP *newpm;
2402 I32 gimme;
2403 register PERL_CONTEXT *cx;
b0d9ce38 2404 SV *sv;
cd06dffe
GS
2405
2406 POPBLOCK(cx,newpm);
5dd42e15 2407 cxstack_ix++; /* temporarily protect top context */
1c846c1f 2408
cd06dffe
GS
2409 TAINT_NOT;
2410
2411 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2412 /* We are an argument to a function or grep().
2413 * This kind of lvalueness was legal before lvalue
2414 * subroutines too, so be backward compatible:
2415 * cannot report errors. */
2416
2417 /* Scalar context *is* possible, on the LHS of -> only,
2418 * as in f()->meth(). But this is not an lvalue. */
2419 if (gimme == G_SCALAR)
2420 goto temporise;
2421 if (gimme == G_ARRAY) {
a8bba7fa 2422 if (!CvLVALUE(cx->blk_sub.cv))
cd06dffe
GS
2423 goto temporise_array;
2424 EXTEND_MORTAL(SP - newsp);
2425 for (mark = newsp + 1; mark <= SP; mark++) {
2426 if (SvTEMP(*mark))
2427 /* empty */ ;
2428 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2429 *mark = sv_mortalcopy(*mark);
2430 else {
2431 /* Can be a localized value subject to deletion. */
2432 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2433 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2434 }
2435 }
2436 }
2437 }
2438 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2439 /* Here we go for robustness, not for speed, so we change all
2440 * the refcounts so the caller gets a live guy. Cannot set
2441 * TEMP, so sv_2mortal is out of question. */
a8bba7fa 2442 if (!CvLVALUE(cx->blk_sub.cv)) {
5dd42e15
DM
2443 LEAVE;
2444 cxstack_ix--;
b0d9ce38 2445 POPSUB(cx,sv);
d470f89e 2446 PL_curpm = newpm;
b0d9ce38 2447 LEAVESUB(sv);
d470f89e
GS
2448 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2449 }
cd06dffe
GS
2450 if (gimme == G_SCALAR) {
2451 MARK = newsp + 1;
2452 EXTEND_MORTAL(1);
2453 if (MARK == SP) {
d470f89e 2454 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
5dd42e15
DM
2455 LEAVE;
2456 cxstack_ix--;
b0d9ce38 2457 POPSUB(cx,sv);
d470f89e 2458 PL_curpm = newpm;
b0d9ce38 2459 LEAVESUB(sv);
e9f19e3c
HS
2460 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2461 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2462 : "a readonly value" : "a temporary");
d470f89e 2463 }
cd06dffe
GS
2464 else { /* Can be a localized value
2465 * subject to deletion. */
2466 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2467 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2468 }
2469 }
d470f89e 2470 else { /* Should not happen? */
5dd42e15
DM
2471 LEAVE;
2472 cxstack_ix--;
b0d9ce38 2473 POPSUB(cx,sv);
d470f89e 2474 PL_curpm = newpm;
b0d9ce38 2475 LEAVESUB(sv);
d470f89e 2476 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
cd06dffe 2477 (MARK > SP ? "Empty array" : "Array"));
d470f89e 2478 }
cd06dffe
GS
2479 SP = MARK;
2480 }
2481 else if (gimme == G_ARRAY) {
2482 EXTEND_MORTAL(SP - newsp);
2483 for (mark = newsp + 1; mark <= SP; mark++) {
f206cdda
AMS
2484 if (*mark != &PL_sv_undef
2485 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
d470f89e
GS
2486 /* Might be flattened array after $#array = */
2487 PUTBACK;
5dd42e15
DM
2488 LEAVE;
2489 cxstack_ix--;
b0d9ce38 2490 POPSUB(cx,sv);
d470f89e 2491 PL_curpm = newpm;
b0d9ce38 2492 LEAVESUB(sv);
f206cdda
AMS
2493 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2494 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2495 }
cd06dffe 2496 else {
cd06dffe
GS
2497 /* Can be a localized value subject to deletion. */
2498 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2499 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2500 }
2501 }
2502 }
2503 }
2504 else {
2505 if (gimme == G_SCALAR) {
2506 temporise:
2507 MARK = newsp + 1;
2508 if (MARK <= SP) {
a8bba7fa 2509 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
cd06dffe
GS
2510 if (SvTEMP(TOPs)) {
2511 *MARK = SvREFCNT_inc(TOPs);
2512 FREETMPS;
2513 sv_2mortal(*MARK);
2514 }
2515 else {
959e3673 2516 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
cd06dffe 2517 FREETMPS;
959e3673
GS
2518 *MARK = sv_mortalcopy(sv);
2519 SvREFCNT_dec(sv);
cd06dffe
GS
2520 }
2521 }
2522 else
2523 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2524 }
2525 else {
2526 MEXTEND(MARK, 0);
2527 *MARK = &PL_sv_undef;
2528 }
2529 SP = MARK;
2530 }
2531 else if (gimme == G_ARRAY) {
2532 temporise_array:
2533 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2534 if (!SvTEMP(*MARK)) {
2535 *MARK = sv_mortalcopy(*MARK);
2536 TAINT_NOT; /* Each item is independent */
2537 }
2538 }
2539 }
2540 }
2541 PUTBACK;
1c846c1f 2542
5dd42e15
DM
2543 LEAVE;
2544 cxstack_ix--;
b0d9ce38 2545 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
cd06dffe
GS
2546 PL_curpm = newpm; /* ... and pop $1 et al */
2547
b0d9ce38 2548 LEAVESUB(sv);
f39bc417 2549 return cx->blk_sub.retop;
cd06dffe
GS
2550}
2551
2552
76e3520e 2553STATIC CV *
cea2e8a9 2554S_get_db_sub(pTHX_ SV **svp, CV *cv)
3de9ffa1 2555{
3280af22 2556 SV *dbsv = GvSV(PL_DBsub);
491527d0 2557
f398eb67 2558 save_item(dbsv);
491527d0
GS
2559 if (!PERLDB_SUB_NN) {
2560 GV *gv = CvGV(cv);
2561
491527d0 2562 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
1c846c1f 2563 || strEQ(GvNAME(gv), "END")
491527d0
GS
2564 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2565 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2566 && (gv = (GV*)*svp) ))) {
2567 /* Use GV from the stack as a fallback. */
2568 /* GV is potentially non-unique, or contain different CV. */
c2e66d9e
GS
2569 SV *tmp = newRV((SV*)cv);
2570 sv_setsv(dbsv, tmp);
2571 SvREFCNT_dec(tmp);
491527d0
GS
2572 }
2573 else {
2574 gv_efullname3(dbsv, gv, Nullch);
2575 }
3de9ffa1
MB
2576 }
2577 else {
a9c4fd4e 2578 const int type = SvTYPE(dbsv);
f398eb67
NC
2579 if (type < SVt_PVIV && type != SVt_IV)
2580 sv_upgrade(dbsv, SVt_PVIV);
155aba94 2581 (void)SvIOK_on(dbsv);
45977657 2582 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
3de9ffa1 2583 }
491527d0 2584
3de9ffa1 2585 if (CvXSUB(cv))
3280af22
NIS
2586 PL_curcopdb = PL_curcop;
2587 cv = GvCV(PL_DBsub);
3de9ffa1
MB
2588 return cv;
2589}
2590
a0d0e21e
LW
2591PP(pp_entersub)
2592{
27da23d5 2593 dVAR; dSP; dPOPss;
a0d0e21e
LW
2594 GV *gv;
2595 HV *stash;
2596 register CV *cv;
c09156bb 2597 register PERL_CONTEXT *cx;
5d94fbed 2598 I32 gimme;
a9c4fd4e 2599 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2600
2601 if (!sv)
cea2e8a9 2602 DIE(aTHX_ "Not a CODE reference");
a0d0e21e 2603 switch (SvTYPE(sv)) {
f1025168
NC
2604 /* This is overwhelming the most common case: */
2605 case SVt_PVGV:
2606 if (!(cv = GvCVu((GV*)sv)))
2607 cv = sv_2cv(sv, &stash, &gv, FALSE);
2608 if (!cv) {
2609 ENTER;
2610 SAVETMPS;
2611 goto try_autoload;
2612 }
2613 break;
a0d0e21e
LW
2614 default:
2615 if (!SvROK(sv)) {
a9c4fd4e 2616 const char *sym;
3280af22 2617 if (sv == &PL_sv_yes) { /* unfound import, ignore */
fb73857a 2618 if (hasargs)
3280af22 2619 SP = PL_stack_base + POPMARK;
a0d0e21e 2620 RETURN;
fb73857a 2621 }
15ff848f
CS
2622 if (SvGMAGICAL(sv)) {
2623 mg_get(sv);
f5f1d18e
AMS
2624 if (SvROK(sv))
2625 goto got_rv;
15ff848f
CS
2626 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2627 }
a9c4fd4e
AL
2628 else {
2629 STRLEN n_a;
2d8e6c8d 2630 sym = SvPV(sv, n_a);
a9c4fd4e 2631 }
15ff848f 2632 if (!sym)
cea2e8a9 2633 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2634 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 2635 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
864dbfa3 2636 cv = get_cv(sym, TRUE);
a0d0e21e
LW
2637 break;
2638 }
f5f1d18e 2639 got_rv:
f5284f61
IZ
2640 {
2641 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2642 tryAMAGICunDEREF(to_cv);
2643 }
a0d0e21e
LW
2644 cv = (CV*)SvRV(sv);
2645 if (SvTYPE(cv) == SVt_PVCV)
2646 break;
2647 /* FALL THROUGH */
2648 case SVt_PVHV:
2649 case SVt_PVAV:
cea2e8a9 2650 DIE(aTHX_ "Not a CODE reference");
f1025168 2651 /* This is the second most common case: */
a0d0e21e
LW
2652 case SVt_PVCV:
2653 cv = (CV*)sv;
2654 break;
a0d0e21e
LW
2655 }
2656
2657 ENTER;
2658 SAVETMPS;
2659
2660 retry:
a0d0e21e 2661 if (!CvROOT(cv) && !CvXSUB(cv)) {
f1025168 2662 goto fooey;
a0d0e21e
LW
2663 }
2664
54310121 2665 gimme = GIMME_V;
67caa1fe 2666 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
06492da6
SF
2667 if (CvASSERTION(cv) && PL_DBassertion)
2668 sv_setiv(PL_DBassertion, 1);
2669
4f01c5a5 2670 cv = get_db_sub(&sv, cv);
ccafdc96
RGS
2671 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2672 DIE(aTHX_ "No DB::sub routine defined");
67caa1fe 2673 }
a0d0e21e 2674
f1025168
NC
2675 if (!(CvXSUB(cv))) {
2676 /* This path taken at least 75% of the time */
a0d0e21e
LW
2677 dMARK;
2678 register I32 items = SP - MARK;
a0d0e21e 2679 AV* padlist = CvPADLIST(cv);
a0d0e21e
LW
2680 PUSHBLOCK(cx, CXt_SUB, MARK);
2681 PUSHSUB(cx);
f39bc417 2682 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 2683 CvDEPTH(cv)++;
6b35e009
GS
2684 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2685 * that eval'' ops within this sub know the correct lexical space.
a3985cdc
DM
2686 * Owing the speed considerations, we choose instead to search for
2687 * the cv using find_runcv() when calling doeval().
6b35e009 2688 */
b36bdeca 2689 if (CvDEPTH(cv) >= 2) {
1d7c1841 2690 PERL_STACK_OVERFLOW_CHECK();
26019298 2691 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2692 }
dd2155a4 2693 PAD_SET_CUR(padlist, CvDEPTH(cv));
6d4ff0d2 2694 if (hasargs)
6d4ff0d2
MB
2695 {
2696 AV* av;
a0d0e21e
LW
2697 SV** ary;
2698
77a005ab 2699#if 0
bf49b057 2700 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2701 "%p entersub preparing @_\n", thr));
77a005ab 2702#endif
dd2155a4 2703 av = (AV*)PAD_SVl(0);
221373f0
GS
2704 if (AvREAL(av)) {
2705 /* @_ is normally not REAL--this should only ever
2706 * happen when DB::sub() calls things that modify @_ */
2707 av_clear(av);
2708 AvREAL_off(av);
2709 AvREIFY_on(av);
2710 }
3280af22
NIS
2711 cx->blk_sub.savearray = GvAV(PL_defgv);
2712 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2713 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2714 cx->blk_sub.argarray = av;
a0d0e21e
LW
2715 ++MARK;
2716
2717 if (items > AvMAX(av) + 1) {
2718 ary = AvALLOC(av);
2719 if (AvARRAY(av) != ary) {
2720 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
f880fe2f 2721 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2722 }
2723 if (items > AvMAX(av) + 1) {
2724 AvMAX(av) = items - 1;
2725 Renew(ary,items,SV*);
2726 AvALLOC(av) = ary;
f880fe2f 2727 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2728 }
2729 }
2730 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2731 AvFILLp(av) = items - 1;
1c846c1f 2732
a0d0e21e
LW
2733 while (items--) {
2734 if (*MARK)
2735 SvTEMP_off(*MARK);
2736 MARK++;
2737 }
2738 }
4a925ff6
GS
2739 /* warning must come *after* we fully set up the context
2740 * stuff so that __WARN__ handlers can safely dounwind()
2741 * if they want to
2742 */
2743 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2744 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2745 sub_crush_depth(cv);
77a005ab 2746#if 0
bf49b057 2747 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2748 "%p entersub returning %p\n", thr, CvSTART(cv)));
77a005ab 2749#endif
a0d0e21e
LW
2750 RETURNOP(CvSTART(cv));
2751 }
f1025168
NC
2752 else {
2753#ifdef PERL_XSUB_OLDSTYLE
2754 if (CvOLDSTYLE(cv)) {
2755 I32 (*fp3)(int,int,int);
2756 dMARK;
2757 register I32 items = SP - MARK;
2758 /* We dont worry to copy from @_. */
2759 while (SP > mark) {
2760 SP[1] = SP[0];
2761 SP--;
2762 }
2763 PL_stack_sp = mark + 1;
2764 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2765 items = (*fp3)(CvXSUBANY(cv).any_i32,
2766 MARK - PL_stack_base + 1,
2767 items);
2768 PL_stack_sp = PL_stack_base + items;
2769 }
2770 else
2771#endif /* PERL_XSUB_OLDSTYLE */
2772 {
2773 I32 markix = TOPMARK;
2774
2775 PUTBACK;
2776
2777 if (!hasargs) {
2778 /* Need to copy @_ to stack. Alternative may be to
2779 * switch stack to @_, and copy return values
2780 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2781 AV* av;
2782 I32 items;
2783 av = GvAV(PL_defgv);
2784 items = AvFILLp(av) + 1; /* @_ is not tieable */
2785
2786 if (items) {
2787 /* Mark is at the end of the stack. */
2788 EXTEND(SP, items);
2789 Copy(AvARRAY(av), SP + 1, items, SV*);
2790 SP += items;
2791 PUTBACK ;
2792 }
2793 }
2794 /* We assume first XSUB in &DB::sub is the called one. */
2795 if (PL_curcopdb) {
2796 SAVEVPTR(PL_curcop);
2797 PL_curcop = PL_curcopdb;
2798 PL_curcopdb = NULL;
2799 }
2800 /* Do we need to open block here? XXXX */
2801 (void)(*CvXSUB(cv))(aTHX_ cv);
2802
2803 /* Enforce some sanity in scalar context. */
2804 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2805 if (markix > PL_stack_sp - PL_stack_base)
2806 *(PL_stack_base + markix) = &PL_sv_undef;
2807 else
2808 *(PL_stack_base + markix) = *PL_stack_sp;
2809 PL_stack_sp = PL_stack_base + markix;
2810 }
2811 }
2812 LEAVE;
2813 return NORMAL;
2814 }
2815
2816 assert (0); /* Cannot get here. */
2817 /* This is deliberately moved here as spaghetti code to keep it out of the
2818 hot path. */
2819 {
2820 GV* autogv;
2821 SV* sub_name;
2822
2823 fooey:
2824 /* anonymous or undef'd function leaves us no recourse */
2825 if (CvANON(cv) || !(gv = CvGV(cv)))
2826 DIE(aTHX_ "Undefined subroutine called");
2827
2828 /* autoloaded stub? */
2829 if (cv != GvCV(gv)) {
2830 cv = GvCV(gv);
2831 }
2832 /* should call AUTOLOAD now? */
2833 else {
2834try_autoload:
2835 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2836 FALSE)))
2837 {
2838 cv = GvCV(autogv);
2839 }
2840 /* sorry */
2841 else {
2842 sub_name = sv_newmortal();
2843 gv_efullname3(sub_name, gv, Nullch);
35c1215d 2844 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
f1025168
NC
2845 }
2846 }
2847 if (!cv)
2848 DIE(aTHX_ "Not a CODE reference");
2849 goto retry;
2850 }
a0d0e21e
LW
2851}
2852
44a8e56a 2853void
864dbfa3 2854Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a
PP
2855{
2856 if (CvANON(cv))
9014280d 2857 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a
PP
2858 else {
2859 SV* tmpstr = sv_newmortal();
2860 gv_efullname3(tmpstr, CvGV(cv), Nullch);
35c1215d
NC
2861 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2862 tmpstr);
44a8e56a
PP
2863 }
2864}
2865
a0d0e21e
LW
2866PP(pp_aelem)
2867{
39644a26 2868 dSP;
a0d0e21e 2869 SV** svp;
d804643f
SC
2870 SV* elemsv = POPs;
2871 IV elem = SvIV(elemsv);
68dc0745 2872 AV* av = (AV*)POPs;
e1ec3a88
AL
2873 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2874 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
be6c24e0 2875 SV *sv;
a0d0e21e 2876
e35c1634 2877 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
35c1215d 2878 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
748a9306 2879 if (elem > 0)
3280af22 2880 elem -= PL_curcop->cop_arybase;
a0d0e21e
LW
2881 if (SvTYPE(av) != SVt_PVAV)
2882 RETPUSHUNDEF;
68dc0745 2883 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2884 if (lval) {
2b573ace
JH
2885#ifdef PERL_MALLOC_WRAP
2886 static const char oom_array_extend[] =
2887 "Out of memory during array extend"; /* Duplicated in av.c */
2888 if (SvUOK(elemsv)) {
a9c4fd4e 2889 const UV uv = SvUV(elemsv);
2b573ace
JH
2890 elem = uv > IV_MAX ? IV_MAX : uv;
2891 }
2892 else if (SvNOK(elemsv))
2893 elem = (IV)SvNV(elemsv);
2894 if (elem > 0)
2895 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2896#endif
3280af22 2897 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
2898 SV* lv;
2899 if (!defer)
cea2e8a9 2900 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
2901 lv = sv_newmortal();
2902 sv_upgrade(lv, SVt_PVLV);
2903 LvTYPE(lv) = 'y';
14befaf4 2904 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
68dc0745
PP
2905 LvTARG(lv) = SvREFCNT_inc(av);
2906 LvTARGOFF(lv) = elem;
2907 LvTARGLEN(lv) = 1;
2908 PUSHs(lv);
2909 RETURN;
2910 }
bfc4de9f 2911 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2912 save_aelem(av, elem, svp);
533c011a
NIS
2913 else if (PL_op->op_private & OPpDEREF)
2914 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 2915 }
3280af22 2916 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
2917 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2918 sv = sv_mortalcopy(sv);
2919 PUSHs(sv);
a0d0e21e
LW
2920 RETURN;
2921}
2922
02a9e968 2923void
864dbfa3 2924Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968
CS
2925{
2926 if (SvGMAGICAL(sv))
2927 mg_get(sv);
2928 if (!SvOK(sv)) {
2929 if (SvREADONLY(sv))
cea2e8a9 2930 Perl_croak(aTHX_ PL_no_modify);
5f05dabc
PP
2931 if (SvTYPE(sv) < SVt_RV)
2932 sv_upgrade(sv, SVt_RV);
2933 else if (SvTYPE(sv) >= SVt_PV) {
8bd4d4c5 2934 SvPV_free(sv);
b162af07
SP
2935 SvLEN_set(sv, 0);
2936 SvCUR_set(sv, 0);
5f05dabc 2937 }
68dc0745 2938 switch (to_what) {
5f05dabc 2939 case OPpDEREF_SV:
b162af07 2940 SvRV_set(sv, NEWSV(355,0));
5f05dabc
PP
2941 break;
2942 case OPpDEREF_AV:
b162af07 2943 SvRV_set(sv, (SV*)newAV());
5f05dabc
PP
2944 break;
2945 case OPpDEREF_HV:
b162af07 2946 SvRV_set(sv, (SV*)newHV());
5f05dabc
PP
2947 break;
2948 }
02a9e968
CS
2949 SvROK_on(sv);
2950 SvSETMAGIC(sv);
2951 }
2952}
2953
a0d0e21e
LW
2954PP(pp_method)
2955{
39644a26 2956 dSP;
f5d5a27c
CS
2957 SV* sv = TOPs;
2958
2959 if (SvROK(sv)) {
eda383f2 2960 SV* rsv = SvRV(sv);
f5d5a27c
CS
2961 if (SvTYPE(rsv) == SVt_PVCV) {
2962 SETs(rsv);
2963 RETURN;
2964 }
2965 }
2966
2967 SETs(method_common(sv, Null(U32*)));
2968 RETURN;
2969}
2970
2971PP(pp_method_named)
2972{
39644a26 2973 dSP;
3848b962 2974 SV* sv = cSVOP_sv;
f5d5a27c
CS
2975 U32 hash = SvUVX(sv);
2976
2977 XPUSHs(method_common(sv, &hash));
2978 RETURN;
2979}
2980
2981STATIC SV *
2982S_method_common(pTHX_ SV* meth, U32* hashp)
2983{
a0d0e21e
LW
2984 SV* sv;
2985 SV* ob;
2986 GV* gv;
56304f61 2987 HV* stash;
f5d5a27c 2988 STRLEN namelen;
a9c4fd4e 2989 const char* packname = 0;
0dae17bd 2990 SV *packsv = Nullsv;
ac91690f 2991 STRLEN packlen;
a9c4fd4e 2992 const char *name = SvPV(meth, namelen);
a0d0e21e 2993
3280af22 2994 sv = *(PL_stack_base + TOPMARK + 1);
f5d5a27c 2995
4f1b7578
SC
2996 if (!sv)
2997 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2998
16d20bd9 2999 if (SvGMAGICAL(sv))
af09ea45 3000 mg_get(sv);
a0d0e21e 3001 if (SvROK(sv))
16d20bd9 3002 ob = (SV*)SvRV(sv);
a0d0e21e
LW
3003 else {
3004 GV* iogv;
a0d0e21e 3005
af09ea45 3006 /* this isn't a reference */
56304f61 3007 packname = Nullch;
081fc587
AB
3008
3009 if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
7e8961ec
AB
3010 HE* he;
3011 he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
081fc587 3012 if (he) {
5e6396ae 3013 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
081fc587
AB
3014 goto fetch;
3015 }
3016 }
3017
a0d0e21e 3018 if (!SvOK(sv) ||
05f5af9a 3019 !(packname) ||
7a5fd60d 3020 !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
a0d0e21e
LW
3021 !(ob=(SV*)GvIO(iogv)))
3022 {
af09ea45 3023 /* this isn't the name of a filehandle either */
1c846c1f 3024 if (!packname ||
fd400ab9 3025 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
b86a2fa7 3026 ? !isIDFIRST_utf8((U8*)packname)
834a4ddd
LW
3027 : !isIDFIRST(*packname)
3028 ))
3029 {
f5d5a27c
CS
3030 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3031 SvOK(sv) ? "without a package or object reference"
3032 : "on an undefined value");
834a4ddd 3033 }
af09ea45
IK
3034 /* assume it's a package name */
3035 stash = gv_stashpvn(packname, packlen, FALSE);
0dae17bd
GS
3036 if (!stash)
3037 packsv = sv;
081fc587 3038 else {
5e6396ae 3039 SV* ref = newSViv(PTR2IV(stash));
7e8961ec
AB
3040 hv_store(PL_stashcache, packname, packlen, ref, 0);
3041 }
ac91690f 3042 goto fetch;
a0d0e21e 3043 }
af09ea45 3044 /* it _is_ a filehandle name -- replace with a reference */
3280af22 3045 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
a0d0e21e
LW
3046 }
3047
af09ea45 3048 /* if we got here, ob should be a reference or a glob */
f0d43078
GS
3049 if (!ob || !(SvOBJECT(ob)
3050 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3051 && SvOBJECT(ob))))
3052 {
f5d5a27c
CS
3053 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3054 name);
f0d43078 3055 }
a0d0e21e 3056
56304f61 3057 stash = SvSTASH(ob);
a0d0e21e 3058
ac91690f 3059 fetch:
af09ea45
IK
3060 /* NOTE: stash may be null, hope hv_fetch_ent and
3061 gv_fetchmethod can cope (it seems they can) */
3062
f5d5a27c
CS
3063 /* shortcut for simple names */
3064 if (hashp) {
3065 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3066 if (he) {
3067 gv = (GV*)HeVAL(he);
3068 if (isGV(gv) && GvCV(gv) &&
3069 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3070 return (SV*)GvCV(gv);
3071 }
3072 }
3073
0dae17bd 3074 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
af09ea45 3075
56304f61 3076 if (!gv) {
af09ea45
IK
3077 /* This code tries to figure out just what went wrong with
3078 gv_fetchmethod. It therefore needs to duplicate a lot of
3079 the internals of that function. We can't move it inside
3080 Perl_gv_fetchmethod_autoload(), however, since that would
3081 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3082 don't want that.
3083 */
a9c4fd4e
AL
3084 const char* leaf = name;
3085 const char* sep = Nullch;
3086 const char* p;
56304f61
CS
3087
3088 for (p = name; *p; p++) {
3089 if (*p == '\'')
3090 sep = p, leaf = p + 1;
3091 else if (*p == ':' && *(p + 1) == ':')
3092 sep = p, leaf = p + 2;
3093 }
3094 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
af09ea45
IK
3095 /* the method name is unqualified or starts with SUPER:: */
3096 packname = sep ? CopSTASHPV(PL_curcop) :
3097 stash ? HvNAME(stash) : packname;
e27ad1f2
AV
3098 if (!packname)
3099 Perl_croak(aTHX_
3100 "Can't use anonymous symbol table for method lookup");
3101 else
3102 packlen = strlen(packname);
56304f61
CS
3103 }
3104 else {
af09ea45 3105 /* the method name is qualified */
56304f61
CS
3106 packname = name;
3107 packlen = sep - name;
3108 }
af09ea45
IK
3109
3110 /* we're relying on gv_fetchmethod not autovivifying the stash */
3111 if (gv_stashpvn(packname, packlen, FALSE)) {
c1899e02 3112 Perl_croak(aTHX_
af09ea45
IK
3113 "Can't locate object method \"%s\" via package \"%.*s\"",
3114 leaf, (int)packlen, packname);
c1899e02
GS
3115 }
3116 else {
3117 Perl_croak(aTHX_
af09ea45
IK
3118 "Can't locate object method \"%s\" via package \"%.*s\""
3119 " (perhaps you forgot to load \"%.*s\"?)",
3120 leaf, (int)packlen, packname, (int)packlen, packname);
c1899e02 3121 }
56304f61 3122 }
f5d5a27c 3123 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
a0d0e21e 3124}
241d1a3b
NC
3125
3126/*
3127 * Local variables:
3128 * c-indentation-style: bsd
3129 * c-basic-offset: 4
3130 * indent-tabs-mode: t
3131 * End:
3132 *
37442d52
RGS
3133 * ex: set ts=8 sts=4 sw=4 noet:
3134 */