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