Add the perlperf manpage, by Richard Foley
[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((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((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 = (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, (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 = (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, (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 = (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 = (GV*)SvRV(PL_last_in_gv);
329         else {
330             dSP;
331             XPUSHs((SV*)PL_last_in_gv);
332             PUTBACK;
333             pp_rv2gv();
334             PL_last_in_gv = (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                 (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((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 = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
718
719     if (gv && (io = GvIO(gv))
720         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
721     {
722       had_magic:
723         if (MARK == ORIGMARK) {
724             /* If using default handle then we need to make space to
725              * pass object as 1st arg, so move other args up ...
726              */
727             MEXTEND(SP, 1);
728             ++MARK;
729             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
730             ++SP;
731         }
732         PUSHMARK(MARK - 1);
733         *MARK = SvTIED_obj((SV*)io, mg);
734         PUTBACK;
735         ENTER;
736         if( PL_op->op_type == OP_SAY ) {
737                 /* local $\ = "\n" */
738                 SAVEGENERICSV(PL_ors_sv);
739                 PL_ors_sv = newSVpvs("\n");
740         }
741         call_method("PRINT", G_SCALAR);
742         LEAVE;
743         SPAGAIN;
744         MARK = ORIGMARK + 1;
745         *MARK = *SP;
746         SP = MARK;
747         RETURN;
748     }
749     if (!(io = GvIO(gv))) {
750         if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
751             && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
752             goto had_magic;
753         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
754             report_evil_fh(gv, io, PL_op->op_type);
755         SETERRNO(EBADF,RMS_IFI);
756         goto just_say_no;
757     }
758     else if (!(fp = IoOFP(io))) {
759         if (ckWARN2(WARN_CLOSED, WARN_IO))  {
760             if (IoIFP(io))
761                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
762             else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
763                 report_evil_fh(gv, io, PL_op->op_type);
764         }
765         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
766         goto just_say_no;
767     }
768     else {
769         MARK++;
770         if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
771             while (MARK <= SP) {
772                 if (!do_print(*MARK, fp))
773                     break;
774                 MARK++;
775                 if (MARK <= SP) {
776                     if (!do_print(PL_ofs_sv, fp)) { /* $, */
777                         MARK--;
778                         break;
779                     }
780                 }
781             }
782         }
783         else {
784             while (MARK <= SP) {
785                 if (!do_print(*MARK, fp))
786                     break;
787                 MARK++;
788             }
789         }
790         if (MARK <= SP)
791             goto just_say_no;
792         else {
793             if (PL_op->op_type == OP_SAY) {
794                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
795                     goto just_say_no;
796             }
797             else if (PL_ors_sv && SvOK(PL_ors_sv))
798                 if (!do_print(PL_ors_sv, fp)) /* $\ */
799                     goto just_say_no;
800
801             if (IoFLAGS(io) & IOf_FLUSH)
802                 if (PerlIO_flush(fp) == EOF)
803                     goto just_say_no;
804         }
805     }
806     SP = ORIGMARK;
807     XPUSHs(&PL_sv_yes);
808     RETURN;
809
810   just_say_no:
811     SP = ORIGMARK;
812     XPUSHs(&PL_sv_undef);
813     RETURN;
814 }
815
816 PP(pp_rv2av)
817 {
818     dVAR; dSP; dTOPss;
819     const I32 gimme = GIMME_V;
820     static const char an_array[] = "an ARRAY";
821     static const char a_hash[] = "a HASH";
822     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
823     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
824
825     if (SvROK(sv)) {
826       wasref:
827         tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
828
829         sv = SvRV(sv);
830         if (SvTYPE(sv) != type)
831             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
832         if (PL_op->op_flags & OPf_REF) {
833             SETs(sv);
834             RETURN;
835         }
836         else if (LVRET) {
837             if (gimme != G_ARRAY)
838                 goto croak_cant_return;
839             SETs(sv);
840             RETURN;
841         }
842         else if (PL_op->op_flags & OPf_MOD
843                 && PL_op->op_private & OPpLVAL_INTRO)
844             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
845     }
846     else {
847         if (SvTYPE(sv) == type) {
848             if (PL_op->op_flags & OPf_REF) {
849                 SETs(sv);
850                 RETURN;
851             }
852             else if (LVRET) {
853                 if (gimme != G_ARRAY)
854                     goto croak_cant_return;
855                 SETs(sv);
856                 RETURN;
857             }
858         }
859         else {
860             GV *gv;
861         
862             if (!isGV_with_GP(sv)) {
863                 if (SvGMAGICAL(sv)) {
864                     mg_get(sv);
865                     if (SvROK(sv))
866                         goto wasref;
867                 }
868                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
869                                      type, &sp);
870                 if (!gv)
871                     RETURN;
872             }
873             else {
874                 gv = (GV*)sv;
875             }
876             sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
877             if (PL_op->op_private & OPpLVAL_INTRO)
878                 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
879             if (PL_op->op_flags & OPf_REF) {
880                 SETs(sv);
881                 RETURN;
882             }
883             else if (LVRET) {
884                 if (gimme != G_ARRAY)
885                     goto croak_cant_return;
886                 SETs(sv);
887                 RETURN;
888             }
889         }
890     }
891
892     if (is_pp_rv2av) {
893         AV *const av = (AV*)sv;
894         /* The guts of pp_rv2av, with no intenting change to preserve history
895            (until such time as we get tools that can do blame annotation across
896            whitespace changes.  */
897     if (gimme == G_ARRAY) {
898         const I32 maxarg = AvFILL(av) + 1;
899         (void)POPs;                     /* XXXX May be optimized away? */
900         EXTEND(SP, maxarg);
901         if (SvRMAGICAL(av)) {
902             U32 i;
903             for (i=0; i < (U32)maxarg; i++) {
904                 SV ** const svp = av_fetch(av, i, FALSE);
905                 /* See note in pp_helem, and bug id #27839 */
906                 SP[i+1] = svp
907                     ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
908                     : &PL_sv_undef;
909             }
910         }
911         else {
912             Copy(AvARRAY(av), SP+1, maxarg, SV*);
913         }
914         SP += maxarg;
915     }
916     else if (gimme == G_SCALAR) {
917         dTARGET;
918         const I32 maxarg = AvFILL(av) + 1;
919         SETi(maxarg);
920     }
921     } else {
922         /* The guts of pp_rv2hv  */
923     if (gimme == G_ARRAY) { /* array wanted */
924         *PL_stack_sp = sv;
925         return do_kv();
926     }
927     else if (gimme == G_SCALAR) {
928         dTARGET;
929     TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
930         SPAGAIN;
931         SETTARG;
932     }
933     }
934     RETURN;
935
936  croak_cant_return:
937     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
938                is_pp_rv2av ? "array" : "hash");
939     RETURN;
940 }
941
942 STATIC void
943 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
944 {
945     dVAR;
946     if (*relem) {
947         SV *tmpstr;
948         const HE *didstore;
949
950         if (ckWARN(WARN_MISC)) {
951             const char *err;
952             if (relem == firstrelem &&
953                 SvROK(*relem) &&
954                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
955                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
956             {
957                 err = "Reference found where even-sized list expected";
958             }
959             else
960                 err = "Odd number of elements in hash assignment";
961             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
962         }
963
964         tmpstr = newSV(0);
965         didstore = hv_store_ent(hash,*relem,tmpstr,0);
966         if (SvMAGICAL(hash)) {
967             if (SvSMAGICAL(tmpstr))
968                 mg_set(tmpstr);
969             if (!didstore)
970                 sv_2mortal(tmpstr);
971         }
972         TAINT_NOT;
973     }
974 }
975
976 PP(pp_aassign)
977 {
978     dVAR; dSP;
979     SV **lastlelem = PL_stack_sp;
980     SV **lastrelem = PL_stack_base + POPMARK;
981     SV **firstrelem = PL_stack_base + POPMARK + 1;
982     SV **firstlelem = lastrelem + 1;
983
984     register SV **relem;
985     register SV **lelem;
986
987     register SV *sv;
988     register AV *ary;
989
990     I32 gimme;
991     HV *hash;
992     I32 i;
993     int magic;
994     int duplicates = 0;
995     SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet  */
996
997     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
998     gimme = GIMME_V;
999
1000     /* If there's a common identifier on both sides we have to take
1001      * special care that assigning the identifier on the left doesn't
1002      * clobber a value on the right that's used later in the list.
1003      */
1004     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1005         EXTEND_MORTAL(lastrelem - firstrelem + 1);
1006         for (relem = firstrelem; relem <= lastrelem; relem++) {
1007             if ((sv = *relem)) {
1008                 TAINT_NOT;      /* Each item is independent */
1009                 *relem = sv_mortalcopy(sv);
1010             }
1011         }
1012     }
1013
1014     relem = firstrelem;
1015     lelem = firstlelem;
1016     ary = NULL;
1017     hash = NULL;
1018
1019     while (lelem <= lastlelem) {
1020         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1021         sv = *lelem++;
1022         switch (SvTYPE(sv)) {
1023         case SVt_PVAV:
1024             ary = (AV*)sv;
1025             magic = SvMAGICAL(ary) != 0;
1026             av_clear(ary);
1027             av_extend(ary, lastrelem - relem);
1028             i = 0;
1029             while (relem <= lastrelem) {        /* gobble up all the rest */
1030                 SV **didstore;
1031                 assert(*relem);
1032                 sv = newSVsv(*relem);
1033                 *(relem++) = sv;
1034                 didstore = av_store(ary,i++,sv);
1035                 if (magic) {
1036                     if (SvSMAGICAL(sv)) {
1037                         /* More magic can happen in the mg_set callback, so we
1038                          * backup the delaymagic for now. */
1039                         U16 dmbak = PL_delaymagic;
1040                         PL_delaymagic = 0;
1041                         mg_set(sv);
1042                         PL_delaymagic = dmbak;
1043                     }
1044                     if (!didstore)
1045                         sv_2mortal(sv);
1046                 }
1047                 TAINT_NOT;
1048             }
1049             if (PL_delaymagic & DM_ARRAY)
1050                 SvSETMAGIC((SV*)ary);
1051             break;
1052         case SVt_PVHV: {                                /* normal hash */
1053                 SV *tmpstr;
1054
1055                 hash = (HV*)sv;
1056                 magic = SvMAGICAL(hash) != 0;
1057                 hv_clear(hash);
1058                 firsthashrelem = relem;
1059
1060                 while (relem < lastrelem) {     /* gobble up all the rest */
1061                     HE *didstore;
1062                     sv = *relem ? *relem : &PL_sv_no;
1063                     relem++;
1064                     tmpstr = newSV(0);
1065                     if (*relem)
1066                         sv_setsv(tmpstr,*relem);        /* value */
1067                     *(relem++) = tmpstr;
1068                     if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1069                         /* key overwrites an existing entry */
1070                         duplicates += 2;
1071                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1072                     if (magic) {
1073                         if (SvSMAGICAL(tmpstr)) {
1074                             U16 dmbak = PL_delaymagic;
1075                             PL_delaymagic = 0;
1076                             mg_set(tmpstr);
1077                             PL_delaymagic = dmbak;
1078                         }
1079                         if (!didstore)
1080                             sv_2mortal(tmpstr);
1081                     }
1082                     TAINT_NOT;
1083                 }
1084                 if (relem == lastrelem) {
1085                     do_oddball(hash, relem, firstrelem);
1086                     relem++;
1087                 }
1088             }
1089             break;
1090         default:
1091             if (SvIMMORTAL(sv)) {
1092                 if (relem <= lastrelem)
1093                     relem++;
1094                 break;
1095             }
1096             if (relem <= lastrelem) {
1097                 sv_setsv(sv, *relem);
1098                 *(relem++) = sv;
1099             }
1100             else
1101                 sv_setsv(sv, &PL_sv_undef);
1102
1103             if (SvSMAGICAL(sv)) {
1104                 U16 dmbak = PL_delaymagic;
1105                 PL_delaymagic = 0;
1106                 mg_set(sv);
1107                 PL_delaymagic = dmbak;
1108             }
1109             break;
1110         }
1111     }
1112     if (PL_delaymagic & ~DM_DELAY) {
1113         if (PL_delaymagic & DM_UID) {
1114 #ifdef HAS_SETRESUID
1115             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1116                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1117                             (Uid_t)-1);
1118 #else
1119 #  ifdef HAS_SETREUID
1120             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1121                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1122 #  else
1123 #    ifdef HAS_SETRUID
1124             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1125                 (void)setruid(PL_uid);
1126                 PL_delaymagic &= ~DM_RUID;
1127             }
1128 #    endif /* HAS_SETRUID */
1129 #    ifdef HAS_SETEUID
1130             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1131                 (void)seteuid(PL_euid);
1132                 PL_delaymagic &= ~DM_EUID;
1133             }
1134 #    endif /* HAS_SETEUID */
1135             if (PL_delaymagic & DM_UID) {
1136                 if (PL_uid != PL_euid)
1137                     DIE(aTHX_ "No setreuid available");
1138                 (void)PerlProc_setuid(PL_uid);
1139             }
1140 #  endif /* HAS_SETREUID */
1141 #endif /* HAS_SETRESUID */
1142             PL_uid = PerlProc_getuid();
1143             PL_euid = PerlProc_geteuid();
1144         }
1145         if (PL_delaymagic & DM_GID) {
1146 #ifdef HAS_SETRESGID
1147             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1148                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1149                             (Gid_t)-1);
1150 #else
1151 #  ifdef HAS_SETREGID
1152             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1153                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1154 #  else
1155 #    ifdef HAS_SETRGID
1156             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1157                 (void)setrgid(PL_gid);
1158                 PL_delaymagic &= ~DM_RGID;
1159             }
1160 #    endif /* HAS_SETRGID */
1161 #    ifdef HAS_SETEGID
1162             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1163                 (void)setegid(PL_egid);
1164                 PL_delaymagic &= ~DM_EGID;
1165             }
1166 #    endif /* HAS_SETEGID */
1167             if (PL_delaymagic & DM_GID) {
1168                 if (PL_gid != PL_egid)
1169                     DIE(aTHX_ "No setregid available");
1170                 (void)PerlProc_setgid(PL_gid);
1171             }
1172 #  endif /* HAS_SETREGID */
1173 #endif /* HAS_SETRESGID */
1174             PL_gid = PerlProc_getgid();
1175             PL_egid = PerlProc_getegid();
1176         }
1177         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1178     }
1179     PL_delaymagic = 0;
1180
1181     if (gimme == G_VOID)
1182         SP = firstrelem - 1;
1183     else if (gimme == G_SCALAR) {
1184         dTARGET;
1185         SP = firstrelem;
1186         SETi(lastrelem - firstrelem + 1 - duplicates);
1187     }
1188     else {
1189         if (ary)
1190             SP = lastrelem;
1191         else if (hash) {
1192             if (duplicates) {
1193                 /* Removes from the stack the entries which ended up as
1194                  * duplicated keys in the hash (fix for [perl #24380]) */
1195                 Move(firsthashrelem + duplicates,
1196                         firsthashrelem, duplicates, SV**);
1197                 lastrelem -= duplicates;
1198             }
1199             SP = lastrelem;
1200         }
1201         else
1202             SP = firstrelem + (lastlelem - firstlelem);
1203         lelem = firstlelem + (relem - firstrelem);
1204         while (relem <= SP)
1205             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1206     }
1207
1208     RETURN;
1209 }
1210
1211 PP(pp_qr)
1212 {
1213     dVAR; dSP;
1214     register PMOP * const pm = cPMOP;
1215     REGEXP * rx = PM_GETRE(pm);
1216     SV * const pkg = CALLREG_PACKAGE(rx);
1217     SV * const rv = sv_newmortal();
1218     SV * const sv = newSVrv(rv, SvPV_nolen(pkg));
1219     SvREFCNT_dec(pkg);
1220     if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1221         SvTAINTED_on(rv);
1222     sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0);
1223     XPUSHs(rv);
1224     RETURN;
1225 }
1226
1227 PP(pp_match)
1228 {
1229     dVAR; dSP; dTARG;
1230     register PMOP *pm = cPMOP;
1231     PMOP *dynpm = pm;
1232     register const char *t;
1233     register const char *s;
1234     const char *strend;
1235     I32 global;
1236     I32 r_flags = REXEC_CHECKED;
1237     const char *truebase;                       /* Start of string  */
1238     register REGEXP *rx = PM_GETRE(pm);
1239     bool rxtainted;
1240     const I32 gimme = GIMME;
1241     STRLEN len;
1242     I32 minmatch = 0;
1243     const I32 oldsave = PL_savestack_ix;
1244     I32 update_minmatch = 1;
1245     I32 had_zerolen = 0;
1246     U32 gpos = 0;
1247
1248     if (PL_op->op_flags & OPf_STACKED)
1249         TARG = POPs;
1250     else if (PL_op->op_private & OPpTARGET_MY)
1251         GETTARGET;
1252     else {
1253         TARG = DEFSV;
1254         EXTEND(SP,1);
1255     }
1256
1257     PUTBACK;                            /* EVAL blocks need stack_sp. */
1258     s = SvPV_const(TARG, len);
1259     if (!s)
1260         DIE(aTHX_ "panic: pp_match");
1261     strend = s + len;
1262     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1263                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1264     TAINT_NOT;
1265
1266     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1267
1268     /* PMdf_USED is set after a ?? matches once */
1269     if (
1270 #ifdef USE_ITHREADS
1271         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1272 #else
1273         pm->op_pmflags & PMf_USED
1274 #endif
1275     ) {
1276       failure:
1277         if (gimme == G_ARRAY)
1278             RETURN;
1279         RETPUSHNO;
1280     }
1281
1282
1283
1284     /* empty pattern special-cased to use last successful pattern if possible */
1285     if (!RX_PRELEN(rx) && PL_curpm) {
1286         pm = PL_curpm;
1287         rx = PM_GETRE(pm);
1288     }
1289
1290     if (RX_MINLEN(rx) > (I32)len)
1291         goto failure;
1292
1293     truebase = t = s;
1294
1295     /* XXXX What part of this is needed with true \G-support? */
1296     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1297         RX_OFFS(rx)[0].start = -1;
1298         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1299             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1300             if (mg && mg->mg_len >= 0) {
1301                 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1302                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1303                 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1304                     r_flags |= REXEC_IGNOREPOS;
1305                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1306                 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT) 
1307                     gpos = mg->mg_len;
1308                 else 
1309                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1310                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1311                 update_minmatch = 0;
1312             }
1313         }
1314     }
1315     /* XXX: comment out !global get safe $1 vars after a
1316        match, BUT be aware that this leads to dramatic slowdowns on
1317        /g matches against large strings.  So far a solution to this problem
1318        appears to be quite tricky.
1319        Test for the unsafe vars are TODO for now. */
1320     if ((  !global && RX_NPARENS(rx)) 
1321             || SvTEMP(TARG) || PL_sawampersand ||
1322             (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1323         r_flags |= REXEC_COPY_STR;
1324     if (SvSCREAM(TARG))
1325         r_flags |= REXEC_SCREAM;
1326
1327 play_it_again:
1328     if (global && RX_OFFS(rx)[0].start != -1) {
1329         t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1330         if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1331             goto nope;
1332         if (update_minmatch++)
1333             minmatch = had_zerolen;
1334     }
1335     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1336         DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1337         /* FIXME - can PL_bostr be made const char *?  */
1338         PL_bostr = (char *)truebase;
1339         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1340
1341         if (!s)
1342             goto nope;
1343         if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1344              && !PL_sawampersand
1345              && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1346              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1347                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1348                       && (r_flags & REXEC_SCREAM)))
1349              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1350             goto yup;
1351     }
1352     if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1353                     minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1354     {
1355         PL_curpm = pm;
1356         if (dynpm->op_pmflags & PMf_ONCE) {
1357 #ifdef USE_ITHREADS
1358             SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1359 #else
1360             dynpm->op_pmflags |= PMf_USED;
1361 #endif
1362         }
1363         goto gotcha;
1364     }
1365     else
1366         goto ret_no;
1367     /*NOTREACHED*/
1368
1369   gotcha:
1370     if (rxtainted)
1371         RX_MATCH_TAINTED_on(rx);
1372     TAINT_IF(RX_MATCH_TAINTED(rx));
1373     if (gimme == G_ARRAY) {
1374         const I32 nparens = RX_NPARENS(rx);
1375         I32 i = (global && !nparens) ? 1 : 0;
1376
1377         SPAGAIN;                        /* EVAL blocks could move the stack. */
1378         EXTEND(SP, nparens + i);
1379         EXTEND_MORTAL(nparens + i);
1380         for (i = !i; i <= nparens; i++) {
1381             PUSHs(sv_newmortal());
1382             if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1383                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1384                 s = RX_OFFS(rx)[i].start + truebase;
1385                 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1386                     len < 0 || len > strend - s)
1387                     DIE(aTHX_ "panic: pp_match start/end pointers");
1388                 sv_setpvn(*SP, s, len);
1389                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1390                     SvUTF8_on(*SP);
1391             }
1392         }
1393         if (global) {
1394             if (dynpm->op_pmflags & PMf_CONTINUE) {
1395                 MAGIC* mg = NULL;
1396                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1397                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1398                 if (!mg) {
1399 #ifdef PERL_OLD_COPY_ON_WRITE
1400                     if (SvIsCOW(TARG))
1401                         sv_force_normal_flags(TARG, 0);
1402 #endif
1403                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1404                                      &PL_vtbl_mglob, NULL, 0);
1405                 }
1406                 if (RX_OFFS(rx)[0].start != -1) {
1407                     mg->mg_len = RX_OFFS(rx)[0].end;
1408                     if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1409                         mg->mg_flags |= MGf_MINMATCH;
1410                     else
1411                         mg->mg_flags &= ~MGf_MINMATCH;
1412                 }
1413             }
1414             had_zerolen = (RX_OFFS(rx)[0].start != -1
1415                            && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1416                                == (UV)RX_OFFS(rx)[0].end));
1417             PUTBACK;                    /* EVAL blocks may use stack */
1418             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1419             goto play_it_again;
1420         }
1421         else if (!nparens)
1422             XPUSHs(&PL_sv_yes);
1423         LEAVE_SCOPE(oldsave);
1424         RETURN;
1425     }
1426     else {
1427         if (global) {
1428             MAGIC* mg;
1429             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1430                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1431             else
1432                 mg = NULL;
1433             if (!mg) {
1434 #ifdef PERL_OLD_COPY_ON_WRITE
1435                 if (SvIsCOW(TARG))
1436                     sv_force_normal_flags(TARG, 0);
1437 #endif
1438                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1439                                  &PL_vtbl_mglob, NULL, 0);
1440             }
1441             if (RX_OFFS(rx)[0].start != -1) {
1442                 mg->mg_len = RX_OFFS(rx)[0].end;
1443                 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1444                     mg->mg_flags |= MGf_MINMATCH;
1445                 else
1446                     mg->mg_flags &= ~MGf_MINMATCH;
1447             }
1448         }
1449         LEAVE_SCOPE(oldsave);
1450         RETPUSHYES;
1451     }
1452
1453 yup:                                    /* Confirmed by INTUIT */
1454     if (rxtainted)
1455         RX_MATCH_TAINTED_on(rx);
1456     TAINT_IF(RX_MATCH_TAINTED(rx));
1457     PL_curpm = pm;
1458     if (dynpm->op_pmflags & PMf_ONCE) {
1459 #ifdef USE_ITHREADS
1460         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1461 #else
1462         dynpm->op_pmflags |= PMf_USED;
1463 #endif
1464     }
1465     if (RX_MATCH_COPIED(rx))
1466         Safefree(RX_SUBBEG(rx));
1467     RX_MATCH_COPIED_off(rx);
1468     RX_SUBBEG(rx) = NULL;
1469     if (global) {
1470         /* FIXME - should rx->subbeg be const char *?  */
1471         RX_SUBBEG(rx) = (char *) truebase;
1472         RX_OFFS(rx)[0].start = s - truebase;
1473         if (RX_MATCH_UTF8(rx)) {
1474             char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1475             RX_OFFS(rx)[0].end = t - truebase;
1476         }
1477         else {
1478             RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1479         }
1480         RX_SUBLEN(rx) = strend - truebase;
1481         goto gotcha;
1482     }
1483     if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1484         I32 off;
1485 #ifdef PERL_OLD_COPY_ON_WRITE
1486         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1487             if (DEBUG_C_TEST) {
1488                 PerlIO_printf(Perl_debug_log,
1489                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1490                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1491                               (int)(t-truebase));
1492             }
1493             rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1494             RX_SUBBEG(rx) = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1495             assert (SvPOKp(rx->saved_copy));
1496         } else
1497 #endif
1498         {
1499
1500             RX_SUBBEG(rx) = savepvn(t, strend - t);
1501 #ifdef PERL_OLD_COPY_ON_WRITE
1502             rx->saved_copy = NULL;
1503 #endif
1504         }
1505         RX_SUBLEN(rx) = strend - t;
1506         RX_MATCH_COPIED_on(rx);
1507         off = RX_OFFS(rx)[0].start = s - t;
1508         RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1509     }
1510     else {                      /* startp/endp are used by @- @+. */
1511         RX_OFFS(rx)[0].start = s - truebase;
1512         RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1513     }
1514     /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1515        -dmq */
1516     RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;      /* used by @-, @+, and $^N */
1517     LEAVE_SCOPE(oldsave);
1518     RETPUSHYES;
1519
1520 nope:
1521 ret_no:
1522     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1523         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1524             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1525             if (mg)
1526                 mg->mg_len = -1;
1527         }
1528     }
1529     LEAVE_SCOPE(oldsave);
1530     if (gimme == G_ARRAY)
1531         RETURN;
1532     RETPUSHNO;
1533 }
1534
1535 OP *
1536 Perl_do_readline(pTHX)
1537 {
1538     dVAR; dSP; dTARGETSTACKED;
1539     register SV *sv;
1540     STRLEN tmplen = 0;
1541     STRLEN offset;
1542     PerlIO *fp;
1543     register IO * const io = GvIO(PL_last_in_gv);
1544     register const I32 type = PL_op->op_type;
1545     const I32 gimme = GIMME_V;
1546
1547     if (io) {
1548         MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1549         if (mg) {
1550             PUSHMARK(SP);
1551             XPUSHs(SvTIED_obj((SV*)io, mg));
1552             PUTBACK;
1553             ENTER;
1554             call_method("READLINE", gimme);
1555             LEAVE;
1556             SPAGAIN;
1557             if (gimme == G_SCALAR) {
1558                 SV* const result = POPs;
1559                 SvSetSV_nosteal(TARG, result);
1560                 PUSHTARG;
1561             }
1562             RETURN;
1563         }
1564     }
1565     fp = NULL;
1566     if (io) {
1567         fp = IoIFP(io);
1568         if (!fp) {
1569             if (IoFLAGS(io) & IOf_ARGV) {
1570                 if (IoFLAGS(io) & IOf_START) {
1571                     IoLINES(io) = 0;
1572                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1573                         IoFLAGS(io) &= ~IOf_START;
1574                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1575                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1576                         SvSETMAGIC(GvSV(PL_last_in_gv));
1577                         fp = IoIFP(io);
1578                         goto have_fp;
1579                     }
1580                 }
1581                 fp = nextargv(PL_last_in_gv);
1582                 if (!fp) { /* Note: fp != IoIFP(io) */
1583                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1584                 }
1585             }
1586             else if (type == OP_GLOB)
1587                 fp = Perl_start_glob(aTHX_ POPs, io);
1588         }
1589         else if (type == OP_GLOB)
1590             SP--;
1591         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1592             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1593         }
1594     }
1595     if (!fp) {
1596         if ((!io || !(IoFLAGS(io) & IOf_START))
1597             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1598         {
1599             if (type == OP_GLOB)
1600                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1601                             "glob failed (can't start child: %s)",
1602                             Strerror(errno));
1603             else
1604                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1605         }
1606         if (gimme == G_SCALAR) {
1607             /* undef TARG, and push that undefined value */
1608             if (type != OP_RCATLINE) {
1609                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1610                 SvOK_off(TARG);
1611             }
1612             PUSHTARG;
1613         }
1614         RETURN;
1615     }
1616   have_fp:
1617     if (gimme == G_SCALAR) {
1618         sv = TARG;
1619         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1620             mg_get(sv);
1621         if (SvROK(sv)) {
1622             if (type == OP_RCATLINE)
1623                 SvPV_force_nolen(sv);
1624             else
1625                 sv_unref(sv);
1626         }
1627         else if (isGV_with_GP(sv)) {
1628             SvPV_force_nolen(sv);
1629         }
1630         SvUPGRADE(sv, SVt_PV);
1631         tmplen = SvLEN(sv);     /* remember if already alloced */
1632         if (!tmplen && !SvREADONLY(sv))
1633             Sv_Grow(sv, 80);    /* try short-buffering it */
1634         offset = 0;
1635         if (type == OP_RCATLINE && SvOK(sv)) {
1636             if (!SvPOK(sv)) {
1637                 SvPV_force_nolen(sv);
1638             }
1639             offset = SvCUR(sv);
1640         }
1641     }
1642     else {
1643         sv = sv_2mortal(newSV(80));
1644         offset = 0;
1645     }
1646
1647     /* This should not be marked tainted if the fp is marked clean */
1648 #define MAYBE_TAINT_LINE(io, sv) \
1649     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1650         TAINT;                          \
1651         SvTAINTED_on(sv);               \
1652     }
1653
1654 /* delay EOF state for a snarfed empty file */
1655 #define SNARF_EOF(gimme,rs,io,sv) \
1656     (gimme != G_SCALAR || SvCUR(sv)                                     \
1657      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1658
1659     for (;;) {
1660         PUTBACK;
1661         if (!sv_gets(sv, fp, offset)
1662             && (type == OP_GLOB
1663                 || SNARF_EOF(gimme, PL_rs, io, sv)
1664                 || PerlIO_error(fp)))
1665         {
1666             PerlIO_clearerr(fp);
1667             if (IoFLAGS(io) & IOf_ARGV) {
1668                 fp = nextargv(PL_last_in_gv);
1669                 if (fp)
1670                     continue;
1671                 (void)do_close(PL_last_in_gv, FALSE);
1672             }
1673             else if (type == OP_GLOB) {
1674                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1675                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1676                            "glob failed (child exited with status %d%s)",
1677                            (int)(STATUS_CURRENT >> 8),
1678                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1679                 }
1680             }
1681             if (gimme == G_SCALAR) {
1682                 if (type != OP_RCATLINE) {
1683                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1684                     SvOK_off(TARG);
1685                 }
1686                 SPAGAIN;
1687                 PUSHTARG;
1688             }
1689             MAYBE_TAINT_LINE(io, sv);
1690             RETURN;
1691         }
1692         MAYBE_TAINT_LINE(io, sv);
1693         IoLINES(io)++;
1694         IoFLAGS(io) |= IOf_NOLINE;
1695         SvSETMAGIC(sv);
1696         SPAGAIN;
1697         XPUSHs(sv);
1698         if (type == OP_GLOB) {
1699             const char *t1;
1700
1701             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1702                 char * const tmps = SvEND(sv) - 1;
1703                 if (*tmps == *SvPVX_const(PL_rs)) {
1704                     *tmps = '\0';
1705                     SvCUR_set(sv, SvCUR(sv) - 1);
1706                 }
1707             }
1708             for (t1 = SvPVX_const(sv); *t1; t1++)
1709                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1710                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1711                         break;
1712             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1713                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1714                 continue;
1715             }
1716         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1717              if (ckWARN(WARN_UTF8)) {
1718                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1719                 const STRLEN len = SvCUR(sv) - offset;
1720                 const U8 *f;
1721
1722                 if (!is_utf8_string_loc(s, len, &f))
1723                     /* Emulate :encoding(utf8) warning in the same case. */
1724                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1725                                 "utf8 \"\\x%02X\" does not map to Unicode",
1726                                 f < (U8*)SvEND(sv) ? *f : 0);
1727              }
1728         }
1729         if (gimme == G_ARRAY) {
1730             if (SvLEN(sv) - SvCUR(sv) > 20) {
1731                 SvPV_shrink_to_cur(sv);
1732             }
1733             sv = sv_2mortal(newSV(80));
1734             continue;
1735         }
1736         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1737             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1738             const STRLEN new_len
1739                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1740             SvPV_renew(sv, new_len);
1741         }
1742         RETURN;
1743     }
1744 }
1745
1746 PP(pp_enter)
1747 {
1748     dVAR; dSP;
1749     register PERL_CONTEXT *cx;
1750     I32 gimme = OP_GIMME(PL_op, -1);
1751
1752     if (gimme == -1) {
1753         if (cxstack_ix >= 0)
1754             gimme = cxstack[cxstack_ix].blk_gimme;
1755         else
1756             gimme = G_SCALAR;
1757     }
1758
1759     ENTER;
1760
1761     SAVETMPS;
1762     PUSHBLOCK(cx, CXt_BLOCK, SP);
1763
1764     RETURN;
1765 }
1766
1767 PP(pp_helem)
1768 {
1769     dVAR; dSP;
1770     HE* he;
1771     SV **svp;
1772     SV * const keysv = POPs;
1773     HV * const hv = (HV*)POPs;
1774     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1775     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1776     SV *sv;
1777     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1778     I32 preeminent = 0;
1779
1780     if (SvTYPE(hv) != SVt_PVHV)
1781         RETPUSHUNDEF;
1782
1783     if (PL_op->op_private & OPpLVAL_INTRO) {
1784         MAGIC *mg;
1785         HV *stash;
1786         /* does the element we're localizing already exist? */
1787         preeminent = /* can we determine whether it exists? */
1788             (    !SvRMAGICAL(hv)
1789                 || mg_find((SV*)hv, PERL_MAGIC_env)
1790                 || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1791                         /* Try to preserve the existenceness of a tied hash
1792                         * element by using EXISTS and DELETE if possible.
1793                         * Fallback to FETCH and STORE otherwise */
1794                     && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1795                     && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1796                     && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1797                 )
1798             ) ? hv_exists_ent(hv, keysv, 0) : 1;
1799     }
1800     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1801     svp = he ? &HeVAL(he) : NULL;
1802     if (lval) {
1803         if (!svp || *svp == &PL_sv_undef) {
1804             SV* lv;
1805             SV* key2;
1806             if (!defer) {
1807                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1808             }
1809             lv = sv_newmortal();
1810             sv_upgrade(lv, SVt_PVLV);
1811             LvTYPE(lv) = 'y';
1812             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1813             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1814             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1815             LvTARGLEN(lv) = 1;
1816             PUSHs(lv);
1817             RETURN;
1818         }
1819         if (PL_op->op_private & OPpLVAL_INTRO) {
1820             if (HvNAME_get(hv) && isGV(*svp))
1821                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1822             else {
1823                 if (!preeminent) {
1824                     STRLEN keylen;
1825                     const char * const key = SvPV_const(keysv, keylen);
1826                     SAVEDELETE(hv, savepvn(key,keylen),
1827                                SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1828                 } else
1829                     save_helem(hv, keysv, svp);
1830             }
1831         }
1832         else if (PL_op->op_private & OPpDEREF)
1833             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1834     }
1835     sv = (svp ? *svp : &PL_sv_undef);
1836     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1837      * Pushing the magical RHS on to the stack is useless, since
1838      * that magic is soon destined to be misled by the local(),
1839      * and thus the later pp_sassign() will fail to mg_get() the
1840      * old value.  This should also cure problems with delayed
1841      * mg_get()s.  GSAR 98-07-03 */
1842     if (!lval && SvGMAGICAL(sv))
1843         sv = sv_mortalcopy(sv);
1844     PUSHs(sv);
1845     RETURN;
1846 }
1847
1848 PP(pp_leave)
1849 {
1850     dVAR; dSP;
1851     register PERL_CONTEXT *cx;
1852     SV **newsp;
1853     PMOP *newpm;
1854     I32 gimme;
1855
1856     if (PL_op->op_flags & OPf_SPECIAL) {
1857         cx = &cxstack[cxstack_ix];
1858         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1859     }
1860
1861     POPBLOCK(cx,newpm);
1862
1863     gimme = OP_GIMME(PL_op, -1);
1864     if (gimme == -1) {
1865         if (cxstack_ix >= 0)
1866             gimme = cxstack[cxstack_ix].blk_gimme;
1867         else
1868             gimme = G_SCALAR;
1869     }
1870
1871     TAINT_NOT;
1872     if (gimme == G_VOID)
1873         SP = newsp;
1874     else if (gimme == G_SCALAR) {
1875         register SV **mark;
1876         MARK = newsp + 1;
1877         if (MARK <= SP) {
1878             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1879                 *MARK = TOPs;
1880             else
1881                 *MARK = sv_mortalcopy(TOPs);
1882         } else {
1883             MEXTEND(mark,0);
1884             *MARK = &PL_sv_undef;
1885         }
1886         SP = MARK;
1887     }
1888     else if (gimme == G_ARRAY) {
1889         /* in case LEAVE wipes old return values */
1890         register SV **mark;
1891         for (mark = newsp + 1; mark <= SP; mark++) {
1892             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1893                 *mark = sv_mortalcopy(*mark);
1894                 TAINT_NOT;      /* Each item is independent */
1895             }
1896         }
1897     }
1898     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1899
1900     LEAVE;
1901
1902     RETURN;
1903 }
1904
1905 PP(pp_iter)
1906 {
1907     dVAR; dSP;
1908     register PERL_CONTEXT *cx;
1909     SV *sv, *oldsv;
1910     AV* av;
1911     SV **itersvp;
1912
1913     EXTEND(SP, 1);
1914     cx = &cxstack[cxstack_ix];
1915     if (CxTYPE(cx) != CXt_LOOP)
1916         DIE(aTHX_ "panic: pp_iter");
1917
1918     itersvp = CxITERVAR(cx);
1919     av = cx->blk_loop.iterary;
1920     if (SvTYPE(av) != SVt_PVAV) {
1921         /* iterate ($min .. $max) */
1922         if (cx->blk_loop.iterlval) {
1923             /* string increment */
1924             register SV* cur = cx->blk_loop.iterlval;
1925             /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1926                It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1927             STRLEN maxlen = 0;
1928             const char *max = SvPV_const((SV*)av, maxlen);
1929             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1930                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1931                     /* safe to reuse old SV */
1932                     sv_setsv(*itersvp, cur);
1933                 }
1934                 else
1935                 {
1936                     /* we need a fresh SV every time so that loop body sees a
1937                      * completely new SV for closures/references to work as
1938                      * they used to */
1939                     oldsv = *itersvp;
1940                     *itersvp = newSVsv(cur);
1941                     SvREFCNT_dec(oldsv);
1942                 }
1943                 if (strEQ(SvPVX_const(cur), max))
1944                     sv_setiv(cur, 0); /* terminate next time */
1945                 else
1946                     sv_inc(cur);
1947                 RETPUSHYES;
1948             }
1949             RETPUSHNO;
1950         }
1951         /* integer increment */
1952         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1953             RETPUSHNO;
1954
1955         /* don't risk potential race */
1956         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1957             /* safe to reuse old SV */
1958             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1959         }
1960         else
1961         {
1962             /* we need a fresh SV every time so that loop body sees a
1963              * completely new SV for closures/references to work as they
1964              * used to */
1965             oldsv = *itersvp;
1966             *itersvp = newSViv(cx->blk_loop.iterix++);
1967             SvREFCNT_dec(oldsv);
1968         }
1969
1970         /* Handle end of range at IV_MAX */
1971         if ((cx->blk_loop.iterix == IV_MIN) &&
1972             (cx->blk_loop.itermax == IV_MAX))
1973         {
1974             cx->blk_loop.iterix++;
1975             cx->blk_loop.itermax++;
1976         }
1977
1978         RETPUSHYES;
1979     }
1980
1981     /* iterate array */
1982     if (PL_op->op_private & OPpITER_REVERSED) {
1983         /* In reverse, use itermax as the min :-)  */
1984         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1985             RETPUSHNO;
1986
1987         if (SvMAGICAL(av) || AvREIFY(av)) {
1988             SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1989             sv = svp ? *svp : NULL;
1990         }
1991         else {
1992             sv = AvARRAY(av)[--cx->blk_loop.iterix];
1993         }
1994     }
1995     else {
1996         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1997                                     AvFILL(av)))
1998             RETPUSHNO;
1999
2000         if (SvMAGICAL(av) || AvREIFY(av)) {
2001             SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
2002             sv = svp ? *svp : NULL;
2003         }
2004         else {
2005             sv = AvARRAY(av)[++cx->blk_loop.iterix];
2006         }
2007     }
2008
2009     if (sv && SvIS_FREED(sv)) {
2010         *itersvp = NULL;
2011         Perl_croak(aTHX_ "Use of freed value in iteration");
2012     }
2013
2014     if (sv)
2015         SvTEMP_off(sv);
2016     else
2017         sv = &PL_sv_undef;
2018     if (av != PL_curstack && sv == &PL_sv_undef) {
2019         SV *lv = cx->blk_loop.iterlval;
2020         if (lv && SvREFCNT(lv) > 1) {
2021             SvREFCNT_dec(lv);
2022             lv = NULL;
2023         }
2024         if (lv)
2025             SvREFCNT_dec(LvTARG(lv));
2026         else {
2027             lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
2028             LvTYPE(lv) = 'y';
2029             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2030         }
2031         LvTARG(lv) = SvREFCNT_inc_simple(av);
2032         LvTARGOFF(lv) = cx->blk_loop.iterix;
2033         LvTARGLEN(lv) = (STRLEN)UV_MAX;
2034         sv = (SV*)lv;
2035     }
2036
2037     oldsv = *itersvp;
2038     *itersvp = SvREFCNT_inc_simple_NN(sv);
2039     SvREFCNT_dec(oldsv);
2040
2041     RETPUSHYES;
2042 }
2043
2044 PP(pp_subst)
2045 {
2046     dVAR; dSP; dTARG;
2047     register PMOP *pm = cPMOP;
2048     PMOP *rpm = pm;
2049     register char *s;
2050     char *strend;
2051     register char *m;
2052     const char *c;
2053     register char *d;
2054     STRLEN clen;
2055     I32 iters = 0;
2056     I32 maxiters;
2057     register I32 i;
2058     bool once;
2059     U8 rxtainted;
2060     char *orig;
2061     I32 r_flags;
2062     register REGEXP *rx = PM_GETRE(pm);
2063     STRLEN len;
2064     int force_on_match = 0;
2065     const I32 oldsave = PL_savestack_ix;
2066     STRLEN slen;
2067     bool doutf8 = FALSE;
2068     I32 matched;
2069 #ifdef PERL_OLD_COPY_ON_WRITE
2070     bool is_cow;
2071 #endif
2072     SV *nsv = NULL;
2073
2074     /* known replacement string? */
2075     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2076     if (PL_op->op_flags & OPf_STACKED)
2077         TARG = POPs;
2078     else if (PL_op->op_private & OPpTARGET_MY)
2079         GETTARGET;
2080     else {
2081         TARG = DEFSV;
2082         EXTEND(SP,1);
2083     }
2084
2085 #ifdef PERL_OLD_COPY_ON_WRITE
2086     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2087        because they make integers such as 256 "false".  */
2088     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2089 #else
2090     if (SvIsCOW(TARG))
2091         sv_force_normal_flags(TARG,0);
2092 #endif
2093     if (
2094 #ifdef PERL_OLD_COPY_ON_WRITE
2095         !is_cow &&
2096 #endif
2097         (SvREADONLY(TARG)
2098          || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2099                || SvTYPE(TARG) > SVt_PVLV)
2100              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2101         DIE(aTHX_ "%s", PL_no_modify);
2102     PUTBACK;
2103
2104     s = SvPV_mutable(TARG, len);
2105     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2106         force_on_match = 1;
2107     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2108                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2109     if (PL_tainted)
2110         rxtainted |= 2;
2111     TAINT_NOT;
2112
2113     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2114
2115   force_it:
2116     if (!pm || !s)
2117         DIE(aTHX_ "panic: pp_subst");
2118
2119     strend = s + len;
2120     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2121     maxiters = 2 * slen + 10;   /* We can match twice at each
2122                                    position, once with zero-length,
2123                                    second time with non-zero. */
2124
2125     if (!RX_PRELEN(rx) && PL_curpm) {
2126         pm = PL_curpm;
2127         rx = PM_GETRE(pm);
2128     }
2129     r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2130             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2131                ? REXEC_COPY_STR : 0;
2132     if (SvSCREAM(TARG))
2133         r_flags |= REXEC_SCREAM;
2134
2135     orig = m = s;
2136     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2137         PL_bostr = orig;
2138         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2139
2140         if (!s)
2141             goto nope;
2142         /* How to do it in subst? */
2143 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2144              && !PL_sawampersand
2145              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2146              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2147                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2148                       && (r_flags & REXEC_SCREAM))))
2149             goto yup;
2150 */
2151     }
2152
2153     /* only replace once? */
2154     once = !(rpm->op_pmflags & PMf_GLOBAL);
2155     matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2156                          r_flags | REXEC_CHECKED);
2157     /* known replacement string? */
2158     if (dstr) {
2159         /* replacement needing upgrading? */
2160         if (DO_UTF8(TARG) && !doutf8) {
2161              nsv = sv_newmortal();
2162              SvSetSV(nsv, dstr);
2163              if (PL_encoding)
2164                   sv_recode_to_utf8(nsv, PL_encoding);
2165              else
2166                   sv_utf8_upgrade(nsv);
2167              c = SvPV_const(nsv, clen);
2168              doutf8 = TRUE;
2169         }
2170         else {
2171             c = SvPV_const(dstr, clen);
2172             doutf8 = DO_UTF8(dstr);
2173         }
2174     }
2175     else {
2176         c = NULL;
2177         doutf8 = FALSE;
2178     }
2179     
2180     /* can do inplace substitution? */
2181     if (c
2182 #ifdef PERL_OLD_COPY_ON_WRITE
2183         && !is_cow
2184 #endif
2185         && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2186         && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2187         && (!doutf8 || SvUTF8(TARG))) {
2188         if (!matched)
2189         {
2190             SPAGAIN;
2191             PUSHs(&PL_sv_no);
2192             LEAVE_SCOPE(oldsave);
2193             RETURN;
2194         }
2195 #ifdef PERL_OLD_COPY_ON_WRITE
2196         if (SvIsCOW(TARG)) {
2197             assert (!force_on_match);
2198             goto have_a_cow;
2199         }
2200 #endif
2201         if (force_on_match) {
2202             force_on_match = 0;
2203             s = SvPV_force(TARG, len);
2204             goto force_it;
2205         }
2206         d = s;
2207         PL_curpm = pm;
2208         SvSCREAM_off(TARG);     /* disable possible screamer */
2209         if (once) {
2210             rxtainted |= RX_MATCH_TAINTED(rx);
2211             m = orig + RX_OFFS(rx)[0].start;
2212             d = orig + RX_OFFS(rx)[0].end;
2213             s = orig;
2214             if (m - s > strend - d) {  /* faster to shorten from end */
2215                 if (clen) {
2216                     Copy(c, m, clen, char);
2217                     m += clen;
2218                 }
2219                 i = strend - d;
2220                 if (i > 0) {
2221                     Move(d, m, i, char);
2222                     m += i;
2223                 }
2224                 *m = '\0';
2225                 SvCUR_set(TARG, m - s);
2226             }
2227             else if ((i = m - s)) {     /* faster from front */
2228                 d -= clen;
2229                 m = d;
2230                 Move(s, d - i, i, char);
2231                 sv_chop(TARG, d-i);
2232                 if (clen)
2233                     Copy(c, m, clen, char);
2234             }
2235             else if (clen) {
2236                 d -= clen;
2237                 sv_chop(TARG, d);
2238                 Copy(c, d, clen, char);
2239             }
2240             else {
2241                 sv_chop(TARG, d);
2242             }
2243             TAINT_IF(rxtainted & 1);
2244             SPAGAIN;
2245             PUSHs(&PL_sv_yes);
2246         }
2247         else {
2248             do {
2249                 if (iters++ > maxiters)
2250                     DIE(aTHX_ "Substitution loop");
2251                 rxtainted |= RX_MATCH_TAINTED(rx);
2252                 m = RX_OFFS(rx)[0].start + orig;
2253                 if ((i = m - s)) {
2254                     if (s != d)
2255                         Move(s, d, i, char);
2256                     d += i;
2257                 }
2258                 if (clen) {
2259                     Copy(c, d, clen, char);
2260                     d += clen;
2261                 }
2262                 s = RX_OFFS(rx)[0].end + orig;
2263             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2264                                  TARG, NULL,
2265                                  /* don't match same null twice */
2266                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2267             if (s != d) {
2268                 i = strend - s;
2269                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2270                 Move(s, d, i+1, char);          /* include the NUL */
2271             }
2272             TAINT_IF(rxtainted & 1);
2273             SPAGAIN;
2274             mPUSHi((I32)iters);
2275         }
2276         (void)SvPOK_only_UTF8(TARG);
2277         TAINT_IF(rxtainted);
2278         if (SvSMAGICAL(TARG)) {
2279             PUTBACK;
2280             mg_set(TARG);
2281             SPAGAIN;
2282         }
2283         SvTAINT(TARG);
2284         if (doutf8)
2285             SvUTF8_on(TARG);
2286         LEAVE_SCOPE(oldsave);
2287         RETURN;
2288     }
2289
2290     if (matched)
2291     {
2292         if (force_on_match) {
2293             force_on_match = 0;
2294             s = SvPV_force(TARG, len);
2295             goto force_it;
2296         }
2297 #ifdef PERL_OLD_COPY_ON_WRITE
2298       have_a_cow:
2299 #endif
2300         rxtainted |= RX_MATCH_TAINTED(rx);
2301         dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2302         SAVEFREESV(dstr);
2303         PL_curpm = pm;
2304         if (!c) {
2305             register PERL_CONTEXT *cx;
2306             SPAGAIN;
2307             PUSHSUBST(cx);
2308             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2309         }
2310         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2311         do {
2312             if (iters++ > maxiters)
2313                 DIE(aTHX_ "Substitution loop");
2314             rxtainted |= RX_MATCH_TAINTED(rx);
2315             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2316                 m = s;
2317                 s = orig;
2318                 orig = RX_SUBBEG(rx);
2319                 s = orig + (m - s);
2320                 strend = s + (strend - m);
2321             }
2322             m = RX_OFFS(rx)[0].start + orig;
2323             if (doutf8 && !SvUTF8(dstr))
2324                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2325             else
2326                 sv_catpvn(dstr, s, m-s);
2327             s = RX_OFFS(rx)[0].end + orig;
2328             if (clen)
2329                 sv_catpvn(dstr, c, clen);
2330             if (once)
2331                 break;
2332         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2333                              TARG, NULL, r_flags));
2334         if (doutf8 && !DO_UTF8(TARG))
2335             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2336         else
2337             sv_catpvn(dstr, s, strend - s);
2338
2339 #ifdef PERL_OLD_COPY_ON_WRITE
2340         /* The match may make the string COW. If so, brilliant, because that's
2341            just saved us one malloc, copy and free - the regexp has donated
2342            the old buffer, and we malloc an entirely new one, rather than the
2343            regexp malloc()ing a buffer and copying our original, only for
2344            us to throw it away here during the substitution.  */
2345         if (SvIsCOW(TARG)) {
2346             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2347         } else
2348 #endif
2349         {
2350             SvPV_free(TARG);
2351         }
2352         SvPV_set(TARG, SvPVX(dstr));
2353         SvCUR_set(TARG, SvCUR(dstr));
2354         SvLEN_set(TARG, SvLEN(dstr));
2355         doutf8 |= DO_UTF8(dstr);
2356         SvPV_set(dstr, NULL);
2357
2358         TAINT_IF(rxtainted & 1);
2359         SPAGAIN;
2360         mPUSHi((I32)iters);
2361
2362         (void)SvPOK_only(TARG);
2363         if (doutf8)
2364             SvUTF8_on(TARG);
2365         TAINT_IF(rxtainted);
2366         SvSETMAGIC(TARG);
2367         SvTAINT(TARG);
2368         LEAVE_SCOPE(oldsave);
2369         RETURN;
2370     }
2371     goto ret_no;
2372
2373 nope:
2374 ret_no:
2375     SPAGAIN;
2376     PUSHs(&PL_sv_no);
2377     LEAVE_SCOPE(oldsave);
2378     RETURN;
2379 }
2380
2381 PP(pp_grepwhile)
2382 {
2383     dVAR; dSP;
2384
2385     if (SvTRUEx(POPs))
2386         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2387     ++*PL_markstack_ptr;
2388     LEAVE;                                      /* exit inner scope */
2389
2390     /* All done yet? */
2391     if (PL_stack_base + *PL_markstack_ptr > SP) {
2392         I32 items;
2393         const I32 gimme = GIMME_V;
2394
2395         LEAVE;                                  /* exit outer scope */
2396         (void)POPMARK;                          /* pop src */
2397         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2398         (void)POPMARK;                          /* pop dst */
2399         SP = PL_stack_base + POPMARK;           /* pop original mark */
2400         if (gimme == G_SCALAR) {
2401             if (PL_op->op_private & OPpGREP_LEX) {
2402                 SV* const sv = sv_newmortal();
2403                 sv_setiv(sv, items);
2404                 PUSHs(sv);
2405             }
2406             else {
2407                 dTARGET;
2408                 XPUSHi(items);
2409             }
2410         }
2411         else if (gimme == G_ARRAY)
2412             SP += items;
2413         RETURN;
2414     }
2415     else {
2416         SV *src;
2417
2418         ENTER;                                  /* enter inner scope */
2419         SAVEVPTR(PL_curpm);
2420
2421         src = PL_stack_base[*PL_markstack_ptr];
2422         SvTEMP_off(src);
2423         if (PL_op->op_private & OPpGREP_LEX)
2424             PAD_SVl(PL_op->op_targ) = src;
2425         else
2426             DEFSV_set(src);
2427
2428         RETURNOP(cLOGOP->op_other);
2429     }
2430 }
2431
2432 PP(pp_leavesub)
2433 {
2434     dVAR; dSP;
2435     SV **mark;
2436     SV **newsp;
2437     PMOP *newpm;
2438     I32 gimme;
2439     register PERL_CONTEXT *cx;
2440     SV *sv;
2441
2442     if (CxMULTICALL(&cxstack[cxstack_ix]))
2443         return 0;
2444
2445     POPBLOCK(cx,newpm);
2446     cxstack_ix++; /* temporarily protect top context */
2447
2448     TAINT_NOT;
2449     if (gimme == G_SCALAR) {
2450         MARK = newsp + 1;
2451         if (MARK <= SP) {
2452             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2453                 if (SvTEMP(TOPs)) {
2454                     *MARK = SvREFCNT_inc(TOPs);
2455                     FREETMPS;
2456                     sv_2mortal(*MARK);
2457                 }
2458                 else {
2459                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2460                     FREETMPS;
2461                     *MARK = sv_mortalcopy(sv);
2462                     SvREFCNT_dec(sv);
2463                 }
2464             }
2465             else
2466                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2467         }
2468         else {
2469             MEXTEND(MARK, 0);
2470             *MARK = &PL_sv_undef;
2471         }
2472         SP = MARK;
2473     }
2474     else if (gimme == G_ARRAY) {
2475         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2476             if (!SvTEMP(*MARK)) {
2477                 *MARK = sv_mortalcopy(*MARK);
2478                 TAINT_NOT;      /* Each item is independent */
2479             }
2480         }
2481     }
2482     PUTBACK;
2483
2484     LEAVE;
2485     cxstack_ix--;
2486     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2487     PL_curpm = newpm;   /* ... and pop $1 et al */
2488
2489     LEAVESUB(sv);
2490     return cx->blk_sub.retop;
2491 }
2492
2493 /* This duplicates the above code because the above code must not
2494  * get any slower by more conditions */
2495 PP(pp_leavesublv)
2496 {
2497     dVAR; dSP;
2498     SV **mark;
2499     SV **newsp;
2500     PMOP *newpm;
2501     I32 gimme;
2502     register PERL_CONTEXT *cx;
2503     SV *sv;
2504
2505     if (CxMULTICALL(&cxstack[cxstack_ix]))
2506         return 0;
2507
2508     POPBLOCK(cx,newpm);
2509     cxstack_ix++; /* temporarily protect top context */
2510
2511     TAINT_NOT;
2512
2513     if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2514         /* We are an argument to a function or grep().
2515          * This kind of lvalueness was legal before lvalue
2516          * subroutines too, so be backward compatible:
2517          * cannot report errors.  */
2518
2519         /* Scalar context *is* possible, on the LHS of -> only,
2520          * as in f()->meth().  But this is not an lvalue. */
2521         if (gimme == G_SCALAR)
2522             goto temporise;
2523         if (gimme == G_ARRAY) {
2524             if (!CvLVALUE(cx->blk_sub.cv))
2525                 goto temporise_array;
2526             EXTEND_MORTAL(SP - newsp);
2527             for (mark = newsp + 1; mark <= SP; mark++) {
2528                 if (SvTEMP(*mark))
2529                     NOOP;
2530                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2531                     *mark = sv_mortalcopy(*mark);
2532                 else {
2533                     /* Can be a localized value subject to deletion. */
2534                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2535                     SvREFCNT_inc_void(*mark);
2536                 }
2537             }
2538         }
2539     }
2540     else if (CxLVAL(cx)) {     /* Leave it as it is if we can. */
2541         /* Here we go for robustness, not for speed, so we change all
2542          * the refcounts so the caller gets a live guy. Cannot set
2543          * TEMP, so sv_2mortal is out of question. */
2544         if (!CvLVALUE(cx->blk_sub.cv)) {
2545             LEAVE;
2546             cxstack_ix--;
2547             POPSUB(cx,sv);
2548             PL_curpm = newpm;
2549             LEAVESUB(sv);
2550             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2551         }
2552         if (gimme == G_SCALAR) {
2553             MARK = newsp + 1;
2554             EXTEND_MORTAL(1);
2555             if (MARK == SP) {
2556                 /* Temporaries are bad unless they happen to be elements
2557                  * of a tied hash or array */
2558                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2559                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2560                     LEAVE;
2561                     cxstack_ix--;
2562                     POPSUB(cx,sv);
2563                     PL_curpm = newpm;
2564                     LEAVESUB(sv);
2565                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2566                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2567                         : "a readonly value" : "a temporary");
2568                 }
2569                 else {                  /* Can be a localized value
2570                                          * subject to deletion. */
2571                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2572                     SvREFCNT_inc_void(*mark);
2573                 }
2574             }
2575             else {                      /* Should not happen? */
2576                 LEAVE;
2577                 cxstack_ix--;
2578                 POPSUB(cx,sv);
2579                 PL_curpm = newpm;
2580                 LEAVESUB(sv);
2581                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2582                     (MARK > SP ? "Empty array" : "Array"));
2583             }
2584             SP = MARK;
2585         }
2586         else if (gimme == G_ARRAY) {
2587             EXTEND_MORTAL(SP - newsp);
2588             for (mark = newsp + 1; mark <= SP; mark++) {
2589                 if (*mark != &PL_sv_undef
2590                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2591                     /* Might be flattened array after $#array =  */
2592                     PUTBACK;
2593                     LEAVE;
2594                     cxstack_ix--;
2595                     POPSUB(cx,sv);
2596                     PL_curpm = newpm;
2597                     LEAVESUB(sv);
2598                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2599                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2600                 }
2601                 else {
2602                     /* Can be a localized value subject to deletion. */
2603                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2604                     SvREFCNT_inc_void(*mark);
2605                 }
2606             }
2607         }
2608     }
2609     else {
2610         if (gimme == G_SCALAR) {
2611           temporise:
2612             MARK = newsp + 1;
2613             if (MARK <= SP) {
2614                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2615                     if (SvTEMP(TOPs)) {
2616                         *MARK = SvREFCNT_inc(TOPs);
2617                         FREETMPS;
2618                         sv_2mortal(*MARK);
2619                     }
2620                     else {
2621                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2622                         FREETMPS;
2623                         *MARK = sv_mortalcopy(sv);
2624                         SvREFCNT_dec(sv);
2625                     }
2626                 }
2627                 else
2628                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2629             }
2630             else {
2631                 MEXTEND(MARK, 0);
2632                 *MARK = &PL_sv_undef;
2633             }
2634             SP = MARK;
2635         }
2636         else if (gimme == G_ARRAY) {
2637           temporise_array:
2638             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2639                 if (!SvTEMP(*MARK)) {
2640                     *MARK = sv_mortalcopy(*MARK);
2641                     TAINT_NOT;  /* Each item is independent */
2642                 }
2643             }
2644         }
2645     }
2646     PUTBACK;
2647
2648     LEAVE;
2649     cxstack_ix--;
2650     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2651     PL_curpm = newpm;   /* ... and pop $1 et al */
2652
2653     LEAVESUB(sv);
2654     return cx->blk_sub.retop;
2655 }
2656
2657 PP(pp_entersub)
2658 {
2659     dVAR; dSP; dPOPss;
2660     GV *gv;
2661     register CV *cv;
2662     register PERL_CONTEXT *cx;
2663     I32 gimme;
2664     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2665
2666     if (!sv)
2667         DIE(aTHX_ "Not a CODE reference");
2668     switch (SvTYPE(sv)) {
2669         /* This is overwhelming the most common case:  */
2670     case SVt_PVGV:
2671         if (!isGV_with_GP(sv))
2672             DIE(aTHX_ "Not a CODE reference");
2673         if (!(cv = GvCVu((GV*)sv))) {
2674             HV *stash;
2675             cv = sv_2cv(sv, &stash, &gv, 0);
2676         }
2677         if (!cv) {
2678             ENTER;
2679             SAVETMPS;
2680             goto try_autoload;
2681         }
2682         break;
2683     default:
2684         if (!SvROK(sv)) {
2685             const char *sym;
2686             STRLEN len;
2687             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2688                 if (hasargs)
2689                     SP = PL_stack_base + POPMARK;
2690                 RETURN;
2691             }
2692             if (SvGMAGICAL(sv)) {
2693                 mg_get(sv);
2694                 if (SvROK(sv))
2695                     goto got_rv;
2696                 if (SvPOKp(sv)) {
2697                     sym = SvPVX_const(sv);
2698                     len = SvCUR(sv);
2699                 } else {
2700                     sym = NULL;
2701                     len = 0;
2702                 }
2703             }
2704             else {
2705                 sym = SvPV_const(sv, len);
2706             }
2707             if (!sym)
2708                 DIE(aTHX_ PL_no_usym, "a subroutine");
2709             if (PL_op->op_private & HINT_STRICT_REFS)
2710                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2711             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2712             break;
2713         }
2714   got_rv:
2715         {
2716             SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2717             tryAMAGICunDEREF(to_cv);
2718         }       
2719         cv = (CV*)SvRV(sv);
2720         if (SvTYPE(cv) == SVt_PVCV)
2721             break;
2722         /* FALL THROUGH */
2723     case SVt_PVHV:
2724     case SVt_PVAV:
2725         DIE(aTHX_ "Not a CODE reference");
2726         /* This is the second most common case:  */
2727     case SVt_PVCV:
2728         cv = (CV*)sv;
2729         break;
2730     }
2731
2732     ENTER;
2733     SAVETMPS;
2734
2735   retry:
2736     if (!CvROOT(cv) && !CvXSUB(cv)) {
2737         GV* autogv;
2738         SV* sub_name;
2739
2740         /* anonymous or undef'd function leaves us no recourse */
2741         if (CvANON(cv) || !(gv = CvGV(cv)))
2742             DIE(aTHX_ "Undefined subroutine called");
2743
2744         /* autoloaded stub? */
2745         if (cv != GvCV(gv)) {
2746             cv = GvCV(gv);
2747         }
2748         /* should call AUTOLOAD now? */
2749         else {
2750 try_autoload:
2751             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2752                                    FALSE)))
2753             {
2754                 cv = GvCV(autogv);
2755             }
2756             /* sorry */
2757             else {
2758                 sub_name = sv_newmortal();
2759                 gv_efullname3(sub_name, gv, NULL);
2760                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2761             }
2762         }
2763         if (!cv)
2764             DIE(aTHX_ "Not a CODE reference");
2765         goto retry;
2766     }
2767
2768     gimme = GIMME_V;
2769     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2770          Perl_get_db_sub(aTHX_ &sv, cv);
2771          if (CvISXSUB(cv))
2772              PL_curcopdb = PL_curcop;
2773          if (CvLVALUE(cv)) {
2774              /* check for lsub that handles lvalue subroutines */
2775              cv = GvCV(gv_HVadd(gv_fetchpv("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2776              /* if lsub not found then fall back to DB::sub */
2777              if (!cv) cv = GvCV(PL_DBsub);
2778          } else {
2779              cv = GvCV(PL_DBsub);
2780          }
2781
2782         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2783             DIE(aTHX_ "No DB::sub routine defined");
2784     }
2785
2786     if (!(CvISXSUB(cv))) {
2787         /* This path taken at least 75% of the time   */
2788         dMARK;
2789         register I32 items = SP - MARK;
2790         AV* const padlist = CvPADLIST(cv);
2791         PUSHBLOCK(cx, CXt_SUB, MARK);
2792         PUSHSUB(cx);
2793         cx->blk_sub.retop = PL_op->op_next;
2794         CvDEPTH(cv)++;
2795         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2796          * that eval'' ops within this sub know the correct lexical space.
2797          * Owing the speed considerations, we choose instead to search for
2798          * the cv using find_runcv() when calling doeval().
2799          */
2800         if (CvDEPTH(cv) >= 2) {
2801             PERL_STACK_OVERFLOW_CHECK();
2802             pad_push(padlist, CvDEPTH(cv));
2803         }
2804         SAVECOMPPAD();
2805         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2806         if (hasargs) {
2807             AV* const av = (AV*)PAD_SVl(0);
2808             if (AvREAL(av)) {
2809                 /* @_ is normally not REAL--this should only ever
2810                  * happen when DB::sub() calls things that modify @_ */
2811                 av_clear(av);
2812                 AvREAL_off(av);
2813                 AvREIFY_on(av);
2814             }
2815             cx->blk_sub.savearray = GvAV(PL_defgv);
2816             GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2817             CX_CURPAD_SAVE(cx->blk_sub);
2818             cx->blk_sub.argarray = av;
2819             ++MARK;
2820
2821             if (items > AvMAX(av) + 1) {
2822                 SV **ary = AvALLOC(av);
2823                 if (AvARRAY(av) != ary) {
2824                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2825                     AvARRAY(av) = ary;
2826                 }
2827                 if (items > AvMAX(av) + 1) {
2828                     AvMAX(av) = items - 1;
2829                     Renew(ary,items,SV*);
2830                     AvALLOC(av) = ary;
2831                     AvARRAY(av) = ary;
2832                 }
2833             }
2834             Copy(MARK,AvARRAY(av),items,SV*);
2835             AvFILLp(av) = items - 1;
2836         
2837             while (items--) {
2838                 if (*MARK)
2839                     SvTEMP_off(*MARK);
2840                 MARK++;
2841             }
2842         }
2843         /* warning must come *after* we fully set up the context
2844          * stuff so that __WARN__ handlers can safely dounwind()
2845          * if they want to
2846          */
2847         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2848             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2849             sub_crush_depth(cv);
2850 #if 0
2851         DEBUG_S(PerlIO_printf(Perl_debug_log,
2852                               "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2853 #endif
2854         RETURNOP(CvSTART(cv));
2855     }
2856     else {
2857         I32 markix = TOPMARK;
2858
2859         PUTBACK;
2860
2861         if (!hasargs) {
2862             /* Need to copy @_ to stack. Alternative may be to
2863              * switch stack to @_, and copy return values
2864              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2865             AV * const av = GvAV(PL_defgv);
2866             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2867
2868             if (items) {
2869                 /* Mark is at the end of the stack. */
2870                 EXTEND(SP, items);
2871                 Copy(AvARRAY(av), SP + 1, items, SV*);
2872                 SP += items;
2873                 PUTBACK ;               
2874             }
2875         }
2876         /* We assume first XSUB in &DB::sub is the called one. */
2877         if (PL_curcopdb) {
2878             SAVEVPTR(PL_curcop);
2879             PL_curcop = PL_curcopdb;
2880             PL_curcopdb = NULL;
2881         }
2882         /* Do we need to open block here? XXXX */
2883         if (CvXSUB(cv)) /* XXX this is supposed to be true */
2884             (void)(*CvXSUB(cv))(aTHX_ cv);
2885
2886         /* Enforce some sanity in scalar context. */
2887         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2888             if (markix > PL_stack_sp - PL_stack_base)
2889                 *(PL_stack_base + markix) = &PL_sv_undef;
2890             else
2891                 *(PL_stack_base + markix) = *PL_stack_sp;
2892             PL_stack_sp = PL_stack_base + markix;
2893         }
2894         LEAVE;
2895         return NORMAL;
2896     }
2897 }
2898
2899 void
2900 Perl_sub_crush_depth(pTHX_ CV *cv)
2901 {
2902     if (CvANON(cv))
2903         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2904     else {
2905         SV* const tmpstr = sv_newmortal();
2906         gv_efullname3(tmpstr, CvGV(cv), NULL);
2907         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2908                     SVfARG(tmpstr));
2909     }
2910 }
2911
2912 PP(pp_aelem)
2913 {
2914     dVAR; dSP;
2915     SV** svp;
2916     SV* const elemsv = POPs;
2917     IV elem = SvIV(elemsv);
2918     AV* const av = (AV*)POPs;
2919     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2920     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2921     SV *sv;
2922
2923     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2924         Perl_warner(aTHX_ packWARN(WARN_MISC),
2925                     "Use of reference \"%"SVf"\" as array index",
2926                     SVfARG(elemsv));
2927     if (elem > 0)
2928         elem -= CopARYBASE_get(PL_curcop);
2929     if (SvTYPE(av) != SVt_PVAV)
2930         RETPUSHUNDEF;
2931     svp = av_fetch(av, elem, lval && !defer);
2932     if (lval) {
2933 #ifdef PERL_MALLOC_WRAP
2934          if (SvUOK(elemsv)) {
2935               const UV uv = SvUV(elemsv);
2936               elem = uv > IV_MAX ? IV_MAX : uv;
2937          }
2938          else if (SvNOK(elemsv))
2939               elem = (IV)SvNV(elemsv);
2940          if (elem > 0) {
2941               static const char oom_array_extend[] =
2942                 "Out of memory during array extend"; /* Duplicated in av.c */
2943               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2944          }
2945 #endif
2946         if (!svp || *svp == &PL_sv_undef) {
2947             SV* lv;
2948             if (!defer)
2949                 DIE(aTHX_ PL_no_aelem, elem);
2950             lv = sv_newmortal();
2951             sv_upgrade(lv, SVt_PVLV);
2952             LvTYPE(lv) = 'y';
2953             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2954             LvTARG(lv) = SvREFCNT_inc_simple(av);
2955             LvTARGOFF(lv) = elem;
2956             LvTARGLEN(lv) = 1;
2957             PUSHs(lv);
2958             RETURN;
2959         }
2960         if (PL_op->op_private & OPpLVAL_INTRO)
2961             save_aelem(av, elem, svp);
2962         else if (PL_op->op_private & OPpDEREF)
2963             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2964     }
2965     sv = (svp ? *svp : &PL_sv_undef);
2966     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2967         sv = sv_mortalcopy(sv);
2968     PUSHs(sv);
2969     RETURN;
2970 }
2971
2972 void
2973 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2974 {
2975     SvGETMAGIC(sv);
2976     if (!SvOK(sv)) {
2977         if (SvREADONLY(sv))
2978             Perl_croak(aTHX_ "%s", PL_no_modify);
2979         if (SvTYPE(sv) < SVt_RV)
2980             sv_upgrade(sv, SVt_RV);
2981         else if (SvTYPE(sv) >= SVt_PV) {
2982             SvPV_free(sv);
2983             SvLEN_set(sv, 0);
2984             SvCUR_set(sv, 0);
2985         }
2986         switch (to_what) {
2987         case OPpDEREF_SV:
2988             SvRV_set(sv, newSV(0));
2989             break;
2990         case OPpDEREF_AV:
2991             SvRV_set(sv, (SV*)newAV());
2992             break;
2993         case OPpDEREF_HV:
2994             SvRV_set(sv, (SV*)newHV());
2995             break;
2996         }
2997         SvROK_on(sv);
2998         SvSETMAGIC(sv);
2999     }
3000 }
3001
3002 PP(pp_method)
3003 {
3004     dVAR; dSP;
3005     SV* const sv = TOPs;
3006
3007     if (SvROK(sv)) {
3008         SV* const rsv = SvRV(sv);
3009         if (SvTYPE(rsv) == SVt_PVCV) {
3010             SETs(rsv);
3011             RETURN;
3012         }
3013     }
3014
3015     SETs(method_common(sv, NULL));
3016     RETURN;
3017 }
3018
3019 PP(pp_method_named)
3020 {
3021     dVAR; dSP;
3022     SV* const sv = cSVOP_sv;
3023     U32 hash = SvSHARED_HASH(sv);
3024
3025     XPUSHs(method_common(sv, &hash));
3026     RETURN;
3027 }
3028
3029 STATIC SV *
3030 S_method_common(pTHX_ SV* meth, U32* hashp)
3031 {
3032     dVAR;
3033     SV* ob;
3034     GV* gv;
3035     HV* stash;
3036     STRLEN namelen;
3037     const char* packname = NULL;
3038     SV *packsv = NULL;
3039     STRLEN packlen;
3040     const char * const name = SvPV_const(meth, namelen);
3041     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3042
3043     if (!sv)
3044         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3045
3046     SvGETMAGIC(sv);
3047     if (SvROK(sv))
3048         ob = (SV*)SvRV(sv);
3049     else {
3050         GV* iogv;
3051
3052         /* this isn't a reference */
3053         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3054           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3055           if (he) { 
3056             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3057             goto fetch;
3058           }
3059         }
3060
3061         if (!SvOK(sv) ||
3062             !(packname) ||
3063             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3064             !(ob=(SV*)GvIO(iogv)))
3065         {
3066             /* this isn't the name of a filehandle either */
3067             if (!packname ||
3068                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3069                     ? !isIDFIRST_utf8((U8*)packname)
3070                     : !isIDFIRST(*packname)
3071                 ))
3072             {
3073                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3074                            SvOK(sv) ? "without a package or object reference"
3075                                     : "on an undefined value");
3076             }
3077             /* assume it's a package name */
3078             stash = gv_stashpvn(packname, packlen, 0);
3079             if (!stash)
3080                 packsv = sv;
3081             else {
3082                 SV* const ref = newSViv(PTR2IV(stash));
3083                 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3084             }
3085             goto fetch;
3086         }
3087         /* it _is_ a filehandle name -- replace with a reference */
3088         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3089     }
3090
3091     /* if we got here, ob should be a reference or a glob */
3092     if (!ob || !(SvOBJECT(ob)
3093                  || (SvTYPE(ob) == SVt_PVGV 
3094                      && isGV_with_GP(ob)
3095                      && (ob = (SV*)GvIO((GV*)ob))
3096                      && SvOBJECT(ob))))
3097     {
3098         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3099                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3100                    name);
3101     }
3102
3103     stash = SvSTASH(ob);
3104
3105   fetch:
3106     /* NOTE: stash may be null, hope hv_fetch_ent and
3107        gv_fetchmethod can cope (it seems they can) */
3108
3109     /* shortcut for simple names */
3110     if (hashp) {
3111         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3112         if (he) {
3113             gv = (GV*)HeVAL(he);
3114             if (isGV(gv) && GvCV(gv) &&
3115                 (!GvCVGEN(gv) || GvCVGEN(gv)
3116                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3117                 return (SV*)GvCV(gv);
3118         }
3119     }
3120
3121     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3122
3123     if (!gv) {
3124         /* This code tries to figure out just what went wrong with
3125            gv_fetchmethod.  It therefore needs to duplicate a lot of
3126            the internals of that function.  We can't move it inside
3127            Perl_gv_fetchmethod_autoload(), however, since that would
3128            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3129            don't want that.
3130         */
3131         const char* leaf = name;
3132         const char* sep = NULL;
3133         const char* p;
3134
3135         for (p = name; *p; p++) {
3136             if (*p == '\'')
3137                 sep = p, leaf = p + 1;
3138             else if (*p == ':' && *(p + 1) == ':')
3139                 sep = p, leaf = p + 2;
3140         }
3141         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3142             /* the method name is unqualified or starts with SUPER:: */
3143 #ifndef USE_ITHREADS
3144             if (sep)
3145                 stash = CopSTASH(PL_curcop);
3146 #else
3147             bool need_strlen = 1;
3148             if (sep) {
3149                 packname = CopSTASHPV(PL_curcop);
3150             }
3151             else
3152 #endif
3153             if (stash) {
3154                 HEK * const packhek = HvNAME_HEK(stash);
3155                 if (packhek) {
3156                     packname = HEK_KEY(packhek);
3157                     packlen = HEK_LEN(packhek);
3158 #ifdef USE_ITHREADS
3159                     need_strlen = 0;
3160 #endif
3161                 } else {
3162                     goto croak;
3163                 }
3164             }
3165
3166             if (!packname) {
3167             croak:
3168                 Perl_croak(aTHX_
3169                            "Can't use anonymous symbol table for method lookup");
3170             }
3171 #ifdef USE_ITHREADS
3172             if (need_strlen)
3173                 packlen = strlen(packname);
3174 #endif
3175
3176         }
3177         else {
3178             /* the method name is qualified */
3179             packname = name;
3180             packlen = sep - name;
3181         }
3182         
3183         /* we're relying on gv_fetchmethod not autovivifying the stash */
3184         if (gv_stashpvn(packname, packlen, 0)) {
3185             Perl_croak(aTHX_
3186                        "Can't locate object method \"%s\" via package \"%.*s\"",
3187                        leaf, (int)packlen, packname);
3188         }
3189         else {
3190             Perl_croak(aTHX_
3191                        "Can't locate object method \"%s\" via package \"%.*s\""
3192                        " (perhaps you forgot to load \"%.*s\"?)",
3193                        leaf, (int)packlen, packname, (int)packlen, packname);
3194         }
3195     }
3196     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3197 }
3198
3199 /*
3200  * Local variables:
3201  * c-indentation-style: bsd
3202  * c-basic-offset: 4
3203  * indent-tabs-mode: t
3204  * End:
3205  *
3206  * ex: set ts=8 sts=4 sw=4 noet:
3207  */