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