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