This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
optimise save/restore of PL_delaymagic.
[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     dSP;
43     XPUSHs(cSVOP_sv);
44     RETURN;
45 }
46
47 PP(pp_nextstate)
48 {
49     PL_curcop = (COP*)PL_op;
50     TAINT_NOT;          /* Each statement is presumed innocent */
51     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
52     FREETMPS;
53     PERL_ASYNC_CHECK();
54     return NORMAL;
55 }
56
57 PP(pp_gvsv)
58 {
59     dSP;
60     EXTEND(SP,1);
61     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
62         PUSHs(save_scalar(cGVOP_gv));
63     else
64         PUSHs(GvSVn(cGVOP_gv));
65     RETURN;
66 }
67
68
69 /* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
70
71 PP(pp_null)
72 {
73     return NORMAL;
74 }
75
76 /* This is sometimes called directly by pp_coreargs, pp_grepstart and
77    amagic_call. */
78 PP(pp_pushmark)
79 {
80     PUSHMARK(PL_stack_sp);
81     return NORMAL;
82 }
83
84 PP(pp_stringify)
85 {
86     dSP; dTARGET;
87     SV * const sv = TOPs;
88     SETs(TARG);
89     sv_copypv(TARG, sv);
90     SvSETMAGIC(TARG);
91     /* no PUTBACK, SETs doesn't inc/dec SP */
92     return NORMAL;
93 }
94
95 PP(pp_gv)
96 {
97     dSP;
98     XPUSHs(MUTABLE_SV(cGVOP_gv));
99     RETURN;
100 }
101
102
103 /* also used for: pp_andassign() */
104
105 PP(pp_and)
106 {
107     PERL_ASYNC_CHECK();
108     {
109         /* SP is not used to remove a variable that is saved across the
110           sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
111           register or load/store vs direct mem ops macro is introduced, this
112           should be a define block between direct PL_stack_sp and dSP operations,
113           presently, using PL_stack_sp is bias towards CISC cpus */
114         SV * const sv = *PL_stack_sp;
115         if (!SvTRUE_NN(sv))
116             return NORMAL;
117         else {
118             if (PL_op->op_type == OP_AND)
119                 --PL_stack_sp;
120             return cLOGOP->op_other;
121         }
122     }
123 }
124
125 PP(pp_sassign)
126 {
127     dSP;
128     /* sassign keeps its args in the optree traditionally backwards.
129        So we pop them differently.
130     */
131     SV *left = POPs; SV *right = TOPs;
132
133     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
134         SV * const temp = left;
135         left = right; right = temp;
136     }
137     if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
138         TAINT_NOT;
139     if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
140         /* *foo =\&bar */
141         SV * const cv = SvRV(right);
142         const U32 cv_type = SvTYPE(cv);
143         const bool is_gv = isGV_with_GP(left);
144         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
145
146         if (!got_coderef) {
147             assert(SvROK(cv));
148         }
149
150         /* Can do the optimisation if left (LVALUE) is not a typeglob,
151            right (RVALUE) is a reference to something, and we're in void
152            context. */
153         if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
154             /* Is the target symbol table currently empty?  */
155             GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
156             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
157                 /* Good. Create a new proxy constant subroutine in the target.
158                    The gv becomes a(nother) reference to the constant.  */
159                 SV *const value = SvRV(cv);
160
161                 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
162                 SvPCS_IMPORTED_on(gv);
163                 SvRV_set(gv, value);
164                 SvREFCNT_inc_simple_void(value);
165                 SETs(left);
166                 RETURN;
167             }
168         }
169
170         /* Need to fix things up.  */
171         if (!is_gv) {
172             /* Need to fix GV.  */
173             left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
174         }
175
176         if (!got_coderef) {
177             /* We've been returned a constant rather than a full subroutine,
178                but they expect a subroutine reference to apply.  */
179             if (SvROK(cv)) {
180                 ENTER_with_name("sassign_coderef");
181                 SvREFCNT_inc_void(SvRV(cv));
182                 /* newCONSTSUB takes a reference count on the passed in SV
183                    from us.  We set the name to NULL, otherwise we get into
184                    all sorts of fun as the reference to our new sub is
185                    donated to the GV that we're about to assign to.
186                 */
187                 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
188                                                       SvRV(cv))));
189                 SvREFCNT_dec_NN(cv);
190                 LEAVE_with_name("sassign_coderef");
191             } else {
192                 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
193                    is that
194                    First:   ops for \&{"BONK"}; return us the constant in the
195                             symbol table
196                    Second:  ops for *{"BONK"} cause that symbol table entry
197                             (and our reference to it) to be upgraded from RV
198                             to typeblob)
199                    Thirdly: We get here. cv is actually PVGV now, and its
200                             GvCV() is actually the subroutine we're looking for
201
202                    So change the reference so that it points to the subroutine
203                    of that typeglob, as that's what they were after all along.
204                 */
205                 GV *const upgraded = MUTABLE_GV(cv);
206                 CV *const source = GvCV(upgraded);
207
208                 assert(source);
209                 assert(CvFLAGS(source) & CVf_CONST);
210
211                 SvREFCNT_inc_void(source);
212                 SvREFCNT_dec_NN(upgraded);
213                 SvRV_set(right, MUTABLE_SV(source));
214             }
215         }
216
217     }
218     if (
219       UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
220       (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
221     )
222         Perl_warner(aTHX_
223             packWARN(WARN_MISC), "Useless assignment to a temporary"
224         );
225     SvSetMagicSV(left, right);
226     SETs(left);
227     RETURN;
228 }
229
230 PP(pp_cond_expr)
231 {
232     dSP;
233     PERL_ASYNC_CHECK();
234     if (SvTRUEx(POPs))
235         RETURNOP(cLOGOP->op_other);
236     else
237         RETURNOP(cLOGOP->op_next);
238 }
239
240 PP(pp_unstack)
241 {
242     PERL_ASYNC_CHECK();
243     TAINT_NOT;          /* Each statement is presumed innocent */
244     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
245     FREETMPS;
246     if (!(PL_op->op_flags & OPf_SPECIAL)) {
247         I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
248         LEAVE_SCOPE(oldsave);
249     }
250     return NORMAL;
251 }
252
253 PP(pp_concat)
254 {
255   dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
256   {
257     dPOPTOPssrl;
258     bool lbyte;
259     STRLEN rlen;
260     const char *rpv = NULL;
261     bool rbyte = FALSE;
262     bool rcopied = FALSE;
263
264     if (TARG == right && right != left) { /* $r = $l.$r */
265         rpv = SvPV_nomg_const(right, rlen);
266         rbyte = !DO_UTF8(right);
267         right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
268         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
269         rcopied = TRUE;
270     }
271
272     if (TARG != left) { /* not $l .= $r */
273         STRLEN llen;
274         const char* const lpv = SvPV_nomg_const(left, llen);
275         lbyte = !DO_UTF8(left);
276         sv_setpvn(TARG, lpv, llen);
277         if (!lbyte)
278             SvUTF8_on(TARG);
279         else
280             SvUTF8_off(TARG);
281     }
282     else { /* $l .= $r   and   left == TARG */
283         if (!SvOK(left)) {
284             if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
285                 report_uninit(right);
286             sv_setpvs(left, "");
287         }
288         else {
289             SvPV_force_nomg_nolen(left);
290         }
291         lbyte = !DO_UTF8(left);
292         if (IN_BYTES)
293             SvUTF8_off(left);
294     }
295
296     if (!rcopied) {
297         rpv = SvPV_nomg_const(right, rlen);
298         rbyte = !DO_UTF8(right);
299     }
300     if (lbyte != rbyte) {
301         if (lbyte)
302             sv_utf8_upgrade_nomg(TARG);
303         else {
304             if (!rcopied)
305                 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
306             sv_utf8_upgrade_nomg(right);
307             rpv = SvPV_nomg_const(right, rlen);
308         }
309     }
310     sv_catpvn_nomg(TARG, rpv, rlen);
311
312     SETTARG;
313     RETURN;
314   }
315 }
316
317 /* push the elements of av onto the stack.
318  * XXX Note that padav has similar code but without the mg_get().
319  * I suspect that the mg_get is no longer needed, but while padav
320  * differs, it can't share this function */
321
322 STATIC void
323 S_pushav(pTHX_ AV* const av)
324 {
325     dSP;
326     const SSize_t maxarg = AvFILL(av) + 1;
327     EXTEND(SP, maxarg);
328     if (UNLIKELY(SvRMAGICAL(av))) {
329         PADOFFSET i;
330         for (i=0; i < (PADOFFSET)maxarg; i++) {
331             SV ** const svp = av_fetch(av, i, FALSE);
332             /* See note in pp_helem, and bug id #27839 */
333             SP[i+1] = svp
334                 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
335                 : &PL_sv_undef;
336         }
337     }
338     else {
339         PADOFFSET i;
340         for (i=0; i < (PADOFFSET)maxarg; i++) {
341             SV * const sv = AvARRAY(av)[i];
342             SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
343         }
344     }
345     SP += maxarg;
346     PUTBACK;
347 }
348
349
350 /* ($lex1,@lex2,...)   or my ($lex1,@lex2,...)  */
351
352 PP(pp_padrange)
353 {
354     dSP;
355     PADOFFSET base = PL_op->op_targ;
356     int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
357     int i;
358     if (PL_op->op_flags & OPf_SPECIAL) {
359         /* fake the RHS of my ($x,$y,..) = @_ */
360         PUSHMARK(SP);
361         S_pushav(aTHX_ GvAVn(PL_defgv));
362         SPAGAIN;
363     }
364
365     /* note, this is only skipped for compile-time-known void cxt */
366     if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
367         EXTEND(SP, count);
368         PUSHMARK(SP);
369         for (i = 0; i <count; i++)
370             *++SP = PAD_SV(base+i);
371     }
372     if (PL_op->op_private & OPpLVAL_INTRO) {
373         SV **svp = &(PAD_SVl(base));
374         const UV payload = (UV)(
375                       (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
376                     | (count << SAVE_TIGHT_SHIFT)
377                     | SAVEt_CLEARPADRANGE);
378         STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
379         assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
380         {
381             dSS_ADD;
382             SS_ADD_UV(payload);
383             SS_ADD_END(1);
384         }
385
386         for (i = 0; i <count; i++)
387             SvPADSTALE_off(*svp++); /* mark lexical as active */
388     }
389     RETURN;
390 }
391
392
393 PP(pp_padsv)
394 {
395     dSP;
396     EXTEND(SP, 1);
397     {
398         OP * const op = PL_op;
399         /* access PL_curpad once */
400         SV ** const padentry = &(PAD_SVl(op->op_targ));
401         {
402             dTARG;
403             TARG = *padentry;
404             PUSHs(TARG);
405             PUTBACK; /* no pop/push after this, TOPs ok */
406         }
407         if (op->op_flags & OPf_MOD) {
408             if (op->op_private & OPpLVAL_INTRO)
409                 if (!(op->op_private & OPpPAD_STATE))
410                     save_clearsv(padentry);
411             if (op->op_private & OPpDEREF) {
412                 /* TOPs is equivalent to TARG here.  Using TOPs (SP) rather
413                    than TARG reduces the scope of TARG, so it does not
414                    span the call to save_clearsv, resulting in smaller
415                    machine code. */
416                 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
417             }
418         }
419         return op->op_next;
420     }
421 }
422
423 PP(pp_readline)
424 {
425     dSP;
426     if (TOPs) {
427         SvGETMAGIC(TOPs);
428         tryAMAGICunTARGETlist(iter_amg, 0);
429         PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
430     }
431     else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
432     if (!isGV_with_GP(PL_last_in_gv)) {
433         if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
434             PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
435         else {
436             dSP;
437             XPUSHs(MUTABLE_SV(PL_last_in_gv));
438             PUTBACK;
439             Perl_pp_rv2gv(aTHX);
440             PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
441             if (PL_last_in_gv == (GV *)&PL_sv_undef)
442                 PL_last_in_gv = NULL;
443             else
444                 assert(isGV_with_GP(PL_last_in_gv));
445         }
446     }
447     return do_readline();
448 }
449
450 PP(pp_eq)
451 {
452     dSP;
453     SV *left, *right;
454
455     tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
456     right = POPs;
457     left  = TOPs;
458     SETs(boolSV(
459         (SvIOK_notUV(left) && SvIOK_notUV(right))
460         ? (SvIVX(left) == SvIVX(right))
461         : ( do_ncmp(left, right) == 0)
462     ));
463     RETURN;
464 }
465
466
467 /* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
468
469 PP(pp_preinc)
470 {
471     dSP;
472     const bool inc =
473         PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
474     if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
475         Perl_croak_no_modify();
476     if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
477         && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
478     {
479         SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
480         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
481     }
482     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
483         if (inc) sv_inc(TOPs);
484         else sv_dec(TOPs);
485     SvSETMAGIC(TOPs);
486     return NORMAL;
487 }
488
489
490 /* also used for: pp_orassign() */
491
492 PP(pp_or)
493 {
494     dSP;
495     PERL_ASYNC_CHECK();
496     if (SvTRUE(TOPs))
497         RETURN;
498     else {
499         if (PL_op->op_type == OP_OR)
500             --SP;
501         RETURNOP(cLOGOP->op_other);
502     }
503 }
504
505
506 /* also used for: pp_dor() pp_dorassign() */
507
508 PP(pp_defined)
509 {
510     dSP;
511     SV* sv;
512     bool defined;
513     const int op_type = PL_op->op_type;
514     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
515
516     if (is_dor) {
517         PERL_ASYNC_CHECK();
518         sv = TOPs;
519         if (UNLIKELY(!sv || !SvANY(sv))) {
520             if (op_type == OP_DOR)
521                 --SP;
522             RETURNOP(cLOGOP->op_other);
523         }
524     }
525     else {
526         /* OP_DEFINED */
527         sv = POPs;
528         if (UNLIKELY(!sv || !SvANY(sv)))
529             RETPUSHNO;
530     }
531
532     defined = FALSE;
533     switch (SvTYPE(sv)) {
534     case SVt_PVAV:
535         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
536             defined = TRUE;
537         break;
538     case SVt_PVHV:
539         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
540             defined = TRUE;
541         break;
542     case SVt_PVCV:
543         if (CvROOT(sv) || CvXSUB(sv))
544             defined = TRUE;
545         break;
546     default:
547         SvGETMAGIC(sv);
548         if (SvOK(sv))
549             defined = TRUE;
550         break;
551     }
552
553     if (is_dor) {
554         if(defined) 
555             RETURN; 
556         if(op_type == OP_DOR)
557             --SP;
558         RETURNOP(cLOGOP->op_other);
559     }
560     /* assuming OP_DEFINED */
561     if(defined) 
562         RETPUSHYES;
563     RETPUSHNO;
564 }
565
566 PP(pp_add)
567 {
568     dSP; dATARGET; bool useleft; SV *svl, *svr;
569     tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
570     svr = TOPs;
571     svl = TOPm1s;
572
573     useleft = USE_LEFT(svl);
574 #ifdef PERL_PRESERVE_IVUV
575     /* We must see if we can perform the addition with integers if possible,
576        as the integer code detects overflow while the NV code doesn't.
577        If either argument hasn't had a numeric conversion yet attempt to get
578        the IV. It's important to do this now, rather than just assuming that
579        it's not IOK as a PV of "9223372036854775806" may not take well to NV
580        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
581        integer in case the second argument is IV=9223372036854775806
582        We can (now) rely on sv_2iv to do the right thing, only setting the
583        public IOK flag if the value in the NV (or PV) slot is truly integer.
584
585        A side effect is that this also aggressively prefers integer maths over
586        fp maths for integer values.
587
588        How to detect overflow?
589
590        C 99 section 6.2.6.1 says
591
592        The range of nonnegative values of a signed integer type is a subrange
593        of the corresponding unsigned integer type, and the representation of
594        the same value in each type is the same. A computation involving
595        unsigned operands can never overflow, because a result that cannot be
596        represented by the resulting unsigned integer type is reduced modulo
597        the number that is one greater than the largest value that can be
598        represented by the resulting type.
599
600        (the 9th paragraph)
601
602        which I read as "unsigned ints wrap."
603
604        signed integer overflow seems to be classed as "exception condition"
605
606        If an exceptional condition occurs during the evaluation of an
607        expression (that is, if the result is not mathematically defined or not
608        in the range of representable values for its type), the behavior is
609        undefined.
610
611        (6.5, the 5th paragraph)
612
613        I had assumed that on 2s complement machines signed arithmetic would
614        wrap, hence coded pp_add and pp_subtract on the assumption that
615        everything perl builds on would be happy.  After much wailing and
616        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
617        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
618        unsigned code below is actually shorter than the old code. :-)
619     */
620
621     if (SvIV_please_nomg(svr)) {
622         /* Unless the left argument is integer in range we are going to have to
623            use NV maths. Hence only attempt to coerce the right argument if
624            we know the left is integer.  */
625         UV auv = 0;
626         bool auvok = FALSE;
627         bool a_valid = 0;
628
629         if (!useleft) {
630             auv = 0;
631             a_valid = auvok = 1;
632             /* left operand is undef, treat as zero. + 0 is identity,
633                Could SETi or SETu right now, but space optimise by not adding
634                lots of code to speed up what is probably a rarish case.  */
635         } else {
636             /* Left operand is defined, so is it IV? */
637             if (SvIV_please_nomg(svl)) {
638                 if ((auvok = SvUOK(svl)))
639                     auv = SvUVX(svl);
640                 else {
641                     const IV aiv = SvIVX(svl);
642                     if (aiv >= 0) {
643                         auv = aiv;
644                         auvok = 1;      /* Now acting as a sign flag.  */
645                     } else {
646                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
647                     }
648                 }
649                 a_valid = 1;
650             }
651         }
652         if (a_valid) {
653             bool result_good = 0;
654             UV result;
655             UV buv;
656             bool buvok = SvUOK(svr);
657         
658             if (buvok)
659                 buv = SvUVX(svr);
660             else {
661                 const IV biv = SvIVX(svr);
662                 if (biv >= 0) {
663                     buv = biv;
664                     buvok = 1;
665                 } else
666                     buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
667             }
668             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
669                else "IV" now, independent of how it came in.
670                if a, b represents positive, A, B negative, a maps to -A etc
671                a + b =>  (a + b)
672                A + b => -(a - b)
673                a + B =>  (a - b)
674                A + B => -(a + b)
675                all UV maths. negate result if A negative.
676                add if signs same, subtract if signs differ. */
677
678             if (auvok ^ buvok) {
679                 /* Signs differ.  */
680                 if (auv >= buv) {
681                     result = auv - buv;
682                     /* Must get smaller */
683                     if (result <= auv)
684                         result_good = 1;
685                 } else {
686                     result = buv - auv;
687                     if (result <= buv) {
688                         /* result really should be -(auv-buv). as its negation
689                            of true value, need to swap our result flag  */
690                         auvok = !auvok;
691                         result_good = 1;
692                     }
693                 }
694             } else {
695                 /* Signs same */
696                 result = auv + buv;
697                 if (result >= auv)
698                     result_good = 1;
699             }
700             if (result_good) {
701                 SP--;
702                 if (auvok)
703                     SETu( result );
704                 else {
705                     /* Negate result */
706                     if (result <= (UV)IV_MIN)
707                         SETi(result == (UV)IV_MIN
708                                 ? IV_MIN : -(IV)result);
709                     else {
710                         /* result valid, but out of range for IV.  */
711                         SETn( -(NV)result );
712                     }
713                 }
714                 RETURN;
715             } /* Overflow, drop through to NVs.  */
716         }
717     }
718 #endif
719     {
720         NV value = SvNV_nomg(svr);
721         (void)POPs;
722         if (!useleft) {
723             /* left operand is undef, treat as zero. + 0.0 is identity. */
724             SETn(value);
725             RETURN;
726         }
727         SETn( value + SvNV_nomg(svl) );
728         RETURN;
729     }
730 }
731
732
733 /* also used for: pp_aelemfast_lex() */
734
735 PP(pp_aelemfast)
736 {
737     dSP;
738     AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
739         ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
740     const U32 lval = PL_op->op_flags & OPf_MOD;
741     SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
742     SV *sv = (svp ? *svp : &PL_sv_undef);
743
744     if (UNLIKELY(!svp && lval))
745         DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
746
747     EXTEND(SP, 1);
748     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
749         mg_get(sv);
750     PUSHs(sv);
751     RETURN;
752 }
753
754 PP(pp_join)
755 {
756     dSP; dMARK; dTARGET;
757     MARK++;
758     do_join(TARG, *MARK, MARK, SP);
759     SP = MARK;
760     SETs(TARG);
761     RETURN;
762 }
763
764 PP(pp_pushre)
765 {
766     dSP;
767 #ifdef DEBUGGING
768     /*
769      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
770      * will be enough to hold an OP*.
771      */
772     SV* const sv = sv_newmortal();
773     sv_upgrade(sv, SVt_PVLV);
774     LvTYPE(sv) = '/';
775     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
776     XPUSHs(sv);
777 #else
778     XPUSHs(MUTABLE_SV(PL_op));
779 #endif
780     RETURN;
781 }
782
783 /* Oversized hot code. */
784
785 /* also used for: pp_say() */
786
787 PP(pp_print)
788 {
789     dSP; dMARK; dORIGMARK;
790     PerlIO *fp;
791     MAGIC *mg;
792     GV * const gv
793         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
794     IO *io = GvIO(gv);
795
796     if (io
797         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
798     {
799       had_magic:
800         if (MARK == ORIGMARK) {
801             /* If using default handle then we need to make space to
802              * pass object as 1st arg, so move other args up ...
803              */
804             MEXTEND(SP, 1);
805             ++MARK;
806             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
807             ++SP;
808         }
809         return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
810                                 mg,
811                                 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
812                                  | (PL_op->op_type == OP_SAY
813                                     ? TIED_METHOD_SAY : 0)), sp - mark);
814     }
815     if (!io) {
816         if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
817             && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
818             goto had_magic;
819         report_evil_fh(gv);
820         SETERRNO(EBADF,RMS_IFI);
821         goto just_say_no;
822     }
823     else if (!(fp = IoOFP(io))) {
824         if (IoIFP(io))
825             report_wrongway_fh(gv, '<');
826         else
827             report_evil_fh(gv);
828         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
829         goto just_say_no;
830     }
831     else {
832         SV * const ofs = GvSV(PL_ofsgv); /* $, */
833         MARK++;
834         if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
835             while (MARK <= SP) {
836                 if (!do_print(*MARK, fp))
837                     break;
838                 MARK++;
839                 if (MARK <= SP) {
840                     /* don't use 'ofs' here - it may be invalidated by magic callbacks */
841                     if (!do_print(GvSV(PL_ofsgv), fp)) {
842                         MARK--;
843                         break;
844                     }
845                 }
846             }
847         }
848         else {
849             while (MARK <= SP) {
850                 if (!do_print(*MARK, fp))
851                     break;
852                 MARK++;
853             }
854         }
855         if (MARK <= SP)
856             goto just_say_no;
857         else {
858             if (PL_op->op_type == OP_SAY) {
859                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
860                     goto just_say_no;
861             }
862             else if (PL_ors_sv && SvOK(PL_ors_sv))
863                 if (!do_print(PL_ors_sv, fp)) /* $\ */
864                     goto just_say_no;
865
866             if (IoFLAGS(io) & IOf_FLUSH)
867                 if (PerlIO_flush(fp) == EOF)
868                     goto just_say_no;
869         }
870     }
871     SP = ORIGMARK;
872     XPUSHs(&PL_sv_yes);
873     RETURN;
874
875   just_say_no:
876     SP = ORIGMARK;
877     XPUSHs(&PL_sv_undef);
878     RETURN;
879 }
880
881
882 /* also used for: pp_rv2hv() */
883 /* also called directly by pp_lvavref */
884
885 PP(pp_rv2av)
886 {
887     dSP; dTOPss;
888     const I32 gimme = GIMME_V;
889     static const char an_array[] = "an ARRAY";
890     static const char a_hash[] = "a HASH";
891     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
892                           || PL_op->op_type == OP_LVAVREF;
893     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
894
895     SvGETMAGIC(sv);
896     if (SvROK(sv)) {
897         if (UNLIKELY(SvAMAGIC(sv))) {
898             sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
899         }
900         sv = SvRV(sv);
901         if (UNLIKELY(SvTYPE(sv) != type))
902             /* diag_listed_as: Not an ARRAY reference */
903             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
904         else if (UNLIKELY(PL_op->op_flags & OPf_MOD
905                 && PL_op->op_private & OPpLVAL_INTRO))
906             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
907     }
908     else if (UNLIKELY(SvTYPE(sv) != type)) {
909             GV *gv;
910         
911             if (!isGV_with_GP(sv)) {
912                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
913                                      type, &sp);
914                 if (!gv)
915                     RETURN;
916             }
917             else {
918                 gv = MUTABLE_GV(sv);
919             }
920             sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
921             if (PL_op->op_private & OPpLVAL_INTRO)
922                 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
923     }
924     if (PL_op->op_flags & OPf_REF) {
925                 SETs(sv);
926                 RETURN;
927     }
928     else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
929               const I32 flags = is_lvalue_sub();
930               if (flags && !(flags & OPpENTERSUB_INARGS)) {
931                 if (gimme != G_ARRAY)
932                     goto croak_cant_return;
933                 SETs(sv);
934                 RETURN;
935               }
936     }
937
938     if (is_pp_rv2av) {
939         AV *const av = MUTABLE_AV(sv);
940         /* The guts of pp_rv2av  */
941         if (gimme == G_ARRAY) {
942             SP--;
943             PUTBACK;
944             S_pushav(aTHX_ av);
945             SPAGAIN;
946         }
947         else if (gimme == G_SCALAR) {
948             dTARGET;
949             const SSize_t maxarg = AvFILL(av) + 1;
950             SETi(maxarg);
951         }
952     } else {
953         /* The guts of pp_rv2hv  */
954         if (gimme == G_ARRAY) { /* array wanted */
955             *PL_stack_sp = sv;
956             return Perl_do_kv(aTHX);
957         }
958         else if ((PL_op->op_private & OPpTRUEBOOL
959               || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
960                  && block_gimme() == G_VOID  ))
961               && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
962             SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
963         else if (gimme == G_SCALAR) {
964             dTARG;
965             TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
966             SETTARG;
967         }
968     }
969     RETURN;
970
971  croak_cant_return:
972     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
973                is_pp_rv2av ? "array" : "hash");
974     RETURN;
975 }
976
977 STATIC void
978 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
979 {
980     PERL_ARGS_ASSERT_DO_ODDBALL;
981
982     if (*oddkey) {
983         if (ckWARN(WARN_MISC)) {
984             const char *err;
985             if (oddkey == firstkey &&
986                 SvROK(*oddkey) &&
987                 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
988                  SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
989             {
990                 err = "Reference found where even-sized list expected";
991             }
992             else
993                 err = "Odd number of elements in hash assignment";
994             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
995         }
996
997     }
998 }
999
1000
1001 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
1002  * are common to both the LHS and RHS of an aassign, and replace them
1003  * with copies. All these copies are made before the actual list assign is
1004  * done.
1005  *
1006  * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
1007  * element ($b) to the first LH element ($a), modifies $a; when the
1008  * second assignment is done, the second RH element now has the wrong
1009  * value. So we initially replace the RHS with ($b, mortalcopy($a)).
1010  * Note that we don't need to make a mortal copy of $b.
1011  *
1012  * The algorithm below works by, for every RHS element, mark the
1013  * corresponding LHS target element with SVf_BREAK. Then if the RHS
1014  * element is found with SVf_BREAK set, it means it would have been
1015  * modified, so make a copy.
1016  * Note that by scanning both LHS and RHS in lockstep, we avoid
1017  * unnecessary copies (like $b above) compared with a naive
1018  * "mark all LHS; copy all marked RHS; unmark all LHS".
1019  *
1020  * If the LHS element is a 'my' declaration' and has a refcount of 1, then
1021  * it can't be common and can be skipped.
1022  *
1023  * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
1024  * that we thought we didn't need to call S_aassign_copy_common(), but we
1025  * have anyway for sanity checking. If we find we need to copy, then panic.
1026  */
1027
1028 PERL_STATIC_INLINE void
1029 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
1030         SV **firstrelem, SV **lastrelem
1031 #ifdef DEBUGGING
1032         , bool fake
1033 #endif
1034 )
1035 {
1036     dVAR;
1037     SV **relem;
1038     SV **lelem;
1039     SSize_t lcount = lastlelem - firstlelem + 1;
1040     bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
1041     bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
1042
1043     assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
1044     assert(firstlelem < lastlelem); /* at least 2 LH elements */
1045     assert(firstrelem < lastrelem); /* at least 2 RH elements */
1046
1047
1048     lelem = firstlelem;
1049     /* we never have to copy the first RH element; it can't be corrupted
1050      * by assigning something to the corresponding first LH element.
1051      * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
1052      */
1053     relem = firstrelem + 1;
1054
1055     for (; relem <= lastrelem; relem++) {
1056         SV *svr;
1057
1058         /* mark next LH element */
1059
1060         if (--lcount >= 0) {
1061             SV *svl = *lelem++;
1062
1063             if (UNLIKELY(!svl)) {/* skip AV alias marker */
1064                 assert (lelem <= lastlelem);
1065                 svl = *lelem++;
1066                 lcount--;
1067             }
1068
1069             assert(svl);
1070             if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
1071                 if (!marked)
1072                     return;
1073                 /* this LH element will consume all further args;
1074                  * no need to mark any further LH elements (if any).
1075                  * But we still need to scan any remaining RHS elements;
1076                  * set lcount negative to distinguish from  lcount == 0,
1077                  * so the loop condition continues being true
1078                  */
1079                 lcount = -1;
1080                 lelem--; /* no need to unmark this element */
1081             }
1082             else if (!(do_rc1 && SvREFCNT(svl) == 1) && svl != &PL_sv_undef) {
1083                 assert(!SvIMMORTAL(svl));
1084                 SvFLAGS(svl) |= SVf_BREAK;
1085                 marked = TRUE;
1086             }
1087             else if (!marked) {
1088                 /* don't check RH element if no SVf_BREAK flags set yet */
1089                 if (!lcount)
1090                     break;
1091                 continue;
1092             }
1093         }
1094
1095         /* see if corresponding RH element needs copying */
1096
1097         assert(marked);
1098         svr = *relem;
1099         assert(svr);
1100
1101         if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK)) {
1102
1103 #ifdef DEBUGGING
1104             if (fake) {
1105                 /* op_dump(PL_op); */
1106                 Perl_croak(aTHX_
1107                     "panic: aassign skipped needed copy of common RH elem %"
1108                         UVuf, (UV)(relem - firstrelem));
1109             }
1110 #endif
1111
1112             TAINT_NOT;  /* Each item is independent */
1113
1114             /* Dear TODO test in t/op/sort.t, I love you.
1115                (It's relying on a panic, not a "semi-panic" from newSVsv()
1116                and then an assertion failure below.)  */
1117             if (UNLIKELY(SvIS_FREED(svr))) {
1118                 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1119                            (void*)svr);
1120             }
1121             /* avoid break flag while copying; otherwise COW etc
1122              * disabled... */
1123             SvFLAGS(svr) &= ~SVf_BREAK;
1124             /* Not newSVsv(), as it does not allow copy-on-write,
1125                resulting in wasteful copies.
1126                Also, we use SV_NOSTEAL in case the SV is used more than
1127                once, e.g.  (...) = (f())[0,0]
1128                Where the same SV appears twice on the RHS without a ref
1129                count bump.  (Although I suspect that the SV won't be
1130                stealable here anyway - DAPM).
1131                */
1132             *relem = sv_mortalcopy_flags(svr,
1133                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1134             /* ... but restore afterwards in case it's needed again,
1135              * e.g. ($a,$b,$c) = (1,$a,$a)
1136              */
1137             SvFLAGS(svr) |= SVf_BREAK;
1138         }
1139
1140         if (!lcount)
1141             break;
1142     }
1143
1144     if (!marked)
1145         return;
1146
1147     /*unmark LHS */
1148
1149     while (lelem > firstlelem) {
1150         SV * const svl = *(--lelem);
1151         if (svl)
1152             SvFLAGS(svl) &= ~SVf_BREAK;
1153     }
1154 }
1155
1156
1157
1158 PP(pp_aassign)
1159 {
1160     dVAR; dSP;
1161     SV **lastlelem = PL_stack_sp;
1162     SV **lastrelem = PL_stack_base + POPMARK;
1163     SV **firstrelem = PL_stack_base + POPMARK + 1;
1164     SV **firstlelem = lastrelem + 1;
1165
1166     SV **relem;
1167     SV **lelem;
1168
1169     SV *sv;
1170     AV *ary;
1171
1172     I32 gimme;
1173     HV *hash;
1174     SSize_t i;
1175     int magic;
1176     U32 lval;
1177     /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
1178      * only need to save locally, not on the save stack */
1179     U16 old_delaymagic = PL_delaymagic;
1180 #ifdef DEBUGGING
1181     bool fake = 0;
1182 #endif
1183
1184     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
1185
1186     /* If there's a common identifier on both sides we have to take
1187      * special care that assigning the identifier on the left doesn't
1188      * clobber a value on the right that's used later in the list.
1189      */
1190
1191     if ( (PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1))
1192         /* at least 2 LH and RH elements, or commonality isn't an issue */
1193         && (firstlelem < lastlelem && firstrelem < lastrelem)
1194     ) {
1195         if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
1196             /* skip the scan if all scalars have a ref count of 1 */
1197             for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1198                 sv = *lelem;
1199                 if (!sv || SvREFCNT(sv) == 1)
1200                     continue;
1201                 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
1202                     goto do_scan;
1203                 break;
1204             }
1205         }
1206         else {
1207           do_scan:
1208             S_aassign_copy_common(aTHX_
1209                         firstlelem, lastlelem, firstrelem, lastrelem
1210 #ifdef DEBUGGING
1211                         , fake
1212 #endif
1213             );
1214         }
1215     }
1216 #ifdef DEBUGGING
1217     else {
1218         /* on debugging builds, do the scan even if we've concluded we
1219          * don't need to, then panic if we find commonality. Note that the
1220          * scanner assumes at least 2 elements */
1221         if (firstlelem < lastlelem && firstrelem < lastrelem) {
1222             fake = 1;
1223             goto do_scan;
1224         }
1225     }
1226 #endif
1227
1228     gimme = GIMME_V;
1229     lval = (gimme == G_ARRAY) ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
1230
1231     relem = firstrelem;
1232     lelem = firstlelem;
1233     ary = NULL;
1234     hash = NULL;
1235
1236     while (LIKELY(lelem <= lastlelem)) {
1237         bool alias = FALSE;
1238         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1239         sv = *lelem++;
1240         if (UNLIKELY(!sv)) {
1241             alias = TRUE;
1242             sv = *lelem++;
1243             ASSUME(SvTYPE(sv) == SVt_PVAV);
1244         }
1245         switch (SvTYPE(sv)) {
1246         case SVt_PVAV: {
1247             bool already_copied = FALSE;
1248             ary = MUTABLE_AV(sv);
1249             magic = SvMAGICAL(ary) != 0;
1250             ENTER;
1251             SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1252
1253             /* We need to clear ary. The is a danger that if we do this,
1254              * elements on the RHS may be prematurely freed, e.g.
1255              *   @a = ($a[0]);
1256              * In the case of possible commonality, make a copy of each
1257              * RHS SV *before* clearing the array, and add a reference
1258              * from the tmps stack, so that it doesn't leak on death.
1259              * Otherwise, make a copy of each RHS SV only as we're storing
1260              * it into the array - that way we don't have to worry about
1261              * it being leaked if we die, but don't incur the cost of
1262              * mortalising everything.
1263              */
1264
1265             if (   (PL_op->op_private & OPpASSIGN_COMMON_AGG)
1266                 && (relem <= lastrelem)
1267                 && (magic || AvFILL(ary) != -1))
1268             {
1269                 SV **svp;
1270                 EXTEND_MORTAL(lastrelem - relem + 1);
1271                 for (svp = relem; svp <= lastrelem; svp++) {
1272                     /* see comment in S_aassign_copy_common about SV_NOSTEAL */
1273                     *svp = sv_mortalcopy_flags(*svp,
1274                             SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1275                     TAINT_NOT;
1276                 }
1277                 already_copied = TRUE;
1278             }
1279
1280             av_clear(ary);
1281             if (relem <= lastrelem)
1282                 av_extend(ary, lastrelem - relem);
1283
1284             i = 0;
1285             while (relem <= lastrelem) {        /* gobble up all the rest */
1286                 SV **didstore;
1287                 if (LIKELY(!alias)) {
1288                     if (already_copied)
1289                         sv = *relem;
1290                     else {
1291                         if (LIKELY(*relem))
1292                             /* before newSV, in case it dies */
1293                             SvGETMAGIC(*relem);
1294                         sv = newSV(0);
1295                         /* see comment in S_aassign_copy_common about
1296                          * SV_NOSTEAL */
1297                         sv_setsv_flags(sv, *relem,
1298                                     (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1299                         *relem = sv;
1300                     }
1301                 }
1302                 else {
1303                     if (!already_copied)
1304                         SvGETMAGIC(*relem);
1305                     if (!SvROK(*relem))
1306                         DIE(aTHX_ "Assigned value is not a reference");
1307                     if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1308                    /* diag_listed_as: Assigned value is not %s reference */
1309                         DIE(aTHX_
1310                            "Assigned value is not a SCALAR reference");
1311                     if (lval && !already_copied)
1312                         *relem = sv_mortalcopy(*relem);
1313                     /* XXX else check for weak refs?  */
1314                     sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1315                 }
1316                 relem++;
1317                 if (already_copied)
1318                     SvREFCNT_inc_simple_NN(sv); /* undo mortal free */
1319                 didstore = av_store(ary,i++,sv);
1320                 if (magic) {
1321                     if (!didstore)
1322                         sv_2mortal(sv);
1323                     if (SvSMAGICAL(sv))
1324                         mg_set(sv);
1325                 }
1326                 TAINT_NOT;
1327             }
1328             if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1329                 SvSETMAGIC(MUTABLE_SV(ary));
1330             LEAVE;
1331             break;
1332         }
1333
1334         case SVt_PVHV: {                                /* normal hash */
1335                 SV *tmpstr;
1336                 int odd;
1337                 int duplicates = 0;
1338                 SV** topelem = relem;
1339                 SV **firsthashrelem = relem;
1340                 bool already_copied = FALSE;
1341
1342                 hash = MUTABLE_HV(sv);
1343                 magic = SvMAGICAL(hash) != 0;
1344
1345                 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1346                 if (UNLIKELY(odd)) {
1347                     do_oddball(lastrelem, firsthashrelem);
1348                     /* we have firstlelem to reuse, it's not needed anymore
1349                      */
1350                     *(lastrelem+1) = &PL_sv_undef;
1351                 }
1352
1353                 ENTER;
1354                 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1355
1356                 /* We need to clear hash. The is a danger that if we do this,
1357                  * elements on the RHS may be prematurely freed, e.g.
1358                  *   %h = (foo => $h{bar});
1359                  * In the case of possible commonality, make a copy of each
1360                  * RHS SV *before* clearing the hash, and add a reference
1361                  * from the tmps stack, so that it doesn't leak on death.
1362                  */
1363
1364                 if (   (PL_op->op_private & OPpASSIGN_COMMON_AGG)
1365                     && (relem <= lastrelem)
1366                     && (magic || HvUSEDKEYS(hash)))
1367                 {
1368                     SV **svp;
1369                     EXTEND_MORTAL(lastrelem - relem + 1);
1370                     for (svp = relem; svp <= lastrelem; svp++) {
1371                         *svp = sv_mortalcopy_flags(*svp,
1372                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1373                         TAINT_NOT;
1374                     }
1375                     already_copied = TRUE;
1376                 }
1377
1378                 hv_clear(hash);
1379
1380                 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1381                     HE *didstore;
1382                     assert(*relem);
1383                     /* Copy the key if aassign is called in lvalue context,
1384                        to avoid having the next op modify our rhs.  Copy
1385                        it also if it is gmagical, lest it make the
1386                        hv_store_ent call below croak, leaking the value. */
1387                     sv = (lval || SvGMAGICAL(*relem)) && !already_copied
1388                          ? sv_mortalcopy(*relem)
1389                          : *relem;
1390                     relem++;
1391                     assert(*relem);
1392                     if (already_copied)
1393                         tmpstr = *relem++;
1394                     else {
1395                         SvGETMAGIC(*relem);
1396                         tmpstr = newSV(0);
1397                         sv_setsv_nomg(tmpstr,*relem++); /* value */
1398                     }
1399
1400                     if (gimme == G_ARRAY) {
1401                         if (hv_exists_ent(hash, sv, 0))
1402                             /* key overwrites an existing entry */
1403                             duplicates += 2;
1404                         else {
1405                             /* copy element back: possibly to an earlier
1406                              * stack location if we encountered dups earlier,
1407                              * possibly to a later stack location if odd */
1408                             *topelem++ = sv;
1409                             *topelem++ = tmpstr;
1410                         }
1411                     }
1412                     if (already_copied)
1413                         SvREFCNT_inc_simple_NN(tmpstr); /* undo mortal free */
1414                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1415                     if (magic) {
1416                         if (!didstore) sv_2mortal(tmpstr);
1417                         SvSETMAGIC(tmpstr);
1418                     }
1419                     TAINT_NOT;
1420                 }
1421                 LEAVE;
1422                 if (duplicates && gimme == G_ARRAY) {
1423                     /* at this point we have removed the duplicate key/value
1424                      * pairs from the stack, but the remaining values may be
1425                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1426                      * the (a 2), but the stack now probably contains
1427                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1428                      * obliterates the earlier key. So refresh all values. */
1429                     lastrelem -= duplicates;
1430                     relem = firsthashrelem;
1431                     while (relem < lastrelem+odd) {
1432                         HE *he;
1433                         he = hv_fetch_ent(hash, *relem++, 0, 0);
1434                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1435                     }
1436                 }
1437                 if (odd && gimme == G_ARRAY) lastrelem++;
1438             }
1439             break;
1440         default:
1441             if (SvIMMORTAL(sv)) {
1442                 if (relem <= lastrelem)
1443                     relem++;
1444                 break;
1445             }
1446             if (relem <= lastrelem) {
1447                 if (UNLIKELY(
1448                   SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1449                   (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1450                 ))
1451                     Perl_warner(aTHX_
1452                        packWARN(WARN_MISC),
1453                       "Useless assignment to a temporary"
1454                     );
1455                 sv_setsv(sv, *relem);
1456                 *(relem++) = sv;
1457             }
1458             else
1459                 sv_setsv(sv, &PL_sv_undef);
1460             SvSETMAGIC(sv);
1461             break;
1462         }
1463     }
1464     if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1465         /* Will be used to set PL_tainting below */
1466         Uid_t tmp_uid  = PerlProc_getuid();
1467         Uid_t tmp_euid = PerlProc_geteuid();
1468         Gid_t tmp_gid  = PerlProc_getgid();
1469         Gid_t tmp_egid = PerlProc_getegid();
1470
1471         /* XXX $> et al currently silently ignore failures */
1472         if (PL_delaymagic & DM_UID) {
1473 #ifdef HAS_SETRESUID
1474             PERL_UNUSED_RESULT(
1475                setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1476                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1477                          (Uid_t)-1));
1478 #else
1479 #  ifdef HAS_SETREUID
1480             PERL_UNUSED_RESULT(
1481                 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1482                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1483 #  else
1484 #    ifdef HAS_SETRUID
1485             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1486                 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1487                 PL_delaymagic &= ~DM_RUID;
1488             }
1489 #    endif /* HAS_SETRUID */
1490 #    ifdef HAS_SETEUID
1491             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1492                 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1493                 PL_delaymagic &= ~DM_EUID;
1494             }
1495 #    endif /* HAS_SETEUID */
1496             if (PL_delaymagic & DM_UID) {
1497                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1498                     DIE(aTHX_ "No setreuid available");
1499                 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1500             }
1501 #  endif /* HAS_SETREUID */
1502 #endif /* HAS_SETRESUID */
1503
1504             tmp_uid  = PerlProc_getuid();
1505             tmp_euid = PerlProc_geteuid();
1506         }
1507         /* XXX $> et al currently silently ignore failures */
1508         if (PL_delaymagic & DM_GID) {
1509 #ifdef HAS_SETRESGID
1510             PERL_UNUSED_RESULT(
1511                 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1512                           (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1513                           (Gid_t)-1));
1514 #else
1515 #  ifdef HAS_SETREGID
1516             PERL_UNUSED_RESULT(
1517                 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1518                          (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1519 #  else
1520 #    ifdef HAS_SETRGID
1521             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1522                 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1523                 PL_delaymagic &= ~DM_RGID;
1524             }
1525 #    endif /* HAS_SETRGID */
1526 #    ifdef HAS_SETEGID
1527             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1528                 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1529                 PL_delaymagic &= ~DM_EGID;
1530             }
1531 #    endif /* HAS_SETEGID */
1532             if (PL_delaymagic & DM_GID) {
1533                 if (PL_delaymagic_gid != PL_delaymagic_egid)
1534                     DIE(aTHX_ "No setregid available");
1535                 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1536             }
1537 #  endif /* HAS_SETREGID */
1538 #endif /* HAS_SETRESGID */
1539
1540             tmp_gid  = PerlProc_getgid();
1541             tmp_egid = PerlProc_getegid();
1542         }
1543         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1544 #ifdef NO_TAINT_SUPPORT
1545         PERL_UNUSED_VAR(tmp_uid);
1546         PERL_UNUSED_VAR(tmp_euid);
1547         PERL_UNUSED_VAR(tmp_gid);
1548         PERL_UNUSED_VAR(tmp_egid);
1549 #endif
1550     }
1551     PL_delaymagic = old_delaymagic;
1552
1553     if (gimme == G_VOID)
1554         SP = firstrelem - 1;
1555     else if (gimme == G_SCALAR) {
1556         dTARGET;
1557         SP = firstrelem;
1558         SETi(lastrelem - firstrelem + 1);
1559     }
1560     else {
1561         if (ary || hash)
1562             /* note that in this case *firstlelem may have been overwritten
1563                by sv_undef in the odd hash case */
1564             SP = lastrelem;
1565         else {
1566             SP = firstrelem + (lastlelem - firstlelem);
1567             lelem = firstlelem + (relem - firstrelem);
1568             while (relem <= SP)
1569                 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1570         }
1571     }
1572
1573     RETURN;
1574 }
1575
1576 PP(pp_qr)
1577 {
1578     dSP;
1579     PMOP * const pm = cPMOP;
1580     REGEXP * rx = PM_GETRE(pm);
1581     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1582     SV * const rv = sv_newmortal();
1583     CV **cvp;
1584     CV *cv;
1585
1586     SvUPGRADE(rv, SVt_IV);
1587     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1588        loathe to use it here, but it seems to be the right fix. Or close.
1589        The key part appears to be that it's essential for pp_qr to return a new
1590        object (SV), which implies that there needs to be an effective way to
1591        generate a new SV from the existing SV that is pre-compiled in the
1592        optree.  */
1593     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1594     SvROK_on(rv);
1595
1596     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1597     if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1598         *cvp = cv_clone(cv);
1599         SvREFCNT_dec_NN(cv);
1600     }
1601
1602     if (pkg) {
1603         HV *const stash = gv_stashsv(pkg, GV_ADD);
1604         SvREFCNT_dec_NN(pkg);
1605         (void)sv_bless(rv, stash);
1606     }
1607
1608     if (UNLIKELY(RX_ISTAINTED(rx))) {
1609         SvTAINTED_on(rv);
1610         SvTAINTED_on(SvRV(rv));
1611     }
1612     XPUSHs(rv);
1613     RETURN;
1614 }
1615
1616 PP(pp_match)
1617 {
1618     dSP; dTARG;
1619     PMOP *pm = cPMOP;
1620     PMOP *dynpm = pm;
1621     const char *s;
1622     const char *strend;
1623     SSize_t curpos = 0; /* initial pos() or current $+[0] */
1624     I32 global;
1625     U8 r_flags = 0;
1626     const char *truebase;                       /* Start of string  */
1627     REGEXP *rx = PM_GETRE(pm);
1628     bool rxtainted;
1629     const I32 gimme = GIMME_V;
1630     STRLEN len;
1631     const I32 oldsave = PL_savestack_ix;
1632     I32 had_zerolen = 0;
1633     MAGIC *mg = NULL;
1634
1635     if (PL_op->op_flags & OPf_STACKED)
1636         TARG = POPs;
1637     else if (ARGTARG)
1638         GETTARGET;
1639     else {
1640         TARG = DEFSV;
1641         EXTEND(SP,1);
1642     }
1643
1644     PUTBACK;                            /* EVAL blocks need stack_sp. */
1645     /* Skip get-magic if this is a qr// clone, because regcomp has
1646        already done it. */
1647     truebase = ReANY(rx)->mother_re
1648          ? SvPV_nomg_const(TARG, len)
1649          : SvPV_const(TARG, len);
1650     if (!truebase)
1651         DIE(aTHX_ "panic: pp_match");
1652     strend = truebase + len;
1653     rxtainted = (RX_ISTAINTED(rx) ||
1654                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1655     TAINT_NOT;
1656
1657     /* We need to know this in case we fail out early - pos() must be reset */
1658     global = dynpm->op_pmflags & PMf_GLOBAL;
1659
1660     /* PMdf_USED is set after a ?? matches once */
1661     if (
1662 #ifdef USE_ITHREADS
1663         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1664 #else
1665         pm->op_pmflags & PMf_USED
1666 #endif
1667     ) {
1668         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1669         goto nope;
1670     }
1671
1672     /* empty pattern special-cased to use last successful pattern if
1673        possible, except for qr// */
1674     if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1675      && PL_curpm) {
1676         pm = PL_curpm;
1677         rx = PM_GETRE(pm);
1678     }
1679
1680     if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1681         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1682                                               UVuf" < %"IVdf")\n",
1683                                               (UV)len, (IV)RX_MINLEN(rx)));
1684         goto nope;
1685     }
1686
1687     /* get pos() if //g */
1688     if (global) {
1689         mg = mg_find_mglob(TARG);
1690         if (mg && mg->mg_len >= 0) {
1691             curpos = MgBYTEPOS(mg, TARG, truebase, len);
1692             /* last time pos() was set, it was zero-length match */
1693             if (mg->mg_flags & MGf_MINMATCH)
1694                 had_zerolen = 1;
1695         }
1696     }
1697
1698 #ifdef PERL_SAWAMPERSAND
1699     if (       RX_NPARENS(rx)
1700             || PL_sawampersand
1701             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1702             || (dynpm->op_pmflags & PMf_KEEPCOPY)
1703     )
1704 #endif
1705     {
1706         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1707         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1708          * only on the first iteration. Therefore we need to copy $' as well
1709          * as $&, to make the rest of the string available for captures in
1710          * subsequent iterations */
1711         if (! (global && gimme == G_ARRAY))
1712             r_flags |= REXEC_COPY_SKIP_POST;
1713     };
1714 #ifdef PERL_SAWAMPERSAND
1715     if (dynpm->op_pmflags & PMf_KEEPCOPY)
1716         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1717         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1718 #endif
1719
1720     s = truebase;
1721
1722   play_it_again:
1723     if (global)
1724         s = truebase + curpos;
1725
1726     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1727                      had_zerolen, TARG, NULL, r_flags))
1728         goto nope;
1729
1730     PL_curpm = pm;
1731     if (dynpm->op_pmflags & PMf_ONCE)
1732 #ifdef USE_ITHREADS
1733         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1734 #else
1735         dynpm->op_pmflags |= PMf_USED;
1736 #endif
1737
1738     if (rxtainted)
1739         RX_MATCH_TAINTED_on(rx);
1740     TAINT_IF(RX_MATCH_TAINTED(rx));
1741
1742     /* update pos */
1743
1744     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1745         if (!mg)
1746             mg = sv_magicext_mglob(TARG);
1747         MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1748         if (RX_ZERO_LEN(rx))
1749             mg->mg_flags |= MGf_MINMATCH;
1750         else
1751             mg->mg_flags &= ~MGf_MINMATCH;
1752     }
1753
1754     if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1755         LEAVE_SCOPE(oldsave);
1756         RETPUSHYES;
1757     }
1758
1759     /* push captures on stack */
1760
1761     {
1762         const I32 nparens = RX_NPARENS(rx);
1763         I32 i = (global && !nparens) ? 1 : 0;
1764
1765         SPAGAIN;                        /* EVAL blocks could move the stack. */
1766         EXTEND(SP, nparens + i);
1767         EXTEND_MORTAL(nparens + i);
1768         for (i = !i; i <= nparens; i++) {
1769             PUSHs(sv_newmortal());
1770             if (LIKELY((RX_OFFS(rx)[i].start != -1)
1771                      && RX_OFFS(rx)[i].end   != -1 ))
1772             {
1773                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1774                 const char * const s = RX_OFFS(rx)[i].start + truebase;
1775                 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1776                         || len < 0 || len > strend - s))
1777                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1778                         "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1779                         (long) i, (long) RX_OFFS(rx)[i].start,
1780                         (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1781                 sv_setpvn(*SP, s, len);
1782                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1783                     SvUTF8_on(*SP);
1784             }
1785         }
1786         if (global) {
1787             curpos = (UV)RX_OFFS(rx)[0].end;
1788             had_zerolen = RX_ZERO_LEN(rx);
1789             PUTBACK;                    /* EVAL blocks may use stack */
1790             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1791             goto play_it_again;
1792         }
1793         LEAVE_SCOPE(oldsave);
1794         RETURN;
1795     }
1796     NOT_REACHED; /* NOTREACHED */
1797
1798   nope:
1799     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1800         if (!mg)
1801             mg = mg_find_mglob(TARG);
1802         if (mg)
1803             mg->mg_len = -1;
1804     }
1805     LEAVE_SCOPE(oldsave);
1806     if (gimme == G_ARRAY)
1807         RETURN;
1808     RETPUSHNO;
1809 }
1810
1811 OP *
1812 Perl_do_readline(pTHX)
1813 {
1814     dSP; dTARGETSTACKED;
1815     SV *sv;
1816     STRLEN tmplen = 0;
1817     STRLEN offset;
1818     PerlIO *fp;
1819     IO * const io = GvIO(PL_last_in_gv);
1820     const I32 type = PL_op->op_type;
1821     const I32 gimme = GIMME_V;
1822
1823     if (io) {
1824         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1825         if (mg) {
1826             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1827             if (gimme == G_SCALAR) {
1828                 SPAGAIN;
1829                 SvSetSV_nosteal(TARG, TOPs);
1830                 SETTARG;
1831             }
1832             return NORMAL;
1833         }
1834     }
1835     fp = NULL;
1836     if (io) {
1837         fp = IoIFP(io);
1838         if (!fp) {
1839             if (IoFLAGS(io) & IOf_ARGV) {
1840                 if (IoFLAGS(io) & IOf_START) {
1841                     IoLINES(io) = 0;
1842                     if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1843                         IoFLAGS(io) &= ~IOf_START;
1844                         do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1845                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1846                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1847                         SvSETMAGIC(GvSV(PL_last_in_gv));
1848                         fp = IoIFP(io);
1849                         goto have_fp;
1850                     }
1851                 }
1852                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1853                 if (!fp) { /* Note: fp != IoIFP(io) */
1854                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1855                 }
1856             }
1857             else if (type == OP_GLOB)
1858                 fp = Perl_start_glob(aTHX_ POPs, io);
1859         }
1860         else if (type == OP_GLOB)
1861             SP--;
1862         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1863             report_wrongway_fh(PL_last_in_gv, '>');
1864         }
1865     }
1866     if (!fp) {
1867         if ((!io || !(IoFLAGS(io) & IOf_START))
1868             && ckWARN(WARN_CLOSED)
1869             && type != OP_GLOB)
1870         {
1871             report_evil_fh(PL_last_in_gv);
1872         }
1873         if (gimme == G_SCALAR) {
1874             /* undef TARG, and push that undefined value */
1875             if (type != OP_RCATLINE) {
1876                 sv_setsv(TARG,NULL);
1877             }
1878             PUSHTARG;
1879         }
1880         RETURN;
1881     }
1882   have_fp:
1883     if (gimme == G_SCALAR) {
1884         sv = TARG;
1885         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1886             mg_get(sv);
1887         if (SvROK(sv)) {
1888             if (type == OP_RCATLINE)
1889                 SvPV_force_nomg_nolen(sv);
1890             else
1891                 sv_unref(sv);
1892         }
1893         else if (isGV_with_GP(sv)) {
1894             SvPV_force_nomg_nolen(sv);
1895         }
1896         SvUPGRADE(sv, SVt_PV);
1897         tmplen = SvLEN(sv);     /* remember if already alloced */
1898         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1899             /* try short-buffering it. Please update t/op/readline.t
1900              * if you change the growth length.
1901              */
1902             Sv_Grow(sv, 80);
1903         }
1904         offset = 0;
1905         if (type == OP_RCATLINE && SvOK(sv)) {
1906             if (!SvPOK(sv)) {
1907                 SvPV_force_nomg_nolen(sv);
1908             }
1909             offset = SvCUR(sv);
1910         }
1911     }
1912     else {
1913         sv = sv_2mortal(newSV(80));
1914         offset = 0;
1915     }
1916
1917     /* This should not be marked tainted if the fp is marked clean */
1918 #define MAYBE_TAINT_LINE(io, sv) \
1919     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1920         TAINT;                          \
1921         SvTAINTED_on(sv);               \
1922     }
1923
1924 /* delay EOF state for a snarfed empty file */
1925 #define SNARF_EOF(gimme,rs,io,sv) \
1926     (gimme != G_SCALAR || SvCUR(sv)                                     \
1927      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1928
1929     for (;;) {
1930         PUTBACK;
1931         if (!sv_gets(sv, fp, offset)
1932             && (type == OP_GLOB
1933                 || SNARF_EOF(gimme, PL_rs, io, sv)
1934                 || PerlIO_error(fp)))
1935         {
1936             PerlIO_clearerr(fp);
1937             if (IoFLAGS(io) & IOf_ARGV) {
1938                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1939                 if (fp)
1940                     continue;
1941                 (void)do_close(PL_last_in_gv, FALSE);
1942             }
1943             else if (type == OP_GLOB) {
1944                 if (!do_close(PL_last_in_gv, FALSE)) {
1945                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1946                                    "glob failed (child exited with status %d%s)",
1947                                    (int)(STATUS_CURRENT >> 8),
1948                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1949                 }
1950             }
1951             if (gimme == G_SCALAR) {
1952                 if (type != OP_RCATLINE) {
1953                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1954                     SvOK_off(TARG);
1955                 }
1956                 SPAGAIN;
1957                 PUSHTARG;
1958             }
1959             MAYBE_TAINT_LINE(io, sv);
1960             RETURN;
1961         }
1962         MAYBE_TAINT_LINE(io, sv);
1963         IoLINES(io)++;
1964         IoFLAGS(io) |= IOf_NOLINE;
1965         SvSETMAGIC(sv);
1966         SPAGAIN;
1967         XPUSHs(sv);
1968         if (type == OP_GLOB) {
1969             const char *t1;
1970             Stat_t statbuf;
1971
1972             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1973                 char * const tmps = SvEND(sv) - 1;
1974                 if (*tmps == *SvPVX_const(PL_rs)) {
1975                     *tmps = '\0';
1976                     SvCUR_set(sv, SvCUR(sv) - 1);
1977                 }
1978             }
1979             for (t1 = SvPVX_const(sv); *t1; t1++)
1980 #ifdef __VMS
1981                 if (strchr("*%?", *t1))
1982 #else
1983                 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1984 #endif
1985                         break;
1986             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
1987                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1988                 continue;
1989             }
1990         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1991              if (ckWARN(WARN_UTF8)) {
1992                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1993                 const STRLEN len = SvCUR(sv) - offset;
1994                 const U8 *f;
1995
1996                 if (!is_utf8_string_loc(s, len, &f))
1997                     /* Emulate :encoding(utf8) warning in the same case. */
1998                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1999                                 "utf8 \"\\x%02X\" does not map to Unicode",
2000                                 f < (U8*)SvEND(sv) ? *f : 0);
2001              }
2002         }
2003         if (gimme == G_ARRAY) {
2004             if (SvLEN(sv) - SvCUR(sv) > 20) {
2005                 SvPV_shrink_to_cur(sv);
2006             }
2007             sv = sv_2mortal(newSV(80));
2008             continue;
2009         }
2010         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
2011             /* try to reclaim a bit of scalar space (only on 1st alloc) */
2012             const STRLEN new_len
2013                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
2014             SvPV_renew(sv, new_len);
2015         }
2016         RETURN;
2017     }
2018 }
2019
2020 PP(pp_helem)
2021 {
2022     dSP;
2023     HE* he;
2024     SV **svp;
2025     SV * const keysv = POPs;
2026     HV * const hv = MUTABLE_HV(POPs);
2027     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2028     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2029     SV *sv;
2030     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2031     bool preeminent = TRUE;
2032
2033     if (SvTYPE(hv) != SVt_PVHV)
2034         RETPUSHUNDEF;
2035
2036     if (localizing) {
2037         MAGIC *mg;
2038         HV *stash;
2039
2040         /* If we can determine whether the element exist,
2041          * Try to preserve the existenceness of a tied hash
2042          * element by using EXISTS and DELETE if possible.
2043          * Fallback to FETCH and STORE otherwise. */
2044         if (SvCANEXISTDELETE(hv))
2045             preeminent = hv_exists_ent(hv, keysv, 0);
2046     }
2047
2048     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2049     svp = he ? &HeVAL(he) : NULL;
2050     if (lval) {
2051         if (!svp || !*svp || *svp == &PL_sv_undef) {
2052             SV* lv;
2053             SV* key2;
2054             if (!defer) {
2055                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2056             }
2057             lv = sv_newmortal();
2058             sv_upgrade(lv, SVt_PVLV);
2059             LvTYPE(lv) = 'y';
2060             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
2061             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
2062             LvTARG(lv) = SvREFCNT_inc_simple(hv);
2063             LvTARGLEN(lv) = 1;
2064             PUSHs(lv);
2065             RETURN;
2066         }
2067         if (localizing) {
2068             if (HvNAME_get(hv) && isGV(*svp))
2069                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
2070             else if (preeminent)
2071                 save_helem_flags(hv, keysv, svp,
2072                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
2073             else
2074                 SAVEHDELETE(hv, keysv);
2075         }
2076         else if (PL_op->op_private & OPpDEREF) {
2077             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2078             RETURN;
2079         }
2080     }
2081     sv = (svp && *svp ? *svp : &PL_sv_undef);
2082     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
2083      * was to make C<local $tied{foo} = $tied{foo}> possible.
2084      * However, it seems no longer to be needed for that purpose, and
2085      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
2086      * would loop endlessly since the pos magic is getting set on the
2087      * mortal copy and lost. However, the copy has the effect of
2088      * triggering the get magic, and losing it altogether made things like
2089      * c<$tied{foo};> in void context no longer do get magic, which some
2090      * code relied on. Also, delayed triggering of magic on @+ and friends
2091      * meant the original regex may be out of scope by now. So as a
2092      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
2093      * being called too many times). */
2094     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
2095         mg_get(sv);
2096     PUSHs(sv);
2097     RETURN;
2098 }
2099
2100
2101 /* a stripped-down version of Perl_softref2xv() for use by
2102  * pp_multideref(), which doesn't use PL_op->op_flags */
2103
2104 GV *
2105 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
2106                 const svtype type)
2107 {
2108     if (PL_op->op_private & HINT_STRICT_REFS) {
2109         if (SvOK(sv))
2110             Perl_die(aTHX_ PL_no_symref_sv, sv,
2111                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
2112         else
2113             Perl_die(aTHX_ PL_no_usym, what);
2114     }
2115     if (!SvOK(sv))
2116         Perl_die(aTHX_ PL_no_usym, what);
2117     return gv_fetchsv_nomg(sv, GV_ADD, type);
2118 }
2119
2120
2121 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
2122  * $h->{foo}  or  $a[0]{$key}[$i]  or  f()->[1]
2123  *
2124  * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
2125  * Each of these either contains a set of actions, or an argument, such as
2126  * an IV to use as an array index, or a lexical var to retrieve.
2127  * Several actions re stored per UV; we keep shifting new actions off the
2128  * one UV, and only reload when it becomes zero.
2129  */
2130
2131 PP(pp_multideref)
2132 {
2133     SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
2134     UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
2135     UV actions = items->uv;
2136
2137     assert(actions);
2138     /* this tells find_uninit_var() where we're up to */
2139     PL_multideref_pc = items;
2140
2141     while (1) {
2142         /* there are three main classes of action; the first retrieve
2143          * the initial AV or HV from a variable or the stack; the second
2144          * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
2145          * the third an unrolled (/DREFHV, rv2hv, helem).
2146          */
2147         switch (actions & MDEREF_ACTION_MASK) {
2148
2149         case MDEREF_reload:
2150             actions = (++items)->uv;
2151             continue;
2152
2153         case MDEREF_AV_padav_aelem:                 /* $lex[...] */
2154             sv = PAD_SVl((++items)->pad_offset);
2155             goto do_AV_aelem;
2156
2157         case MDEREF_AV_gvav_aelem:                  /* $pkg[...] */
2158             sv = UNOP_AUX_item_sv(++items);
2159             assert(isGV_with_GP(sv));
2160             sv = (SV*)GvAVn((GV*)sv);
2161             goto do_AV_aelem;
2162
2163         case MDEREF_AV_pop_rv2av_aelem:             /* expr->[...] */
2164             {
2165                 dSP;
2166                 sv = POPs;
2167                 PUTBACK;
2168                 goto do_AV_rv2av_aelem;
2169             }
2170
2171         case MDEREF_AV_gvsv_vivify_rv2av_aelem:     /* $pkg->[...] */
2172             sv = UNOP_AUX_item_sv(++items);
2173             assert(isGV_with_GP(sv));
2174             sv = GvSVn((GV*)sv);
2175             goto do_AV_vivify_rv2av_aelem;
2176
2177         case MDEREF_AV_padsv_vivify_rv2av_aelem:     /* $lex->[...] */
2178             sv = PAD_SVl((++items)->pad_offset);
2179             /* FALLTHROUGH */
2180
2181         do_AV_vivify_rv2av_aelem:
2182         case MDEREF_AV_vivify_rv2av_aelem:           /* vivify, ->[...] */
2183             /* this is the OPpDEREF action normally found at the end of
2184              * ops like aelem, helem, rv2sv */
2185             sv = vivify_ref(sv, OPpDEREF_AV);
2186             /* FALLTHROUGH */
2187
2188         do_AV_rv2av_aelem:
2189             /* this is basically a copy of pp_rv2av when it just has the
2190              * sKR/1 flags */
2191             SvGETMAGIC(sv);
2192             if (LIKELY(SvROK(sv))) {
2193                 if (UNLIKELY(SvAMAGIC(sv))) {
2194                     sv = amagic_deref_call(sv, to_av_amg);
2195                 }
2196                 sv = SvRV(sv);
2197                 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
2198                     DIE(aTHX_ "Not an ARRAY reference");
2199             }
2200             else if (SvTYPE(sv) != SVt_PVAV) {
2201                 if (!isGV_with_GP(sv))
2202                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
2203                 sv = MUTABLE_SV(GvAVn((GV*)sv));
2204             }
2205             /* FALLTHROUGH */
2206
2207         do_AV_aelem:
2208             {
2209                 /* retrieve the key; this may be either a lexical or package
2210                  * var (whose index/ptr is stored as an item) or a signed
2211                  * integer constant stored as an item.
2212                  */
2213                 SV *elemsv;
2214                 IV elem = 0; /* to shut up stupid compiler warnings */
2215
2216
2217                 assert(SvTYPE(sv) == SVt_PVAV);
2218
2219                 switch (actions & MDEREF_INDEX_MASK) {
2220                 case MDEREF_INDEX_none:
2221                     goto finish;
2222                 case MDEREF_INDEX_const:
2223                     elem  = (++items)->iv;
2224                     break;
2225                 case MDEREF_INDEX_padsv:
2226                     elemsv = PAD_SVl((++items)->pad_offset);
2227                     goto check_elem;
2228                 case MDEREF_INDEX_gvsv:
2229                     elemsv = UNOP_AUX_item_sv(++items);
2230                     assert(isGV_with_GP(elemsv));
2231                     elemsv = GvSVn((GV*)elemsv);
2232                 check_elem:
2233                     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
2234                                             && ckWARN(WARN_MISC)))
2235                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2236                                 "Use of reference \"%"SVf"\" as array index",
2237                                 SVfARG(elemsv));
2238                     /* the only time that S_find_uninit_var() needs this
2239                      * is to determine which index value triggered the
2240                      * undef warning. So just update it here. Note that
2241                      * since we don't save and restore this var (e.g. for
2242                      * tie or overload execution), its value will be
2243                      * meaningless apart from just here */
2244                     PL_multideref_pc = items;
2245                     elem = SvIV(elemsv);
2246                     break;
2247                 }
2248
2249
2250                 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2251
2252                 if (!(actions & MDEREF_FLAG_last)) {
2253                     SV** svp = av_fetch((AV*)sv, elem, 1);
2254                     if (!svp || ! (sv=*svp))
2255                         DIE(aTHX_ PL_no_aelem, elem);
2256                     break;
2257                 }
2258
2259                 if (PL_op->op_private &
2260                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2261                 {
2262                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2263                         sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2264                     }
2265                     else {
2266                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2267                         sv = av_delete((AV*)sv, elem, discard);
2268                         if (discard)
2269                             return NORMAL;
2270                         if (!sv)
2271                             sv = &PL_sv_undef;
2272                     }
2273                 }
2274                 else {
2275                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2276                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2277                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2278                     bool preeminent = TRUE;
2279                     AV *const av = (AV*)sv;
2280                     SV** svp;
2281
2282                     if (UNLIKELY(localizing)) {
2283                         MAGIC *mg;
2284                         HV *stash;
2285
2286                         /* If we can determine whether the element exist,
2287                          * Try to preserve the existenceness of a tied array
2288                          * element by using EXISTS and DELETE if possible.
2289                          * Fallback to FETCH and STORE otherwise. */
2290                         if (SvCANEXISTDELETE(av))
2291                             preeminent = av_exists(av, elem);
2292                     }
2293
2294                     svp = av_fetch(av, elem, lval && !defer);
2295
2296                     if (lval) {
2297                         if (!svp || !(sv = *svp)) {
2298                             IV len;
2299                             if (!defer)
2300                                 DIE(aTHX_ PL_no_aelem, elem);
2301                             len = av_tindex(av);
2302                             sv = sv_2mortal(newSVavdefelem(av,
2303                             /* Resolve a negative index now, unless it points
2304                              * before the beginning of the array, in which
2305                              * case record it for error reporting in
2306                              * magic_setdefelem. */
2307                                 elem < 0 && len + elem >= 0
2308                                     ? len + elem : elem, 1));
2309                         }
2310                         else {
2311                             if (UNLIKELY(localizing)) {
2312                                 if (preeminent) {
2313                                     save_aelem(av, elem, svp);
2314                                     sv = *svp; /* may have changed */
2315                                 }
2316                                 else
2317                                     SAVEADELETE(av, elem);
2318                             }
2319                         }
2320                     }
2321                     else {
2322                         sv = (svp ? *svp : &PL_sv_undef);
2323                         /* see note in pp_helem() */
2324                         if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2325                             mg_get(sv);
2326                     }
2327                 }
2328
2329             }
2330           finish:
2331             {
2332                 dSP;
2333                 XPUSHs(sv);
2334                 RETURN;
2335             }
2336             /* NOTREACHED */
2337
2338
2339
2340
2341         case MDEREF_HV_padhv_helem:                 /* $lex{...} */
2342             sv = PAD_SVl((++items)->pad_offset);
2343             goto do_HV_helem;
2344
2345         case MDEREF_HV_gvhv_helem:                  /* $pkg{...} */
2346             sv = UNOP_AUX_item_sv(++items);
2347             assert(isGV_with_GP(sv));
2348             sv = (SV*)GvHVn((GV*)sv);
2349             goto do_HV_helem;
2350
2351         case MDEREF_HV_pop_rv2hv_helem:             /* expr->{...} */
2352             {
2353                 dSP;
2354                 sv = POPs;
2355                 PUTBACK;
2356                 goto do_HV_rv2hv_helem;
2357             }
2358
2359         case MDEREF_HV_gvsv_vivify_rv2hv_helem:     /* $pkg->{...} */
2360             sv = UNOP_AUX_item_sv(++items);
2361             assert(isGV_with_GP(sv));
2362             sv = GvSVn((GV*)sv);
2363             goto do_HV_vivify_rv2hv_helem;
2364
2365         case MDEREF_HV_padsv_vivify_rv2hv_helem:    /* $lex->{...} */
2366             sv = PAD_SVl((++items)->pad_offset);
2367             /* FALLTHROUGH */
2368
2369         do_HV_vivify_rv2hv_helem:
2370         case MDEREF_HV_vivify_rv2hv_helem:           /* vivify, ->{...} */
2371             /* this is the OPpDEREF action normally found at the end of
2372              * ops like aelem, helem, rv2sv */
2373             sv = vivify_ref(sv, OPpDEREF_HV);
2374             /* FALLTHROUGH */
2375
2376         do_HV_rv2hv_helem:
2377             /* this is basically a copy of pp_rv2hv when it just has the
2378              * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2379
2380             SvGETMAGIC(sv);
2381             if (LIKELY(SvROK(sv))) {
2382                 if (UNLIKELY(SvAMAGIC(sv))) {
2383                     sv = amagic_deref_call(sv, to_hv_amg);
2384                 }
2385                 sv = SvRV(sv);
2386                 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2387                     DIE(aTHX_ "Not a HASH reference");
2388             }
2389             else if (SvTYPE(sv) != SVt_PVHV) {
2390                 if (!isGV_with_GP(sv))
2391                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2392                 sv = MUTABLE_SV(GvHVn((GV*)sv));
2393             }
2394             /* FALLTHROUGH */
2395
2396         do_HV_helem:
2397             {
2398                 /* retrieve the key; this may be either a lexical / package
2399                  * var or a string constant, whose index/ptr is stored as an
2400                  * item
2401                  */
2402                 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2403
2404                 assert(SvTYPE(sv) == SVt_PVHV);
2405
2406                 switch (actions & MDEREF_INDEX_MASK) {
2407                 case MDEREF_INDEX_none:
2408                     goto finish;
2409
2410                 case MDEREF_INDEX_const:
2411                     keysv = UNOP_AUX_item_sv(++items);
2412                     break;
2413
2414                 case MDEREF_INDEX_padsv:
2415                     keysv = PAD_SVl((++items)->pad_offset);
2416                     break;
2417
2418                 case MDEREF_INDEX_gvsv:
2419                     keysv = UNOP_AUX_item_sv(++items);
2420                     keysv = GvSVn((GV*)keysv);
2421                     break;
2422                 }
2423
2424                 /* see comment above about setting this var */
2425                 PL_multideref_pc = items;
2426
2427
2428                 /* ensure that candidate CONSTs have been HEKified */
2429                 assert(   ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2430                        || SvTYPE(keysv) >= SVt_PVMG
2431                        || !SvOK(keysv)
2432                        || SvROK(keysv)
2433                        || SvIsCOW_shared_hash(keysv));
2434
2435                 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2436
2437                 if (!(actions & MDEREF_FLAG_last)) {
2438                     HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2439                     if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2440                         DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2441                     break;
2442                 }
2443
2444                 if (PL_op->op_private &
2445                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2446                 {
2447                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2448                         sv = hv_exists_ent((HV*)sv, keysv, 0)
2449                                                 ? &PL_sv_yes : &PL_sv_no;
2450                     }
2451                     else {
2452                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2453                         sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2454                         if (discard)
2455                             return NORMAL;
2456                         if (!sv)
2457                             sv = &PL_sv_undef;
2458                     }
2459                 }
2460                 else {
2461                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2462                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2463                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2464                     bool preeminent = TRUE;
2465                     SV **svp;
2466                     HV * const hv = (HV*)sv;
2467                     HE* he;
2468
2469                     if (UNLIKELY(localizing)) {
2470                         MAGIC *mg;
2471                         HV *stash;
2472
2473                         /* If we can determine whether the element exist,
2474                          * Try to preserve the existenceness of a tied hash
2475                          * element by using EXISTS and DELETE if possible.
2476                          * Fallback to FETCH and STORE otherwise. */
2477                         if (SvCANEXISTDELETE(hv))
2478                             preeminent = hv_exists_ent(hv, keysv, 0);
2479                     }
2480
2481                     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2482                     svp = he ? &HeVAL(he) : NULL;
2483
2484
2485                     if (lval) {
2486                         if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2487                             SV* lv;
2488                             SV* key2;
2489                             if (!defer)
2490                                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2491                             lv = sv_newmortal();
2492                             sv_upgrade(lv, SVt_PVLV);
2493                             LvTYPE(lv) = 'y';
2494                             sv_magic(lv, key2 = newSVsv(keysv),
2495                                                 PERL_MAGIC_defelem, NULL, 0);
2496                             /* sv_magic() increments refcount */
2497                             SvREFCNT_dec_NN(key2);
2498                             LvTARG(lv) = SvREFCNT_inc_simple(hv);
2499                             LvTARGLEN(lv) = 1;
2500                             sv = lv;
2501                         }
2502                         else {
2503                             if (localizing) {
2504                                 if (HvNAME_get(hv) && isGV(sv))
2505                                     save_gp(MUTABLE_GV(sv),
2506                                         !(PL_op->op_flags & OPf_SPECIAL));
2507                                 else if (preeminent) {
2508                                     save_helem_flags(hv, keysv, svp,
2509                                          (PL_op->op_flags & OPf_SPECIAL)
2510                                             ? 0 : SAVEf_SETMAGIC);
2511                                     sv = *svp; /* may have changed */
2512                                 }
2513                                 else
2514                                     SAVEHDELETE(hv, keysv);
2515                             }
2516                         }
2517                     }
2518                     else {
2519                         sv = (svp && *svp ? *svp : &PL_sv_undef);
2520                         /* see note in pp_helem() */
2521                         if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2522                             mg_get(sv);
2523                     }
2524                 }
2525                 goto finish;
2526             }
2527
2528         } /* switch */
2529
2530         actions >>= MDEREF_SHIFT;
2531     } /* while */
2532     /* NOTREACHED */
2533 }
2534
2535
2536 PP(pp_iter)
2537 {
2538     dSP;
2539     PERL_CONTEXT *cx;
2540     SV *oldsv;
2541     SV **itersvp;
2542
2543     EXTEND(SP, 1);
2544     cx = &cxstack[cxstack_ix];
2545     itersvp = CxITERVAR(cx);
2546
2547     switch (CxTYPE(cx)) {
2548
2549     case CXt_LOOP_LAZYSV: /* string increment */
2550     {
2551         SV* cur = cx->blk_loop.state_u.lazysv.cur;
2552         SV *end = cx->blk_loop.state_u.lazysv.end;
2553         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2554            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
2555         STRLEN maxlen = 0;
2556         const char *max = SvPV_const(end, maxlen);
2557         if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
2558             RETPUSHNO;
2559
2560         oldsv = *itersvp;
2561         if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2562             /* safe to reuse old SV */
2563             sv_setsv(oldsv, cur);
2564         }
2565         else
2566         {
2567             /* we need a fresh SV every time so that loop body sees a
2568              * completely new SV for closures/references to work as
2569              * they used to */
2570             *itersvp = newSVsv(cur);
2571             SvREFCNT_dec_NN(oldsv);
2572         }
2573         if (strEQ(SvPVX_const(cur), max))
2574             sv_setiv(cur, 0); /* terminate next time */
2575         else
2576             sv_inc(cur);
2577         break;
2578     }
2579
2580     case CXt_LOOP_LAZYIV: /* integer increment */
2581     {
2582         IV cur = cx->blk_loop.state_u.lazyiv.cur;
2583         if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
2584             RETPUSHNO;
2585
2586         oldsv = *itersvp;
2587         /* don't risk potential race */
2588         if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2589             /* safe to reuse old SV */
2590             sv_setiv(oldsv, cur);
2591         }
2592         else
2593         {
2594             /* we need a fresh SV every time so that loop body sees a
2595              * completely new SV for closures/references to work as they
2596              * used to */
2597             *itersvp = newSViv(cur);
2598             SvREFCNT_dec_NN(oldsv);
2599         }
2600
2601         if (UNLIKELY(cur == IV_MAX)) {
2602             /* Handle end of range at IV_MAX */
2603             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2604         } else
2605             ++cx->blk_loop.state_u.lazyiv.cur;
2606         break;
2607     }
2608
2609     case CXt_LOOP_FOR: /* iterate array */
2610     {
2611
2612         AV *av = cx->blk_loop.state_u.ary.ary;
2613         SV *sv;
2614         bool av_is_stack = FALSE;
2615         IV ix;
2616
2617         if (!av) {
2618             av_is_stack = TRUE;
2619             av = PL_curstack;
2620         }
2621         if (PL_op->op_private & OPpITER_REVERSED) {
2622             ix = --cx->blk_loop.state_u.ary.ix;
2623             if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
2624                 RETPUSHNO;
2625         }
2626         else {
2627             ix = ++cx->blk_loop.state_u.ary.ix;
2628             if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
2629                 RETPUSHNO;
2630         }
2631
2632         if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
2633             SV * const * const svp = av_fetch(av, ix, FALSE);
2634             sv = svp ? *svp : NULL;
2635         }
2636         else {
2637             sv = AvARRAY(av)[ix];
2638         }
2639
2640         if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
2641             SvSetMagicSV(*itersvp, sv);
2642             break;
2643         }
2644
2645         if (LIKELY(sv)) {
2646             if (UNLIKELY(SvIS_FREED(sv))) {
2647                 *itersvp = NULL;
2648                 Perl_croak(aTHX_ "Use of freed value in iteration");
2649             }
2650             if (SvPADTMP(sv)) {
2651                 sv = newSVsv(sv);
2652             }
2653             else {
2654                 SvTEMP_off(sv);
2655                 SvREFCNT_inc_simple_void_NN(sv);
2656             }
2657         }
2658         else if (!av_is_stack) {
2659             sv = newSVavdefelem(av, ix, 0);
2660         }
2661         else
2662             sv = &PL_sv_undef;
2663
2664         oldsv = *itersvp;
2665         *itersvp = sv;
2666         SvREFCNT_dec(oldsv);
2667         break;
2668     }
2669
2670     default:
2671         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2672     }
2673     RETPUSHYES;
2674 }
2675
2676 /*
2677 A description of how taint works in pattern matching and substitution.
2678
2679 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2680 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2681
2682 While the pattern is being assembled/concatenated and then compiled,
2683 PL_tainted will get set (via TAINT_set) if any component of the pattern
2684 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
2685 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2686 TAINT_get).  It will also be set if any component of the pattern matches
2687 based on locale-dependent behavior.
2688
2689 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2690 the pattern is marked as tainted. This means that subsequent usage, such
2691 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2692 on the new pattern too.
2693
2694 RXf_TAINTED_SEEN is used post-execution by the get magic code
2695 of $1 et al to indicate whether the returned value should be tainted.
2696 It is the responsibility of the caller of the pattern (i.e. pp_match,
2697 pp_subst etc) to set this flag for any other circumstances where $1 needs
2698 to be tainted.
2699
2700 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2701
2702 There are three possible sources of taint
2703     * the source string
2704     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2705     * the replacement string (or expression under /e)
2706     
2707 There are four destinations of taint and they are affected by the sources
2708 according to the rules below:
2709
2710     * the return value (not including /r):
2711         tainted by the source string and pattern, but only for the
2712         number-of-iterations case; boolean returns aren't tainted;
2713     * the modified string (or modified copy under /r):
2714         tainted by the source string, pattern, and replacement strings;
2715     * $1 et al:
2716         tainted by the pattern, and under 'use re "taint"', by the source
2717         string too;
2718     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2719         should always be unset before executing subsequent code.
2720
2721 The overall action of pp_subst is:
2722
2723     * at the start, set bits in rxtainted indicating the taint status of
2724         the various sources.
2725
2726     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2727         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2728         pattern has subsequently become tainted via locale ops.
2729
2730     * If control is being passed to pp_substcont to execute a /e block,
2731         save rxtainted in the CXt_SUBST block, for future use by
2732         pp_substcont.
2733
2734     * Whenever control is being returned to perl code (either by falling
2735         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2736         use the flag bits in rxtainted to make all the appropriate types of
2737         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2738         et al will appear tainted.
2739
2740 pp_match is just a simpler version of the above.
2741
2742 */
2743
2744 PP(pp_subst)
2745 {
2746     dSP; dTARG;
2747     PMOP *pm = cPMOP;
2748     PMOP *rpm = pm;
2749     char *s;
2750     char *strend;
2751     const char *c;
2752     STRLEN clen;
2753     SSize_t iters = 0;
2754     SSize_t maxiters;
2755     bool once;
2756     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2757                         See "how taint works" above */
2758     char *orig;
2759     U8 r_flags;
2760     REGEXP *rx = PM_GETRE(pm);
2761     STRLEN len;
2762     int force_on_match = 0;
2763     const I32 oldsave = PL_savestack_ix;
2764     STRLEN slen;
2765     bool doutf8 = FALSE; /* whether replacement is in utf8 */
2766 #ifdef PERL_ANY_COW
2767     bool is_cow;
2768 #endif
2769     SV *nsv = NULL;
2770     /* known replacement string? */
2771     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2772
2773     PERL_ASYNC_CHECK();
2774
2775     if (PL_op->op_flags & OPf_STACKED)
2776         TARG = POPs;
2777     else if (ARGTARG)
2778         GETTARGET;
2779     else {
2780         TARG = DEFSV;
2781         EXTEND(SP,1);
2782     }
2783
2784     SvGETMAGIC(TARG); /* must come before cow check */
2785 #ifdef PERL_ANY_COW
2786     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2787        because they make integers such as 256 "false".  */
2788     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2789 #else
2790     if (SvIsCOW(TARG))
2791         sv_force_normal_flags(TARG,0);
2792 #endif
2793     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2794         && (SvREADONLY(TARG)
2795             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2796                   || SvTYPE(TARG) > SVt_PVLV)
2797                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2798         Perl_croak_no_modify();
2799     PUTBACK;
2800
2801     orig = SvPV_nomg(TARG, len);
2802     /* note we don't (yet) force the var into being a string; if we fail
2803      * to match, we leave as-is; on successful match howeverm, we *will*
2804      * coerce into a string, then repeat the match */
2805     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2806         force_on_match = 1;
2807
2808     /* only replace once? */
2809     once = !(rpm->op_pmflags & PMf_GLOBAL);
2810
2811     /* See "how taint works" above */
2812     if (TAINTING_get) {
2813         rxtainted  = (
2814             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2815           | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2816           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2817           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2818                 ? SUBST_TAINT_BOOLRET : 0));
2819         TAINT_NOT;
2820     }
2821
2822   force_it:
2823     if (!pm || !orig)
2824         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2825
2826     strend = orig + len;
2827     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2828     maxiters = 2 * slen + 10;   /* We can match twice at each
2829                                    position, once with zero-length,
2830                                    second time with non-zero. */
2831
2832     if (!RX_PRELEN(rx) && PL_curpm
2833      && !ReANY(rx)->mother_re) {
2834         pm = PL_curpm;
2835         rx = PM_GETRE(pm);
2836     }
2837
2838 #ifdef PERL_SAWAMPERSAND
2839     r_flags = (    RX_NPARENS(rx)
2840                 || PL_sawampersand
2841                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2842                 || (rpm->op_pmflags & PMf_KEEPCOPY)
2843               )
2844           ? REXEC_COPY_STR
2845           : 0;
2846 #else
2847     r_flags = REXEC_COPY_STR;
2848 #endif
2849
2850     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2851     {
2852         SPAGAIN;
2853         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2854         LEAVE_SCOPE(oldsave);
2855         RETURN;
2856     }
2857     PL_curpm = pm;
2858
2859     /* known replacement string? */
2860     if (dstr) {
2861         /* replacement needing upgrading? */
2862         if (DO_UTF8(TARG) && !doutf8) {
2863              nsv = sv_newmortal();
2864              SvSetSV(nsv, dstr);
2865              if (IN_ENCODING)
2866                   sv_recode_to_utf8(nsv, _get_encoding());
2867              else
2868                   sv_utf8_upgrade(nsv);
2869              c = SvPV_const(nsv, clen);
2870              doutf8 = TRUE;
2871         }
2872         else {
2873             c = SvPV_const(dstr, clen);
2874             doutf8 = DO_UTF8(dstr);
2875         }
2876
2877         if (SvTAINTED(dstr))
2878             rxtainted |= SUBST_TAINT_REPL;
2879     }
2880     else {
2881         c = NULL;
2882         doutf8 = FALSE;
2883     }
2884     
2885     /* can do inplace substitution? */
2886     if (c
2887 #ifdef PERL_ANY_COW
2888         && !is_cow
2889 #endif
2890         && (I32)clen <= RX_MINLENRET(rx)
2891         && (  once
2892            || !(r_flags & REXEC_COPY_STR)
2893            || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2894            )
2895         && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2896         && (!doutf8 || SvUTF8(TARG))
2897         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2898     {
2899
2900 #ifdef PERL_ANY_COW
2901         if (SvIsCOW(TARG)) {
2902           if (!force_on_match)
2903             goto have_a_cow;
2904           assert(SvVOK(TARG));
2905         }
2906 #endif
2907         if (force_on_match) {
2908             /* redo the first match, this time with the orig var
2909              * forced into being a string */
2910             force_on_match = 0;
2911             orig = SvPV_force_nomg(TARG, len);
2912             goto force_it;
2913         }
2914
2915         if (once) {
2916             char *d, *m;
2917             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2918                 rxtainted |= SUBST_TAINT_PAT;
2919             m = orig + RX_OFFS(rx)[0].start;
2920             d = orig + RX_OFFS(rx)[0].end;
2921             s = orig;
2922             if (m - s > strend - d) {  /* faster to shorten from end */
2923                 I32 i;
2924                 if (clen) {
2925                     Copy(c, m, clen, char);
2926                     m += clen;
2927                 }
2928                 i = strend - d;
2929                 if (i > 0) {
2930                     Move(d, m, i, char);
2931                     m += i;
2932                 }
2933                 *m = '\0';
2934                 SvCUR_set(TARG, m - s);
2935             }
2936             else {      /* faster from front */
2937                 I32 i = m - s;
2938                 d -= clen;
2939                 if (i > 0)
2940                     Move(s, d - i, i, char);
2941                 sv_chop(TARG, d-i);
2942                 if (clen)
2943                     Copy(c, d, clen, char);
2944             }
2945             SPAGAIN;
2946             PUSHs(&PL_sv_yes);
2947         }
2948         else {
2949             char *d, *m;
2950             d = s = RX_OFFS(rx)[0].start + orig;
2951             do {
2952                 I32 i;
2953                 if (UNLIKELY(iters++ > maxiters))
2954                     DIE(aTHX_ "Substitution loop");
2955                 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2956                     rxtainted |= SUBST_TAINT_PAT;
2957                 m = RX_OFFS(rx)[0].start + orig;
2958                 if ((i = m - s)) {
2959                     if (s != d)
2960                         Move(s, d, i, char);
2961                     d += i;
2962                 }
2963                 if (clen) {
2964                     Copy(c, d, clen, char);
2965                     d += clen;
2966                 }
2967                 s = RX_OFFS(rx)[0].end + orig;
2968             } while (CALLREGEXEC(rx, s, strend, orig,
2969                                  s == m, /* don't match same null twice */
2970                                  TARG, NULL,
2971                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2972             if (s != d) {
2973                 I32 i = strend - s;
2974                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2975                 Move(s, d, i+1, char);          /* include the NUL */
2976             }
2977             SPAGAIN;
2978             mPUSHi(iters);
2979         }
2980     }
2981     else {
2982         bool first;
2983         char *m;
2984         SV *repl;
2985         if (force_on_match) {
2986             /* redo the first match, this time with the orig var
2987              * forced into being a string */
2988             force_on_match = 0;
2989             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2990                 /* I feel that it should be possible to avoid this mortal copy
2991                    given that the code below copies into a new destination.
2992                    However, I suspect it isn't worth the complexity of
2993                    unravelling the C<goto force_it> for the small number of
2994                    cases where it would be viable to drop into the copy code. */
2995                 TARG = sv_2mortal(newSVsv(TARG));
2996             }
2997             orig = SvPV_force_nomg(TARG, len);
2998             goto force_it;
2999         }
3000 #ifdef PERL_ANY_COW
3001       have_a_cow:
3002 #endif
3003         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
3004             rxtainted |= SUBST_TAINT_PAT;
3005         repl = dstr;
3006         s = RX_OFFS(rx)[0].start + orig;
3007         dstr = newSVpvn_flags(orig, s-orig,
3008                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3009         if (!c) {
3010             PERL_CONTEXT *cx;
3011             SPAGAIN;
3012             m = orig;
3013             /* note that a whole bunch of local vars are saved here for
3014              * use by pp_substcont: here's a list of them in case you're
3015              * searching for places in this sub that uses a particular var:
3016              * iters maxiters r_flags oldsave rxtainted orig dstr targ
3017              * s m strend rx once */
3018             PUSHSUBST(cx);
3019             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
3020         }
3021         first = TRUE;
3022         do {
3023             if (UNLIKELY(iters++ > maxiters))
3024                 DIE(aTHX_ "Substitution loop");
3025             if (UNLIKELY(RX_MATCH_TAINTED(rx)))
3026                 rxtainted |= SUBST_TAINT_PAT;
3027             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
3028                 char *old_s    = s;
3029                 char *old_orig = orig;
3030                 assert(RX_SUBOFFSET(rx) == 0);
3031
3032                 orig = RX_SUBBEG(rx);
3033                 s = orig + (old_s - old_orig);
3034                 strend = s + (strend - old_s);
3035             }
3036             m = RX_OFFS(rx)[0].start + orig;
3037             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
3038             s = RX_OFFS(rx)[0].end + orig;
3039             if (first) {
3040                 /* replacement already stringified */
3041               if (clen)
3042                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
3043               first = FALSE;
3044             }
3045             else {
3046                 if (IN_ENCODING) {
3047                     if (!nsv) nsv = sv_newmortal();
3048                     sv_copypv(nsv, repl);
3049                     if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
3050                     sv_catsv(dstr, nsv);
3051                 }
3052                 else sv_catsv(dstr, repl);
3053                 if (UNLIKELY(SvTAINTED(repl)))
3054                     rxtainted |= SUBST_TAINT_REPL;
3055             }
3056             if (once)
3057                 break;
3058         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
3059                              TARG, NULL,
3060                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3061         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
3062
3063         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3064             /* From here on down we're using the copy, and leaving the original
3065                untouched.  */
3066             TARG = dstr;
3067             SPAGAIN;
3068             PUSHs(dstr);
3069         } else {
3070 #ifdef PERL_ANY_COW
3071             /* The match may make the string COW. If so, brilliant, because
3072                that's just saved us one malloc, copy and free - the regexp has
3073                donated the old buffer, and we malloc an entirely new one, rather
3074                than the regexp malloc()ing a buffer and copying our original,
3075                only for us to throw it away here during the substitution.  */
3076             if (SvIsCOW(TARG)) {
3077                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
3078             } else
3079 #endif
3080             {
3081                 SvPV_free(TARG);
3082             }
3083             SvPV_set(TARG, SvPVX(dstr));
3084             SvCUR_set(TARG, SvCUR(dstr));
3085             SvLEN_set(TARG, SvLEN(dstr));
3086             SvFLAGS(TARG) |= SvUTF8(dstr);
3087             SvPV_set(dstr, NULL);
3088
3089             SPAGAIN;
3090             mPUSHi(iters);
3091         }
3092     }
3093
3094     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3095         (void)SvPOK_only_UTF8(TARG);
3096     }
3097
3098     /* See "how taint works" above */
3099     if (TAINTING_get) {
3100         if ((rxtainted & SUBST_TAINT_PAT) ||
3101             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
3102                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
3103         )
3104             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
3105
3106         if (!(rxtainted & SUBST_TAINT_BOOLRET)
3107             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
3108         )
3109             SvTAINTED_on(TOPs);  /* taint return value */
3110         else
3111             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
3112
3113         /* needed for mg_set below */
3114         TAINT_set(
3115           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
3116         );
3117         SvTAINT(TARG);
3118     }
3119     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
3120     TAINT_NOT;
3121     LEAVE_SCOPE(oldsave);
3122     RETURN;
3123 }
3124
3125 PP(pp_grepwhile)
3126 {
3127     dSP;
3128
3129     if (SvTRUEx(POPs))
3130         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
3131     ++*PL_markstack_ptr;
3132     FREETMPS;
3133     LEAVE_with_name("grep_item");                                       /* exit inner scope */
3134
3135     /* All done yet? */
3136     if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
3137         I32 items;
3138         const I32 gimme = GIMME_V;
3139
3140         LEAVE_with_name("grep");                                        /* exit outer scope */
3141         (void)POPMARK;                          /* pop src */
3142         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
3143         (void)POPMARK;                          /* pop dst */
3144         SP = PL_stack_base + POPMARK;           /* pop original mark */
3145         if (gimme == G_SCALAR) {
3146                 dTARGET;
3147                 XPUSHi(items);
3148         }
3149         else if (gimme == G_ARRAY)
3150             SP += items;
3151         RETURN;
3152     }
3153     else {
3154         SV *src;
3155
3156         ENTER_with_name("grep_item");                                   /* enter inner scope */
3157         SAVEVPTR(PL_curpm);
3158
3159         src = PL_stack_base[*PL_markstack_ptr];
3160         if (SvPADTMP(src)) {
3161             src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
3162             PL_tmps_floor++;
3163         }
3164         SvTEMP_off(src);
3165         DEFSV_set(src);
3166
3167         RETURNOP(cLOGOP->op_other);
3168     }
3169 }
3170
3171 PP(pp_leavesub)
3172 {
3173     dSP;
3174     SV **mark;
3175     SV **newsp;
3176     PMOP *newpm;
3177     I32 gimme;
3178     PERL_CONTEXT *cx;
3179     SV *sv;
3180
3181     if (CxMULTICALL(&cxstack[cxstack_ix])) {
3182         /* entry zero of a stack is always PL_sv_undef, which
3183          * simplifies converting a '()' return into undef in scalar context */
3184         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
3185         return 0;
3186     }
3187
3188     POPBLOCK(cx,newpm);
3189     cxstack_ix++; /* temporarily protect top context */
3190
3191     TAINT_NOT;
3192     if (gimme == G_SCALAR) {
3193         MARK = newsp + 1;
3194         if (LIKELY(MARK <= SP)) {
3195             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
3196                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
3197                      && !SvMAGICAL(TOPs)) {
3198                     *MARK = SvREFCNT_inc(TOPs);
3199                     FREETMPS;
3200                     sv_2mortal(*MARK);
3201                 }
3202                 else {
3203                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
3204                     FREETMPS;
3205                     *MARK = sv_mortalcopy(sv);
3206                     SvREFCNT_dec_NN(sv);
3207                 }
3208             }
3209             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
3210                      && !SvMAGICAL(TOPs)) {
3211                 *MARK = TOPs;
3212             }
3213             else
3214                 *MARK = sv_mortalcopy(TOPs);
3215         }
3216         else {
3217             MEXTEND(MARK, 0);
3218             *MARK = &PL_sv_undef;
3219         }
3220         SP = MARK;
3221     }
3222     else if (gimme == G_ARRAY) {
3223         for (MARK = newsp + 1; MARK <= SP; MARK++) {
3224             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
3225                  || SvMAGICAL(*MARK)) {
3226                 *MARK = sv_mortalcopy(*MARK);
3227                 TAINT_NOT;      /* Each item is independent */
3228             }
3229         }
3230     }
3231     PUTBACK;
3232
3233     LEAVE;
3234     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
3235     cxstack_ix--;
3236     PL_curpm = newpm;   /* ... and pop $1 et al */
3237
3238     LEAVESUB(sv);
3239     return cx->blk_sub.retop;
3240 }
3241
3242 PP(pp_entersub)
3243 {
3244     dSP; dPOPss;
3245     GV *gv;
3246     CV *cv;
3247     PERL_CONTEXT *cx;
3248     I32 gimme;
3249     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
3250
3251     if (UNLIKELY(!sv))
3252         DIE(aTHX_ "Not a CODE reference");
3253     /* This is overwhelmingly the most common case:  */
3254     if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
3255         switch (SvTYPE(sv)) {
3256         case SVt_PVGV:
3257           we_have_a_glob:
3258             if (!(cv = GvCVu((const GV *)sv))) {
3259                 HV *stash;
3260                 cv = sv_2cv(sv, &stash, &gv, 0);
3261             }
3262             if (!cv) {
3263                 ENTER;
3264                 SAVETMPS;
3265                 goto try_autoload;
3266             }
3267             break;
3268         case SVt_PVLV:
3269             if(isGV_with_GP(sv)) goto we_have_a_glob;
3270             /* FALLTHROUGH */
3271         default:
3272             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
3273                 if (hasargs)
3274                     SP = PL_stack_base + POPMARK;
3275                 else
3276                     (void)POPMARK;
3277                 RETURN;
3278             }
3279             SvGETMAGIC(sv);
3280             if (SvROK(sv)) {
3281                 if (SvAMAGIC(sv)) {
3282                     sv = amagic_deref_call(sv, to_cv_amg);
3283                     /* Don't SPAGAIN here.  */
3284                 }
3285             }
3286             else {
3287                 const char *sym;
3288                 STRLEN len;
3289                 if (!SvOK(sv))
3290                     DIE(aTHX_ PL_no_usym, "a subroutine");
3291                 sym = SvPV_nomg_const(sv, len);
3292                 if (PL_op->op_private & HINT_STRICT_REFS)
3293                     DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
3294                 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
3295                 break;
3296             }
3297             cv = MUTABLE_CV(SvRV(sv));
3298             if (SvTYPE(cv) == SVt_PVCV)
3299                 break;
3300             /* FALLTHROUGH */
3301         case SVt_PVHV:
3302         case SVt_PVAV:
3303             DIE(aTHX_ "Not a CODE reference");
3304             /* This is the second most common case:  */
3305         case SVt_PVCV:
3306             cv = MUTABLE_CV(sv);
3307             break;
3308         }
3309     }
3310
3311     ENTER;
3312
3313   retry:
3314     if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
3315         DIE(aTHX_ "Closure prototype called");
3316     if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
3317         GV* autogv;
3318         SV* sub_name;
3319
3320         /* anonymous or undef'd function leaves us no recourse */
3321         if (CvLEXICAL(cv) && CvHASGV(cv))
3322             DIE(aTHX_ "Undefined subroutine &%"SVf" called",
3323                        SVfARG(cv_name(cv, NULL, 0)));
3324         if (CvANON(cv) || !CvHASGV(cv)) {
3325             DIE(aTHX_ "Undefined subroutine called");
3326         }
3327
3328         /* autoloaded stub? */
3329         if (cv != GvCV(gv = CvGV(cv))) {
3330             cv = GvCV(gv);
3331         }
3332         /* should call AUTOLOAD now? */
3333         else {
3334           try_autoload:
3335             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
3336                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
3337             {
3338                 cv = GvCV(autogv);
3339             }
3340             else {
3341                sorry:
3342                 sub_name = sv_newmortal();
3343                 gv_efullname3(sub_name, gv, NULL);
3344                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
3345             }
3346         }
3347         if (!cv)
3348             goto sorry;
3349         goto retry;
3350     }
3351
3352     if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
3353             && !CvNODEBUG(cv)))
3354     {
3355          Perl_get_db_sub(aTHX_ &sv, cv);
3356          if (CvISXSUB(cv))
3357              PL_curcopdb = PL_curcop;
3358          if (CvLVALUE(cv)) {
3359              /* check for lsub that handles lvalue subroutines */
3360              cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
3361              /* if lsub not found then fall back to DB::sub */
3362              if (!cv) cv = GvCV(PL_DBsub);
3363          } else {
3364              cv = GvCV(PL_DBsub);
3365          }
3366
3367         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
3368             DIE(aTHX_ "No DB::sub routine defined");
3369     }
3370
3371     gimme = GIMME_V;
3372
3373     if (!(CvISXSUB(cv))) {
3374         /* This path taken at least 75% of the time   */
3375         dMARK;
3376         PADLIST * const padlist = CvPADLIST(cv);
3377         I32 depth;
3378
3379         PUSHBLOCK(cx, CXt_SUB, MARK);
3380         PUSHSUB(cx);
3381         cx->blk_sub.retop = PL_op->op_next;
3382         if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3383             PERL_STACK_OVERFLOW_CHECK();
3384             pad_push(padlist, depth);
3385         }
3386         SAVECOMPPAD();
3387         PAD_SET_CUR_NOSAVE(padlist, depth);
3388         if (LIKELY(hasargs)) {
3389             AV *const av = MUTABLE_AV(PAD_SVl(0));
3390             SSize_t items;
3391             AV **defavp;
3392
3393             if (UNLIKELY(AvREAL(av))) {
3394                 /* @_ is normally not REAL--this should only ever
3395                  * happen when DB::sub() calls things that modify @_ */
3396                 av_clear(av);
3397                 AvREAL_off(av);
3398                 AvREIFY_on(av);
3399             }
3400             defavp = &GvAV(PL_defgv);
3401             cx->blk_sub.savearray = *defavp;
3402             *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
3403             CX_CURPAD_SAVE(cx->blk_sub);
3404             cx->blk_sub.argarray = av;
3405             items = SP - MARK;
3406
3407             if (UNLIKELY(items - 1 > AvMAX(av))) {
3408                 SV **ary = AvALLOC(av);
3409                 AvMAX(av) = items - 1;
3410                 Renew(ary, items, SV*);
3411                 AvALLOC(av) = ary;
3412                 AvARRAY(av) = ary;
3413             }
3414
3415             Copy(MARK+1,AvARRAY(av),items,SV*);
3416             AvFILLp(av) = items - 1;
3417         
3418             MARK = AvARRAY(av);
3419             while (items--) {
3420                 if (*MARK)
3421                 {
3422                     if (SvPADTMP(*MARK)) {
3423                         *MARK = sv_mortalcopy(*MARK);
3424                     }
3425                     SvTEMP_off(*MARK);
3426                 }
3427                 MARK++;
3428             }
3429         }
3430         SAVETMPS;
3431         if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3432             !CvLVALUE(cv)))
3433             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf,
3434                 SVfARG(cv_name(cv, NULL, 0)));
3435         /* warning must come *after* we fully set up the context
3436          * stuff so that __WARN__ handlers can safely dounwind()
3437          * if they want to
3438          */
3439         if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
3440                 && ckWARN(WARN_RECURSION)
3441                 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
3442             sub_crush_depth(cv);
3443         RETURNOP(CvSTART(cv));
3444     }
3445     else {
3446         SSize_t markix = TOPMARK;
3447
3448         SAVETMPS;
3449         PUTBACK;
3450
3451         if (UNLIKELY(((PL_op->op_private
3452                & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
3453              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3454             !CvLVALUE(cv)))
3455             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf,
3456                 SVfARG(cv_name(cv, NULL, 0)));
3457
3458         if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3459             /* Need to copy @_ to stack. Alternative may be to
3460              * switch stack to @_, and copy return values
3461              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3462             AV * const av = GvAV(PL_defgv);
3463             const SSize_t items = AvFILL(av) + 1;
3464
3465             if (items) {
3466                 SSize_t i = 0;
3467                 const bool m = cBOOL(SvRMAGICAL(av));
3468                 /* Mark is at the end of the stack. */
3469                 EXTEND(SP, items);
3470                 for (; i < items; ++i)
3471                 {
3472                     SV *sv;
3473                     if (m) {
3474                         SV ** const svp = av_fetch(av, i, 0);
3475                         sv = svp ? *svp : NULL;
3476                     }
3477                     else sv = AvARRAY(av)[i];
3478                     if (sv) SP[i+1] = sv;
3479                     else {
3480                         SP[i+1] = newSVavdefelem(av, i, 1);
3481                     }
3482                 }
3483                 SP += items;
3484                 PUTBACK ;               
3485             }
3486         }
3487         else {
3488             SV **mark = PL_stack_base + markix;
3489             SSize_t items = SP - mark;
3490             while (items--) {
3491                 mark++;
3492                 if (*mark && SvPADTMP(*mark)) {
3493                     *mark = sv_mortalcopy(*mark);
3494                 }
3495             }
3496         }
3497         /* We assume first XSUB in &DB::sub is the called one. */
3498         if (UNLIKELY(PL_curcopdb)) {
3499             SAVEVPTR(PL_curcop);
3500             PL_curcop = PL_curcopdb;
3501             PL_curcopdb = NULL;
3502         }
3503         /* Do we need to open block here? XXXX */
3504
3505         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3506         assert(CvXSUB(cv));
3507         CvXSUB(cv)(aTHX_ cv);
3508
3509         /* Enforce some sanity in scalar context. */
3510         if (gimme == G_SCALAR) {
3511             SV **svp = PL_stack_base + markix + 1;
3512             if (svp != PL_stack_sp) {
3513                 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
3514                 PL_stack_sp = svp;
3515             }
3516         }
3517         LEAVE;
3518         return NORMAL;
3519     }
3520 }
3521
3522 void
3523 Perl_sub_crush_depth(pTHX_ CV *cv)
3524 {
3525     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3526
3527     if (CvANON(cv))
3528         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3529     else {
3530         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3531                     SVfARG(cv_name(cv,NULL,0)));
3532     }
3533 }
3534
3535 PP(pp_aelem)
3536 {
3537     dSP;
3538     SV** svp;
3539     SV* const elemsv = POPs;
3540     IV elem = SvIV(elemsv);
3541     AV *const av = MUTABLE_AV(POPs);
3542     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3543     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3544     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3545     bool preeminent = TRUE;
3546     SV *sv;
3547
3548     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
3549         Perl_warner(aTHX_ packWARN(WARN_MISC),
3550                     "Use of reference \"%"SVf"\" as array index",
3551                     SVfARG(elemsv));
3552     if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
3553         RETPUSHUNDEF;
3554
3555     if (UNLIKELY(localizing)) {
3556         MAGIC *mg;
3557         HV *stash;
3558
3559         /* If we can determine whether the element exist,
3560          * Try to preserve the existenceness of a tied array
3561          * element by using EXISTS and DELETE if possible.
3562          * Fallback to FETCH and STORE otherwise. */
3563         if (SvCANEXISTDELETE(av))
3564             preeminent = av_exists(av, elem);
3565     }
3566
3567     svp = av_fetch(av, elem, lval && !defer);
3568     if (lval) {
3569 #ifdef PERL_MALLOC_WRAP
3570          if (SvUOK(elemsv)) {
3571               const UV uv = SvUV(elemsv);
3572               elem = uv > IV_MAX ? IV_MAX : uv;
3573          }
3574          else if (SvNOK(elemsv))
3575               elem = (IV)SvNV(elemsv);
3576          if (elem > 0) {
3577               static const char oom_array_extend[] =
3578                 "Out of memory during array extend"; /* Duplicated in av.c */
3579               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3580          }
3581 #endif
3582         if (!svp || !*svp) {
3583             IV len;
3584             if (!defer)
3585                 DIE(aTHX_ PL_no_aelem, elem);
3586             len = av_tindex(av);
3587             mPUSHs(newSVavdefelem(av,
3588             /* Resolve a negative index now, unless it points before the
3589                beginning of the array, in which case record it for error
3590                reporting in magic_setdefelem. */
3591                 elem < 0 && len + elem >= 0 ? len + elem : elem,
3592                 1));
3593             RETURN;
3594         }
3595         if (UNLIKELY(localizing)) {
3596             if (preeminent)
3597                 save_aelem(av, elem, svp);
3598             else
3599                 SAVEADELETE(av, elem);
3600         }
3601         else if (PL_op->op_private & OPpDEREF) {
3602             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3603             RETURN;
3604         }
3605     }
3606     sv = (svp ? *svp : &PL_sv_undef);
3607     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3608         mg_get(sv);
3609     PUSHs(sv);
3610     RETURN;
3611 }
3612
3613 SV*
3614 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3615 {
3616     PERL_ARGS_ASSERT_VIVIFY_REF;
3617
3618     SvGETMAGIC(sv);
3619     if (!SvOK(sv)) {
3620         if (SvREADONLY(sv))
3621             Perl_croak_no_modify();
3622         prepare_SV_for_RV(sv);
3623         switch (to_what) {
3624         case OPpDEREF_SV:
3625             SvRV_set(sv, newSV(0));
3626             break;
3627         case OPpDEREF_AV:
3628             SvRV_set(sv, MUTABLE_SV(newAV()));
3629             break;
3630         case OPpDEREF_HV:
3631             SvRV_set(sv, MUTABLE_SV(newHV()));
3632             break;
3633         }
3634         SvROK_on(sv);
3635         SvSETMAGIC(sv);
3636         SvGETMAGIC(sv);
3637     }
3638     if (SvGMAGICAL(sv)) {
3639         /* copy the sv without magic to prevent magic from being
3640            executed twice */
3641         SV* msv = sv_newmortal();
3642         sv_setsv_nomg(msv, sv);
3643         return msv;
3644     }
3645     return sv;
3646 }
3647
3648 PERL_STATIC_INLINE HV *
3649 S_opmethod_stash(pTHX_ SV* meth)
3650 {
3651     SV* ob;
3652     HV* stash;
3653
3654     SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
3655         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3656                             "package or object reference", SVfARG(meth)),
3657            (SV *)NULL)
3658         : *(PL_stack_base + TOPMARK + 1);
3659
3660     PERL_ARGS_ASSERT_OPMETHOD_STASH;
3661
3662     if (UNLIKELY(!sv))
3663        undefined:
3664         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3665                    SVfARG(meth));
3666
3667     if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
3668     else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
3669         stash = gv_stashsv(sv, GV_CACHE_ONLY);
3670         if (stash) return stash;
3671     }
3672
3673     if (SvROK(sv))
3674         ob = MUTABLE_SV(SvRV(sv));
3675     else if (!SvOK(sv)) goto undefined;
3676     else if (isGV_with_GP(sv)) {
3677         if (!GvIO(sv))
3678             Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3679                              "without a package or object reference",
3680                               SVfARG(meth));
3681         ob = sv;
3682         if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3683             assert(!LvTARGLEN(ob));
3684             ob = LvTARG(ob);
3685             assert(ob);
3686         }
3687         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3688     }
3689     else {
3690         /* this isn't a reference */
3691         GV* iogv;
3692         STRLEN packlen;
3693         const char * const packname = SvPV_nomg_const(sv, packlen);
3694         const U32 packname_utf8 = SvUTF8(sv);
3695         stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3696         if (stash) return stash;
3697
3698         if (!(iogv = gv_fetchpvn_flags(
3699                 packname, packlen, packname_utf8, SVt_PVIO
3700              )) ||
3701             !(ob=MUTABLE_SV(GvIO(iogv))))
3702         {
3703             /* this isn't the name of a filehandle either */
3704             if (!packlen)
3705             {
3706                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3707                                  "without a package or object reference",
3708                                   SVfARG(meth));
3709             }
3710             /* assume it's a package name */
3711             stash = gv_stashpvn(packname, packlen, packname_utf8);
3712             if (stash) return stash;
3713             else return MUTABLE_HV(sv);
3714         }
3715         /* it _is_ a filehandle name -- replace with a reference */
3716         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3717     }
3718
3719     /* if we got here, ob should be an object or a glob */
3720     if (!ob || !(SvOBJECT(ob)
3721                  || (isGV_with_GP(ob)
3722                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3723                      && SvOBJECT(ob))))
3724     {
3725         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3726                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3727                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3728                                         : meth));
3729     }
3730
3731     return SvSTASH(ob);
3732 }
3733
3734 PP(pp_method)
3735 {
3736     dSP;
3737     GV* gv;
3738     HV* stash;
3739     SV* const meth = TOPs;
3740
3741     if (SvROK(meth)) {
3742         SV* const rmeth = SvRV(meth);
3743         if (SvTYPE(rmeth) == SVt_PVCV) {
3744             SETs(rmeth);
3745             RETURN;
3746         }
3747     }
3748
3749     stash = opmethod_stash(meth);
3750
3751     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3752     assert(gv);
3753
3754     SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3755     RETURN;
3756 }
3757
3758 #define METHOD_CHECK_CACHE(stash,cache,meth)                            \
3759     const HE* const he = hv_fetch_ent(cache, meth, 0, 0);               \
3760     if (he) {                                                           \
3761         gv = MUTABLE_GV(HeVAL(he));                                     \
3762         if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv)        \
3763              == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))     \
3764         {                                                               \
3765             XPUSHs(MUTABLE_SV(GvCV(gv)));                               \
3766             RETURN;                                                     \
3767         }                                                               \
3768     }                                                                   \
3769
3770 PP(pp_method_named)
3771 {
3772     dSP;
3773     GV* gv;
3774     SV* const meth = cMETHOPx_meth(PL_op);
3775     HV* const stash = opmethod_stash(meth);
3776
3777     if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
3778         METHOD_CHECK_CACHE(stash, stash, meth);
3779     }
3780
3781     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3782     assert(gv);
3783
3784     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3785     RETURN;
3786 }
3787
3788 PP(pp_method_super)
3789 {
3790     dSP;
3791     GV* gv;
3792     HV* cache;
3793     SV* const meth = cMETHOPx_meth(PL_op);
3794     HV* const stash = CopSTASH(PL_curcop);
3795     /* Actually, SUPER doesn't need real object's (or class') stash at all,
3796      * as it uses CopSTASH. However, we must ensure that object(class) is
3797      * correct (this check is done by S_opmethod_stash) */
3798     opmethod_stash(meth);
3799
3800     if ((cache = HvMROMETA(stash)->super)) {
3801         METHOD_CHECK_CACHE(stash, cache, meth);
3802     }
3803
3804     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3805     assert(gv);
3806
3807     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3808     RETURN;
3809 }
3810
3811 PP(pp_method_redir)
3812 {
3813     dSP;
3814     GV* gv;
3815     SV* const meth = cMETHOPx_meth(PL_op);
3816     HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3817     opmethod_stash(meth); /* not used but needed for error checks */
3818
3819     if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
3820     else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3821
3822     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3823     assert(gv);
3824
3825     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3826     RETURN;
3827 }
3828
3829 PP(pp_method_redir_super)
3830 {
3831     dSP;
3832     GV* gv;
3833     HV* cache;
3834     SV* const meth = cMETHOPx_meth(PL_op);
3835     HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3836     opmethod_stash(meth); /* not used but needed for error checks */
3837
3838     if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3839     else if ((cache = HvMROMETA(stash)->super)) {
3840          METHOD_CHECK_CACHE(stash, cache, meth);
3841     }
3842
3843     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3844     assert(gv);
3845
3846     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3847     RETURN;
3848 }
3849
3850 /*
3851  * ex: set ts=8 sts=4 sw=4 et:
3852  */