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