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