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