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