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