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