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