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