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