This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_iter: final whitespace/comment tidy up
[perl5.git] / pp_hot.c
1 /*    pp_hot.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
13  * shaking the air.
14  *
15  *                  Awake!  Awake!  Fear, Fire, Foes!  Awake!
16  *                               Fire, Foes!  Awake!
17  *
18  *     [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
19  */
20
21 /* This file contains 'hot' pp ("push/pop") functions that
22  * execute the opcodes that make up a perl program. A typical pp function
23  * expects to find its arguments on the stack, and usually pushes its
24  * results onto the stack, hence the 'pp' terminology. Each OP structure
25  * contains a pointer to the relevant pp_foo() function.
26  *
27  * By 'hot', we mean common ops whose execution speed is critical.
28  * By gathering them together into a single file, we encourage
29  * CPU cache hits on hot code. Also it could be taken as a warning not to
30  * change any code in this file unless you're sure it won't affect
31  * performance.
32  */
33
34 #include "EXTERN.h"
35 #define PERL_IN_PP_HOT_C
36 #include "perl.h"
37
38 /* Hot code. */
39
40 PP(pp_const)
41 {
42     dVAR;
43     dSP;
44     XPUSHs(cSVOP_sv);
45     RETURN;
46 }
47
48 PP(pp_nextstate)
49 {
50     dVAR;
51     PL_curcop = (COP*)PL_op;
52     TAINT_NOT;          /* Each statement is presumed innocent */
53     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
54     FREETMPS;
55     PERL_ASYNC_CHECK();
56     return NORMAL;
57 }
58
59 PP(pp_gvsv)
60 {
61     dVAR;
62     dSP;
63     EXTEND(SP,1);
64     if (PL_op->op_private & OPpLVAL_INTRO)
65         PUSHs(save_scalar(cGVOP_gv));
66     else
67         PUSHs(GvSVn(cGVOP_gv));
68     RETURN;
69 }
70
71 PP(pp_null)
72 {
73     dVAR;
74     return NORMAL;
75 }
76
77 /* This is sometimes called directly by pp_coreargs and pp_grepstart. */
78 PP(pp_pushmark)
79 {
80     dVAR;
81     PUSHMARK(PL_stack_sp);
82     return NORMAL;
83 }
84
85 PP(pp_stringify)
86 {
87     dVAR; dSP; dTARGET;
88     sv_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 *oldsv;
1901     SV **itersvp;
1902
1903     EXTEND(SP, 1);
1904     cx = &cxstack[cxstack_ix];
1905     itersvp = CxITERVAR(cx);
1906
1907     switch (CxTYPE(cx)) {
1908
1909     case CXt_LOOP_LAZYSV: /* string increment */
1910     {
1911         SV* cur = cx->blk_loop.state_u.lazysv.cur;
1912         SV *end = cx->blk_loop.state_u.lazysv.end;
1913         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1914            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1915         STRLEN maxlen = 0;
1916         const char *max = SvPV_const(end, maxlen);
1917         if (SvNIOK(cur) || SvCUR(cur) > maxlen)
1918             RETPUSHNO;
1919
1920         oldsv = *itersvp;
1921         if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1922             /* safe to reuse old SV */
1923             sv_setsv(oldsv, cur);
1924         }
1925         else
1926         {
1927             /* we need a fresh SV every time so that loop body sees a
1928              * completely new SV for closures/references to work as
1929              * they used to */
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         break;
1938     }
1939
1940     case CXt_LOOP_LAZYIV: /* integer increment */
1941     {
1942         IV cur = cx->blk_loop.state_u.lazyiv.cur;
1943         if (cur > cx->blk_loop.state_u.lazyiv.end)
1944             RETPUSHNO;
1945
1946         oldsv = *itersvp;
1947         /* don't risk potential race */
1948         if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1949             /* safe to reuse old SV */
1950             sv_setiv(oldsv, cur);
1951         }
1952         else
1953         {
1954             /* we need a fresh SV every time so that loop body sees a
1955              * completely new SV for closures/references to work as they
1956              * used to */
1957             *itersvp = newSViv(cur);
1958             SvREFCNT_dec(oldsv);
1959         }
1960
1961         if (cur == IV_MAX) {
1962             /* Handle end of range at IV_MAX */
1963             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1964         } else
1965             ++cx->blk_loop.state_u.lazyiv.cur;
1966         break;
1967     }
1968
1969     case CXt_LOOP_FOR: /* iterate array */
1970     {
1971
1972         AV *av = cx->blk_loop.state_u.ary.ary;
1973         SV *sv;
1974         bool av_is_stack = FALSE;
1975         IV ix;
1976
1977         if (!av) {
1978             av_is_stack = TRUE;
1979             av = PL_curstack;
1980         }
1981         if (PL_op->op_private & OPpITER_REVERSED) {
1982             ix = --cx->blk_loop.state_u.ary.ix;
1983             if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))
1984                 RETPUSHNO;
1985         }
1986         else {
1987             ix = ++cx->blk_loop.state_u.ary.ix;
1988             if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))
1989                 RETPUSHNO;
1990         }
1991
1992         if (SvMAGICAL(av) || AvREIFY(av)) {
1993             SV * const * const svp = av_fetch(av, ix, FALSE);
1994             sv = svp ? *svp : NULL;
1995         }
1996         else {
1997             sv = AvARRAY(av)[ix];
1998         }
1999
2000         if (sv) {
2001             if (SvIS_FREED(sv)) {
2002                 *itersvp = NULL;
2003                 Perl_croak(aTHX_ "Use of freed value in iteration");
2004             }
2005             SvTEMP_off(sv);
2006             SvREFCNT_inc_simple_void_NN(sv);
2007         }
2008         else
2009             sv = &PL_sv_undef;
2010
2011         if (!av_is_stack && sv == &PL_sv_undef) {
2012             SV *lv = newSV_type(SVt_PVLV);
2013             LvTYPE(lv) = 'y';
2014             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2015             LvTARG(lv) = SvREFCNT_inc_simple(av);
2016             LvTARGOFF(lv) = ix;
2017             LvTARGLEN(lv) = (STRLEN)UV_MAX;
2018             sv = lv;
2019         }
2020
2021         oldsv = *itersvp;
2022         *itersvp = sv;
2023         SvREFCNT_dec(oldsv);
2024         break;
2025     }
2026
2027     default:
2028         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2029     }
2030     RETPUSHYES;
2031 }
2032
2033 /*
2034 A description of how taint works in pattern matching and substitution.
2035
2036 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2037 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2038
2039 While the pattern is being assembled/concatenated and then compiled,
2040 PL_tainted will get set (via TAINT_set) if any component of the pattern
2041 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
2042 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2043 TAINT_get).
2044
2045 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2046 the pattern is marked as tainted. This means that subsequent usage, such
2047 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2048 on the new pattern too.
2049
2050 During execution of a pattern, locale-variant ops such as ALNUML set the
2051 local flag RF_tainted. At the end of execution, the engine sets the
2052 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
2053 otherwise.
2054
2055 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
2056 of $1 et al to indicate whether the returned value should be tainted.
2057 It is the responsibility of the caller of the pattern (i.e. pp_match,
2058 pp_subst etc) to set this flag for any other circumstances where $1 needs
2059 to be tainted.
2060
2061 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2062
2063 There are three possible sources of taint
2064     * the source string
2065     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2066     * the replacement string (or expression under /e)
2067     
2068 There are four destinations of taint and they are affected by the sources
2069 according to the rules below:
2070
2071     * the return value (not including /r):
2072         tainted by the source string and pattern, but only for the
2073         number-of-iterations case; boolean returns aren't tainted;
2074     * the modified string (or modified copy under /r):
2075         tainted by the source string, pattern, and replacement strings;
2076     * $1 et al:
2077         tainted by the pattern, and under 'use re "taint"', by the source
2078         string too;
2079     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2080         should always be unset before executing subsequent code.
2081
2082 The overall action of pp_subst is:
2083
2084     * at the start, set bits in rxtainted indicating the taint status of
2085         the various sources.
2086
2087     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2088         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2089         pattern has subsequently become tainted via locale ops.
2090
2091     * If control is being passed to pp_substcont to execute a /e block,
2092         save rxtainted in the CXt_SUBST block, for future use by
2093         pp_substcont.
2094
2095     * Whenever control is being returned to perl code (either by falling
2096         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2097         use the flag bits in rxtainted to make all the appropriate types of
2098         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2099         et al will appear tainted.
2100
2101 pp_match is just a simpler version of the above.
2102
2103 */
2104
2105 PP(pp_subst)
2106 {
2107     dVAR; dSP; dTARG;
2108     PMOP *pm = cPMOP;
2109     PMOP *rpm = pm;
2110     char *s;
2111     char *strend;
2112     char *m;
2113     const char *c;
2114     char *d;
2115     STRLEN clen;
2116     I32 iters = 0;
2117     I32 maxiters;
2118     I32 i;
2119     bool once;
2120     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2121                         See "how taint works" above */
2122     char *orig;
2123     U8 r_flags;
2124     REGEXP *rx = PM_GETRE(pm);
2125     STRLEN len;
2126     int force_on_match = 0;
2127     const I32 oldsave = PL_savestack_ix;
2128     STRLEN slen;
2129     bool doutf8 = FALSE; /* whether replacement is in utf8 */
2130 #ifdef PERL_OLD_COPY_ON_WRITE
2131     bool is_cow;
2132 #endif
2133     SV *nsv = NULL;
2134     /* known replacement string? */
2135     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2136
2137     PERL_ASYNC_CHECK();
2138
2139     if (PL_op->op_flags & OPf_STACKED)
2140         TARG = POPs;
2141     else if (PL_op->op_private & OPpTARGET_MY)
2142         GETTARGET;
2143     else {
2144         TARG = DEFSV;
2145         EXTEND(SP,1);
2146     }
2147
2148     SvGETMAGIC(TARG); /* must come before cow check */
2149 #ifdef PERL_OLD_COPY_ON_WRITE
2150     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2151        because they make integers such as 256 "false".  */
2152     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2153 #else
2154     if (SvIsCOW(TARG))
2155         sv_force_normal_flags(TARG,0);
2156 #endif
2157     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2158 #ifdef PERL_OLD_COPY_ON_WRITE
2159         && !is_cow
2160 #endif
2161         && (SvREADONLY(TARG)
2162             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2163                   || SvTYPE(TARG) > SVt_PVLV)
2164                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2165         Perl_croak_no_modify();
2166     PUTBACK;
2167
2168     s = SvPV_nomg(TARG, len);
2169     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2170         force_on_match = 1;
2171
2172     /* only replace once? */
2173     once = !(rpm->op_pmflags & PMf_GLOBAL);
2174
2175     /* See "how taint works" above */
2176     if (TAINTING_get) {
2177         rxtainted  = (
2178             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2179           | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2180           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2181           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2182                 ? SUBST_TAINT_BOOLRET : 0));
2183         TAINT_NOT;
2184     }
2185
2186     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2187
2188   force_it:
2189     if (!pm || !s)
2190         DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
2191
2192     strend = s + len;
2193     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2194     maxiters = 2 * slen + 10;   /* We can match twice at each
2195                                    position, once with zero-length,
2196                                    second time with non-zero. */
2197
2198     if (!RX_PRELEN(rx) && PL_curpm
2199      && !ReANY(rx)->mother_re) {
2200         pm = PL_curpm;
2201         rx = PM_GETRE(pm);
2202     }
2203
2204     r_flags = (    RX_NPARENS(rx)
2205                 || PL_sawampersand
2206                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2207               )
2208           ? REXEC_COPY_STR
2209           : 0;
2210
2211     orig = m = s;
2212     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2213         PL_bostr = orig;
2214         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2215
2216         if (!s)
2217             goto ret_no;
2218         /* How to do it in subst? */
2219 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2220              && !PL_sawampersand
2221              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
2222             goto yup;
2223 */
2224     }
2225
2226     if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2227                          r_flags | REXEC_CHECKED))
2228     {
2229       ret_no:
2230         SPAGAIN;
2231         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2232         LEAVE_SCOPE(oldsave);
2233         RETURN;
2234     }
2235
2236     PL_curpm = pm;
2237
2238     /* known replacement string? */
2239     if (dstr) {
2240         /* replacement needing upgrading? */
2241         if (DO_UTF8(TARG) && !doutf8) {
2242              nsv = sv_newmortal();
2243              SvSetSV(nsv, dstr);
2244              if (PL_encoding)
2245                   sv_recode_to_utf8(nsv, PL_encoding);
2246              else
2247                   sv_utf8_upgrade(nsv);
2248              c = SvPV_const(nsv, clen);
2249              doutf8 = TRUE;
2250         }
2251         else {
2252             c = SvPV_const(dstr, clen);
2253             doutf8 = DO_UTF8(dstr);
2254         }
2255
2256         if (SvTAINTED(dstr))
2257             rxtainted |= SUBST_TAINT_REPL;
2258     }
2259     else {
2260         c = NULL;
2261         doutf8 = FALSE;
2262     }
2263     
2264     /* can do inplace substitution? */
2265     if (c
2266 #ifdef PERL_OLD_COPY_ON_WRITE
2267         && !is_cow
2268 #endif
2269         && (I32)clen <= RX_MINLENRET(rx)
2270         && (once || !(r_flags & REXEC_COPY_STR))
2271         && !(RX_EXTFLAGS(rx) & (RXf_LOOKBEHIND_SEEN|RXf_MODIFIES_VARS))
2272         && (!doutf8 || SvUTF8(TARG))
2273         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2274     {
2275
2276 #ifdef PERL_OLD_COPY_ON_WRITE
2277         if (SvIsCOW(TARG)) {
2278             assert (!force_on_match);
2279             goto have_a_cow;
2280         }
2281 #endif
2282         if (force_on_match) {
2283             force_on_match = 0;
2284             s = SvPV_force_nomg(TARG, len);
2285             goto force_it;
2286         }
2287         d = s;
2288         if (once) {
2289             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2290                 rxtainted |= SUBST_TAINT_PAT;
2291             m = orig + RX_OFFS(rx)[0].start;
2292             d = orig + RX_OFFS(rx)[0].end;
2293             s = orig;
2294             if (m - s > strend - d) {  /* faster to shorten from end */
2295                 if (clen) {
2296                     Copy(c, m, clen, char);
2297                     m += clen;
2298                 }
2299                 i = strend - d;
2300                 if (i > 0) {
2301                     Move(d, m, i, char);
2302                     m += i;
2303                 }
2304                 *m = '\0';
2305                 SvCUR_set(TARG, m - s);
2306             }
2307             else if ((i = m - s)) {     /* faster from front */
2308                 d -= clen;
2309                 m = d;
2310                 Move(s, d - i, i, char);
2311                 sv_chop(TARG, d-i);
2312                 if (clen)
2313                     Copy(c, m, clen, char);
2314             }
2315             else if (clen) {
2316                 d -= clen;
2317                 sv_chop(TARG, d);
2318                 Copy(c, d, clen, char);
2319             }
2320             else {
2321                 sv_chop(TARG, d);
2322             }
2323             SPAGAIN;
2324             PUSHs(&PL_sv_yes);
2325         }
2326         else {
2327             do {
2328                 if (iters++ > maxiters)
2329                     DIE(aTHX_ "Substitution loop");
2330                 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2331                     rxtainted |= SUBST_TAINT_PAT;
2332                 m = RX_OFFS(rx)[0].start + orig;
2333                 if ((i = m - s)) {
2334                     if (s != d)
2335                         Move(s, d, i, char);
2336                     d += i;
2337                 }
2338                 if (clen) {
2339                     Copy(c, d, clen, char);
2340                     d += clen;
2341                 }
2342                 s = RX_OFFS(rx)[0].end + orig;
2343             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2344                                  TARG, NULL,
2345                                  /* don't match same null twice */
2346                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2347             if (s != d) {
2348                 i = strend - s;
2349                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2350                 Move(s, d, i+1, char);          /* include the NUL */
2351             }
2352             SPAGAIN;
2353             mPUSHi((I32)iters);
2354         }
2355     }
2356     else {
2357         bool first;
2358         SV *repl;
2359         if (force_on_match) {
2360             force_on_match = 0;
2361             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2362                 /* I feel that it should be possible to avoid this mortal copy
2363                    given that the code below copies into a new destination.
2364                    However, I suspect it isn't worth the complexity of
2365                    unravelling the C<goto force_it> for the small number of
2366                    cases where it would be viable to drop into the copy code. */
2367                 TARG = sv_2mortal(newSVsv(TARG));
2368             }
2369             s = SvPV_force_nomg(TARG, len);
2370             goto force_it;
2371         }
2372 #ifdef PERL_OLD_COPY_ON_WRITE
2373       have_a_cow:
2374 #endif
2375         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2376             rxtainted |= SUBST_TAINT_PAT;
2377         repl = dstr;
2378         dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2379         if (!c) {
2380             PERL_CONTEXT *cx;
2381             SPAGAIN;
2382             /* note that a whole bunch of local vars are saved here for
2383              * use by pp_substcont: here's a list of them in case you're
2384              * searching for places in this sub that uses a particular var:
2385              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2386              * s m strend rx once */
2387             PUSHSUBST(cx);
2388             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2389         }
2390         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2391         first = TRUE;
2392         do {
2393             if (iters++ > maxiters)
2394                 DIE(aTHX_ "Substitution loop");
2395             if (RX_MATCH_TAINTED(rx))
2396                 rxtainted |= SUBST_TAINT_PAT;
2397             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2398                 m = s;
2399                 s = orig;
2400                 assert(RX_SUBOFFSET(rx) == 0);
2401                 orig = RX_SUBBEG(rx);
2402                 s = orig + (m - s);
2403                 strend = s + (strend - m);
2404             }
2405             m = RX_OFFS(rx)[0].start + orig;
2406             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2407             s = RX_OFFS(rx)[0].end + orig;
2408             if (first) {
2409                 /* replacement already stringified */
2410               if (clen)
2411                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2412               first = FALSE;
2413             }
2414             else {
2415                 if (PL_encoding) {
2416                     if (!nsv) nsv = sv_newmortal();
2417                     sv_copypv(nsv, repl);
2418                     if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2419                     sv_catsv(dstr, nsv);
2420                 }
2421                 else sv_catsv(dstr, repl);
2422                 if (SvTAINTED(repl))
2423                     rxtainted |= SUBST_TAINT_REPL;
2424             }
2425             if (once)
2426                 break;
2427         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2428                              TARG, NULL, r_flags));
2429         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2430
2431         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2432             /* From here on down we're using the copy, and leaving the original
2433                untouched.  */
2434             TARG = dstr;
2435             SPAGAIN;
2436             PUSHs(dstr);
2437         } else {
2438 #ifdef PERL_OLD_COPY_ON_WRITE
2439             /* The match may make the string COW. If so, brilliant, because
2440                that's just saved us one malloc, copy and free - the regexp has
2441                donated the old buffer, and we malloc an entirely new one, rather
2442                than the regexp malloc()ing a buffer and copying our original,
2443                only for us to throw it away here during the substitution.  */
2444             if (SvIsCOW(TARG)) {
2445                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2446             } else
2447 #endif
2448             {
2449                 SvPV_free(TARG);
2450             }
2451             SvPV_set(TARG, SvPVX(dstr));
2452             SvCUR_set(TARG, SvCUR(dstr));
2453             SvLEN_set(TARG, SvLEN(dstr));
2454             SvFLAGS(TARG) |= SvUTF8(dstr);
2455             SvPV_set(dstr, NULL);
2456
2457             SPAGAIN;
2458             mPUSHi((I32)iters);
2459         }
2460     }
2461
2462     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2463         (void)SvPOK_only_UTF8(TARG);
2464     }
2465
2466     /* See "how taint works" above */
2467     if (TAINTING_get) {
2468         if ((rxtainted & SUBST_TAINT_PAT) ||
2469             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2470                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2471         )
2472             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2473
2474         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2475             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2476         )
2477             SvTAINTED_on(TOPs);  /* taint return value */
2478         else
2479             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2480
2481         /* needed for mg_set below */
2482         TAINT_set(
2483           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2484         );
2485         SvTAINT(TARG);
2486     }
2487     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2488     TAINT_NOT;
2489     LEAVE_SCOPE(oldsave);
2490     RETURN;
2491 }
2492
2493 PP(pp_grepwhile)
2494 {
2495     dVAR; dSP;
2496
2497     if (SvTRUEx(POPs))
2498         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2499     ++*PL_markstack_ptr;
2500     FREETMPS;
2501     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2502
2503     /* All done yet? */
2504     if (PL_stack_base + *PL_markstack_ptr > SP) {
2505         I32 items;
2506         const I32 gimme = GIMME_V;
2507
2508         LEAVE_with_name("grep");                                        /* exit outer scope */
2509         (void)POPMARK;                          /* pop src */
2510         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2511         (void)POPMARK;                          /* pop dst */
2512         SP = PL_stack_base + POPMARK;           /* pop original mark */
2513         if (gimme == G_SCALAR) {
2514             if (PL_op->op_private & OPpGREP_LEX) {
2515                 SV* const sv = sv_newmortal();
2516                 sv_setiv(sv, items);
2517                 PUSHs(sv);
2518             }
2519             else {
2520                 dTARGET;
2521                 XPUSHi(items);
2522             }
2523         }
2524         else if (gimme == G_ARRAY)
2525             SP += items;
2526         RETURN;
2527     }
2528     else {
2529         SV *src;
2530
2531         ENTER_with_name("grep_item");                                   /* enter inner scope */
2532         SAVEVPTR(PL_curpm);
2533
2534         src = PL_stack_base[*PL_markstack_ptr];
2535         SvTEMP_off(src);
2536         if (PL_op->op_private & OPpGREP_LEX)
2537             PAD_SVl(PL_op->op_targ) = src;
2538         else
2539             DEFSV_set(src);
2540
2541         RETURNOP(cLOGOP->op_other);
2542     }
2543 }
2544
2545 PP(pp_leavesub)
2546 {
2547     dVAR; dSP;
2548     SV **mark;
2549     SV **newsp;
2550     PMOP *newpm;
2551     I32 gimme;
2552     PERL_CONTEXT *cx;
2553     SV *sv;
2554
2555     if (CxMULTICALL(&cxstack[cxstack_ix]))
2556         return 0;
2557
2558     POPBLOCK(cx,newpm);
2559     cxstack_ix++; /* temporarily protect top context */
2560
2561     TAINT_NOT;
2562     if (gimme == G_SCALAR) {
2563         MARK = newsp + 1;
2564         if (MARK <= SP) {
2565             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2566                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2567                      && !SvMAGICAL(TOPs)) {
2568                     *MARK = SvREFCNT_inc(TOPs);
2569                     FREETMPS;
2570                     sv_2mortal(*MARK);
2571                 }
2572                 else {
2573                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2574                     FREETMPS;
2575                     *MARK = sv_mortalcopy(sv);
2576                     SvREFCNT_dec(sv);
2577                 }
2578             }
2579             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2580                      && !SvMAGICAL(TOPs)) {
2581                 *MARK = TOPs;
2582             }
2583             else
2584                 *MARK = sv_mortalcopy(TOPs);
2585         }
2586         else {
2587             MEXTEND(MARK, 0);
2588             *MARK = &PL_sv_undef;
2589         }
2590         SP = MARK;
2591     }
2592     else if (gimme == G_ARRAY) {
2593         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2594             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2595                  || SvMAGICAL(*MARK)) {
2596                 *MARK = sv_mortalcopy(*MARK);
2597                 TAINT_NOT;      /* Each item is independent */
2598             }
2599         }
2600     }
2601     PUTBACK;
2602
2603     LEAVE;
2604     cxstack_ix--;
2605     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2606     PL_curpm = newpm;   /* ... and pop $1 et al */
2607
2608     LEAVESUB(sv);
2609     return cx->blk_sub.retop;
2610 }
2611
2612 PP(pp_entersub)
2613 {
2614     dVAR; dSP; dPOPss;
2615     GV *gv;
2616     CV *cv;
2617     PERL_CONTEXT *cx;
2618     I32 gimme;
2619     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2620
2621     if (!sv)
2622         DIE(aTHX_ "Not a CODE reference");
2623     switch (SvTYPE(sv)) {
2624         /* This is overwhelming the most common case:  */
2625     case SVt_PVGV:
2626       we_have_a_glob:
2627         if (!(cv = GvCVu((const GV *)sv))) {
2628             HV *stash;
2629             cv = sv_2cv(sv, &stash, &gv, 0);
2630         }
2631         if (!cv) {
2632             ENTER;
2633             SAVETMPS;
2634             goto try_autoload;
2635         }
2636         break;
2637     case SVt_PVLV:
2638         if(isGV_with_GP(sv)) goto we_have_a_glob;
2639         /*FALLTHROUGH*/
2640     default:
2641         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2642             if (hasargs)
2643                 SP = PL_stack_base + POPMARK;
2644             else
2645                 (void)POPMARK;
2646             RETURN;
2647         }
2648         SvGETMAGIC(sv);
2649         if (SvROK(sv)) {
2650             if (SvAMAGIC(sv)) {
2651                 sv = amagic_deref_call(sv, to_cv_amg);
2652                 /* Don't SPAGAIN here.  */
2653             }
2654         }
2655         else {
2656             const char *sym;
2657             STRLEN len;
2658             if (!SvOK(sv))
2659                 DIE(aTHX_ PL_no_usym, "a subroutine");
2660             sym = SvPV_nomg_const(sv, len);
2661             if (PL_op->op_private & HINT_STRICT_REFS)
2662                 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2663             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2664             break;
2665         }
2666         cv = MUTABLE_CV(SvRV(sv));
2667         if (SvTYPE(cv) == SVt_PVCV)
2668             break;
2669         /* FALL THROUGH */
2670     case SVt_PVHV:
2671     case SVt_PVAV:
2672         DIE(aTHX_ "Not a CODE reference");
2673         /* This is the second most common case:  */
2674     case SVt_PVCV:
2675         cv = MUTABLE_CV(sv);
2676         break;
2677     }
2678
2679     ENTER;
2680     SAVETMPS;
2681
2682   retry:
2683     if (CvCLONE(cv) && ! CvCLONED(cv))
2684         DIE(aTHX_ "Closure prototype called");
2685     if (!CvROOT(cv) && !CvXSUB(cv)) {
2686         GV* autogv;
2687         SV* sub_name;
2688
2689         /* anonymous or undef'd function leaves us no recourse */
2690         if (CvANON(cv) || !(gv = CvGV(cv))) {
2691             if (CvNAMED(cv))
2692                 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2693                            HEKfARG(CvNAME_HEK(cv)));
2694             DIE(aTHX_ "Undefined subroutine called");
2695         }
2696
2697         /* autoloaded stub? */
2698         if (cv != GvCV(gv)) {
2699             cv = GvCV(gv);
2700         }
2701         /* should call AUTOLOAD now? */
2702         else {
2703 try_autoload:
2704             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2705                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2706             {
2707                 cv = GvCV(autogv);
2708             }
2709             else {
2710                sorry:
2711                 sub_name = sv_newmortal();
2712                 gv_efullname3(sub_name, gv, NULL);
2713                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2714             }
2715         }
2716         if (!cv)
2717             goto sorry;
2718         goto retry;
2719     }
2720
2721     gimme = GIMME_V;
2722     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2723          Perl_get_db_sub(aTHX_ &sv, cv);
2724          if (CvISXSUB(cv))
2725              PL_curcopdb = PL_curcop;
2726          if (CvLVALUE(cv)) {
2727              /* check for lsub that handles lvalue subroutines */
2728              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2729              /* if lsub not found then fall back to DB::sub */
2730              if (!cv) cv = GvCV(PL_DBsub);
2731          } else {
2732              cv = GvCV(PL_DBsub);
2733          }
2734
2735         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2736             DIE(aTHX_ "No DB::sub routine defined");
2737     }
2738
2739     if (!(CvISXSUB(cv))) {
2740         /* This path taken at least 75% of the time   */
2741         dMARK;
2742         I32 items = SP - MARK;
2743         PADLIST * const padlist = CvPADLIST(cv);
2744         PUSHBLOCK(cx, CXt_SUB, MARK);
2745         PUSHSUB(cx);
2746         cx->blk_sub.retop = PL_op->op_next;
2747         CvDEPTH(cv)++;
2748         if (CvDEPTH(cv) >= 2) {
2749             PERL_STACK_OVERFLOW_CHECK();
2750             pad_push(padlist, CvDEPTH(cv));
2751         }
2752         SAVECOMPPAD();
2753         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2754         if (hasargs) {
2755             AV *const av = MUTABLE_AV(PAD_SVl(0));
2756             if (AvREAL(av)) {
2757                 /* @_ is normally not REAL--this should only ever
2758                  * happen when DB::sub() calls things that modify @_ */
2759                 av_clear(av);
2760                 AvREAL_off(av);
2761                 AvREIFY_on(av);
2762             }
2763             cx->blk_sub.savearray = GvAV(PL_defgv);
2764             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2765             CX_CURPAD_SAVE(cx->blk_sub);
2766             cx->blk_sub.argarray = av;
2767             ++MARK;
2768
2769             if (items > AvMAX(av) + 1) {
2770                 SV **ary = AvALLOC(av);
2771                 if (AvARRAY(av) != ary) {
2772                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2773                     AvARRAY(av) = ary;
2774                 }
2775                 if (items > AvMAX(av) + 1) {
2776                     AvMAX(av) = items - 1;
2777                     Renew(ary,items,SV*);
2778                     AvALLOC(av) = ary;
2779                     AvARRAY(av) = ary;
2780                 }
2781             }
2782             Copy(MARK,AvARRAY(av),items,SV*);
2783             AvFILLp(av) = items - 1;
2784         
2785             while (items--) {
2786                 if (*MARK)
2787                     SvTEMP_off(*MARK);
2788                 MARK++;
2789             }
2790         }
2791         if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2792             !CvLVALUE(cv))
2793             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2794         /* warning must come *after* we fully set up the context
2795          * stuff so that __WARN__ handlers can safely dounwind()
2796          * if they want to
2797          */
2798         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2799             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2800             sub_crush_depth(cv);
2801         RETURNOP(CvSTART(cv));
2802     }
2803     else {
2804         I32 markix = TOPMARK;
2805
2806         PUTBACK;
2807
2808         if (!hasargs) {
2809             /* Need to copy @_ to stack. Alternative may be to
2810              * switch stack to @_, and copy return values
2811              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2812             AV * const av = GvAV(PL_defgv);
2813             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2814
2815             if (items) {
2816                 /* Mark is at the end of the stack. */
2817                 EXTEND(SP, items);
2818                 Copy(AvARRAY(av), SP + 1, items, SV*);
2819                 SP += items;
2820                 PUTBACK ;               
2821             }
2822         }
2823         /* We assume first XSUB in &DB::sub is the called one. */
2824         if (PL_curcopdb) {
2825             SAVEVPTR(PL_curcop);
2826             PL_curcop = PL_curcopdb;
2827             PL_curcopdb = NULL;
2828         }
2829         /* Do we need to open block here? XXXX */
2830
2831         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2832         assert(CvXSUB(cv));
2833         CvXSUB(cv)(aTHX_ cv);
2834
2835         /* Enforce some sanity in scalar context. */
2836         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2837             if (markix > PL_stack_sp - PL_stack_base)
2838                 *(PL_stack_base + markix) = &PL_sv_undef;
2839             else
2840                 *(PL_stack_base + markix) = *PL_stack_sp;
2841             PL_stack_sp = PL_stack_base + markix;
2842         }
2843         LEAVE;
2844         return NORMAL;
2845     }
2846 }
2847
2848 void
2849 Perl_sub_crush_depth(pTHX_ CV *cv)
2850 {
2851     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2852
2853     if (CvANON(cv))
2854         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2855     else {
2856         SV* const tmpstr = sv_newmortal();
2857         gv_efullname3(tmpstr, CvGV(cv), NULL);
2858         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2859                     SVfARG(tmpstr));
2860     }
2861 }
2862
2863 PP(pp_aelem)
2864 {
2865     dVAR; dSP;
2866     SV** svp;
2867     SV* const elemsv = POPs;
2868     IV elem = SvIV(elemsv);
2869     AV *const av = MUTABLE_AV(POPs);
2870     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2871     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2872     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2873     bool preeminent = TRUE;
2874     SV *sv;
2875
2876     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2877         Perl_warner(aTHX_ packWARN(WARN_MISC),
2878                     "Use of reference \"%"SVf"\" as array index",
2879                     SVfARG(elemsv));
2880     if (SvTYPE(av) != SVt_PVAV)
2881         RETPUSHUNDEF;
2882
2883     if (localizing) {
2884         MAGIC *mg;
2885         HV *stash;
2886
2887         /* If we can determine whether the element exist,
2888          * Try to preserve the existenceness of a tied array
2889          * element by using EXISTS and DELETE if possible.
2890          * Fallback to FETCH and STORE otherwise. */
2891         if (SvCANEXISTDELETE(av))
2892             preeminent = av_exists(av, elem);
2893     }
2894
2895     svp = av_fetch(av, elem, lval && !defer);
2896     if (lval) {
2897 #ifdef PERL_MALLOC_WRAP
2898          if (SvUOK(elemsv)) {
2899               const UV uv = SvUV(elemsv);
2900               elem = uv > IV_MAX ? IV_MAX : uv;
2901          }
2902          else if (SvNOK(elemsv))
2903               elem = (IV)SvNV(elemsv);
2904          if (elem > 0) {
2905               static const char oom_array_extend[] =
2906                 "Out of memory during array extend"; /* Duplicated in av.c */
2907               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2908          }
2909 #endif
2910         if (!svp || *svp == &PL_sv_undef) {
2911             SV* lv;
2912             if (!defer)
2913                 DIE(aTHX_ PL_no_aelem, elem);
2914             lv = sv_newmortal();
2915             sv_upgrade(lv, SVt_PVLV);
2916             LvTYPE(lv) = 'y';
2917             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2918             LvTARG(lv) = SvREFCNT_inc_simple(av);
2919             LvTARGOFF(lv) = elem;
2920             LvTARGLEN(lv) = 1;
2921             PUSHs(lv);
2922             RETURN;
2923         }
2924         if (localizing) {
2925             if (preeminent)
2926                 save_aelem(av, elem, svp);
2927             else
2928                 SAVEADELETE(av, elem);
2929         }
2930         else if (PL_op->op_private & OPpDEREF) {
2931             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2932             RETURN;
2933         }
2934     }
2935     sv = (svp ? *svp : &PL_sv_undef);
2936     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2937         mg_get(sv);
2938     PUSHs(sv);
2939     RETURN;
2940 }
2941
2942 SV*
2943 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2944 {
2945     PERL_ARGS_ASSERT_VIVIFY_REF;
2946
2947     SvGETMAGIC(sv);
2948     if (!SvOK(sv)) {
2949         if (SvREADONLY(sv))
2950             Perl_croak_no_modify();
2951         prepare_SV_for_RV(sv);
2952         switch (to_what) {
2953         case OPpDEREF_SV:
2954             SvRV_set(sv, newSV(0));
2955             break;
2956         case OPpDEREF_AV:
2957             SvRV_set(sv, MUTABLE_SV(newAV()));
2958             break;
2959         case OPpDEREF_HV:
2960             SvRV_set(sv, MUTABLE_SV(newHV()));
2961             break;
2962         }
2963         SvROK_on(sv);
2964         SvSETMAGIC(sv);
2965         SvGETMAGIC(sv);
2966     }
2967     if (SvGMAGICAL(sv)) {
2968         /* copy the sv without magic to prevent magic from being
2969            executed twice */
2970         SV* msv = sv_newmortal();
2971         sv_setsv_nomg(msv, sv);
2972         return msv;
2973     }
2974     return sv;
2975 }
2976
2977 PP(pp_method)
2978 {
2979     dVAR; dSP;
2980     SV* const sv = TOPs;
2981
2982     if (SvROK(sv)) {
2983         SV* const rsv = SvRV(sv);
2984         if (SvTYPE(rsv) == SVt_PVCV) {
2985             SETs(rsv);
2986             RETURN;
2987         }
2988     }
2989
2990     SETs(method_common(sv, NULL));
2991     RETURN;
2992 }
2993
2994 PP(pp_method_named)
2995 {
2996     dVAR; dSP;
2997     SV* const sv = cSVOP_sv;
2998     U32 hash = SvSHARED_HASH(sv);
2999
3000     XPUSHs(method_common(sv, &hash));
3001     RETURN;
3002 }
3003
3004 STATIC SV *
3005 S_method_common(pTHX_ SV* meth, U32* hashp)
3006 {
3007     dVAR;
3008     SV* ob;
3009     GV* gv;
3010     HV* stash;
3011     SV *packsv = NULL;
3012     SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
3013         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3014                             "package or object reference", SVfARG(meth)),
3015            (SV *)NULL)
3016         : *(PL_stack_base + TOPMARK + 1);
3017
3018     PERL_ARGS_ASSERT_METHOD_COMMON;
3019
3020     if (!sv)
3021        undefined:
3022         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3023                    SVfARG(meth));
3024
3025     SvGETMAGIC(sv);
3026     if (SvROK(sv))
3027         ob = MUTABLE_SV(SvRV(sv));
3028     else if (!SvOK(sv)) goto undefined;
3029     else {
3030         /* this isn't a reference */
3031         GV* iogv;
3032         STRLEN packlen;
3033         const char * const packname = SvPV_nomg_const(sv, packlen);
3034         const bool packname_is_utf8 = !!SvUTF8(sv);
3035         const HE* const he =
3036             (const HE *)hv_common(
3037                 PL_stashcache, NULL, packname, packlen,
3038                 packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
3039             );
3040           
3041         if (he) { 
3042             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3043             DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
3044                              stash, sv));
3045             goto fetch;
3046         }
3047
3048         if (!(iogv = gv_fetchpvn_flags(
3049                 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
3050              )) ||
3051             !(ob=MUTABLE_SV(GvIO(iogv))))
3052         {
3053             /* this isn't the name of a filehandle either */
3054             if (!packlen)
3055             {
3056                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3057                                  "without a package or object reference",
3058                                   SVfARG(meth));
3059             }
3060             /* assume it's a package name */
3061             stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3062             if (!stash)
3063                 packsv = sv;
3064             else {
3065                 SV* const ref = newSViv(PTR2IV(stash));
3066                 (void)hv_store(PL_stashcache, packname,
3067                                 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3068                 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
3069                                  stash, sv));
3070             }
3071             goto fetch;
3072         }
3073         /* it _is_ a filehandle name -- replace with a reference */
3074         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3075     }
3076
3077     /* if we got here, ob should be a reference or a glob */
3078     if (!ob || !(SvOBJECT(ob)
3079                  || (SvTYPE(ob) == SVt_PVGV 
3080                      && isGV_with_GP(ob)
3081                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3082                      && SvOBJECT(ob))))
3083     {
3084         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3085                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3086                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3087                                         : meth));
3088     }
3089
3090     stash = SvSTASH(ob);
3091
3092   fetch:
3093     /* NOTE: stash may be null, hope hv_fetch_ent and
3094        gv_fetchmethod can cope (it seems they can) */
3095
3096     /* shortcut for simple names */
3097     if (hashp) {
3098         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3099         if (he) {
3100             gv = MUTABLE_GV(HeVAL(he));
3101             if (isGV(gv) && GvCV(gv) &&
3102                 (!GvCVGEN(gv) || GvCVGEN(gv)
3103                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3104                 return MUTABLE_SV(GvCV(gv));
3105         }
3106     }
3107
3108     gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3109                                      meth, GV_AUTOLOAD | GV_CROAK);
3110
3111     assert(gv);
3112
3113     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3114 }
3115
3116 /*
3117  * Local variables:
3118  * c-indentation-style: bsd
3119  * c-basic-offset: 4
3120  * indent-tabs-mode: nil
3121  * End:
3122  *
3123  * ex: set ts=8 sts=4 sw=4 et:
3124  */