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