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