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