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