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