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