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