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