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