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