This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Store GvGP in the SV head union. For all the common lookups [eg GvCV()]
[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(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(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(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(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(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 SV *dstr;
2029     register char *s;
2030     char *strend;
2031     register char *m;
2032     const char *c;
2033     register char *d;
2034     STRLEN clen;
2035     I32 iters = 0;
2036     I32 maxiters;
2037     register I32 i;
2038     bool once;
2039     bool rxtainted;
2040     char *orig;
2041     I32 r_flags;
2042     register REGEXP *rx = PM_GETRE(pm);
2043     STRLEN len;
2044     int force_on_match = 0;
2045     const I32 oldsave = PL_savestack_ix;
2046     STRLEN slen;
2047     bool doutf8 = FALSE;
2048 #ifdef PERL_OLD_COPY_ON_WRITE
2049     bool is_cow;
2050 #endif
2051     SV *nsv = NULL;
2052
2053     /* known replacement string? */
2054     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2055     if (PL_op->op_flags & OPf_STACKED)
2056         TARG = POPs;
2057     else if (PL_op->op_private & OPpTARGET_MY)
2058         GETTARGET;
2059     else {
2060         TARG = DEFSV;
2061         EXTEND(SP,1);
2062     }
2063
2064 #ifdef PERL_OLD_COPY_ON_WRITE
2065     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2066        because they make integers such as 256 "false".  */
2067     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2068 #else
2069     if (SvIsCOW(TARG))
2070         sv_force_normal_flags(TARG,0);
2071 #endif
2072     if (
2073 #ifdef PERL_OLD_COPY_ON_WRITE
2074         !is_cow &&
2075 #endif
2076         (SvREADONLY(TARG)
2077         || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2078              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2079         DIE(aTHX_ PL_no_modify);
2080     PUTBACK;
2081
2082     s = SvPV_mutable(TARG, len);
2083     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2084         force_on_match = 1;
2085     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2086                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2087     if (PL_tainted)
2088         rxtainted |= 2;
2089     TAINT_NOT;
2090
2091     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2092
2093   force_it:
2094     if (!pm || !s)
2095         DIE(aTHX_ "panic: pp_subst");
2096
2097     strend = s + len;
2098     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2099     maxiters = 2 * slen + 10;   /* We can match twice at each
2100                                    position, once with zero-length,
2101                                    second time with non-zero. */
2102
2103     if (!rx->prelen && PL_curpm) {
2104         pm = PL_curpm;
2105         rx = PM_GETRE(pm);
2106     }
2107     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2108             || (pm->op_pmflags & PMf_EVAL))
2109                ? REXEC_COPY_STR : 0;
2110     if (SvSCREAM(TARG))
2111         r_flags |= REXEC_SCREAM;
2112
2113     orig = m = s;
2114     if (rx->reganch & RE_USE_INTUIT) {
2115         PL_bostr = orig;
2116         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2117
2118         if (!s)
2119             goto nope;
2120         /* How to do it in subst? */
2121 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
2122              && !PL_sawampersand
2123              && ((rx->reganch & ROPT_NOSCAN)
2124                  || !((rx->reganch & RE_INTUIT_TAIL)
2125                       && (r_flags & REXEC_SCREAM))))
2126             goto yup;
2127 */
2128     }
2129
2130     /* only replace once? */
2131     once = !(rpm->op_pmflags & PMf_GLOBAL);
2132
2133     /* known replacement string? */
2134     if (dstr) {
2135         /* replacement needing upgrading? */
2136         if (DO_UTF8(TARG) && !doutf8) {
2137              nsv = sv_newmortal();
2138              SvSetSV(nsv, dstr);
2139              if (PL_encoding)
2140                   sv_recode_to_utf8(nsv, PL_encoding);
2141              else
2142                   sv_utf8_upgrade(nsv);
2143              c = SvPV_const(nsv, clen);
2144              doutf8 = TRUE;
2145         }
2146         else {
2147             c = SvPV_const(dstr, clen);
2148             doutf8 = DO_UTF8(dstr);
2149         }
2150     }
2151     else {
2152         c = NULL;
2153         doutf8 = FALSE;
2154     }
2155     
2156     /* can do inplace substitution? */
2157     if (c
2158 #ifdef PERL_OLD_COPY_ON_WRITE
2159         && !is_cow
2160 #endif
2161         && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2162         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2163         && (!doutf8 || SvUTF8(TARG))) {
2164         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2165                          r_flags | REXEC_CHECKED))
2166         {
2167             SPAGAIN;
2168             PUSHs(&PL_sv_no);
2169             LEAVE_SCOPE(oldsave);
2170             RETURN;
2171         }
2172 #ifdef PERL_OLD_COPY_ON_WRITE
2173         if (SvIsCOW(TARG)) {
2174             assert (!force_on_match);
2175             goto have_a_cow;
2176         }
2177 #endif
2178         if (force_on_match) {
2179             force_on_match = 0;
2180             s = SvPV_force(TARG, len);
2181             goto force_it;
2182         }
2183         d = s;
2184         PL_curpm = pm;
2185         SvSCREAM_off(TARG);     /* disable possible screamer */
2186         if (once) {
2187             rxtainted |= RX_MATCH_TAINTED(rx);
2188             m = orig + rx->startp[0];
2189             d = orig + rx->endp[0];
2190             s = orig;
2191             if (m - s > strend - d) {  /* faster to shorten from end */
2192                 if (clen) {
2193                     Copy(c, m, clen, char);
2194                     m += clen;
2195                 }
2196                 i = strend - d;
2197                 if (i > 0) {
2198                     Move(d, m, i, char);
2199                     m += i;
2200                 }
2201                 *m = '\0';
2202                 SvCUR_set(TARG, m - s);
2203             }
2204             else if ((i = m - s)) {     /* faster from front */
2205                 d -= clen;
2206                 m = d;
2207                 sv_chop(TARG, d-i);
2208                 s += i;
2209                 while (i--)
2210                     *--d = *--s;
2211                 if (clen)
2212                     Copy(c, m, clen, char);
2213             }
2214             else if (clen) {
2215                 d -= clen;
2216                 sv_chop(TARG, d);
2217                 Copy(c, d, clen, char);
2218             }
2219             else {
2220                 sv_chop(TARG, d);
2221             }
2222             TAINT_IF(rxtainted & 1);
2223             SPAGAIN;
2224             PUSHs(&PL_sv_yes);
2225         }
2226         else {
2227             do {
2228                 if (iters++ > maxiters)
2229                     DIE(aTHX_ "Substitution loop");
2230                 rxtainted |= RX_MATCH_TAINTED(rx);
2231                 m = rx->startp[0] + orig;
2232                 if ((i = m - s)) {
2233                     if (s != d)
2234                         Move(s, d, i, char);
2235                     d += i;
2236                 }
2237                 if (clen) {
2238                     Copy(c, d, clen, char);
2239                     d += clen;
2240                 }
2241                 s = rx->endp[0] + orig;
2242             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2243                                  TARG, NULL,
2244                                  /* don't match same null twice */
2245                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2246             if (s != d) {
2247                 i = strend - s;
2248                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2249                 Move(s, d, i+1, char);          /* include the NUL */
2250             }
2251             TAINT_IF(rxtainted & 1);
2252             SPAGAIN;
2253             PUSHs(sv_2mortal(newSViv((I32)iters)));
2254         }
2255         (void)SvPOK_only_UTF8(TARG);
2256         TAINT_IF(rxtainted);
2257         if (SvSMAGICAL(TARG)) {
2258             PUTBACK;
2259             mg_set(TARG);
2260             SPAGAIN;
2261         }
2262         SvTAINT(TARG);
2263         if (doutf8)
2264             SvUTF8_on(TARG);
2265         LEAVE_SCOPE(oldsave);
2266         RETURN;
2267     }
2268
2269     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2270                     r_flags | REXEC_CHECKED))
2271     {
2272         if (force_on_match) {
2273             force_on_match = 0;
2274             s = SvPV_force(TARG, len);
2275             goto force_it;
2276         }
2277 #ifdef PERL_OLD_COPY_ON_WRITE
2278       have_a_cow:
2279 #endif
2280         rxtainted |= RX_MATCH_TAINTED(rx);
2281         dstr = newSVpvn(m, s-m);
2282         if (DO_UTF8(TARG))
2283             SvUTF8_on(dstr);
2284         PL_curpm = pm;
2285         if (!c) {
2286             register PERL_CONTEXT *cx;
2287             SPAGAIN;
2288             (void)ReREFCNT_inc(rx);
2289             PUSHSUBST(cx);
2290             RETURNOP(cPMOP->op_pmreplroot);
2291         }
2292         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2293         do {
2294             if (iters++ > maxiters)
2295                 DIE(aTHX_ "Substitution loop");
2296             rxtainted |= RX_MATCH_TAINTED(rx);
2297             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2298                 m = s;
2299                 s = orig;
2300                 orig = rx->subbeg;
2301                 s = orig + (m - s);
2302                 strend = s + (strend - m);
2303             }
2304             m = rx->startp[0] + orig;
2305             if (doutf8 && !SvUTF8(dstr))
2306                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2307             else
2308                 sv_catpvn(dstr, s, m-s);
2309             s = rx->endp[0] + orig;
2310             if (clen)
2311                 sv_catpvn(dstr, c, clen);
2312             if (once)
2313                 break;
2314         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2315                              TARG, NULL, r_flags));
2316         if (doutf8 && !DO_UTF8(TARG))
2317             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2318         else
2319             sv_catpvn(dstr, s, strend - s);
2320
2321 #ifdef PERL_OLD_COPY_ON_WRITE
2322         /* The match may make the string COW. If so, brilliant, because that's
2323            just saved us one malloc, copy and free - the regexp has donated
2324            the old buffer, and we malloc an entirely new one, rather than the
2325            regexp malloc()ing a buffer and copying our original, only for
2326            us to throw it away here during the substitution.  */
2327         if (SvIsCOW(TARG)) {
2328             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2329         } else
2330 #endif
2331         {
2332             SvPV_free(TARG);
2333         }
2334         SvPV_set(TARG, SvPVX(dstr));
2335         SvCUR_set(TARG, SvCUR(dstr));
2336         SvLEN_set(TARG, SvLEN(dstr));
2337         doutf8 |= DO_UTF8(dstr);
2338         SvPV_set(dstr, NULL);
2339         sv_free(dstr);
2340
2341         TAINT_IF(rxtainted & 1);
2342         SPAGAIN;
2343         PUSHs(sv_2mortal(newSViv((I32)iters)));
2344
2345         (void)SvPOK_only(TARG);
2346         if (doutf8)
2347             SvUTF8_on(TARG);
2348         TAINT_IF(rxtainted);
2349         SvSETMAGIC(TARG);
2350         SvTAINT(TARG);
2351         LEAVE_SCOPE(oldsave);
2352         RETURN;
2353     }
2354     goto ret_no;
2355
2356 nope:
2357 ret_no:
2358     SPAGAIN;
2359     PUSHs(&PL_sv_no);
2360     LEAVE_SCOPE(oldsave);
2361     RETURN;
2362 }
2363
2364 PP(pp_grepwhile)
2365 {
2366     dVAR; dSP;
2367
2368     if (SvTRUEx(POPs))
2369         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2370     ++*PL_markstack_ptr;
2371     LEAVE;                                      /* exit inner scope */
2372
2373     /* All done yet? */
2374     if (PL_stack_base + *PL_markstack_ptr > SP) {
2375         I32 items;
2376         const I32 gimme = GIMME_V;
2377
2378         LEAVE;                                  /* exit outer scope */
2379         (void)POPMARK;                          /* pop src */
2380         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2381         (void)POPMARK;                          /* pop dst */
2382         SP = PL_stack_base + POPMARK;           /* pop original mark */
2383         if (gimme == G_SCALAR) {
2384             if (PL_op->op_private & OPpGREP_LEX) {
2385                 SV* const sv = sv_newmortal();
2386                 sv_setiv(sv, items);
2387                 PUSHs(sv);
2388             }
2389             else {
2390                 dTARGET;
2391                 XPUSHi(items);
2392             }
2393         }
2394         else if (gimme == G_ARRAY)
2395             SP += items;
2396         RETURN;
2397     }
2398     else {
2399         SV *src;
2400
2401         ENTER;                                  /* enter inner scope */
2402         SAVEVPTR(PL_curpm);
2403
2404         src = PL_stack_base[*PL_markstack_ptr];
2405         SvTEMP_off(src);
2406         if (PL_op->op_private & OPpGREP_LEX)
2407             PAD_SVl(PL_op->op_targ) = src;
2408         else
2409             DEFSV = src;
2410
2411         RETURNOP(cLOGOP->op_other);
2412     }
2413 }
2414
2415 PP(pp_leavesub)
2416 {
2417     dVAR; dSP;
2418     SV **mark;
2419     SV **newsp;
2420     PMOP *newpm;
2421     I32 gimme;
2422     register PERL_CONTEXT *cx;
2423     SV *sv;
2424
2425     if (CxMULTICALL(&cxstack[cxstack_ix]))
2426         return 0;
2427
2428     POPBLOCK(cx,newpm);
2429     cxstack_ix++; /* temporarily protect top context */
2430
2431     TAINT_NOT;
2432     if (gimme == G_SCALAR) {
2433         MARK = newsp + 1;
2434         if (MARK <= SP) {
2435             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2436                 if (SvTEMP(TOPs)) {
2437                     *MARK = SvREFCNT_inc(TOPs);
2438                     FREETMPS;
2439                     sv_2mortal(*MARK);
2440                 }
2441                 else {
2442                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2443                     FREETMPS;
2444                     *MARK = sv_mortalcopy(sv);
2445                     SvREFCNT_dec(sv);
2446                 }
2447             }
2448             else
2449                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2450         }
2451         else {
2452             MEXTEND(MARK, 0);
2453             *MARK = &PL_sv_undef;
2454         }
2455         SP = MARK;
2456     }
2457     else if (gimme == G_ARRAY) {
2458         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2459             if (!SvTEMP(*MARK)) {
2460                 *MARK = sv_mortalcopy(*MARK);
2461                 TAINT_NOT;      /* Each item is independent */
2462             }
2463         }
2464     }
2465     PUTBACK;
2466
2467     LEAVE;
2468     cxstack_ix--;
2469     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2470     PL_curpm = newpm;   /* ... and pop $1 et al */
2471
2472     LEAVESUB(sv);
2473     return cx->blk_sub.retop;
2474 }
2475
2476 /* This duplicates the above code because the above code must not
2477  * get any slower by more conditions */
2478 PP(pp_leavesublv)
2479 {
2480     dVAR; dSP;
2481     SV **mark;
2482     SV **newsp;
2483     PMOP *newpm;
2484     I32 gimme;
2485     register PERL_CONTEXT *cx;
2486     SV *sv;
2487
2488     if (CxMULTICALL(&cxstack[cxstack_ix]))
2489         return 0;
2490
2491     POPBLOCK(cx,newpm);
2492     cxstack_ix++; /* temporarily protect top context */
2493
2494     TAINT_NOT;
2495
2496     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2497         /* We are an argument to a function or grep().
2498          * This kind of lvalueness was legal before lvalue
2499          * subroutines too, so be backward compatible:
2500          * cannot report errors.  */
2501
2502         /* Scalar context *is* possible, on the LHS of -> only,
2503          * as in f()->meth().  But this is not an lvalue. */
2504         if (gimme == G_SCALAR)
2505             goto temporise;
2506         if (gimme == G_ARRAY) {
2507             if (!CvLVALUE(cx->blk_sub.cv))
2508                 goto temporise_array;
2509             EXTEND_MORTAL(SP - newsp);
2510             for (mark = newsp + 1; mark <= SP; mark++) {
2511                 if (SvTEMP(*mark))
2512                     /*EMPTY*/;
2513                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2514                     *mark = sv_mortalcopy(*mark);
2515                 else {
2516                     /* Can be a localized value subject to deletion. */
2517                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2518                     (void)SvREFCNT_inc(*mark);
2519                 }
2520             }
2521         }
2522     }
2523     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2524         /* Here we go for robustness, not for speed, so we change all
2525          * the refcounts so the caller gets a live guy. Cannot set
2526          * TEMP, so sv_2mortal is out of question. */
2527         if (!CvLVALUE(cx->blk_sub.cv)) {
2528             LEAVE;
2529             cxstack_ix--;
2530             POPSUB(cx,sv);
2531             PL_curpm = newpm;
2532             LEAVESUB(sv);
2533             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2534         }
2535         if (gimme == G_SCALAR) {
2536             MARK = newsp + 1;
2537             EXTEND_MORTAL(1);
2538             if (MARK == SP) {
2539                 /* Temporaries are bad unless they happen to be elements
2540                  * of a tied hash or array */
2541                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2542                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2543                     LEAVE;
2544                     cxstack_ix--;
2545                     POPSUB(cx,sv);
2546                     PL_curpm = newpm;
2547                     LEAVESUB(sv);
2548                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2549                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2550                         : "a readonly value" : "a temporary");
2551                 }
2552                 else {                  /* Can be a localized value
2553                                          * subject to deletion. */
2554                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2555                     (void)SvREFCNT_inc(*mark);
2556                 }
2557             }
2558             else {                      /* Should not happen? */
2559                 LEAVE;
2560                 cxstack_ix--;
2561                 POPSUB(cx,sv);
2562                 PL_curpm = newpm;
2563                 LEAVESUB(sv);
2564                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2565                     (MARK > SP ? "Empty array" : "Array"));
2566             }
2567             SP = MARK;
2568         }
2569         else if (gimme == G_ARRAY) {
2570             EXTEND_MORTAL(SP - newsp);
2571             for (mark = newsp + 1; mark <= SP; mark++) {
2572                 if (*mark != &PL_sv_undef
2573                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2574                     /* Might be flattened array after $#array =  */
2575                     PUTBACK;
2576                     LEAVE;
2577                     cxstack_ix--;
2578                     POPSUB(cx,sv);
2579                     PL_curpm = newpm;
2580                     LEAVESUB(sv);
2581                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2582                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2583                 }
2584                 else {
2585                     /* Can be a localized value subject to deletion. */
2586                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2587                     (void)SvREFCNT_inc(*mark);
2588                 }
2589             }
2590         }
2591     }
2592     else {
2593         if (gimme == G_SCALAR) {
2594           temporise:
2595             MARK = newsp + 1;
2596             if (MARK <= SP) {
2597                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2598                     if (SvTEMP(TOPs)) {
2599                         *MARK = SvREFCNT_inc(TOPs);
2600                         FREETMPS;
2601                         sv_2mortal(*MARK);
2602                     }
2603                     else {
2604                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2605                         FREETMPS;
2606                         *MARK = sv_mortalcopy(sv);
2607                         SvREFCNT_dec(sv);
2608                     }
2609                 }
2610                 else
2611                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2612             }
2613             else {
2614                 MEXTEND(MARK, 0);
2615                 *MARK = &PL_sv_undef;
2616             }
2617             SP = MARK;
2618         }
2619         else if (gimme == G_ARRAY) {
2620           temporise_array:
2621             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2622                 if (!SvTEMP(*MARK)) {
2623                     *MARK = sv_mortalcopy(*MARK);
2624                     TAINT_NOT;  /* Each item is independent */
2625                 }
2626             }
2627         }
2628     }
2629     PUTBACK;
2630
2631     LEAVE;
2632     cxstack_ix--;
2633     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2634     PL_curpm = newpm;   /* ... and pop $1 et al */
2635
2636     LEAVESUB(sv);
2637     return cx->blk_sub.retop;
2638 }
2639
2640
2641 STATIC CV *
2642 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2643 {
2644     dVAR;
2645     SV * const dbsv = GvSVn(PL_DBsub);
2646
2647     save_item(dbsv);
2648     if (!PERLDB_SUB_NN) {
2649         GV *gv = CvGV(cv);
2650
2651         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2652              || strEQ(GvNAME(gv), "END")
2653              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2654                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2655                     && (gv = (GV*)*svp) ))) {
2656             /* Use GV from the stack as a fallback. */
2657             /* GV is potentially non-unique, or contain different CV. */
2658             SV * const tmp = newRV((SV*)cv);
2659             sv_setsv(dbsv, tmp);
2660             SvREFCNT_dec(tmp);
2661         }
2662         else {
2663             gv_efullname3(dbsv, gv, NULL);
2664         }
2665     }
2666     else {
2667         const int type = SvTYPE(dbsv);
2668         if (type < SVt_PVIV && type != SVt_IV)
2669             sv_upgrade(dbsv, SVt_PVIV);
2670         (void)SvIOK_on(dbsv);
2671         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
2672     }
2673
2674     if (CvISXSUB(cv))
2675         PL_curcopdb = PL_curcop;
2676     cv = GvCV(PL_DBsub);
2677     return cv;
2678 }
2679
2680 PP(pp_entersub)
2681 {
2682     dVAR; dSP; dPOPss;
2683     GV *gv;
2684     register CV *cv;
2685     register PERL_CONTEXT *cx;
2686     I32 gimme;
2687     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2688
2689     if (!sv)
2690         DIE(aTHX_ "Not a CODE reference");
2691     switch (SvTYPE(sv)) {
2692         /* This is overwhelming the most common case:  */
2693     case SVt_PVGV:
2694         if (!(cv = GvCVu((GV*)sv))) {
2695             HV *stash;
2696             cv = sv_2cv(sv, &stash, &gv, 0);
2697         }
2698         if (!cv) {
2699             ENTER;
2700             SAVETMPS;
2701             goto try_autoload;
2702         }
2703         break;
2704     default:
2705         if (!SvROK(sv)) {
2706             const char *sym;
2707             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2708                 if (hasargs)
2709                     SP = PL_stack_base + POPMARK;
2710                 RETURN;
2711             }
2712             if (SvGMAGICAL(sv)) {
2713                 mg_get(sv);
2714                 if (SvROK(sv))
2715                     goto got_rv;
2716                 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2717             }
2718             else {
2719                 sym = SvPV_nolen_const(sv);
2720             }
2721             if (!sym)
2722                 DIE(aTHX_ PL_no_usym, "a subroutine");
2723             if (PL_op->op_private & HINT_STRICT_REFS)
2724                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2725             cv = get_cv(sym, TRUE);
2726             break;
2727         }
2728   got_rv:
2729         {
2730             SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2731             tryAMAGICunDEREF(to_cv);
2732         }       
2733         cv = (CV*)SvRV(sv);
2734         if (SvTYPE(cv) == SVt_PVCV)
2735             break;
2736         /* FALL THROUGH */
2737     case SVt_PVHV:
2738     case SVt_PVAV:
2739         DIE(aTHX_ "Not a CODE reference");
2740         /* This is the second most common case:  */
2741     case SVt_PVCV:
2742         cv = (CV*)sv;
2743         break;
2744     }
2745
2746     ENTER;
2747     SAVETMPS;
2748
2749   retry:
2750     if (!CvROOT(cv) && !CvXSUB(cv)) {
2751         GV* autogv;
2752         SV* sub_name;
2753
2754         /* anonymous or undef'd function leaves us no recourse */
2755         if (CvANON(cv) || !(gv = CvGV(cv)))
2756             DIE(aTHX_ "Undefined subroutine called");
2757
2758         /* autoloaded stub? */
2759         if (cv != GvCV(gv)) {
2760             cv = GvCV(gv);
2761         }
2762         /* should call AUTOLOAD now? */
2763         else {
2764 try_autoload:
2765             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2766                                    FALSE)))
2767             {
2768                 cv = GvCV(autogv);
2769             }
2770             /* sorry */
2771             else {
2772                 sub_name = sv_newmortal();
2773                 gv_efullname3(sub_name, gv, NULL);
2774                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2775             }
2776         }
2777         if (!cv)
2778             DIE(aTHX_ "Not a CODE reference");
2779         goto retry;
2780     }
2781
2782     gimme = GIMME_V;
2783     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2784         if (CvASSERTION(cv) && PL_DBassertion)
2785             sv_setiv(PL_DBassertion, 1);
2786         
2787         cv = get_db_sub(&sv, cv);
2788         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2789             DIE(aTHX_ "No DB::sub routine defined");
2790     }
2791
2792     if (!(CvISXSUB(cv))) {
2793         /* This path taken at least 75% of the time   */
2794         dMARK;
2795         register I32 items = SP - MARK;
2796         AV* const padlist = CvPADLIST(cv);
2797         PUSHBLOCK(cx, CXt_SUB, MARK);
2798         PUSHSUB(cx);
2799         cx->blk_sub.retop = PL_op->op_next;
2800         CvDEPTH(cv)++;
2801         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2802          * that eval'' ops within this sub know the correct lexical space.
2803          * Owing the speed considerations, we choose instead to search for
2804          * the cv using find_runcv() when calling doeval().
2805          */
2806         if (CvDEPTH(cv) >= 2) {
2807             PERL_STACK_OVERFLOW_CHECK();
2808             pad_push(padlist, CvDEPTH(cv));
2809         }
2810         SAVECOMPPAD();
2811         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2812         if (hasargs)
2813         {
2814             AV* const av = (AV*)PAD_SVl(0);
2815             if (AvREAL(av)) {
2816                 /* @_ is normally not REAL--this should only ever
2817                  * happen when DB::sub() calls things that modify @_ */
2818                 av_clear(av);
2819                 AvREAL_off(av);
2820                 AvREIFY_on(av);
2821             }
2822             cx->blk_sub.savearray = GvAV(PL_defgv);
2823             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2824             CX_CURPAD_SAVE(cx->blk_sub);
2825             cx->blk_sub.argarray = av;
2826             ++MARK;
2827
2828             if (items > AvMAX(av) + 1) {
2829                 SV **ary = AvALLOC(av);
2830                 if (AvARRAY(av) != ary) {
2831                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2832                     SvPV_set(av, (char*)ary);
2833                 }
2834                 if (items > AvMAX(av) + 1) {
2835                     AvMAX(av) = items - 1;
2836                     Renew(ary,items,SV*);
2837                     AvALLOC(av) = ary;
2838                     SvPV_set(av, (char*)ary);
2839                 }
2840             }
2841             Copy(MARK,AvARRAY(av),items,SV*);
2842             AvFILLp(av) = items - 1;
2843         
2844             while (items--) {
2845                 if (*MARK)
2846                     SvTEMP_off(*MARK);
2847                 MARK++;
2848             }
2849         }
2850         /* warning must come *after* we fully set up the context
2851          * stuff so that __WARN__ handlers can safely dounwind()
2852          * if they want to
2853          */
2854         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2855             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2856             sub_crush_depth(cv);
2857 #if 0
2858         DEBUG_S(PerlIO_printf(Perl_debug_log,
2859                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2860 #endif
2861         RETURNOP(CvSTART(cv));
2862     }
2863     else {
2864             I32 markix = TOPMARK;
2865
2866             PUTBACK;
2867
2868             if (!hasargs) {
2869                 /* Need to copy @_ to stack. Alternative may be to
2870                  * switch stack to @_, and copy return values
2871                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2872                 AV * const av = GvAV(PL_defgv);
2873                 const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2874
2875                 if (items) {
2876                     /* Mark is at the end of the stack. */
2877                     EXTEND(SP, items);
2878                     Copy(AvARRAY(av), SP + 1, items, SV*);
2879                     SP += items;
2880                     PUTBACK ;           
2881                 }
2882             }
2883             /* We assume first XSUB in &DB::sub is the called one. */
2884             if (PL_curcopdb) {
2885                 SAVEVPTR(PL_curcop);
2886                 PL_curcop = PL_curcopdb;
2887                 PL_curcopdb = NULL;
2888             }
2889             /* Do we need to open block here? XXXX */
2890             (void)(*CvXSUB(cv))(aTHX_ cv);
2891
2892             /* Enforce some sanity in scalar context. */
2893             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2894                 if (markix > PL_stack_sp - PL_stack_base)
2895                     *(PL_stack_base + markix) = &PL_sv_undef;
2896                 else
2897                     *(PL_stack_base + markix) = *PL_stack_sp;
2898                 PL_stack_sp = PL_stack_base + markix;
2899             }
2900         LEAVE;
2901         return NORMAL;
2902     }
2903 }
2904
2905 void
2906 Perl_sub_crush_depth(pTHX_ CV *cv)
2907 {
2908     if (CvANON(cv))
2909         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2910     else {
2911         SV* const tmpstr = sv_newmortal();
2912         gv_efullname3(tmpstr, CvGV(cv), NULL);
2913         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2914                 tmpstr);
2915     }
2916 }
2917
2918 PP(pp_aelem)
2919 {
2920     dVAR; dSP;
2921     SV** svp;
2922     SV* const elemsv = POPs;
2923     IV elem = SvIV(elemsv);
2924     AV* const av = (AV*)POPs;
2925     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2926     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2927     SV *sv;
2928
2929     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2930         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2931     if (elem > 0)
2932         elem -= PL_curcop->cop_arybase;
2933     if (SvTYPE(av) != SVt_PVAV)
2934         RETPUSHUNDEF;
2935     svp = av_fetch(av, elem, lval && !defer);
2936     if (lval) {
2937 #ifdef PERL_MALLOC_WRAP
2938          if (SvUOK(elemsv)) {
2939               const UV uv = SvUV(elemsv);
2940               elem = uv > IV_MAX ? IV_MAX : uv;
2941          }
2942          else if (SvNOK(elemsv))
2943               elem = (IV)SvNV(elemsv);
2944          if (elem > 0) {
2945               static const char oom_array_extend[] =
2946                 "Out of memory during array extend"; /* Duplicated in av.c */
2947               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2948          }
2949 #endif
2950         if (!svp || *svp == &PL_sv_undef) {
2951             SV* lv;
2952             if (!defer)
2953                 DIE(aTHX_ PL_no_aelem, elem);
2954             lv = sv_newmortal();
2955             sv_upgrade(lv, SVt_PVLV);
2956             LvTYPE(lv) = 'y';
2957             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2958             LvTARG(lv) = SvREFCNT_inc(av);
2959             LvTARGOFF(lv) = elem;
2960             LvTARGLEN(lv) = 1;
2961             PUSHs(lv);
2962             RETURN;
2963         }
2964         if (PL_op->op_private & OPpLVAL_INTRO)
2965             save_aelem(av, elem, svp);
2966         else if (PL_op->op_private & OPpDEREF)
2967             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2968     }
2969     sv = (svp ? *svp : &PL_sv_undef);
2970     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2971         sv = sv_mortalcopy(sv);
2972     PUSHs(sv);
2973     RETURN;
2974 }
2975
2976 void
2977 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2978 {
2979     SvGETMAGIC(sv);
2980     if (!SvOK(sv)) {
2981         if (SvREADONLY(sv))
2982             Perl_croak(aTHX_ PL_no_modify);
2983         if (SvTYPE(sv) < SVt_RV)
2984             sv_upgrade(sv, SVt_RV);
2985         else if (SvTYPE(sv) >= SVt_PV) {
2986             SvPV_free(sv);
2987             SvLEN_set(sv, 0);
2988             SvCUR_set(sv, 0);
2989         }
2990         switch (to_what) {
2991         case OPpDEREF_SV:
2992             SvRV_set(sv, newSV(0));
2993             break;
2994         case OPpDEREF_AV:
2995             SvRV_set(sv, (SV*)newAV());
2996             break;
2997         case OPpDEREF_HV:
2998             SvRV_set(sv, (SV*)newHV());
2999             break;
3000         }
3001         SvROK_on(sv);
3002         SvSETMAGIC(sv);
3003     }
3004 }
3005
3006 PP(pp_method)
3007 {
3008     dVAR; dSP;
3009     SV* const sv = TOPs;
3010
3011     if (SvROK(sv)) {
3012         SV* const rsv = SvRV(sv);
3013         if (SvTYPE(rsv) == SVt_PVCV) {
3014             SETs(rsv);
3015             RETURN;
3016         }
3017     }
3018
3019     SETs(method_common(sv, NULL));
3020     RETURN;
3021 }
3022
3023 PP(pp_method_named)
3024 {
3025     dVAR; dSP;
3026     SV* const sv = cSVOP_sv;
3027     U32 hash = SvSHARED_HASH(sv);
3028
3029     XPUSHs(method_common(sv, &hash));
3030     RETURN;
3031 }
3032
3033 STATIC SV *
3034 S_method_common(pTHX_ SV* meth, U32* hashp)
3035 {
3036     dVAR;
3037     SV* ob;
3038     GV* gv;
3039     HV* stash;
3040     STRLEN namelen;
3041     const char* packname = NULL;
3042     SV *packsv = NULL;
3043     STRLEN packlen;
3044     const char * const name = SvPV_const(meth, namelen);
3045     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3046
3047     if (!sv)
3048         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3049
3050     SvGETMAGIC(sv);
3051     if (SvROK(sv))
3052         ob = (SV*)SvRV(sv);
3053     else {
3054         GV* iogv;
3055
3056         /* this isn't a reference */
3057         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3058           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3059           if (he) { 
3060             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3061             goto fetch;
3062           }
3063         }
3064
3065         if (!SvOK(sv) ||
3066             !(packname) ||
3067             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3068             !(ob=(SV*)GvIO(iogv)))
3069         {
3070             /* this isn't the name of a filehandle either */
3071             if (!packname ||
3072                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3073                     ? !isIDFIRST_utf8((U8*)packname)
3074                     : !isIDFIRST(*packname)
3075                 ))
3076             {
3077                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3078                            SvOK(sv) ? "without a package or object reference"
3079                                     : "on an undefined value");
3080             }
3081             /* assume it's a package name */
3082             stash = gv_stashpvn(packname, packlen, FALSE);
3083             if (!stash)
3084                 packsv = sv;
3085             else {
3086                 SV* ref = newSViv(PTR2IV(stash));
3087                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3088             }
3089             goto fetch;
3090         }
3091         /* it _is_ a filehandle name -- replace with a reference */
3092         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3093     }
3094
3095     /* if we got here, ob should be a reference or a glob */
3096     if (!ob || !(SvOBJECT(ob)
3097                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3098                      && SvOBJECT(ob))))
3099     {
3100         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3101                    name);
3102     }
3103
3104     stash = SvSTASH(ob);
3105
3106   fetch:
3107     /* NOTE: stash may be null, hope hv_fetch_ent and
3108        gv_fetchmethod can cope (it seems they can) */
3109
3110     /* shortcut for simple names */
3111     if (hashp) {
3112         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3113         if (he) {
3114             gv = (GV*)HeVAL(he);
3115             if (isGV(gv) && GvCV(gv) &&
3116                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3117                 return (SV*)GvCV(gv);
3118         }
3119     }
3120
3121     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3122
3123     if (!gv) {
3124         /* This code tries to figure out just what went wrong with
3125            gv_fetchmethod.  It therefore needs to duplicate a lot of
3126            the internals of that function.  We can't move it inside
3127            Perl_gv_fetchmethod_autoload(), however, since that would
3128            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3129            don't want that.
3130         */
3131         const char* leaf = name;
3132         const char* sep = NULL;
3133         const char* p;
3134
3135         for (p = name; *p; p++) {
3136             if (*p == '\'')
3137                 sep = p, leaf = p + 1;
3138             else if (*p == ':' && *(p + 1) == ':')
3139                 sep = p, leaf = p + 2;
3140         }
3141         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3142             /* the method name is unqualified or starts with SUPER:: */
3143             bool need_strlen = 1;
3144             if (sep) {
3145                 packname = CopSTASHPV(PL_curcop);
3146             }
3147             else if (stash) {
3148                 HEK * const packhek = HvNAME_HEK(stash);
3149                 if (packhek) {
3150                     packname = HEK_KEY(packhek);
3151                     packlen = HEK_LEN(packhek);
3152                     need_strlen = 0;
3153                 } else {
3154                     goto croak;
3155                 }
3156             }
3157
3158             if (!packname) {
3159             croak:
3160                 Perl_croak(aTHX_
3161                            "Can't use anonymous symbol table for method lookup");
3162             }
3163             else if (need_strlen)
3164                 packlen = strlen(packname);
3165
3166         }
3167         else {
3168             /* the method name is qualified */
3169             packname = name;
3170             packlen = sep - name;
3171         }
3172         
3173         /* we're relying on gv_fetchmethod not autovivifying the stash */
3174         if (gv_stashpvn(packname, packlen, FALSE)) {
3175             Perl_croak(aTHX_
3176                        "Can't locate object method \"%s\" via package \"%.*s\"",
3177                        leaf, (int)packlen, packname);
3178         }
3179         else {
3180             Perl_croak(aTHX_
3181                        "Can't locate object method \"%s\" via package \"%.*s\""
3182                        " (perhaps you forgot to load \"%.*s\"?)",
3183                        leaf, (int)packlen, packname, (int)packlen, packname);
3184         }
3185     }
3186     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3187 }
3188
3189 /*
3190  * Local variables:
3191  * c-indentation-style: bsd
3192  * c-basic-offset: 4
3193  * indent-tabs-mode: t
3194  * End:
3195  *
3196  * ex: set ts=8 sts=4 sw=4 noet:
3197  */