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