perldelta for the shift work.
[perl.git] / pp.c
1 /*    pp.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  * 'It's a big house this, and very peculiar.  Always a bit more
13  *  to discover, and no knowing what you'll find round a corner.
14  *  And Elves, sir!'                            --Samwise Gamgee
15  *
16  *     [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
17  */
18
19 /* This file contains general pp ("push/pop") functions that execute the
20  * opcodes that make up a perl program. A typical pp function expects to
21  * find its arguments on the stack, and usually pushes its results onto
22  * the stack, hence the 'pp' terminology. Each OP structure contains
23  * a pointer to the relevant pp_foo() function.
24  */
25
26 #include "EXTERN.h"
27 #define PERL_IN_PP_C
28 #include "perl.h"
29 #include "keywords.h"
30
31 #include "reentr.h"
32 #include "regcharclass.h"
33
34 /* XXX I can't imagine anyone who doesn't have this actually _needs_
35    it, since pid_t is an integral type.
36    --AD  2/20/1998
37 */
38 #ifdef NEED_GETPID_PROTO
39 extern Pid_t getpid (void);
40 #endif
41
42 /*
43  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44  * This switches them over to IEEE.
45  */
46 #if defined(LIBM_LIB_VERSION)
47     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
48 #endif
49
50 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
52
53 /* variations on pp_null */
54
55 PP(pp_stub)
56 {
57     dSP;
58     if (GIMME_V == G_SCALAR)
59         XPUSHs(&PL_sv_undef);
60     RETURN;
61 }
62
63 /* Pushy stuff. */
64
65 /* This is also called directly by pp_lvavref.  */
66 PP(pp_padav)
67 {
68     dSP; dTARGET;
69     I32 gimme;
70     assert(SvTYPE(TARG) == SVt_PVAV);
71     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
72         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
73             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
74     EXTEND(SP, 1);
75     if (PL_op->op_flags & OPf_REF) {
76         PUSHs(TARG);
77         RETURN;
78     } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
79        const I32 flags = is_lvalue_sub();
80        if (flags && !(flags & OPpENTERSUB_INARGS)) {
81         if (GIMME_V == G_SCALAR)
82             /* diag_listed_as: Can't return %s to lvalue scalar context */
83             Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
84         PUSHs(TARG);
85         RETURN;
86        }
87     }
88     gimme = GIMME_V;
89     if (gimme == G_ARRAY) {
90         /* XXX see also S_pushav in pp_hot.c */
91         const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
92         EXTEND(SP, maxarg);
93         if (SvMAGICAL(TARG)) {
94             Size_t i;
95             for (i=0; i < maxarg; i++) {
96                 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
97                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
98             }
99         }
100         else {
101             PADOFFSET i;
102             for (i=0; i < (PADOFFSET)maxarg; i++) {
103                 SV * const sv = AvARRAY((const AV *)TARG)[i];
104                 SP[i+1] = sv ? sv : &PL_sv_undef;
105             }
106         }
107         SP += maxarg;
108     }
109     else if (gimme == G_SCALAR) {
110         SV* const sv = sv_newmortal();
111         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
112         sv_setiv(sv, maxarg);
113         PUSHs(sv);
114     }
115     RETURN;
116 }
117
118 PP(pp_padhv)
119 {
120     dSP; dTARGET;
121     I32 gimme;
122
123     assert(SvTYPE(TARG) == SVt_PVHV);
124     XPUSHs(TARG);
125     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
126         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
127             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
128     if (PL_op->op_flags & OPf_REF)
129         RETURN;
130     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
131       const I32 flags = is_lvalue_sub();
132       if (flags && !(flags & OPpENTERSUB_INARGS)) {
133         if (GIMME_V == G_SCALAR)
134             /* diag_listed_as: Can't return %s to lvalue scalar context */
135             Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
136         RETURN;
137       }
138     }
139     gimme = GIMME_V;
140     if (gimme == G_ARRAY) {
141         RETURNOP(Perl_do_kv(aTHX));
142     }
143     else if ((PL_op->op_private & OPpTRUEBOOL
144           || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
145              && block_gimme() == G_VOID  ))
146           && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
147         SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
148     else if (gimme == G_SCALAR) {
149         SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
150         SETs(sv);
151     }
152     RETURN;
153 }
154
155 PP(pp_padcv)
156 {
157     dSP; dTARGET;
158     assert(SvTYPE(TARG) == SVt_PVCV);
159     XPUSHs(TARG);
160     RETURN;
161 }
162
163 PP(pp_introcv)
164 {
165     dTARGET;
166     SvPADSTALE_off(TARG);
167     return NORMAL;
168 }
169
170 PP(pp_clonecv)
171 {
172     dTARGET;
173     CV * const protocv = PadnamePROTOCV(
174         PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
175     );
176     assert(SvTYPE(TARG) == SVt_PVCV);
177     assert(protocv);
178     if (CvISXSUB(protocv)) { /* constant */
179         /* XXX Should we clone it here? */
180         /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
181            to introcv and remove the SvPADSTALE_off. */
182         SAVEPADSVANDMORTALIZE(ARGTARG);
183         PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
184     }
185     else {
186         if (CvROOT(protocv)) {
187             assert(CvCLONE(protocv));
188             assert(!CvCLONED(protocv));
189         }
190         cv_clone_into(protocv,(CV *)TARG);
191         SAVECLEARSV(PAD_SVl(ARGTARG));
192     }
193     return NORMAL;
194 }
195
196 /* Translations. */
197
198 /* In some cases this function inspects PL_op.  If this function is called
199    for new op types, more bool parameters may need to be added in place of
200    the checks.
201
202    When noinit is true, the absence of a gv will cause a retval of undef.
203    This is unrelated to the cv-to-gv assignment case.
204 */
205
206 static SV *
207 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
208               const bool noinit)
209 {
210     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
211     if (SvROK(sv)) {
212         if (SvAMAGIC(sv)) {
213             sv = amagic_deref_call(sv, to_gv_amg);
214         }
215       wasref:
216         sv = SvRV(sv);
217         if (SvTYPE(sv) == SVt_PVIO) {
218             GV * const gv = MUTABLE_GV(sv_newmortal());
219             gv_init(gv, 0, "__ANONIO__", 10, 0);
220             GvIOp(gv) = MUTABLE_IO(sv);
221             SvREFCNT_inc_void_NN(sv);
222             sv = MUTABLE_SV(gv);
223         }
224         else if (!isGV_with_GP(sv)) {
225             Perl_die(aTHX_ "Not a GLOB reference");
226         }
227     }
228     else {
229         if (!isGV_with_GP(sv)) {
230             if (!SvOK(sv)) {
231                 /* If this is a 'my' scalar and flag is set then vivify
232                  * NI-S 1999/05/07
233                  */
234                 if (vivify_sv && sv != &PL_sv_undef) {
235                     GV *gv;
236                     if (SvREADONLY(sv))
237                         Perl_croak_no_modify();
238                     if (cUNOP->op_targ) {
239                         SV * const namesv = PAD_SV(cUNOP->op_targ);
240                         HV *stash = CopSTASH(PL_curcop);
241                         if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
242                         gv = MUTABLE_GV(newSV(0));
243                         gv_init_sv(gv, stash, namesv, 0);
244                     }
245                     else {
246                         const char * const name = CopSTASHPV(PL_curcop);
247                         gv = newGVgen_flags(name,
248                                 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
249                         SvREFCNT_inc_simple_void_NN(gv);
250                     }
251                     prepare_SV_for_RV(sv);
252                     SvRV_set(sv, MUTABLE_SV(gv));
253                     SvROK_on(sv);
254                     SvSETMAGIC(sv);
255                     goto wasref;
256                 }
257                 if (PL_op->op_flags & OPf_REF || strict) {
258                     Perl_die(aTHX_ PL_no_usym, "a symbol");
259                 }
260                 if (ckWARN(WARN_UNINITIALIZED))
261                     report_uninit(sv);
262                 return &PL_sv_undef;
263             }
264             if (noinit)
265             {
266                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
267                            sv, GV_ADDMG, SVt_PVGV
268                    ))))
269                     return &PL_sv_undef;
270             }
271             else {
272                 if (strict) {
273                     Perl_die(aTHX_
274                              PL_no_symref_sv,
275                              sv,
276                              (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
277                              "a symbol"
278                              );
279                 }
280                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
281                     == OPpDONT_INIT_GV) {
282                     /* We are the target of a coderef assignment.  Return
283                        the scalar unchanged, and let pp_sasssign deal with
284                        things.  */
285                     return sv;
286                 }
287                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
288             }
289             /* FAKE globs in the symbol table cause weird bugs (#77810) */
290             SvFAKE_off(sv);
291         }
292     }
293     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
294         SV *newsv = sv_newmortal();
295         sv_setsv_flags(newsv, sv, 0);
296         SvFAKE_off(newsv);
297         sv = newsv;
298     }
299     return sv;
300 }
301
302 PP(pp_rv2gv)
303 {
304     dSP; dTOPss;
305
306     sv = S_rv2gv(aTHX_
307           sv, PL_op->op_private & OPpDEREF,
308           PL_op->op_private & HINT_STRICT_REFS,
309           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
310              || PL_op->op_type == OP_READLINE
311          );
312     if (PL_op->op_private & OPpLVAL_INTRO)
313         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
314     SETs(sv);
315     RETURN;
316 }
317
318 /* Helper function for pp_rv2sv and pp_rv2av  */
319 GV *
320 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
321                 const svtype type, SV ***spp)
322 {
323     GV *gv;
324
325     PERL_ARGS_ASSERT_SOFTREF2XV;
326
327     if (PL_op->op_private & HINT_STRICT_REFS) {
328         if (SvOK(sv))
329             Perl_die(aTHX_ PL_no_symref_sv, sv,
330                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
331         else
332             Perl_die(aTHX_ PL_no_usym, what);
333     }
334     if (!SvOK(sv)) {
335         if (
336           PL_op->op_flags & OPf_REF
337         )
338             Perl_die(aTHX_ PL_no_usym, what);
339         if (ckWARN(WARN_UNINITIALIZED))
340             report_uninit(sv);
341         if (type != SVt_PV && GIMME_V == G_ARRAY) {
342             (*spp)--;
343             return NULL;
344         }
345         **spp = &PL_sv_undef;
346         return NULL;
347     }
348     if ((PL_op->op_flags & OPf_SPECIAL) &&
349         !(PL_op->op_flags & OPf_MOD))
350         {
351             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
352                 {
353                     **spp = &PL_sv_undef;
354                     return NULL;
355                 }
356         }
357     else {
358         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
359     }
360     return gv;
361 }
362
363 PP(pp_rv2sv)
364 {
365     dSP; dTOPss;
366     GV *gv = NULL;
367
368     SvGETMAGIC(sv);
369     if (SvROK(sv)) {
370         if (SvAMAGIC(sv)) {
371             sv = amagic_deref_call(sv, to_sv_amg);
372         }
373
374         sv = SvRV(sv);
375         if (SvTYPE(sv) >= SVt_PVAV)
376             DIE(aTHX_ "Not a SCALAR reference");
377     }
378     else {
379         gv = MUTABLE_GV(sv);
380
381         if (!isGV_with_GP(gv)) {
382             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
383             if (!gv)
384                 RETURN;
385         }
386         sv = GvSVn(gv);
387     }
388     if (PL_op->op_flags & OPf_MOD) {
389         if (PL_op->op_private & OPpLVAL_INTRO) {
390             if (cUNOP->op_first->op_type == OP_NULL)
391                 sv = save_scalar(MUTABLE_GV(TOPs));
392             else if (gv)
393                 sv = save_scalar(gv);
394             else
395                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
396         }
397         else if (PL_op->op_private & OPpDEREF)
398             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
399     }
400     SETs(sv);
401     RETURN;
402 }
403
404 PP(pp_av2arylen)
405 {
406     dSP;
407     AV * const av = MUTABLE_AV(TOPs);
408     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
409     if (lvalue) {
410         SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
411         if (!*svp) {
412             *svp = newSV_type(SVt_PVMG);
413             sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
414         }
415         SETs(*svp);
416     } else {
417         SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
418     }
419     RETURN;
420 }
421
422 PP(pp_pos)
423 {
424     dSP; dTOPss;
425
426     if (PL_op->op_flags & OPf_MOD || LVRET) {
427         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
428         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
429         LvTYPE(ret) = '.';
430         LvTARG(ret) = SvREFCNT_inc_simple(sv);
431         SETs(ret);    /* no SvSETMAGIC */
432     }
433     else {
434             const MAGIC * const mg = mg_find_mglob(sv);
435             if (mg && mg->mg_len != -1) {
436                 dTARGET;
437                 STRLEN i = mg->mg_len;
438                 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
439                     i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
440                 SETu(i);
441                 return NORMAL;
442             }
443             SETs(&PL_sv_undef);
444     }
445     return NORMAL;
446 }
447
448 PP(pp_rv2cv)
449 {
450     dSP;
451     GV *gv;
452     HV *stash_unused;
453     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
454         ? GV_ADDMG
455         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
456                                                     == OPpMAY_RETURN_CONSTANT)
457             ? GV_ADD|GV_NOEXPAND
458             : GV_ADD;
459     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
460     /* (But not in defined().) */
461
462     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
463     if (cv) NOOP;
464     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
465         cv = SvTYPE(SvRV(gv)) == SVt_PVCV
466             ? MUTABLE_CV(SvRV(gv))
467             : MUTABLE_CV(gv);
468     }    
469     else
470         cv = MUTABLE_CV(&PL_sv_undef);
471     SETs(MUTABLE_SV(cv));
472     return NORMAL;
473 }
474
475 PP(pp_prototype)
476 {
477     dSP;
478     CV *cv;
479     HV *stash;
480     GV *gv;
481     SV *ret = &PL_sv_undef;
482
483     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
484     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
485         const char * s = SvPVX_const(TOPs);
486         if (strnEQ(s, "CORE::", 6)) {
487             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
488             if (!code)
489                 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
490                    UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
491             {
492                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
493                 if (sv) ret = sv;
494             }
495             goto set;
496         }
497     }
498     cv = sv_2cv(TOPs, &stash, &gv, 0);
499     if (cv && SvPOK(cv))
500         ret = newSVpvn_flags(
501             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
502         );
503   set:
504     SETs(ret);
505     RETURN;
506 }
507
508 PP(pp_anoncode)
509 {
510     dSP;
511     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
512     if (CvCLONE(cv))
513         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
514     EXTEND(SP,1);
515     PUSHs(MUTABLE_SV(cv));
516     RETURN;
517 }
518
519 PP(pp_srefgen)
520 {
521     dSP;
522     *SP = refto(*SP);
523     return NORMAL;
524 }
525
526 PP(pp_refgen)
527 {
528     dSP; dMARK;
529     if (GIMME_V != G_ARRAY) {
530         if (++MARK <= SP)
531             *MARK = *SP;
532         else
533         {
534             MEXTEND(SP, 1);
535             *MARK = &PL_sv_undef;
536         }
537         *MARK = refto(*MARK);
538         SP = MARK;
539         RETURN;
540     }
541     EXTEND_MORTAL(SP - MARK);
542     while (++MARK <= SP)
543         *MARK = refto(*MARK);
544     RETURN;
545 }
546
547 STATIC SV*
548 S_refto(pTHX_ SV *sv)
549 {
550     SV* rv;
551
552     PERL_ARGS_ASSERT_REFTO;
553
554     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
555         if (LvTARGLEN(sv))
556             vivify_defelem(sv);
557         if (!(sv = LvTARG(sv)))
558             sv = &PL_sv_undef;
559         else
560             SvREFCNT_inc_void_NN(sv);
561     }
562     else if (SvTYPE(sv) == SVt_PVAV) {
563         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
564             av_reify(MUTABLE_AV(sv));
565         SvTEMP_off(sv);
566         SvREFCNT_inc_void_NN(sv);
567     }
568     else if (SvPADTMP(sv)) {
569         sv = newSVsv(sv);
570     }
571     else {
572         SvTEMP_off(sv);
573         SvREFCNT_inc_void_NN(sv);
574     }
575     rv = sv_newmortal();
576     sv_upgrade(rv, SVt_IV);
577     SvRV_set(rv, sv);
578     SvROK_on(rv);
579     return rv;
580 }
581
582 PP(pp_ref)
583 {
584     dSP;
585     SV * const sv = TOPs;
586
587     SvGETMAGIC(sv);
588     if (!SvROK(sv))
589         SETs(&PL_sv_no);
590     else {
591         dTARGET;
592         SETs(TARG);
593         /* use the return value that is in a register, its the same as TARG */
594         TARG = sv_ref(TARG,SvRV(sv),TRUE);
595         SvSETMAGIC(TARG);
596     }
597
598     return NORMAL;
599 }
600
601 PP(pp_bless)
602 {
603     dSP;
604     HV *stash;
605
606     if (MAXARG == 1)
607     {
608       curstash:
609         stash = CopSTASH(PL_curcop);
610         if (SvTYPE(stash) != SVt_PVHV)
611             Perl_croak(aTHX_ "Attempt to bless into a freed package");
612     }
613     else {
614         SV * const ssv = POPs;
615         STRLEN len;
616         const char *ptr;
617
618         if (!ssv) goto curstash;
619         SvGETMAGIC(ssv);
620         if (SvROK(ssv)) {
621           if (!SvAMAGIC(ssv)) {
622            frog:
623             Perl_croak(aTHX_ "Attempt to bless into a reference");
624           }
625           /* SvAMAGIC is on here, but it only means potentially overloaded,
626              so after stringification: */
627           ptr = SvPV_nomg_const(ssv,len);
628           /* We need to check the flag again: */
629           if (!SvAMAGIC(ssv)) goto frog;
630         }
631         else ptr = SvPV_nomg_const(ssv,len);
632         if (len == 0)
633             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
634                            "Explicit blessing to '' (assuming package main)");
635         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
636     }
637
638     (void)sv_bless(TOPs, stash);
639     RETURN;
640 }
641
642 PP(pp_gelem)
643 {
644     dSP;
645
646     SV *sv = POPs;
647     STRLEN len;
648     const char * const elem = SvPV_const(sv, len);
649     GV * const gv = MUTABLE_GV(TOPs);
650     SV * tmpRef = NULL;
651
652     sv = NULL;
653     if (elem) {
654         /* elem will always be NUL terminated.  */
655         const char * const second_letter = elem + 1;
656         switch (*elem) {
657         case 'A':
658             if (len == 5 && strEQ(second_letter, "RRAY"))
659             {
660                 tmpRef = MUTABLE_SV(GvAV(gv));
661                 if (tmpRef && !AvREAL((const AV *)tmpRef)
662                  && AvREIFY((const AV *)tmpRef))
663                     av_reify(MUTABLE_AV(tmpRef));
664             }
665             break;
666         case 'C':
667             if (len == 4 && strEQ(second_letter, "ODE"))
668                 tmpRef = MUTABLE_SV(GvCVu(gv));
669             break;
670         case 'F':
671             if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
672                 /* finally deprecated in 5.8.0 */
673                 deprecate("*glob{FILEHANDLE}");
674                 tmpRef = MUTABLE_SV(GvIOp(gv));
675             }
676             else
677                 if (len == 6 && strEQ(second_letter, "ORMAT"))
678                     tmpRef = MUTABLE_SV(GvFORM(gv));
679             break;
680         case 'G':
681             if (len == 4 && strEQ(second_letter, "LOB"))
682                 tmpRef = MUTABLE_SV(gv);
683             break;
684         case 'H':
685             if (len == 4 && strEQ(second_letter, "ASH"))
686                 tmpRef = MUTABLE_SV(GvHV(gv));
687             break;
688         case 'I':
689             if (*second_letter == 'O' && !elem[2] && len == 2)
690                 tmpRef = MUTABLE_SV(GvIOp(gv));
691             break;
692         case 'N':
693             if (len == 4 && strEQ(second_letter, "AME"))
694                 sv = newSVhek(GvNAME_HEK(gv));
695             break;
696         case 'P':
697             if (len == 7 && strEQ(second_letter, "ACKAGE")) {
698                 const HV * const stash = GvSTASH(gv);
699                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
700                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
701             }
702             break;
703         case 'S':
704             if (len == 6 && strEQ(second_letter, "CALAR"))
705                 tmpRef = GvSVn(gv);
706             break;
707         }
708     }
709     if (tmpRef)
710         sv = newRV(tmpRef);
711     if (sv)
712         sv_2mortal(sv);
713     else
714         sv = &PL_sv_undef;
715     SETs(sv);
716     RETURN;
717 }
718
719 /* Pattern matching */
720
721 PP(pp_study)
722 {
723     dSP; dTOPss;
724     STRLEN len;
725
726     (void)SvPV(sv, len);
727     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
728         /* Historically, study was skipped in these cases. */
729         SETs(&PL_sv_no);
730         return NORMAL;
731     }
732
733     /* Make study a no-op. It's no longer useful and its existence
734        complicates matters elsewhere. */
735     SETs(&PL_sv_yes);
736     return NORMAL;
737 }
738
739
740 /* also used for: pp_transr() */
741
742 PP(pp_trans)
743 {
744     dSP; 
745     SV *sv;
746
747     if (PL_op->op_flags & OPf_STACKED)
748         sv = POPs;
749     else {
750         EXTEND(SP,1);
751         if (ARGTARG)
752             sv = PAD_SV(ARGTARG);
753         else {
754             sv = DEFSV;
755         }
756     }
757     if(PL_op->op_type == OP_TRANSR) {
758         STRLEN len;
759         const char * const pv = SvPV(sv,len);
760         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
761         do_trans(newsv);
762         PUSHs(newsv);
763     }
764     else {
765         mPUSHi(do_trans(sv));
766     }
767     RETURN;
768 }
769
770 /* Lvalue operators. */
771
772 static size_t
773 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
774 {
775     STRLEN len;
776     char *s;
777     size_t count = 0;
778
779     PERL_ARGS_ASSERT_DO_CHOMP;
780
781     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
782         return 0;
783     if (SvTYPE(sv) == SVt_PVAV) {
784         I32 i;
785         AV *const av = MUTABLE_AV(sv);
786         const I32 max = AvFILL(av);
787
788         for (i = 0; i <= max; i++) {
789             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
790             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
791                 count += do_chomp(retval, sv, chomping);
792         }
793         return count;
794     }
795     else if (SvTYPE(sv) == SVt_PVHV) {
796         HV* const hv = MUTABLE_HV(sv);
797         HE* entry;
798         (void)hv_iterinit(hv);
799         while ((entry = hv_iternext(hv)))
800             count += do_chomp(retval, hv_iterval(hv,entry), chomping);
801         return count;
802     }
803     else if (SvREADONLY(sv)) {
804             Perl_croak_no_modify();
805     }
806
807     if (IN_ENCODING) {
808         if (!SvUTF8(sv)) {
809             /* XXX, here sv is utf8-ized as a side-effect!
810                If encoding.pm is used properly, almost string-generating
811                operations, including literal strings, chr(), input data, etc.
812                should have been utf8-ized already, right?
813             */
814             sv_recode_to_utf8(sv, _get_encoding());
815         }
816     }
817
818     s = SvPV(sv, len);
819     if (chomping) {
820         char *temp_buffer = NULL;
821         SV *svrecode = NULL;
822
823         if (s && len) {
824             s += --len;
825             if (RsPARA(PL_rs)) {
826                 if (*s != '\n')
827                     goto nope;
828                 ++count;
829                 while (len && s[-1] == '\n') {
830                     --len;
831                     --s;
832                     ++count;
833                 }
834             }
835             else {
836                 STRLEN rslen, rs_charlen;
837                 const char *rsptr = SvPV_const(PL_rs, rslen);
838
839                 rs_charlen = SvUTF8(PL_rs)
840                     ? sv_len_utf8(PL_rs)
841                     : rslen;
842
843                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
844                     /* Assumption is that rs is shorter than the scalar.  */
845                     if (SvUTF8(PL_rs)) {
846                         /* RS is utf8, scalar is 8 bit.  */
847                         bool is_utf8 = TRUE;
848                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
849                                                              &rslen, &is_utf8);
850                         if (is_utf8) {
851                             /* Cannot downgrade, therefore cannot possibly match
852                              */
853                             assert (temp_buffer == rsptr);
854                             temp_buffer = NULL;
855                             goto nope;
856                         }
857                         rsptr = temp_buffer;
858                     }
859                     else if (IN_ENCODING) {
860                         /* RS is 8 bit, encoding.pm is used.
861                          * Do not recode PL_rs as a side-effect. */
862                         svrecode = newSVpvn(rsptr, rslen);
863                         sv_recode_to_utf8(svrecode, _get_encoding());
864                         rsptr = SvPV_const(svrecode, rslen);
865                         rs_charlen = sv_len_utf8(svrecode);
866                     }
867                     else {
868                         /* RS is 8 bit, scalar is utf8.  */
869                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
870                         rsptr = temp_buffer;
871                     }
872                 }
873                 if (rslen == 1) {
874                     if (*s != *rsptr)
875                         goto nope;
876                     ++count;
877                 }
878                 else {
879                     if (len < rslen - 1)
880                         goto nope;
881                     len -= rslen - 1;
882                     s -= rslen - 1;
883                     if (memNE(s, rsptr, rslen))
884                         goto nope;
885                     count += rs_charlen;
886                 }
887             }
888             SvPV_force_nomg_nolen(sv);
889             SvCUR_set(sv, len);
890             *SvEND(sv) = '\0';
891             SvNIOK_off(sv);
892             SvSETMAGIC(sv);
893         }
894     nope:
895
896         SvREFCNT_dec(svrecode);
897
898         Safefree(temp_buffer);
899     } else {
900         if (len && (!SvPOK(sv) || SvIsCOW(sv)))
901             s = SvPV_force_nomg(sv, len);
902         if (DO_UTF8(sv)) {
903             if (s && len) {
904                 char * const send = s + len;
905                 char * const start = s;
906                 s = send - 1;
907                 while (s > start && UTF8_IS_CONTINUATION(*s))
908                     s--;
909                 if (is_utf8_string((U8*)s, send - s)) {
910                     sv_setpvn(retval, s, send - s);
911                     *s = '\0';
912                     SvCUR_set(sv, s - start);
913                     SvNIOK_off(sv);
914                     SvUTF8_on(retval);
915                 }
916             }
917             else
918                 sv_setpvs(retval, "");
919         }
920         else if (s && len) {
921             s += --len;
922             sv_setpvn(retval, s, 1);
923             *s = '\0';
924             SvCUR_set(sv, len);
925             SvUTF8_off(sv);
926             SvNIOK_off(sv);
927         }
928         else
929             sv_setpvs(retval, "");
930         SvSETMAGIC(sv);
931     }
932     return count;
933 }
934
935
936 /* also used for: pp_schomp() */
937
938 PP(pp_schop)
939 {
940     dSP; dTARGET;
941     const bool chomping = PL_op->op_type == OP_SCHOMP;
942
943     const size_t count = do_chomp(TARG, TOPs, chomping);
944     if (chomping)
945         sv_setiv(TARG, count);
946     SETTARG;
947     return NORMAL;
948 }
949
950
951 /* also used for: pp_chomp() */
952
953 PP(pp_chop)
954 {
955     dSP; dMARK; dTARGET; dORIGMARK;
956     const bool chomping = PL_op->op_type == OP_CHOMP;
957     size_t count = 0;
958
959     while (MARK < SP)
960         count += do_chomp(TARG, *++MARK, chomping);
961     if (chomping)
962         sv_setiv(TARG, count);
963     SP = ORIGMARK;
964     XPUSHTARG;
965     RETURN;
966 }
967
968 PP(pp_undef)
969 {
970     dSP;
971     SV *sv;
972
973     if (!PL_op->op_private) {
974         EXTEND(SP, 1);
975         RETPUSHUNDEF;
976     }
977
978     sv = TOPs;
979     if (!sv)
980     {
981         SETs(&PL_sv_undef);
982         return NORMAL;
983     }
984
985     if (SvTHINKFIRST(sv))
986         sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
987
988     switch (SvTYPE(sv)) {
989     case SVt_NULL:
990         break;
991     case SVt_PVAV:
992         av_undef(MUTABLE_AV(sv));
993         break;
994     case SVt_PVHV:
995         hv_undef(MUTABLE_HV(sv));
996         break;
997     case SVt_PVCV:
998         if (cv_const_sv((const CV *)sv))
999             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1000                           "Constant subroutine %"SVf" undefined",
1001                            SVfARG(CvANON((const CV *)sv)
1002                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
1003                              : sv_2mortal(newSVhek(
1004                                 CvNAMED(sv)
1005                                  ? CvNAME_HEK((CV *)sv)
1006                                  : GvENAME_HEK(CvGV((const CV *)sv))
1007                                ))
1008                            ));
1009         /* FALLTHROUGH */
1010     case SVt_PVFM:
1011             /* let user-undef'd sub keep its identity */
1012         cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
1013         break;
1014     case SVt_PVGV:
1015         assert(isGV_with_GP(sv));
1016         assert(!SvFAKE(sv));
1017         {
1018             GP *gp;
1019             HV *stash;
1020
1021             /* undef *Pkg::meth_name ... */
1022             bool method_changed
1023              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1024               && HvENAME_get(stash);
1025             /* undef *Foo:: */
1026             if((stash = GvHV((const GV *)sv))) {
1027                 if(HvENAME_get(stash))
1028                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1029                 else stash = NULL;
1030             }
1031
1032             SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1033             gp_free(MUTABLE_GV(sv));
1034             Newxz(gp, 1, GP);
1035             GvGP_set(sv, gp_ref(gp));
1036 #ifndef PERL_DONT_CREATE_GVSV
1037             GvSV(sv) = newSV(0);
1038 #endif
1039             GvLINE(sv) = CopLINE(PL_curcop);
1040             GvEGV(sv) = MUTABLE_GV(sv);
1041             GvMULTI_on(sv);
1042
1043             if(stash)
1044                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1045             stash = NULL;
1046             /* undef *Foo::ISA */
1047             if( strEQ(GvNAME((const GV *)sv), "ISA")
1048              && (stash = GvSTASH((const GV *)sv))
1049              && (method_changed || HvENAME(stash)) )
1050                 mro_isa_changed_in(stash);
1051             else if(method_changed)
1052                 mro_method_changed_in(
1053                  GvSTASH((const GV *)sv)
1054                 );
1055
1056             break;
1057         }
1058     default:
1059         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1060             SvPV_free(sv);
1061             SvPV_set(sv, NULL);
1062             SvLEN_set(sv, 0);
1063         }
1064         SvOK_off(sv);
1065         SvSETMAGIC(sv);
1066     }
1067
1068     SETs(&PL_sv_undef);
1069     return NORMAL;
1070 }
1071
1072
1073 /* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */
1074
1075 PP(pp_postinc)
1076 {
1077     dSP; dTARGET;
1078     const bool inc =
1079         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1080     if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1081         Perl_croak_no_modify();
1082     if (SvROK(TOPs))
1083         TARG = sv_newmortal();
1084     sv_setsv(TARG, TOPs);
1085     if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1086         && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1087     {
1088         SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1089         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1090     }
1091     else if (inc)
1092         sv_inc_nomg(TOPs);
1093     else sv_dec_nomg(TOPs);
1094     SvSETMAGIC(TOPs);
1095     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1096     if (inc && !SvOK(TARG))
1097         sv_setiv(TARG, 0);
1098     SETTARG;
1099     return NORMAL;
1100 }
1101
1102 /* Ordinary operators. */
1103
1104 PP(pp_pow)
1105 {
1106     dSP; dATARGET; SV *svl, *svr;
1107 #ifdef PERL_PRESERVE_IVUV
1108     bool is_int = 0;
1109 #endif
1110     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1111     svr = TOPs;
1112     svl = TOPm1s;
1113 #ifdef PERL_PRESERVE_IVUV
1114     /* For integer to integer power, we do the calculation by hand wherever
1115        we're sure it is safe; otherwise we call pow() and try to convert to
1116        integer afterwards. */
1117     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1118                 UV power;
1119                 bool baseuok;
1120                 UV baseuv;
1121
1122                 if (SvUOK(svr)) {
1123                     power = SvUVX(svr);
1124                 } else {
1125                     const IV iv = SvIVX(svr);
1126                     if (iv >= 0) {
1127                         power = iv;
1128                     } else {
1129                         goto float_it; /* Can't do negative powers this way.  */
1130                     }
1131                 }
1132
1133                 baseuok = SvUOK(svl);
1134                 if (baseuok) {
1135                     baseuv = SvUVX(svl);
1136                 } else {
1137                     const IV iv = SvIVX(svl);
1138                     if (iv >= 0) {
1139                         baseuv = iv;
1140                         baseuok = TRUE; /* effectively it's a UV now */
1141                     } else {
1142                         baseuv = -iv; /* abs, baseuok == false records sign */
1143                     }
1144                 }
1145                 /* now we have integer ** positive integer. */
1146                 is_int = 1;
1147
1148                 /* foo & (foo - 1) is zero only for a power of 2.  */
1149                 if (!(baseuv & (baseuv - 1))) {
1150                     /* We are raising power-of-2 to a positive integer.
1151                        The logic here will work for any base (even non-integer
1152                        bases) but it can be less accurate than
1153                        pow (base,power) or exp (power * log (base)) when the
1154                        intermediate values start to spill out of the mantissa.
1155                        With powers of 2 we know this can't happen.
1156                        And powers of 2 are the favourite thing for perl
1157                        programmers to notice ** not doing what they mean. */
1158                     NV result = 1.0;
1159                     NV base = baseuok ? baseuv : -(NV)baseuv;
1160
1161                     if (power & 1) {
1162                         result *= base;
1163                     }
1164                     while (power >>= 1) {
1165                         base *= base;
1166                         if (power & 1) {
1167                             result *= base;
1168                         }
1169                     }
1170                     SP--;
1171                     SETn( result );
1172                     SvIV_please_nomg(svr);
1173                     RETURN;
1174                 } else {
1175                     unsigned int highbit = 8 * sizeof(UV);
1176                     unsigned int diff = 8 * sizeof(UV);
1177                     while (diff >>= 1) {
1178                         highbit -= diff;
1179                         if (baseuv >> highbit) {
1180                             highbit += diff;
1181                         }
1182                     }
1183                     /* we now have baseuv < 2 ** highbit */
1184                     if (power * highbit <= 8 * sizeof(UV)) {
1185                         /* result will definitely fit in UV, so use UV math
1186                            on same algorithm as above */
1187                         UV result = 1;
1188                         UV base = baseuv;
1189                         const bool odd_power = cBOOL(power & 1);
1190                         if (odd_power) {
1191                             result *= base;
1192                         }
1193                         while (power >>= 1) {
1194                             base *= base;
1195                             if (power & 1) {
1196                                 result *= base;
1197                             }
1198                         }
1199                         SP--;
1200                         if (baseuok || !odd_power)
1201                             /* answer is positive */
1202                             SETu( result );
1203                         else if (result <= (UV)IV_MAX)
1204                             /* answer negative, fits in IV */
1205                             SETi( -(IV)result );
1206                         else if (result == (UV)IV_MIN) 
1207                             /* 2's complement assumption: special case IV_MIN */
1208                             SETi( IV_MIN );
1209                         else
1210                             /* answer negative, doesn't fit */
1211                             SETn( -(NV)result );
1212                         RETURN;
1213                     } 
1214                 }
1215     }
1216   float_it:
1217 #endif    
1218     {
1219         NV right = SvNV_nomg(svr);
1220         NV left  = SvNV_nomg(svl);
1221         (void)POPs;
1222
1223 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1224     /*
1225     We are building perl with long double support and are on an AIX OS
1226     afflicted with a powl() function that wrongly returns NaNQ for any
1227     negative base.  This was reported to IBM as PMR #23047-379 on
1228     03/06/2006.  The problem exists in at least the following versions
1229     of AIX and the libm fileset, and no doubt others as well:
1230
1231         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1232         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1233         AIX 5.2.0           bos.adt.libm 5.2.0.85
1234
1235     So, until IBM fixes powl(), we provide the following workaround to
1236     handle the problem ourselves.  Our logic is as follows: for
1237     negative bases (left), we use fmod(right, 2) to check if the
1238     exponent is an odd or even integer:
1239
1240         - if odd,  powl(left, right) == -powl(-left, right)
1241         - if even, powl(left, right) ==  powl(-left, right)
1242
1243     If the exponent is not an integer, the result is rightly NaNQ, so
1244     we just return that (as NV_NAN).
1245     */
1246
1247         if (left < 0.0) {
1248             NV mod2 = Perl_fmod( right, 2.0 );
1249             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1250                 SETn( -Perl_pow( -left, right) );
1251             } else if (mod2 == 0.0) {           /* even integer */
1252                 SETn( Perl_pow( -left, right) );
1253             } else {                            /* fractional power */
1254                 SETn( NV_NAN );
1255             }
1256         } else {
1257             SETn( Perl_pow( left, right) );
1258         }
1259 #else
1260         SETn( Perl_pow( left, right) );
1261 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1262
1263 #ifdef PERL_PRESERVE_IVUV
1264         if (is_int)
1265             SvIV_please_nomg(svr);
1266 #endif
1267         RETURN;
1268     }
1269 }
1270
1271 PP(pp_multiply)
1272 {
1273     dSP; dATARGET; SV *svl, *svr;
1274     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1275     svr = TOPs;
1276     svl = TOPm1s;
1277 #ifdef PERL_PRESERVE_IVUV
1278     if (SvIV_please_nomg(svr)) {
1279         /* Unless the left argument is integer in range we are going to have to
1280            use NV maths. Hence only attempt to coerce the right argument if
1281            we know the left is integer.  */
1282         /* Left operand is defined, so is it IV? */
1283         if (SvIV_please_nomg(svl)) {
1284             bool auvok = SvUOK(svl);
1285             bool buvok = SvUOK(svr);
1286             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1287             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1288             UV alow;
1289             UV ahigh;
1290             UV blow;
1291             UV bhigh;
1292
1293             if (auvok) {
1294                 alow = SvUVX(svl);
1295             } else {
1296                 const IV aiv = SvIVX(svl);
1297                 if (aiv >= 0) {
1298                     alow = aiv;
1299                     auvok = TRUE; /* effectively it's a UV now */
1300                 } else {
1301                     /* abs, auvok == false records sign */
1302                     alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1303                 }
1304             }
1305             if (buvok) {
1306                 blow = SvUVX(svr);
1307             } else {
1308                 const IV biv = SvIVX(svr);
1309                 if (biv >= 0) {
1310                     blow = biv;
1311                     buvok = TRUE; /* effectively it's a UV now */
1312                 } else {
1313                     /* abs, buvok == false records sign */
1314                     blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1315                 }
1316             }
1317
1318             /* If this does sign extension on unsigned it's time for plan B  */
1319             ahigh = alow >> (4 * sizeof (UV));
1320             alow &= botmask;
1321             bhigh = blow >> (4 * sizeof (UV));
1322             blow &= botmask;
1323             if (ahigh && bhigh) {
1324                 NOOP;
1325                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1326                    which is overflow. Drop to NVs below.  */
1327             } else if (!ahigh && !bhigh) {
1328                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1329                    so the unsigned multiply cannot overflow.  */
1330                 const UV product = alow * blow;
1331                 if (auvok == buvok) {
1332                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1333                     SP--;
1334                     SETu( product );
1335                     RETURN;
1336                 } else if (product <= (UV)IV_MIN) {
1337                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1338                     /* -ve result, which could overflow an IV  */
1339                     SP--;
1340                     /* can't negate IV_MIN, but there are aren't two
1341                      * integers such that !ahigh && !bhigh, where the
1342                      * product equals 0x800....000 */
1343                     assert(product != (UV)IV_MIN);
1344                     SETi( -(IV)product );
1345                     RETURN;
1346                 } /* else drop to NVs below. */
1347             } else {
1348                 /* One operand is large, 1 small */
1349                 UV product_middle;
1350                 if (bhigh) {
1351                     /* swap the operands */
1352                     ahigh = bhigh;
1353                     bhigh = blow; /* bhigh now the temp var for the swap */
1354                     blow = alow;
1355                     alow = bhigh;
1356                 }
1357                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1358                    multiplies can't overflow. shift can, add can, -ve can.  */
1359                 product_middle = ahigh * blow;
1360                 if (!(product_middle & topmask)) {
1361                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1362                     UV product_low;
1363                     product_middle <<= (4 * sizeof (UV));
1364                     product_low = alow * blow;
1365
1366                     /* as for pp_add, UV + something mustn't get smaller.
1367                        IIRC ANSI mandates this wrapping *behaviour* for
1368                        unsigned whatever the actual representation*/
1369                     product_low += product_middle;
1370                     if (product_low >= product_middle) {
1371                         /* didn't overflow */
1372                         if (auvok == buvok) {
1373                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1374                             SP--;
1375                             SETu( product_low );
1376                             RETURN;
1377                         } else if (product_low <= (UV)IV_MIN) {
1378                             /* 2s complement assumption again  */
1379                             /* -ve result, which could overflow an IV  */
1380                             SP--;
1381                             SETi(product_low == (UV)IV_MIN
1382                                     ? IV_MIN : -(IV)product_low);
1383                             RETURN;
1384                         } /* else drop to NVs below. */
1385                     }
1386                 } /* product_middle too large */
1387             } /* ahigh && bhigh */
1388         } /* SvIOK(svl) */
1389     } /* SvIOK(svr) */
1390 #endif
1391     {
1392       NV right = SvNV_nomg(svr);
1393       NV left  = SvNV_nomg(svl);
1394       (void)POPs;
1395       SETn( left * right );
1396       RETURN;
1397     }
1398 }
1399
1400 PP(pp_divide)
1401 {
1402     dSP; dATARGET; SV *svl, *svr;
1403     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1404     svr = TOPs;
1405     svl = TOPm1s;
1406     /* Only try to do UV divide first
1407        if ((SLOPPYDIVIDE is true) or
1408            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1409             to preserve))
1410        The assumption is that it is better to use floating point divide
1411        whenever possible, only doing integer divide first if we can't be sure.
1412        If NV_PRESERVES_UV is true then we know at compile time that no UV
1413        can be too large to preserve, so don't need to compile the code to
1414        test the size of UVs.  */
1415
1416 #ifdef SLOPPYDIVIDE
1417 #  define PERL_TRY_UV_DIVIDE
1418     /* ensure that 20./5. == 4. */
1419 #else
1420 #  ifdef PERL_PRESERVE_IVUV
1421 #    ifndef NV_PRESERVES_UV
1422 #      define PERL_TRY_UV_DIVIDE
1423 #    endif
1424 #  endif
1425 #endif
1426
1427 #ifdef PERL_TRY_UV_DIVIDE
1428     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1429             bool left_non_neg = SvUOK(svl);
1430             bool right_non_neg = SvUOK(svr);
1431             UV left;
1432             UV right;
1433
1434             if (right_non_neg) {
1435                 right = SvUVX(svr);
1436             }
1437             else {
1438                 const IV biv = SvIVX(svr);
1439                 if (biv >= 0) {
1440                     right = biv;
1441                     right_non_neg = TRUE; /* effectively it's a UV now */
1442                 }
1443                 else {
1444                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1445                 }
1446             }
1447             /* historically undef()/0 gives a "Use of uninitialized value"
1448                warning before dieing, hence this test goes here.
1449                If it were immediately before the second SvIV_please, then
1450                DIE() would be invoked before left was even inspected, so
1451                no inspection would give no warning.  */
1452             if (right == 0)
1453                 DIE(aTHX_ "Illegal division by zero");
1454
1455             if (left_non_neg) {
1456                 left = SvUVX(svl);
1457             }
1458             else {
1459                 const IV aiv = SvIVX(svl);
1460                 if (aiv >= 0) {
1461                     left = aiv;
1462                     left_non_neg = TRUE; /* effectively it's a UV now */
1463                 }
1464                 else {
1465                     left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1466                 }
1467             }
1468
1469             if (left >= right
1470 #ifdef SLOPPYDIVIDE
1471                 /* For sloppy divide we always attempt integer division.  */
1472 #else
1473                 /* Otherwise we only attempt it if either or both operands
1474                    would not be preserved by an NV.  If both fit in NVs
1475                    we fall through to the NV divide code below.  However,
1476                    as left >= right to ensure integer result here, we know that
1477                    we can skip the test on the right operand - right big
1478                    enough not to be preserved can't get here unless left is
1479                    also too big.  */
1480
1481                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1482 #endif
1483                 ) {
1484                 /* Integer division can't overflow, but it can be imprecise.  */
1485                 const UV result = left / right;
1486                 if (result * right == left) {
1487                     SP--; /* result is valid */
1488                     if (left_non_neg == right_non_neg) {
1489                         /* signs identical, result is positive.  */
1490                         SETu( result );
1491                         RETURN;
1492                     }
1493                     /* 2s complement assumption */
1494                     if (result <= (UV)IV_MIN)
1495                         SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1496                     else {
1497                         /* It's exact but too negative for IV. */
1498                         SETn( -(NV)result );
1499                     }
1500                     RETURN;
1501                 } /* tried integer divide but it was not an integer result */
1502             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1503     } /* one operand wasn't SvIOK */
1504 #endif /* PERL_TRY_UV_DIVIDE */
1505     {
1506         NV right = SvNV_nomg(svr);
1507         NV left  = SvNV_nomg(svl);
1508         (void)POPs;(void)POPs;
1509 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1510         if (! Perl_isnan(right) && right == 0.0)
1511 #else
1512         if (right == 0.0)
1513 #endif
1514             DIE(aTHX_ "Illegal division by zero");
1515         PUSHn( left / right );
1516         RETURN;
1517     }
1518 }
1519
1520 PP(pp_modulo)
1521 {
1522     dSP; dATARGET;
1523     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1524     {
1525         UV left  = 0;
1526         UV right = 0;
1527         bool left_neg = FALSE;
1528         bool right_neg = FALSE;
1529         bool use_double = FALSE;
1530         bool dright_valid = FALSE;
1531         NV dright = 0.0;
1532         NV dleft  = 0.0;
1533         SV * const svr = TOPs;
1534         SV * const svl = TOPm1s;
1535         if (SvIV_please_nomg(svr)) {
1536             right_neg = !SvUOK(svr);
1537             if (!right_neg) {
1538                 right = SvUVX(svr);
1539             } else {
1540                 const IV biv = SvIVX(svr);
1541                 if (biv >= 0) {
1542                     right = biv;
1543                     right_neg = FALSE; /* effectively it's a UV now */
1544                 } else {
1545                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1546                 }
1547             }
1548         }
1549         else {
1550             dright = SvNV_nomg(svr);
1551             right_neg = dright < 0;
1552             if (right_neg)
1553                 dright = -dright;
1554             if (dright < UV_MAX_P1) {
1555                 right = U_V(dright);
1556                 dright_valid = TRUE; /* In case we need to use double below.  */
1557             } else {
1558                 use_double = TRUE;
1559             }
1560         }
1561
1562         /* At this point use_double is only true if right is out of range for
1563            a UV.  In range NV has been rounded down to nearest UV and
1564            use_double false.  */
1565         if (!use_double && SvIV_please_nomg(svl)) {
1566                 left_neg = !SvUOK(svl);
1567                 if (!left_neg) {
1568                     left = SvUVX(svl);
1569                 } else {
1570                     const IV aiv = SvIVX(svl);
1571                     if (aiv >= 0) {
1572                         left = aiv;
1573                         left_neg = FALSE; /* effectively it's a UV now */
1574                     } else {
1575                         left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1576                     }
1577                 }
1578         }
1579         else {
1580             dleft = SvNV_nomg(svl);
1581             left_neg = dleft < 0;
1582             if (left_neg)
1583                 dleft = -dleft;
1584
1585             /* This should be exactly the 5.6 behaviour - if left and right are
1586                both in range for UV then use U_V() rather than floor.  */
1587             if (!use_double) {
1588                 if (dleft < UV_MAX_P1) {
1589                     /* right was in range, so is dleft, so use UVs not double.
1590                      */
1591                     left = U_V(dleft);
1592                 }
1593                 /* left is out of range for UV, right was in range, so promote
1594                    right (back) to double.  */
1595                 else {
1596                     /* The +0.5 is used in 5.6 even though it is not strictly
1597                        consistent with the implicit +0 floor in the U_V()
1598                        inside the #if 1. */
1599                     dleft = Perl_floor(dleft + 0.5);
1600                     use_double = TRUE;
1601                     if (dright_valid)
1602                         dright = Perl_floor(dright + 0.5);
1603                     else
1604                         dright = right;
1605                 }
1606             }
1607         }
1608         sp -= 2;
1609         if (use_double) {
1610             NV dans;
1611
1612             if (!dright)
1613                 DIE(aTHX_ "Illegal modulus zero");
1614
1615             dans = Perl_fmod(dleft, dright);
1616             if ((left_neg != right_neg) && dans)
1617                 dans = dright - dans;
1618             if (right_neg)
1619                 dans = -dans;
1620             sv_setnv(TARG, dans);
1621         }
1622         else {
1623             UV ans;
1624
1625             if (!right)
1626                 DIE(aTHX_ "Illegal modulus zero");
1627
1628             ans = left % right;
1629             if ((left_neg != right_neg) && ans)
1630                 ans = right - ans;
1631             if (right_neg) {
1632                 /* XXX may warn: unary minus operator applied to unsigned type */
1633                 /* could change -foo to be (~foo)+1 instead     */
1634                 if (ans <= ~((UV)IV_MAX)+1)
1635                     sv_setiv(TARG, ~ans+1);
1636                 else
1637                     sv_setnv(TARG, -(NV)ans);
1638             }
1639             else
1640                 sv_setuv(TARG, ans);
1641         }
1642         PUSHTARG;
1643         RETURN;
1644     }
1645 }
1646
1647 PP(pp_repeat)
1648 {
1649     dSP; dATARGET;
1650     IV count;
1651     SV *sv;
1652     bool infnan = FALSE;
1653
1654     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1655         /* TODO: think of some way of doing list-repeat overloading ??? */
1656         sv = POPs;
1657         SvGETMAGIC(sv);
1658     }
1659     else {
1660         if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1661             /* The parser saw this as a list repeat, and there
1662                are probably several items on the stack. But we're
1663                in scalar/void context, and there's no pp_list to save us
1664                now. So drop the rest of the items -- robin@kitsite.com
1665              */
1666             dMARK;
1667             if (MARK + 1 < SP) {
1668                 MARK[1] = TOPm1s;
1669                 MARK[2] = TOPs;
1670             }
1671             else {
1672                 dTOPss;
1673                 ASSUME(MARK + 1 == SP);
1674                 XPUSHs(sv);
1675                 MARK[1] = &PL_sv_undef;
1676             }
1677             SP = MARK + 2;
1678         }
1679         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1680         sv = POPs;
1681     }
1682
1683     if (SvIOKp(sv)) {
1684          if (SvUOK(sv)) {
1685               const UV uv = SvUV_nomg(sv);
1686               if (uv > IV_MAX)
1687                    count = IV_MAX; /* The best we can do? */
1688               else
1689                    count = uv;
1690          } else {
1691               count = SvIV_nomg(sv);
1692          }
1693     }
1694     else if (SvNOKp(sv)) {
1695         const NV nv = SvNV_nomg(sv);
1696         infnan = Perl_isinfnan(nv);
1697         if (UNLIKELY(infnan)) {
1698             count = 0;
1699         } else {
1700             if (nv < 0.0)
1701                 count = -1;   /* An arbitrary negative integer */
1702             else
1703                 count = (IV)nv;
1704         }
1705     }
1706     else
1707         count = SvIV_nomg(sv);
1708
1709     if (infnan) {
1710         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1711                        "Non-finite repeat count does nothing");
1712     } else if (count < 0) {
1713         count = 0;
1714         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1715                        "Negative repeat count does nothing");
1716     }
1717
1718     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1719         dMARK;
1720         const Size_t items = SP - MARK;
1721         const U8 mod = PL_op->op_flags & OPf_MOD;
1722
1723         if (count > 1) {
1724             Size_t max;
1725
1726             if (  items > MEM_SIZE_MAX / (UV)count   /* max would overflow */
1727                || items > (U32)I32_MAX / sizeof(SV *) /* repeatcpy would overflow */
1728             )
1729                Perl_croak(aTHX_ "%s","Out of memory during list extend");
1730             max = items * count;
1731             MEXTEND(MARK, max);
1732
1733             while (SP > MARK) {
1734                 if (*SP) {
1735                    if (mod && SvPADTMP(*SP)) {
1736                        *SP = sv_mortalcopy(*SP);
1737                    }
1738                    SvTEMP_off((*SP));
1739                 }
1740                 SP--;
1741             }
1742             MARK++;
1743             repeatcpy((char*)(MARK + items), (char*)MARK,
1744                 items * sizeof(const SV *), count - 1);
1745             SP += max;
1746         }
1747         else if (count <= 0)
1748             SP -= items;
1749     }
1750     else {      /* Note: mark already snarfed by pp_list */
1751         SV * const tmpstr = POPs;
1752         STRLEN len;
1753         bool isutf;
1754
1755         if (TARG != tmpstr)
1756             sv_setsv_nomg(TARG, tmpstr);
1757         SvPV_force_nomg(TARG, len);
1758         isutf = DO_UTF8(TARG);
1759         if (count != 1) {
1760             if (count < 1)
1761                 SvCUR_set(TARG, 0);
1762             else {
1763                 STRLEN max;
1764
1765                 if (   len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1766                     || len > (U32)I32_MAX  /* repeatcpy would overflow */
1767                 )
1768                      Perl_croak(aTHX_ "%s",
1769                                         "Out of memory during string extend");
1770                 max = (UV)count * len + 1;
1771                 SvGROW(TARG, max);
1772
1773                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1774                 SvCUR_set(TARG, SvCUR(TARG) * count);
1775             }
1776             *SvEND(TARG) = '\0';
1777         }
1778         if (isutf)
1779             (void)SvPOK_only_UTF8(TARG);
1780         else
1781             (void)SvPOK_only(TARG);
1782
1783         PUSHTARG;
1784     }
1785     RETURN;
1786 }
1787
1788 PP(pp_subtract)
1789 {
1790     dSP; dATARGET; bool useleft; SV *svl, *svr;
1791     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1792     svr = TOPs;
1793     svl = TOPm1s;
1794     useleft = USE_LEFT(svl);
1795 #ifdef PERL_PRESERVE_IVUV
1796     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1797        "bad things" happen if you rely on signed integers wrapping.  */
1798     if (SvIV_please_nomg(svr)) {
1799         /* Unless the left argument is integer in range we are going to have to
1800            use NV maths. Hence only attempt to coerce the right argument if
1801            we know the left is integer.  */
1802         UV auv = 0;
1803         bool auvok = FALSE;
1804         bool a_valid = 0;
1805
1806         if (!useleft) {
1807             auv = 0;
1808             a_valid = auvok = 1;
1809             /* left operand is undef, treat as zero.  */
1810         } else {
1811             /* Left operand is defined, so is it IV? */
1812             if (SvIV_please_nomg(svl)) {
1813                 if ((auvok = SvUOK(svl)))
1814                     auv = SvUVX(svl);
1815                 else {
1816                     const IV aiv = SvIVX(svl);
1817                     if (aiv >= 0) {
1818                         auv = aiv;
1819                         auvok = 1;      /* Now acting as a sign flag.  */
1820                     } else { /* 2s complement assumption for IV_MIN */
1821                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
1822                     }
1823                 }
1824                 a_valid = 1;
1825             }
1826         }
1827         if (a_valid) {
1828             bool result_good = 0;
1829             UV result;
1830             UV buv;
1831             bool buvok = SvUOK(svr);
1832         
1833             if (buvok)
1834                 buv = SvUVX(svr);
1835             else {
1836                 const IV biv = SvIVX(svr);
1837                 if (biv >= 0) {
1838                     buv = biv;
1839                     buvok = 1;
1840                 } else
1841                     buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
1842             }
1843             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1844                else "IV" now, independent of how it came in.
1845                if a, b represents positive, A, B negative, a maps to -A etc
1846                a - b =>  (a - b)
1847                A - b => -(a + b)
1848                a - B =>  (a + b)
1849                A - B => -(a - b)
1850                all UV maths. negate result if A negative.
1851                subtract if signs same, add if signs differ. */
1852
1853             if (auvok ^ buvok) {
1854                 /* Signs differ.  */
1855                 result = auv + buv;
1856                 if (result >= auv)
1857                     result_good = 1;
1858             } else {
1859                 /* Signs same */
1860                 if (auv >= buv) {
1861                     result = auv - buv;
1862                     /* Must get smaller */
1863                     if (result <= auv)
1864                         result_good = 1;
1865                 } else {
1866                     result = buv - auv;
1867                     if (result <= buv) {
1868                         /* result really should be -(auv-buv). as its negation
1869                            of true value, need to swap our result flag  */
1870                         auvok = !auvok;
1871                         result_good = 1;
1872                     }
1873                 }
1874             }
1875             if (result_good) {
1876                 SP--;
1877                 if (auvok)
1878                     SETu( result );
1879                 else {
1880                     /* Negate result */
1881                     if (result <= (UV)IV_MIN)
1882                         SETi(result == (UV)IV_MIN
1883                                 ? IV_MIN : -(IV)result);
1884                     else {
1885                         /* result valid, but out of range for IV.  */
1886                         SETn( -(NV)result );
1887                     }
1888                 }
1889                 RETURN;
1890             } /* Overflow, drop through to NVs.  */
1891         }
1892     }
1893 #endif
1894     {
1895         NV value = SvNV_nomg(svr);
1896         (void)POPs;
1897
1898         if (!useleft) {
1899             /* left operand is undef, treat as zero - value */
1900             SETn(-value);
1901             RETURN;
1902         }
1903         SETn( SvNV_nomg(svl) - value );
1904         RETURN;
1905     }
1906 }
1907
1908 #define IV_BITS (IVSIZE * 8)
1909
1910 static UV S_uv_shift(UV uv, int shift, bool left)
1911 {
1912    if (shift < 0) {
1913        shift = -shift;
1914        left = !left;
1915    }
1916    if (shift >= IV_BITS) {
1917        return 0;
1918    }
1919    return left ? uv << shift : uv >> shift;
1920 }
1921
1922 static IV S_iv_shift(IV iv, int shift, bool left)
1923 {
1924    if (shift < 0) {
1925        shift = -shift;
1926        left = !left;
1927    }
1928    if (shift >= IV_BITS) {
1929        return iv < 0 && !left ? -1 : 0;
1930    }
1931    return left ? iv << shift : iv >> shift;
1932 }
1933
1934 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
1935 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
1936 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
1937 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
1938
1939 PP(pp_left_shift)
1940 {
1941     dSP; dATARGET; SV *svl, *svr;
1942     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1943     svr = POPs;
1944     svl = TOPs;
1945     {
1946       const IV shift = SvIV_nomg(svr);
1947       if (PL_op->op_private & HINT_INTEGER) {
1948           SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
1949       }
1950       else {
1951           SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
1952       }
1953       RETURN;
1954     }
1955 }
1956
1957 PP(pp_right_shift)
1958 {
1959     dSP; dATARGET; SV *svl, *svr;
1960     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1961     svr = POPs;
1962     svl = TOPs;
1963     {
1964       const IV shift = SvIV_nomg(svr);
1965       if (PL_op->op_private & HINT_INTEGER) {
1966           SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
1967       }
1968       else {
1969           SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
1970       }
1971       RETURN;
1972     }
1973 }
1974
1975 PP(pp_lt)
1976 {
1977     dSP;
1978     SV *left, *right;
1979
1980     tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1981     right = POPs;
1982     left  = TOPs;
1983     SETs(boolSV(
1984         (SvIOK_notUV(left) && SvIOK_notUV(right))
1985         ? (SvIVX(left) < SvIVX(right))
1986         : (do_ncmp(left, right) == -1)
1987     ));
1988     RETURN;
1989 }
1990
1991 PP(pp_gt)
1992 {
1993     dSP;
1994     SV *left, *right;
1995
1996     tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1997     right = POPs;
1998     left  = TOPs;
1999     SETs(boolSV(
2000         (SvIOK_notUV(left) && SvIOK_notUV(right))
2001         ? (SvIVX(left) > SvIVX(right))
2002         : (do_ncmp(left, right) == 1)
2003     ));
2004     RETURN;
2005 }
2006
2007 PP(pp_le)
2008 {
2009     dSP;
2010     SV *left, *right;
2011
2012     tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2013     right = POPs;
2014     left  = TOPs;
2015     SETs(boolSV(
2016         (SvIOK_notUV(left) && SvIOK_notUV(right))
2017         ? (SvIVX(left) <= SvIVX(right))
2018         : (do_ncmp(left, right) <= 0)
2019     ));
2020     RETURN;
2021 }
2022
2023 PP(pp_ge)
2024 {
2025     dSP;
2026     SV *left, *right;
2027
2028     tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2029     right = POPs;
2030     left  = TOPs;
2031     SETs(boolSV(
2032         (SvIOK_notUV(left) && SvIOK_notUV(right))
2033         ? (SvIVX(left) >= SvIVX(right))
2034         : ( (do_ncmp(left, right) & 2) == 0)
2035     ));
2036     RETURN;
2037 }
2038
2039 PP(pp_ne)
2040 {
2041     dSP;
2042     SV *left, *right;
2043
2044     tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2045     right = POPs;
2046     left  = TOPs;
2047     SETs(boolSV(
2048         (SvIOK_notUV(left) && SvIOK_notUV(right))
2049         ? (SvIVX(left) != SvIVX(right))
2050         : (do_ncmp(left, right) != 0)
2051     ));
2052     RETURN;
2053 }
2054
2055 /* compare left and right SVs. Returns:
2056  * -1: <
2057  *  0: ==
2058  *  1: >
2059  *  2: left or right was a NaN
2060  */
2061 I32
2062 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2063 {
2064     PERL_ARGS_ASSERT_DO_NCMP;
2065 #ifdef PERL_PRESERVE_IVUV
2066     /* Fortunately it seems NaN isn't IOK */
2067     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2068             if (!SvUOK(left)) {
2069                 const IV leftiv = SvIVX(left);
2070                 if (!SvUOK(right)) {
2071                     /* ## IV <=> IV ## */
2072                     const IV rightiv = SvIVX(right);
2073                     return (leftiv > rightiv) - (leftiv < rightiv);
2074                 }
2075                 /* ## IV <=> UV ## */
2076                 if (leftiv < 0)
2077                     /* As (b) is a UV, it's >=0, so it must be < */
2078                     return -1;
2079                 {
2080                     const UV rightuv = SvUVX(right);
2081                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2082                 }
2083             }
2084
2085             if (SvUOK(right)) {
2086                 /* ## UV <=> UV ## */
2087                 const UV leftuv = SvUVX(left);
2088                 const UV rightuv = SvUVX(right);
2089                 return (leftuv > rightuv) - (leftuv < rightuv);
2090             }
2091             /* ## UV <=> IV ## */
2092             {
2093                 const IV rightiv = SvIVX(right);
2094                 if (rightiv < 0)
2095                     /* As (a) is a UV, it's >=0, so it cannot be < */
2096                     return 1;
2097                 {
2098                     const UV leftuv = SvUVX(left);
2099                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2100                 }
2101             }
2102             NOT_REACHED; /* NOTREACHED */
2103     }
2104 #endif
2105     {
2106       NV const rnv = SvNV_nomg(right);
2107       NV const lnv = SvNV_nomg(left);
2108
2109 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2110       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2111           return 2;
2112        }
2113       return (lnv > rnv) - (lnv < rnv);
2114 #else
2115       if (lnv < rnv)
2116         return -1;
2117       if (lnv > rnv)
2118         return 1;
2119       if (lnv == rnv)
2120         return 0;
2121       return 2;
2122 #endif
2123     }
2124 }
2125
2126
2127 PP(pp_ncmp)
2128 {
2129     dSP;
2130     SV *left, *right;
2131     I32 value;
2132     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2133     right = POPs;
2134     left  = TOPs;
2135     value = do_ncmp(left, right);
2136     if (value == 2) {
2137         SETs(&PL_sv_undef);
2138     }
2139     else {
2140         dTARGET;
2141         SETi(value);
2142     }
2143     RETURN;
2144 }
2145
2146
2147 /* also used for: pp_sge() pp_sgt() pp_slt() */
2148
2149 PP(pp_sle)
2150 {
2151     dSP;
2152
2153     int amg_type = sle_amg;
2154     int multiplier = 1;
2155     int rhs = 1;
2156
2157     switch (PL_op->op_type) {
2158     case OP_SLT:
2159         amg_type = slt_amg;
2160         /* cmp < 0 */
2161         rhs = 0;
2162         break;
2163     case OP_SGT:
2164         amg_type = sgt_amg;
2165         /* cmp > 0 */
2166         multiplier = -1;
2167         rhs = 0;
2168         break;
2169     case OP_SGE:
2170         amg_type = sge_amg;
2171         /* cmp >= 0 */
2172         multiplier = -1;
2173         break;
2174     }
2175
2176     tryAMAGICbin_MG(amg_type, AMGf_set);
2177     {
2178       dPOPTOPssrl;
2179       const int cmp =
2180 #ifdef USE_LOCALE_COLLATE
2181                       (IN_LC_RUNTIME(LC_COLLATE))
2182                       ? sv_cmp_locale_flags(left, right, 0)
2183                       :
2184 #endif
2185                         sv_cmp_flags(left, right, 0);
2186       SETs(boolSV(cmp * multiplier < rhs));
2187       RETURN;
2188     }
2189 }
2190
2191 PP(pp_seq)
2192 {
2193     dSP;
2194     tryAMAGICbin_MG(seq_amg, AMGf_set);
2195     {
2196       dPOPTOPssrl;
2197       SETs(boolSV(sv_eq_flags(left, right, 0)));
2198       RETURN;
2199     }
2200 }
2201
2202 PP(pp_sne)
2203 {
2204     dSP;
2205     tryAMAGICbin_MG(sne_amg, AMGf_set);
2206     {
2207       dPOPTOPssrl;
2208       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2209       RETURN;
2210     }
2211 }
2212
2213 PP(pp_scmp)
2214 {
2215     dSP; dTARGET;
2216     tryAMAGICbin_MG(scmp_amg, 0);
2217     {
2218       dPOPTOPssrl;
2219       const int cmp =
2220 #ifdef USE_LOCALE_COLLATE
2221                       (IN_LC_RUNTIME(LC_COLLATE))
2222                       ? sv_cmp_locale_flags(left, right, 0)
2223                       :
2224 #endif
2225                         sv_cmp_flags(left, right, 0);
2226       SETi( cmp );
2227       RETURN;
2228     }
2229 }
2230
2231 PP(pp_bit_and)
2232 {
2233     dSP; dATARGET;
2234     tryAMAGICbin_MG(band_amg, AMGf_assign);
2235     {
2236       dPOPTOPssrl;
2237       if (SvNIOKp(left) || SvNIOKp(right)) {
2238         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2239         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2240         if (PL_op->op_private & HINT_INTEGER) {
2241           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2242           SETi(i);
2243         }
2244         else {
2245           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2246           SETu(u);
2247         }
2248         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2249         if (right_ro_nonnum) SvNIOK_off(right);
2250       }
2251       else {
2252         do_vop(PL_op->op_type, TARG, left, right);
2253         SETTARG;
2254       }
2255       RETURN;
2256     }
2257 }
2258
2259 PP(pp_nbit_and)
2260 {
2261     dSP;
2262     tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2263     {
2264         dATARGET; dPOPTOPssrl;
2265         if (PL_op->op_private & HINT_INTEGER) {
2266           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2267           SETi(i);
2268         }
2269         else {
2270           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2271           SETu(u);
2272         }
2273     }
2274     RETURN;
2275 }
2276
2277 PP(pp_sbit_and)
2278 {
2279     dSP;
2280     tryAMAGICbin_MG(sband_amg, AMGf_assign);
2281     {
2282         dATARGET; dPOPTOPssrl;
2283         do_vop(OP_BIT_AND, TARG, left, right);
2284         RETSETTARG;
2285     }
2286 }
2287
2288 /* also used for: pp_bit_xor() */
2289
2290 PP(pp_bit_or)
2291 {
2292     dSP; dATARGET;
2293     const int op_type = PL_op->op_type;
2294
2295     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2296     {
2297       dPOPTOPssrl;
2298       if (SvNIOKp(left) || SvNIOKp(right)) {
2299         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2300         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2301         if (PL_op->op_private & HINT_INTEGER) {
2302           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2303           const IV r = SvIV_nomg(right);
2304           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2305           SETi(result);
2306         }
2307         else {
2308           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2309           const UV r = SvUV_nomg(right);
2310           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2311           SETu(result);
2312         }
2313         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2314         if (right_ro_nonnum) SvNIOK_off(right);
2315       }
2316       else {
2317         do_vop(op_type, TARG, left, right);
2318         SETTARG;
2319       }
2320       RETURN;
2321     }
2322 }
2323
2324 /* also used for: pp_nbit_xor() */
2325
2326 PP(pp_nbit_or)
2327 {
2328     dSP;
2329     const int op_type = PL_op->op_type;
2330
2331     tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2332                     AMGf_assign|AMGf_numarg);
2333     {
2334         dATARGET; dPOPTOPssrl;
2335         if (PL_op->op_private & HINT_INTEGER) {
2336           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2337           const IV r = SvIV_nomg(right);
2338           const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2339           SETi(result);
2340         }
2341         else {
2342           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2343           const UV r = SvUV_nomg(right);
2344           const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2345           SETu(result);
2346         }
2347     }
2348     RETURN;
2349 }
2350
2351 /* also used for: pp_sbit_xor() */
2352
2353 PP(pp_sbit_or)
2354 {
2355     dSP;
2356     const int op_type = PL_op->op_type;
2357
2358     tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2359                     AMGf_assign);
2360     {
2361         dATARGET; dPOPTOPssrl;
2362         do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2363                right);
2364         RETSETTARG;
2365     }
2366 }
2367
2368 PERL_STATIC_INLINE bool
2369 S_negate_string(pTHX)
2370 {
2371     dTARGET; dSP;
2372     STRLEN len;
2373     const char *s;
2374     SV * const sv = TOPs;
2375     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2376         return FALSE;
2377     s = SvPV_nomg_const(sv, len);
2378     if (isIDFIRST(*s)) {
2379         sv_setpvs(TARG, "-");
2380         sv_catsv(TARG, sv);
2381     }
2382     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2383         sv_setsv_nomg(TARG, sv);
2384         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2385     }
2386     else return FALSE;
2387     SETTARG;
2388     return TRUE;
2389 }
2390
2391 PP(pp_negate)
2392 {
2393     dSP; dTARGET;
2394     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2395     if (S_negate_string(aTHX)) return NORMAL;
2396     {
2397         SV * const sv = TOPs;
2398
2399         if (SvIOK(sv)) {
2400             /* It's publicly an integer */
2401         oops_its_an_int:
2402             if (SvIsUV(sv)) {
2403                 if (SvIVX(sv) == IV_MIN) {
2404                     /* 2s complement assumption. */
2405                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2406                                            IV_MIN */
2407                     return NORMAL;
2408                 }
2409                 else if (SvUVX(sv) <= IV_MAX) {
2410                     SETi(-SvIVX(sv));
2411                     return NORMAL;
2412                 }
2413             }
2414             else if (SvIVX(sv) != IV_MIN) {
2415                 SETi(-SvIVX(sv));
2416                 return NORMAL;
2417             }
2418 #ifdef PERL_PRESERVE_IVUV
2419             else {
2420                 SETu((UV)IV_MIN);
2421                 return NORMAL;
2422             }
2423 #endif
2424         }
2425         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2426             SETn(-SvNV_nomg(sv));
2427         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2428                   goto oops_its_an_int;
2429         else
2430             SETn(-SvNV_nomg(sv));
2431     }
2432     return NORMAL;
2433 }
2434
2435 PP(pp_not)
2436 {
2437     dSP;
2438     tryAMAGICun_MG(not_amg, AMGf_set);
2439     *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2440     return NORMAL;
2441 }
2442
2443 static void
2444 S_scomplement(pTHX_ SV *targ, SV *sv)
2445 {
2446         U8 *tmps;
2447         I32 anum;
2448         STRLEN len;
2449
2450         sv_copypv_nomg(TARG, sv);
2451         tmps = (U8*)SvPV_nomg(TARG, len);
2452         anum = len;
2453         if (SvUTF8(TARG)) {
2454           /* Calculate exact length, let's not estimate. */
2455           STRLEN targlen = 0;
2456           STRLEN l;
2457           UV nchar = 0;
2458           UV nwide = 0;
2459           U8 * const send = tmps + len;
2460           U8 * const origtmps = tmps;
2461           const UV utf8flags = UTF8_ALLOW_ANYUV;
2462
2463           while (tmps < send) {
2464             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2465             tmps += l;
2466             targlen += UNISKIP(~c);
2467             nchar++;
2468             if (c > 0xff)
2469                 nwide++;
2470           }
2471
2472           /* Now rewind strings and write them. */
2473           tmps = origtmps;
2474
2475           if (nwide) {
2476               U8 *result;
2477               U8 *p;
2478
2479               Newx(result, targlen + 1, U8);
2480               p = result;
2481               while (tmps < send) {
2482                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2483                   tmps += l;
2484                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2485               }
2486               *p = '\0';
2487               sv_usepvn_flags(TARG, (char*)result, targlen,
2488                               SV_HAS_TRAILING_NUL);
2489               SvUTF8_on(TARG);
2490           }
2491           else {
2492               U8 *result;
2493               U8 *p;
2494
2495               Newx(result, nchar + 1, U8);
2496               p = result;
2497               while (tmps < send) {
2498                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2499                   tmps += l;
2500                   *p++ = ~c;
2501               }
2502               *p = '\0';
2503               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2504               SvUTF8_off(TARG);
2505           }
2506           return;
2507         }
2508 #ifdef LIBERAL
2509         {
2510             long *tmpl;
2511             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2512                 *tmps = ~*tmps;
2513             tmpl = (long*)tmps;
2514             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2515                 *tmpl = ~*tmpl;
2516             tmps = (U8*)tmpl;
2517         }
2518 #endif
2519         for ( ; anum > 0; anum--, tmps++)
2520             *tmps = ~*tmps;
2521 }
2522
2523 PP(pp_complement)
2524 {
2525     dSP; dTARGET;
2526     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2527     {
2528       dTOPss;
2529       if (SvNIOKp(sv)) {
2530         if (PL_op->op_private & HINT_INTEGER) {
2531           const IV i = ~SvIV_nomg(sv);
2532           SETi(i);
2533         }
2534         else {
2535           const UV u = ~SvUV_nomg(sv);
2536           SETu(u);
2537         }
2538       }
2539       else {
2540         S_scomplement(aTHX_ TARG, sv);
2541         SETTARG;
2542       }
2543       return NORMAL;
2544     }
2545 }
2546
2547 PP(pp_ncomplement)
2548 {
2549     dSP;
2550     tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2551     {
2552         dTARGET; dTOPss;
2553         if (PL_op->op_private & HINT_INTEGER) {
2554           const IV i = ~SvIV_nomg(sv);
2555           SETi(i);
2556         }
2557         else {
2558           const UV u = ~SvUV_nomg(sv);
2559           SETu(u);
2560         }
2561     }
2562     return NORMAL;
2563 }
2564
2565 PP(pp_scomplement)
2566 {
2567     dSP;
2568     tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2569     {
2570         dTARGET; dTOPss;
2571         S_scomplement(aTHX_ TARG, sv);
2572         SETTARG;
2573         return NORMAL;
2574     }
2575 }
2576
2577 /* integer versions of some of the above */
2578
2579 PP(pp_i_multiply)
2580 {
2581     dSP; dATARGET;
2582     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2583     {
2584       dPOPTOPiirl_nomg;
2585       SETi( left * right );
2586       RETURN;
2587     }
2588 }
2589
2590 PP(pp_i_divide)
2591 {
2592     IV num;
2593     dSP; dATARGET;
2594     tryAMAGICbin_MG(div_amg, AMGf_assign);
2595     {
2596       dPOPTOPssrl;
2597       IV value = SvIV_nomg(right);
2598       if (value == 0)
2599           DIE(aTHX_ "Illegal division by zero");
2600       num = SvIV_nomg(left);
2601
2602       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2603       if (value == -1)
2604           value = - num;
2605       else
2606           value = num / value;
2607       SETi(value);
2608       RETURN;
2609     }
2610 }
2611
2612 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2613     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2614 STATIC
2615 PP(pp_i_modulo_0)
2616 #else
2617 PP(pp_i_modulo)
2618 #endif
2619 {
2620      /* This is the vanilla old i_modulo. */
2621      dSP; dATARGET;
2622      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2623      {
2624           dPOPTOPiirl_nomg;
2625           if (!right)
2626                DIE(aTHX_ "Illegal modulus zero");
2627           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2628           if (right == -1)
2629               SETi( 0 );
2630           else
2631               SETi( left % right );
2632           RETURN;
2633      }
2634 }
2635
2636 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2637     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2638 STATIC
2639 PP(pp_i_modulo_1)
2640
2641 {
2642      /* This is the i_modulo with the workaround for the _moddi3 bug
2643       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2644       * See below for pp_i_modulo. */
2645      dSP; dATARGET;
2646      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2647      {
2648           dPOPTOPiirl_nomg;
2649           if (!right)
2650                DIE(aTHX_ "Illegal modulus zero");
2651           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2652           if (right == -1)
2653               SETi( 0 );
2654           else
2655               SETi( left % PERL_ABS(right) );
2656           RETURN;
2657      }
2658 }
2659
2660 PP(pp_i_modulo)
2661 {
2662      dVAR; dSP; dATARGET;
2663      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2664      {
2665           dPOPTOPiirl_nomg;
2666           if (!right)
2667                DIE(aTHX_ "Illegal modulus zero");
2668           /* The assumption is to use hereafter the old vanilla version... */
2669           PL_op->op_ppaddr =
2670                PL_ppaddr[OP_I_MODULO] =
2671                    Perl_pp_i_modulo_0;
2672           /* .. but if we have glibc, we might have a buggy _moddi3
2673            * (at least glibc 2.2.5 is known to have this bug), in other
2674            * words our integer modulus with negative quad as the second
2675            * argument might be broken.  Test for this and re-patch the
2676            * opcode dispatch table if that is the case, remembering to
2677            * also apply the workaround so that this first round works
2678            * right, too.  See [perl #9402] for more information. */
2679           {
2680                IV l =   3;
2681                IV r = -10;
2682                /* Cannot do this check with inlined IV constants since
2683                 * that seems to work correctly even with the buggy glibc. */
2684                if (l % r == -3) {
2685                     /* Yikes, we have the bug.
2686                      * Patch in the workaround version. */
2687                     PL_op->op_ppaddr =
2688                          PL_ppaddr[OP_I_MODULO] =
2689                              &Perl_pp_i_modulo_1;
2690                     /* Make certain we work right this time, too. */
2691                     right = PERL_ABS(right);
2692                }
2693           }
2694           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2695           if (right == -1)
2696               SETi( 0 );
2697           else
2698               SETi( left % right );
2699           RETURN;
2700      }
2701 }
2702 #endif
2703
2704 PP(pp_i_add)
2705 {
2706     dSP; dATARGET;
2707     tryAMAGICbin_MG(add_amg, AMGf_assign);
2708     {
2709       dPOPTOPiirl_ul_nomg;
2710       SETi( left + right );
2711       RETURN;
2712     }
2713 }
2714
2715 PP(pp_i_subtract)
2716 {
2717     dSP; dATARGET;
2718     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2719     {
2720       dPOPTOPiirl_ul_nomg;
2721       SETi( left - right );
2722       RETURN;
2723     }
2724 }
2725
2726 PP(pp_i_lt)
2727 {
2728     dSP;
2729     tryAMAGICbin_MG(lt_amg, AMGf_set);
2730     {
2731       dPOPTOPiirl_nomg;
2732       SETs(boolSV(left < right));
2733       RETURN;
2734     }
2735 }
2736
2737 PP(pp_i_gt)
2738 {
2739     dSP;
2740     tryAMAGICbin_MG(gt_amg, AMGf_set);
2741     {
2742       dPOPTOPiirl_nomg;
2743       SETs(boolSV(left > right));
2744       RETURN;
2745     }
2746 }
2747
2748 PP(pp_i_le)
2749 {
2750     dSP;
2751     tryAMAGICbin_MG(le_amg, AMGf_set);
2752     {
2753       dPOPTOPiirl_nomg;
2754       SETs(boolSV(left <= right));
2755       RETURN;
2756     }
2757 }
2758
2759 PP(pp_i_ge)
2760 {
2761     dSP;
2762     tryAMAGICbin_MG(ge_amg, AMGf_set);
2763     {
2764       dPOPTOPiirl_nomg;
2765       SETs(boolSV(left >= right));
2766       RETURN;
2767     }
2768 }
2769
2770 PP(pp_i_eq)
2771 {
2772     dSP;
2773     tryAMAGICbin_MG(eq_amg, AMGf_set);
2774     {
2775       dPOPTOPiirl_nomg;
2776       SETs(boolSV(left == right));
2777       RETURN;
2778     }
2779 }
2780
2781 PP(pp_i_ne)
2782 {
2783     dSP;
2784     tryAMAGICbin_MG(ne_amg, AMGf_set);
2785     {
2786       dPOPTOPiirl_nomg;
2787       SETs(boolSV(left != right));
2788       RETURN;
2789     }
2790 }
2791
2792 PP(pp_i_ncmp)
2793 {
2794     dSP; dTARGET;
2795     tryAMAGICbin_MG(ncmp_amg, 0);
2796     {
2797       dPOPTOPiirl_nomg;
2798       I32 value;
2799
2800       if (left > right)
2801         value = 1;
2802       else if (left < right)
2803         value = -1;
2804       else
2805         value = 0;
2806       SETi(value);
2807       RETURN;
2808     }
2809 }
2810
2811 PP(pp_i_negate)
2812 {
2813     dSP; dTARGET;
2814     tryAMAGICun_MG(neg_amg, 0);
2815     if (S_negate_string(aTHX)) return NORMAL;
2816     {
2817         SV * const sv = TOPs;
2818         IV const i = SvIV_nomg(sv);
2819         SETi(-i);
2820         return NORMAL;
2821     }
2822 }
2823
2824 /* High falutin' math. */
2825
2826 PP(pp_atan2)
2827 {
2828     dSP; dTARGET;
2829     tryAMAGICbin_MG(atan2_amg, 0);
2830     {
2831       dPOPTOPnnrl_nomg;
2832       SETn(Perl_atan2(left, right));
2833       RETURN;
2834     }
2835 }
2836
2837
2838 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2839
2840 PP(pp_sin)
2841 {
2842     dSP; dTARGET;
2843     int amg_type = fallback_amg;
2844     const char *neg_report = NULL;
2845     const int op_type = PL_op->op_type;
2846
2847     switch (op_type) {
2848     case OP_SIN:  amg_type = sin_amg; break;
2849     case OP_COS:  amg_type = cos_amg; break;
2850     case OP_EXP:  amg_type = exp_amg; break;
2851     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2852     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2853     }
2854
2855     assert(amg_type != fallback_amg);
2856
2857     tryAMAGICun_MG(amg_type, 0);
2858     {
2859       SV * const arg = TOPs;
2860       const NV value = SvNV_nomg(arg);
2861       NV result = NV_NAN;
2862       if (neg_report) { /* log or sqrt */
2863           if (
2864 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2865               ! Perl_isnan(value) &&
2866 #endif
2867               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2868               SET_NUMERIC_STANDARD();
2869               /* diag_listed_as: Can't take log of %g */
2870               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2871           }
2872       }
2873       switch (op_type) {
2874       default:
2875       case OP_SIN:  result = Perl_sin(value);  break;
2876       case OP_COS:  result = Perl_cos(value);  break;
2877       case OP_EXP:  result = Perl_exp(value);  break;
2878       case OP_LOG:  result = Perl_log(value);  break;
2879       case OP_SQRT: result = Perl_sqrt(value); break;
2880       }
2881       SETn(result);
2882       return NORMAL;
2883     }
2884 }
2885
2886 /* Support Configure command-line overrides for rand() functions.
2887    After 5.005, perhaps we should replace this by Configure support
2888    for drand48(), random(), or rand().  For 5.005, though, maintain
2889    compatibility by calling rand() but allow the user to override it.
2890    See INSTALL for details.  --Andy Dougherty  15 July 1998
2891 */
2892 /* Now it's after 5.005, and Configure supports drand48() and random(),
2893    in addition to rand().  So the overrides should not be needed any more.
2894    --Jarkko Hietaniemi  27 September 1998
2895  */
2896
2897 PP(pp_rand)
2898 {
2899     if (!PL_srand_called) {
2900         (void)seedDrand01((Rand_seed_t)seed());
2901         PL_srand_called = TRUE;
2902     }
2903     {
2904         dSP;
2905         NV value;
2906     
2907         if (MAXARG < 1)
2908         {
2909             EXTEND(SP, 1);
2910             value = 1.0;
2911         }
2912         else {
2913             SV * const sv = POPs;
2914             if(!sv)
2915                 value = 1.0;
2916             else
2917                 value = SvNV(sv);
2918         }
2919     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2920 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2921         if (! Perl_isnan(value) && value == 0.0)
2922 #else
2923         if (value == 0.0)
2924 #endif
2925             value = 1.0;
2926         {
2927             dTARGET;
2928             PUSHs(TARG);
2929             PUTBACK;
2930             value *= Drand01();
2931             sv_setnv_mg(TARG, value);
2932         }
2933     }
2934     return NORMAL;
2935 }
2936
2937 PP(pp_srand)
2938 {
2939     dSP; dTARGET;
2940     UV anum;
2941
2942     if (MAXARG >= 1 && (TOPs || POPs)) {
2943         SV *top;
2944         char *pv;
2945         STRLEN len;
2946         int flags;
2947
2948         top = POPs;
2949         pv = SvPV(top, len);
2950         flags = grok_number(pv, len, &anum);
2951
2952         if (!(flags & IS_NUMBER_IN_UV)) {
2953             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2954                              "Integer overflow in srand");
2955             anum = UV_MAX;
2956         }
2957     }
2958     else {
2959         anum = seed();
2960     }
2961
2962     (void)seedDrand01((Rand_seed_t)anum);
2963     PL_srand_called = TRUE;
2964     if (anum)
2965         XPUSHu(anum);
2966     else {
2967         /* Historically srand always returned true. We can avoid breaking
2968            that like this:  */
2969         sv_setpvs(TARG, "0 but true");
2970         XPUSHTARG;
2971     }
2972     RETURN;
2973 }
2974
2975 PP(pp_int)
2976 {
2977     dSP; dTARGET;
2978     tryAMAGICun_MG(int_amg, AMGf_numeric);
2979     {
2980       SV * const sv = TOPs;
2981       const IV iv = SvIV_nomg(sv);
2982       /* XXX it's arguable that compiler casting to IV might be subtly
2983          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2984          else preferring IV has introduced a subtle behaviour change bug. OTOH
2985          relying on floating point to be accurate is a bug.  */
2986
2987       if (!SvOK(sv)) {
2988         SETu(0);
2989       }
2990       else if (SvIOK(sv)) {
2991         if (SvIsUV(sv))
2992             SETu(SvUV_nomg(sv));
2993         else
2994             SETi(iv);
2995       }
2996       else {
2997           const NV value = SvNV_nomg(sv);
2998           if (UNLIKELY(Perl_isinfnan(value)))
2999               SETn(value);
3000           else if (value >= 0.0) {
3001               if (value < (NV)UV_MAX + 0.5) {
3002                   SETu(U_V(value));
3003               } else {
3004                   SETn(Perl_floor(value));
3005               }
3006           }
3007           else {
3008               if (value > (NV)IV_MIN - 0.5) {
3009                   SETi(I_V(value));
3010               } else {
3011                   SETn(Perl_ceil(value));
3012               }
3013           }
3014       }
3015     }
3016     return NORMAL;
3017 }
3018
3019 PP(pp_abs)
3020 {
3021     dSP; dTARGET;
3022     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3023     {
3024       SV * const sv = TOPs;
3025       /* This will cache the NV value if string isn't actually integer  */
3026       const IV iv = SvIV_nomg(sv);
3027
3028       if (!SvOK(sv)) {
3029         SETu(0);
3030       }
3031       else if (SvIOK(sv)) {
3032         /* IVX is precise  */
3033         if (SvIsUV(sv)) {
3034           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3035         } else {
3036           if (iv >= 0) {
3037             SETi(iv);
3038           } else {
3039             if (iv != IV_MIN) {
3040               SETi(-iv);
3041             } else {
3042               /* 2s complement assumption. Also, not really needed as
3043                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3044               SETu(IV_MIN);
3045             }
3046           }
3047         }
3048       } else{
3049         const NV value = SvNV_nomg(sv);
3050         if (value < 0.0)
3051           SETn(-value);
3052         else
3053           SETn(value);
3054       }
3055     }
3056     return NORMAL;
3057 }
3058
3059
3060 /* also used for: pp_hex() */
3061
3062 PP(pp_oct)
3063 {
3064     dSP; dTARGET;
3065     const char *tmps;
3066     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3067     STRLEN len;
3068     NV result_nv;
3069     UV result_uv;
3070     SV* const sv = TOPs;
3071
3072     tmps = (SvPV_const(sv, len));
3073     if (DO_UTF8(sv)) {
3074          /* If Unicode, try to downgrade
3075           * If not possible, croak. */
3076          SV* const tsv = sv_2mortal(newSVsv(sv));
3077         
3078          SvUTF8_on(tsv);
3079          sv_utf8_downgrade(tsv, FALSE);
3080          tmps = SvPV_const(tsv, len);
3081     }
3082     if (PL_op->op_type == OP_HEX)
3083         goto hex;
3084
3085     while (*tmps && len && isSPACE(*tmps))
3086         tmps++, len--;
3087     if (*tmps == '0')
3088         tmps++, len--;
3089     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3090     hex:
3091         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3092     }
3093     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3094         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3095     else
3096         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3097
3098     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3099         SETn(result_nv);
3100     }
3101     else {
3102         SETu(result_uv);
3103     }
3104     return NORMAL;
3105 }
3106
3107 /* String stuff. */
3108
3109 PP(pp_length)
3110 {
3111     dSP; dTARGET;
3112     SV * const sv = TOPs;
3113
3114     U32 in_bytes = IN_BYTES;
3115     /* simplest case shortcut */
3116     /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3117     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3118     STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3119     SETs(TARG);
3120
3121     if(LIKELY(svflags == SVf_POK))
3122         goto simple_pv;
3123     if(svflags & SVs_GMG)
3124         mg_get(sv);
3125     if (SvOK(sv)) {
3126         if (!IN_BYTES) /* reread to avoid using an C auto/register */
3127             sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3128         else
3129         {
3130             STRLEN len;
3131             /* unrolled SvPV_nomg_const(sv,len) */
3132             if(SvPOK_nog(sv)){
3133                 simple_pv:
3134                 len = SvCUR(sv);
3135             } else  {
3136                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3137             }
3138             sv_setiv(TARG, (IV)(len));
3139         }
3140     } else {
3141         if (!SvPADTMP(TARG)) {
3142             sv_setsv_nomg(TARG, &PL_sv_undef);
3143         } else { /* TARG is on stack at this point and is overwriten by SETs.
3144                    This branch is the odd one out, so put TARG by default on
3145                    stack earlier to let local SP go out of liveness sooner */
3146             SETs(&PL_sv_undef);
3147             goto no_set_magic;
3148         }
3149     }
3150     SvSETMAGIC(TARG);
3151     no_set_magic:
3152     return NORMAL; /* no putback, SP didn't move in this opcode */
3153 }
3154
3155 /* Returns false if substring is completely outside original string.
3156    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3157    always be true for an explicit 0.
3158 */
3159 bool
3160 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3161                                 bool pos1_is_uv, IV len_iv,
3162                                 bool len_is_uv, STRLEN *posp,
3163                                 STRLEN *lenp)
3164 {
3165     IV pos2_iv;
3166     int    pos2_is_uv;
3167
3168     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3169
3170     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3171         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3172         pos1_iv += curlen;
3173     }
3174     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3175         return FALSE;
3176
3177     if (len_iv || len_is_uv) {
3178         if (!len_is_uv && len_iv < 0) {
3179             pos2_iv = curlen + len_iv;
3180             if (curlen)
3181                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3182             else
3183                 pos2_is_uv = 0;
3184         } else {  /* len_iv >= 0 */
3185             if (!pos1_is_uv && pos1_iv < 0) {
3186                 pos2_iv = pos1_iv + len_iv;
3187                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3188             } else {
3189                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3190                     pos2_iv = curlen;
3191                 else
3192                     pos2_iv = pos1_iv+len_iv;
3193                 pos2_is_uv = 1;
3194             }
3195         }
3196     }
3197     else {
3198         pos2_iv = curlen;
3199         pos2_is_uv = 1;
3200     }
3201
3202     if (!pos2_is_uv && pos2_iv < 0) {
3203         if (!pos1_is_uv && pos1_iv < 0)
3204             return FALSE;
3205         pos2_iv = 0;
3206     }
3207     else if (!pos1_is_uv && pos1_iv < 0)
3208         pos1_iv = 0;
3209
3210     if ((UV)pos2_iv < (UV)pos1_iv)
3211         pos2_iv = pos1_iv;
3212     if ((UV)pos2_iv > curlen)
3213         pos2_iv = curlen;
3214
3215     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3216     *posp = (STRLEN)( (UV)pos1_iv );
3217     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3218
3219     return TRUE;
3220 }
3221
3222 PP(pp_substr)
3223 {
3224     dSP; dTARGET;
3225     SV *sv;
3226     STRLEN curlen;
3227     STRLEN utf8_curlen;
3228     SV *   pos_sv;
3229     IV     pos1_iv;
3230     int    pos1_is_uv;
3231     SV *   len_sv;
3232     IV     len_iv = 0;
3233     int    len_is_uv = 0;
3234     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3235     const bool rvalue = (GIMME_V != G_VOID);
3236     const char *tmps;
3237     SV *repl_sv = NULL;
3238     const char *repl = NULL;
3239     STRLEN repl_len;
3240     int num_args = PL_op->op_private & 7;
3241     bool repl_need_utf8_upgrade = FALSE;
3242
3243     if (num_args > 2) {
3244         if (num_args > 3) {
3245           if(!(repl_sv = POPs)) num_args--;
3246         }
3247         if ((len_sv = POPs)) {
3248             len_iv    = SvIV(len_sv);
3249             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3250         }
3251         else num_args--;
3252     }
3253     pos_sv     = POPs;
3254     pos1_iv    = SvIV(pos_sv);
3255     pos1_is_uv = SvIOK_UV(pos_sv);
3256     sv = POPs;
3257     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3258         assert(!repl_sv);
3259         repl_sv = POPs;
3260     }
3261     if (lvalue && !repl_sv) {
3262         SV * ret;
3263         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3264         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3265         LvTYPE(ret) = 'x';
3266         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3267         LvTARGOFF(ret) =
3268             pos1_is_uv || pos1_iv >= 0
3269                 ? (STRLEN)(UV)pos1_iv
3270                 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3271         LvTARGLEN(ret) =
3272             len_is_uv || len_iv > 0
3273                 ? (STRLEN)(UV)len_iv
3274                 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3275
3276         PUSHs(ret);    /* avoid SvSETMAGIC here */
3277         RETURN;
3278     }
3279     if (repl_sv) {
3280         repl = SvPV_const(repl_sv, repl_len);
3281         SvGETMAGIC(sv);
3282         if (SvROK(sv))
3283             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3284                             "Attempt to use reference as lvalue in substr"
3285             );
3286         tmps = SvPV_force_nomg(sv, curlen);
3287         if (DO_UTF8(repl_sv) && repl_len) {
3288             if (!DO_UTF8(sv)) {
3289                 sv_utf8_upgrade_nomg(sv);
3290                 curlen = SvCUR(sv);
3291             }
3292         }
3293         else if (DO_UTF8(sv))
3294             repl_need_utf8_upgrade = TRUE;
3295     }
3296     else tmps = SvPV_const(sv, curlen);
3297     if (DO_UTF8(sv)) {
3298         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3299         if (utf8_curlen == curlen)
3300             utf8_curlen = 0;
3301         else
3302             curlen = utf8_curlen;
3303     }
3304     else
3305         utf8_curlen = 0;
3306
3307     {
3308         STRLEN pos, len, byte_len, byte_pos;
3309
3310         if (!translate_substr_offsets(
3311                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3312         )) goto bound_fail;
3313
3314         byte_len = len;
3315         byte_pos = utf8_curlen
3316             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3317
3318         tmps += byte_pos;
3319
3320         if (rvalue) {
3321             SvTAINTED_off(TARG);                        /* decontaminate */
3322             SvUTF8_off(TARG);                   /* decontaminate */
3323             sv_setpvn(TARG, tmps, byte_len);
3324 #ifdef USE_LOCALE_COLLATE
3325             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3326 #endif
3327             if (utf8_curlen)
3328                 SvUTF8_on(TARG);
3329         }
3330
3331         if (repl) {
3332             SV* repl_sv_copy = NULL;
3333
3334             if (repl_need_utf8_upgrade) {
3335                 repl_sv_copy = newSVsv(repl_sv);
3336                 sv_utf8_upgrade(repl_sv_copy);
3337                 repl = SvPV_const(repl_sv_copy, repl_len);
3338             }
3339             if (!SvOK(sv))
3340                 sv_setpvs(sv, "");
3341             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3342             SvREFCNT_dec(repl_sv_copy);
3343         }
3344     }
3345     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3346         SP++;
3347     else if (rvalue) {
3348         SvSETMAGIC(TARG);
3349         PUSHs(TARG);
3350     }
3351     RETURN;
3352
3353   bound_fail:
3354     if (repl)
3355         Perl_croak(aTHX_ "substr outside of string");
3356     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3357     RETPUSHUNDEF;
3358 }
3359
3360 PP(pp_vec)
3361 {
3362     dSP;
3363     const IV size   = POPi;
3364     const IV offset = POPi;
3365     SV * const src = POPs;
3366     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3367     SV * ret;
3368
3369     if (lvalue) {                       /* it's an lvalue! */
3370         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3371         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3372         LvTYPE(ret) = 'v';
3373         LvTARG(ret) = SvREFCNT_inc_simple(src);
3374         LvTARGOFF(ret) = offset;
3375         LvTARGLEN(ret) = size;
3376     }
3377     else {
3378         dTARGET;
3379         SvTAINTED_off(TARG);            /* decontaminate */
3380         ret = TARG;
3381     }
3382
3383     sv_setuv(ret, do_vecget(src, offset, size));
3384     if (!lvalue)
3385         SvSETMAGIC(ret);
3386     PUSHs(ret);
3387     RETURN;
3388 }
3389
3390
3391 /* also used for: pp_rindex() */
3392
3393 PP(pp_index)
3394 {
3395     dSP; dTARGET;
3396     SV *big;
3397     SV *little;
3398     SV *temp = NULL;
3399     STRLEN biglen;
3400     STRLEN llen = 0;
3401     SSize_t offset = 0;
3402     SSize_t retval;
3403     const char *big_p;
3404     const char *little_p;
3405     bool big_utf8;
3406     bool little_utf8;
3407     const bool is_index = PL_op->op_type == OP_INDEX;
3408     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3409
3410     if (threeargs)
3411         offset = POPi;
3412     little = POPs;
3413     big = POPs;
3414     big_p = SvPV_const(big, biglen);
3415     little_p = SvPV_const(little, llen);
3416
3417     big_utf8 = DO_UTF8(big);
3418     little_utf8 = DO_UTF8(little);
3419     if (big_utf8 ^ little_utf8) {
3420         /* One needs to be upgraded.  */
3421         if (little_utf8 && !IN_ENCODING) {
3422             /* Well, maybe instead we might be able to downgrade the small
3423                string?  */
3424             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3425                                                      &little_utf8);
3426             if (little_utf8) {
3427                 /* If the large string is ISO-8859-1, and it's not possible to
3428                    convert the small string to ISO-8859-1, then there is no
3429                    way that it could be found anywhere by index.  */
3430                 retval = -1;
3431                 goto fail;
3432             }
3433
3434             /* At this point, pv is a malloc()ed string. So donate it to temp
3435                to ensure it will get free()d  */
3436             little = temp = newSV(0);
3437             sv_usepvn(temp, pv, llen);
3438             little_p = SvPVX(little);
3439         } else {
3440             temp = little_utf8
3441                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3442
3443             if (IN_ENCODING) {
3444                 sv_recode_to_utf8(temp, _get_encoding());
3445             } else {
3446                 sv_utf8_upgrade(temp);
3447             }
3448             if (little_utf8) {
3449                 big = temp;
3450                 big_utf8 = TRUE;
3451                 big_p = SvPV_const(big, biglen);
3452             } else {
3453                 little = temp;
3454                 little_p = SvPV_const(little, llen);
3455             }
3456         }
3457     }
3458     if (SvGAMAGIC(big)) {
3459         /* Life just becomes a lot easier if I use a temporary here.
3460            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3461            will trigger magic and overloading again, as will fbm_instr()
3462         */
3463         big = newSVpvn_flags(big_p, biglen,
3464                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3465         big_p = SvPVX(big);
3466     }
3467     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3468         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3469            warn on undef, and we've already triggered a warning with the
3470            SvPV_const some lines above. We can't remove that, as we need to
3471            call some SvPV to trigger overloading early and find out if the
3472            string is UTF-8.
3473            This is all getting to messy. The API isn't quite clean enough,
3474            because data access has side effects.
3475         */
3476         little = newSVpvn_flags(little_p, llen,
3477                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3478         little_p = SvPVX(little);
3479     }
3480
3481     if (!threeargs)
3482         offset = is_index ? 0 : biglen;
3483     else {
3484         if (big_utf8 && offset > 0)
3485             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3486         if (!is_index)
3487             offset += llen;
3488     }
3489     if (offset < 0)
3490         offset = 0;
3491     else if (offset > (SSize_t)biglen)
3492         offset = biglen;
3493     if (!(little_p = is_index
3494           ? fbm_instr((unsigned char*)big_p + offset,
3495                       (unsigned char*)big_p + biglen, little, 0)
3496           : rninstr(big_p,  big_p  + offset,
3497                     little_p, little_p + llen)))
3498         retval = -1;
3499     else {
3500         retval = little_p - big_p;
3501         if (retval > 1 && big_utf8)
3502             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3503     }
3504     SvREFCNT_dec(temp);
3505  fail:
3506     PUSHi(retval);
3507     RETURN;
3508 }
3509
3510 PP(pp_sprintf)
3511 {
3512     dSP; dMARK; dORIGMARK; dTARGET;
3513     SvTAINTED_off(TARG);
3514     do_sprintf(TARG, SP-MARK, MARK+1);
3515     TAINT_IF(SvTAINTED(TARG));
3516     SP = ORIGMARK;
3517     PUSHTARG;
3518     RETURN;
3519 }
3520
3521 PP(pp_ord)
3522 {
3523     dSP; dTARGET;
3524
3525     SV *argsv = TOPs;
3526     STRLEN len;
3527     const U8 *s = (U8*)SvPV_const(argsv, len);
3528
3529     if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
3530         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3531         s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
3532         len = UTF8SKIP(s);  /* Should be well-formed; so this is its length */
3533         argsv = tmpsv;
3534     }
3535
3536     SETu(DO_UTF8(argsv)
3537            ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3538            : (UV)(*s));
3539
3540     return NORMAL;
3541 }
3542
3543 PP(pp_chr)
3544 {
3545     dSP; dTARGET;
3546     char *tmps;
3547     UV value;
3548     SV *top = TOPs;
3549
3550     SvGETMAGIC(top);
3551     if (UNLIKELY(SvAMAGIC(top)))
3552         top = sv_2num(top);
3553     if (UNLIKELY(isinfnansv(top)))
3554         Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3555     else {
3556         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3557             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3558                 ||
3559                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3560                  && SvNV_nomg(top) < 0.0))) {
3561             if (ckWARN(WARN_UTF8)) {
3562                 if (SvGMAGICAL(top)) {
3563                     SV *top2 = sv_newmortal();
3564                     sv_setsv_nomg(top2, top);
3565                     top = top2;
3566                 }
3567                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3568                             "Invalid negative number (%"SVf") in chr", SVfARG(top));
3569             }
3570             value = UNICODE_REPLACEMENT;
3571         } else {
3572             value = SvUV_nomg(top);
3573         }
3574     }
3575
3576     SvUPGRADE(TARG,SVt_PV);
3577
3578     if (value > 255 && !IN_BYTES) {
3579         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3580         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3581         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3582         *tmps = '\0';
3583         (void)SvPOK_only(TARG);
3584         SvUTF8_on(TARG);
3585         SETTARG;
3586         return NORMAL;
3587     }
3588
3589     SvGROW(TARG,2);
3590     SvCUR_set(TARG, 1);
3591     tmps = SvPVX(TARG);
3592     *tmps++ = (char)value;
3593     *tmps = '\0';
3594     (void)SvPOK_only(TARG);
3595
3596     if (IN_ENCODING && !IN_BYTES) {
3597         sv_recode_to_utf8(TARG, _get_encoding());
3598         tmps = SvPVX(TARG);
3599         if (SvCUR(TARG) == 0
3600             || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3601             || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3602         {
3603             SvGROW(TARG, 2);
3604             tmps = SvPVX(TARG);
3605             SvCUR_set(TARG, 1);
3606             *tmps++ = (char)value;
3607             *tmps = '\0';
3608             SvUTF8_off(TARG);
3609         }
3610     }
3611
3612     SETTARG;
3613     return NORMAL;
3614 }
3615
3616 PP(pp_crypt)
3617 {
3618 #ifdef HAS_CRYPT
3619     dSP; dTARGET;
3620     dPOPTOPssrl;
3621     STRLEN len;
3622     const char *tmps = SvPV_const(left, len);
3623
3624     if (DO_UTF8(left)) {
3625          /* If Unicode, try to downgrade.
3626           * If not possible, croak.
3627           * Yes, we made this up.  */
3628          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3629
3630          sv_utf8_downgrade(tsv, FALSE);
3631          tmps = SvPV_const(tsv, len);
3632     }
3633 #   ifdef USE_ITHREADS
3634 #     ifdef HAS_CRYPT_R
3635     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3636       /* This should be threadsafe because in ithreads there is only
3637        * one thread per interpreter.  If this would not be true,
3638        * we would need a mutex to protect this malloc. */
3639         PL_reentrant_buffer->_crypt_struct_buffer =
3640           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3641 #if defined(__GLIBC__) || defined(__EMX__)
3642         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3643             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3644             /* work around glibc-2.2.5 bug */
3645             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3646         }
3647 #endif
3648     }
3649 #     endif /* HAS_CRYPT_R */
3650 #   endif /* USE_ITHREADS */
3651 #   ifdef FCRYPT
3652     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3653 #   else
3654     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3655 #   endif
3656     SvUTF8_off(TARG);
3657     SETTARG;
3658     RETURN;
3659 #else
3660     DIE(aTHX_
3661       "The crypt() function is unimplemented due to excessive paranoia.");
3662 #endif
3663 }
3664
3665 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So 
3666  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3667
3668
3669 /* also used for: pp_lcfirst() */
3670
3671 PP(pp_ucfirst)
3672 {
3673     /* Actually is both lcfirst() and ucfirst().  Only the first character
3674      * changes.  This means that possibly we can change in-place, ie., just
3675      * take the source and change that one character and store it back, but not
3676      * if read-only etc, or if the length changes */
3677
3678     dSP;
3679     SV *source = TOPs;
3680     STRLEN slen; /* slen is the byte length of the whole SV. */
3681     STRLEN need;
3682     SV *dest;
3683     bool inplace;   /* ? Convert first char only, in-place */
3684     bool doing_utf8 = FALSE;               /* ? using utf8 */
3685     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3686     const int op_type = PL_op->op_type;
3687     const U8 *s;
3688     U8 *d;
3689     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3690     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3691                      * stored as UTF-8 at s. */
3692     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3693                      * lowercased) character stored in tmpbuf.  May be either
3694                      * UTF-8 or not, but in either case is the number of bytes */
3695
3696     s = (const U8*)SvPV_const(source, slen);
3697
3698     /* We may be able to get away with changing only the first character, in
3699      * place, but not if read-only, etc.  Later we may discover more reasons to
3700      * not convert in-place. */
3701     inplace = !SvREADONLY(source)
3702            && (  SvPADTMP(source)
3703               || (  SvTEMP(source) && !SvSMAGICAL(source)
3704                  && SvREFCNT(source) == 1));
3705
3706     /* First calculate what the changed first character should be.  This affects
3707      * whether we can just swap it out, leaving the rest of the string unchanged,
3708      * or even if have to convert the dest to UTF-8 when the source isn't */
3709
3710     if (! slen) {   /* If empty */
3711         need = 1; /* still need a trailing NUL */
3712         ulen = 0;
3713     }
3714     else if (DO_UTF8(source)) { /* Is the source utf8? */
3715         doing_utf8 = TRUE;
3716         ulen = UTF8SKIP(s);
3717         if (op_type == OP_UCFIRST) {
3718 #ifdef USE_LOCALE_CTYPE
3719             _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3720 #else
3721             _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3722 #endif
3723         }
3724         else {
3725 #ifdef USE_LOCALE_CTYPE
3726             _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3727 #else
3728             _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3729 #endif
3730         }
3731
3732         /* we can't do in-place if the length changes.  */
3733         if (ulen != tculen) inplace = FALSE;
3734         need = slen + 1 - ulen + tculen;
3735     }
3736     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3737             * latin1 is treated as caseless.  Note that a locale takes
3738             * precedence */ 
3739         ulen = 1;       /* Original character is 1 byte */
3740         tculen = 1;     /* Most characters will require one byte, but this will
3741                          * need to be overridden for the tricky ones */
3742         need = slen + 1;
3743
3744         if (op_type == OP_LCFIRST) {
3745
3746             /* lower case the first letter: no trickiness for any character */
3747 #ifdef USE_LOCALE_CTYPE
3748             if (IN_LC_RUNTIME(LC_CTYPE)) {
3749                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3750                 *tmpbuf = toLOWER_LC(*s);
3751             }
3752             else
3753 #endif
3754             {
3755                 *tmpbuf = (IN_UNI_8_BIT)
3756                           ? toLOWER_LATIN1(*s)
3757                           : toLOWER(*s);
3758             }
3759         }
3760 #ifdef USE_LOCALE_CTYPE
3761         /* is ucfirst() */
3762         else if (IN_LC_RUNTIME(LC_CTYPE)) {
3763             if (IN_UTF8_CTYPE_LOCALE) {
3764                 goto do_uni_rules;
3765             }
3766
3767             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3768             *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3769                                               locales have upper and title case
3770                                               different */
3771         }
3772 #endif
3773         else if (! IN_UNI_8_BIT) {
3774             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3775                                          * on EBCDIC machines whatever the
3776                                          * native function does */
3777         }
3778         else {
3779             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3780              * UTF-8, which we treat as not in locale), and cased latin1 */
3781             UV title_ord;
3782 #ifdef USE_LOCALE_CTYPE
3783       do_uni_rules:
3784 #endif
3785
3786             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3787             if (tculen > 1) {
3788                 assert(tculen == 2);
3789
3790                 /* If the result is an upper Latin1-range character, it can
3791                  * still be represented in one byte, which is its ordinal */
3792                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3793                     *tmpbuf = (U8) title_ord;
3794                     tculen = 1;
3795                 }
3796                 else {
3797                     /* Otherwise it became more than one ASCII character (in
3798                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3799                      * beyond Latin1, so the number of bytes changed, so can't
3800                      * replace just the first character in place. */
3801                     inplace = FALSE;
3802
3803                     /* If the result won't fit in a byte, the entire result
3804                      * will have to be in UTF-8.  Assume worst case sizing in
3805                      * conversion. (all latin1 characters occupy at most two
3806                      * bytes in utf8) */
3807                     if (title_ord > 255) {
3808                         doing_utf8 = TRUE;
3809                         convert_source_to_utf8 = TRUE;
3810                         need = slen * 2 + 1;
3811
3812                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3813                          * (both) characters whose title case is above 255 is
3814                          * 2. */
3815                         ulen = 2;
3816                     }
3817                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3818                         need = slen + 1 + 1;
3819                     }
3820                 }
3821             }
3822         } /* End of use Unicode (Latin1) semantics */
3823     } /* End of changing the case of the first character */
3824
3825     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3826      * generate the result */
3827     if (inplace) {
3828
3829         /* We can convert in place.  This means we change just the first
3830          * character without disturbing the rest; no need to grow */
3831         dest = source;
3832         s = d = (U8*)SvPV_force_nomg(source, slen);
3833     } else {
3834         dTARGET;
3835
3836         dest = TARG;
3837
3838         /* Here, we can't convert in place; we earlier calculated how much
3839          * space we will need, so grow to accommodate that */
3840         SvUPGRADE(dest, SVt_PV);
3841         d = (U8*)SvGROW(dest, need);
3842         (void)SvPOK_only(dest);
3843
3844         SETs(dest);
3845     }
3846
3847     if (doing_utf8) {
3848         if (! inplace) {
3849             if (! convert_source_to_utf8) {
3850
3851                 /* Here  both source and dest are in UTF-8, but have to create
3852                  * the entire output.  We initialize the result to be the
3853                  * title/lower cased first character, and then append the rest
3854                  * of the string. */
3855                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3856                 if (slen > ulen) {
3857                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3858                 }
3859             }
3860             else {
3861                 const U8 *const send = s + slen;
3862
3863                 /* Here the dest needs to be in UTF-8, but the source isn't,
3864                  * except we earlier UTF-8'd the first character of the source
3865                  * into tmpbuf.  First put that into dest, and then append the
3866                  * rest of the source, converting it to UTF-8 as we go. */
3867
3868                 /* Assert tculen is 2 here because the only two characters that
3869                  * get to this part of the code have 2-byte UTF-8 equivalents */
3870                 *d++ = *tmpbuf;
3871                 *d++ = *(tmpbuf + 1);
3872                 s++;    /* We have just processed the 1st char */
3873
3874                 for (; s < send; s++) {
3875                     d = uvchr_to_utf8(d, *s);
3876                 }
3877                 *d = '\0';
3878                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3879             }
3880             SvUTF8_on(dest);
3881         }
3882         else {   /* in-place UTF-8.  Just overwrite the first character */
3883             Copy(tmpbuf, d, tculen, U8);
3884             SvCUR_set(dest, need - 1);
3885         }
3886
3887     }
3888     else {  /* Neither source nor dest are in or need to be UTF-8 */
3889         if (slen) {
3890             if (inplace) {  /* in-place, only need to change the 1st char */
3891                 *d = *tmpbuf;
3892             }
3893             else {      /* Not in-place */
3894
3895                 /* Copy the case-changed character(s) from tmpbuf */
3896                 Copy(tmpbuf, d, tculen, U8);
3897                 d += tculen - 1; /* Code below expects d to point to final
3898                                   * character stored */
3899             }
3900         }
3901         else {  /* empty source */
3902             /* See bug #39028: Don't taint if empty  */
3903             *d = *s;
3904         }
3905
3906         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3907          * the destination to retain that flag */
3908         if (SvUTF8(source) && ! IN_BYTES)
3909             SvUTF8_on(dest);
3910
3911         if (!inplace) { /* Finish the rest of the string, unchanged */
3912             /* This will copy the trailing NUL  */
3913             Copy(s + 1, d + 1, slen, U8);
3914             SvCUR_set(dest, need - 1);
3915         }
3916     }
3917 #ifdef USE_LOCALE_CTYPE
3918     if (IN_LC_RUNTIME(LC_CTYPE)) {
3919         TAINT;
3920         SvTAINTED_on(dest);
3921     }
3922 #endif
3923     if (dest != source && SvTAINTED(source))
3924         SvTAINT(dest);
3925     SvSETMAGIC(dest);
3926     return NORMAL;
3927 }
3928
3929 /* There's so much setup/teardown code common between uc and lc, I wonder if
3930    it would be worth merging the two, and just having a switch outside each
3931    of the three tight loops.  There is less and less commonality though */
3932 PP(pp_uc)
3933 {
3934     dSP;
3935     SV *source = TOPs;
3936     STRLEN len;
3937     STRLEN min;
3938     SV *dest;
3939     const U8 *s;
3940     U8 *d;
3941
3942     SvGETMAGIC(source);
3943
3944     if ((SvPADTMP(source)
3945          ||
3946         (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
3947         && !SvREADONLY(source) && SvPOK(source)
3948         && !DO_UTF8(source)
3949         && (
3950 #ifdef USE_LOCALE_CTYPE
3951             (IN_LC_RUNTIME(LC_CTYPE))
3952             ? ! IN_UTF8_CTYPE_LOCALE
3953             :
3954 #endif
3955               ! IN_UNI_8_BIT))
3956     {
3957
3958         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
3959          * make the loop tight, so we overwrite the source with the dest before
3960          * looking at it, and we need to look at the original source
3961          * afterwards.  There would also need to be code added to handle
3962          * switching to not in-place in midstream if we run into characters
3963          * that change the length.  Since being in locale overrides UNI_8_BIT,
3964          * that latter becomes irrelevant in the above test; instead for
3965          * locale, the size can't normally change, except if the locale is a
3966          * UTF-8 one */
3967         dest = source;
3968         s = d = (U8*)SvPV_force_nomg(source, len);
3969         min = len + 1;
3970     } else {
3971         dTARGET;
3972
3973         dest = TARG;
3974
3975         s = (const U8*)SvPV_nomg_const(source, len);
3976         min = len + 1;
3977
3978         SvUPGRADE(dest, SVt_PV);
3979         d = (U8*)SvGROW(dest, min);
3980         (void)SvPOK_only(dest);
3981
3982         SETs(dest);
3983     }
3984
3985     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3986        to check DO_UTF8 again here.  */
3987
3988     if (DO_UTF8(source)) {
3989         const U8 *const send = s + len;
3990         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3991
3992         /* All occurrences of these are to be moved to follow any other marks.
3993          * This is context-dependent.  We may not be passed enough context to
3994          * move the iota subscript beyond all of them, but we do the best we can
3995          * with what we're given.  The result is always better than if we
3996          * hadn't done this.  And, the problem would only arise if we are
3997          * passed a character without all its combining marks, which would be
3998          * the caller's mistake.  The information this is based on comes from a
3999          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4000          * itself) and so can't be checked properly to see if it ever gets
4001          * revised.  But the likelihood of it changing is remote */
4002         bool in_iota_subscript = FALSE;
4003
4004         while (s < send) {
4005             STRLEN u;
4006             STRLEN ulen;
4007             UV uv;
4008             if (in_iota_subscript && ! _is_utf8_mark(s)) {
4009
4010                 /* A non-mark.  Time to output the iota subscript */
4011                 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4012                 d += capital_iota_len;
4013                 in_iota_subscript = FALSE;
4014             }
4015
4016             /* Then handle the current character.  Get the changed case value
4017              * and copy it to the output buffer */
4018
4019             u = UTF8SKIP(s);
4020 #ifdef USE_LOCALE_CTYPE
4021             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4022 #else
4023             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
4024 #endif
4025 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4026 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4027             if (uv == GREEK_CAPITAL_LETTER_IOTA
4028                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4029             {
4030                 in_iota_subscript = TRUE;
4031             }
4032             else {
4033                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4034                     /* If the eventually required minimum size outgrows the
4035                      * available space, we need to grow. */
4036                     const UV o = d - (U8*)SvPVX_const(dest);
4037
4038                     /* If someone uppercases one million U+03B0s we SvGROW()
4039                      * one million times.  Or we could try guessing how much to
4040                      * allocate without allocating too much.  Such is life.
4041                      * See corresponding comment in lc code for another option
4042                      * */
4043                     SvGROW(dest, min);
4044                     d = (U8*)SvPVX(dest) + o;
4045                 }
4046                 Copy(tmpbuf, d, ulen, U8);
4047                 d += ulen;
4048             }
4049             s += u;
4050         }
4051         if (in_iota_subscript) {
4052             Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4053             d += capital_iota_len;
4054         }
4055         SvUTF8_on(dest);
4056         *d = '\0';
4057
4058         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4059     }
4060     else {      /* Not UTF-8 */
4061         if (len) {
4062             const U8 *const send = s + len;
4063
4064             /* Use locale casing if in locale; regular style if not treating
4065              * latin1 as having case; otherwise the latin1 casing.  Do the
4066              * whole thing in a tight loop, for speed, */
4067 #ifdef USE_LOCALE_CTYPE
4068             if (IN_LC_RUNTIME(LC_CTYPE)) {
4069                 if (IN_UTF8_CTYPE_LOCALE) {
4070                     goto do_uni_rules;
4071                 }
4072                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4073                 for (; s < send; d++, s++)
4074                     *d = (U8) toUPPER_LC(*s);
4075             }
4076             else
4077 #endif
4078                  if (! IN_UNI_8_BIT) {
4079                 for (; s < send; d++, s++) {
4080                     *d = toUPPER(*s);
4081                 }
4082             }
4083             else {
4084 #ifdef USE_LOCALE_CTYPE
4085           do_uni_rules:
4086 #endif
4087                 for (; s < send; d++, s++) {
4088                     *d = toUPPER_LATIN1_MOD(*s);
4089                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4090                         continue;
4091                     }
4092
4093                     /* The mainstream case is the tight loop above.  To avoid
4094                      * extra tests in that, all three characters that require
4095                      * special handling are mapped by the MOD to the one tested
4096                      * just above.  
4097                      * Use the source to distinguish between the three cases */
4098
4099                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4100
4101                         /* uc() of this requires 2 characters, but they are
4102                          * ASCII.  If not enough room, grow the string */
4103                         if (SvLEN(dest) < ++min) {      
4104                             const UV o = d - (U8*)SvPVX_const(dest);
4105                             SvGROW(dest, min);
4106                             d = (U8*)SvPVX(dest) + o;
4107                         }
4108                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4109                         continue;   /* Back to the tight loop; still in ASCII */
4110                     }
4111
4112                     /* The other two special handling characters have their
4113                      * upper cases outside the latin1 range, hence need to be
4114                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4115                      * here we are somewhere in the middle of processing a
4116                      * non-UTF-8 string, and realize that we will have to convert
4117                      * the whole thing to UTF-8.  What to do?  There are
4118                      * several possibilities.  The simplest to code is to
4119                      * convert what we have so far, set a flag, and continue on
4120                      * in the loop.  The flag would be tested each time through
4121                      * the loop, and if set, the next character would be
4122                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4123                      * to slow down the mainstream case at all for this fairly
4124                      * rare case, so I didn't want to add a test that didn't
4125                      * absolutely have to be there in the loop, besides the
4126                      * possibility that it would get too complicated for
4127                      * optimizers to deal with.  Another possibility is to just
4128                      * give up, convert the source to UTF-8, and restart the
4129                      * function that way.  Another possibility is to convert
4130                      * both what has already been processed and what is yet to
4131                      * come separately to UTF-8, then jump into the loop that
4132                      * handles UTF-8.  But the most efficient time-wise of the
4133                      * ones I could think of is what follows, and turned out to
4134                      * not require much extra code.  */
4135
4136                     /* Convert what we have so far into UTF-8, telling the
4137                      * function that we know it should be converted, and to
4138                      * allow extra space for what we haven't processed yet.
4139                      * Assume the worst case space requirements for converting
4140                      * what we haven't processed so far: that it will require
4141                      * two bytes for each remaining source character, plus the
4142                      * NUL at the end.  This may cause the string pointer to
4143                      * move, so re-find it. */
4144
4145                     len = d - (U8*)SvPVX_const(dest);
4146                     SvCUR_set(dest, len);
4147                     len = sv_utf8_upgrade_flags_grow(dest,
4148                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4149                                                 (send -s) * 2 + 1);
4150                     d = (U8*)SvPVX(dest) + len;
4151
4152                     /* Now process the remainder of the source, converting to
4153                      * upper and UTF-8.  If a resulting byte is invariant in
4154                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4155                      * append it to the output. */
4156                     for (; s < send; s++) {
4157                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
4158                         d += len;
4159                     }
4160
4161                     /* Here have processed the whole source; no need to continue
4162                      * with the outer loop.  Each character has been converted
4163                      * to upper case and converted to UTF-8 */
4164
4165                     break;
4166                 } /* End of processing all latin1-style chars */
4167             } /* End of processing all chars */
4168         } /* End of source is not empty */
4169
4170         if (source != dest) {
4171             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4172             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4173         }
4174     } /* End of isn't utf8 */
4175 #ifdef USE_LOCALE_CTYPE
4176     if (IN_LC_RUNTIME(LC_CTYPE)) {
4177         TAINT;
4178         SvTAINTED_on(dest);
4179     }
4180 #endif
4181     if (dest != source && SvTAINTED(source))
4182         SvTAINT(dest);
4183     SvSETMAGIC(dest);
4184     return NORMAL;
4185 }
4186
4187 PP(pp_lc)
4188 {
4189     dSP;
4190     SV *source = TOPs;
4191     STRLEN len;
4192     STRLEN min;
4193     SV *dest;
4194     const U8 *s;
4195     U8 *d;
4196
4197     SvGETMAGIC(source);
4198
4199     if (   (  SvPADTMP(source)
4200            || (  SvTEMP(source) && !SvSMAGICAL(source)
4201               && SvREFCNT(source) == 1  )
4202            )
4203         && !SvREADONLY(source) && SvPOK(source)
4204         && !DO_UTF8(source)) {
4205
4206         /* We can convert in place, as lowercasing anything in the latin1 range
4207          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4208         dest = source;
4209         s = d = (U8*)SvPV_force_nomg(source, len);
4210         min = len + 1;
4211     } else {
4212         dTARGET;
4213
4214         dest = TARG;
4215
4216         s = (const U8*)SvPV_nomg_const(source, len);
4217         min = len + 1;
4218
4219         SvUPGRADE(dest, SVt_PV);
4220         d = (U8*)SvGROW(dest, min);
4221         (void)SvPOK_only(dest);
4222
4223         SETs(dest);
4224     }
4225
4226     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4227        to check DO_UTF8 again here.  */
4228
4229     if (DO_UTF8(source)) {
4230         const U8 *const send = s + len;
4231         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4232
4233         while (s < send) {
4234             const STRLEN u = UTF8SKIP(s);
4235             STRLEN ulen;
4236
4237 #ifdef USE_LOCALE_CTYPE
4238             _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4239 #else
4240             _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4241 #endif
4242
4243             /* Here is where we would do context-sensitive actions.  See the
4244              * commit message for 86510fb15 for why there isn't any */
4245
4246             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4247
4248                 /* If the eventually required minimum size outgrows the
4249                  * available space, we need to grow. */
4250                 const UV o = d - (U8*)SvPVX_const(dest);
4251
4252                 /* If someone lowercases one million U+0130s we SvGROW() one
4253                  * million times.  Or we could try guessing how much to
4254                  * allocate without allocating too much.  Such is life.
4255                  * Another option would be to grow an extra byte or two more
4256                  * each time we need to grow, which would cut down the million
4257                  * to 500K, with little waste */
4258                 SvGROW(dest, min);
4259                 d = (U8*)SvPVX(dest) + o;
4260             }
4261
4262             /* Copy the newly lowercased letter to the output buffer we're
4263              * building */
4264             Copy(tmpbuf, d, ulen, U8);
4265             d += ulen;
4266             s += u;
4267         }   /* End of looping through the source string */
4268         SvUTF8_on(dest);
4269         *d = '\0';
4270         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4271     } else {    /* Not utf8 */
4272         if (len) {
4273             const U8 *const send = s + len;
4274
4275             /* Use locale casing if in locale; regular style if not treating
4276              * latin1 as having case; otherwise the latin1 casing.  Do the
4277              * whole thing in a tight loop, for speed, */
4278 #ifdef USE_LOCALE_CTYPE
4279             if (IN_LC_RUNTIME(LC_CTYPE)) {
4280                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4281                 for (; s < send; d++, s++)
4282                     *d = toLOWER_LC(*s);
4283             }
4284             else
4285 #endif
4286             if (! IN_UNI_8_BIT) {
4287                 for (; s < send; d++, s++) {
4288                     *d = toLOWER(*s);
4289                 }
4290             }
4291             else {
4292                 for (; s < send; d++, s++) {
4293                     *d = toLOWER_LATIN1(*s);
4294                 }
4295             }
4296         }
4297         if (source != dest) {
4298             *d = '\0';
4299             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4300         }
4301     }
4302 #ifdef USE_LOCALE_CTYPE
4303     if (IN_LC_RUNTIME(LC_CTYPE)) {
4304         TAINT;
4305         SvTAINTED_on(dest);
4306     }
4307 #endif
4308     if (dest != source && SvTAINTED(source))
4309         SvTAINT(dest);
4310     SvSETMAGIC(dest);
4311     return NORMAL;
4312 }
4313
4314 PP(pp_quotemeta)
4315 {
4316     dSP; dTARGET;
4317     SV * const sv = TOPs;
4318     STRLEN len;
4319     const char *s = SvPV_const(sv,len);
4320
4321     SvUTF8_off(TARG);                           /* decontaminate */
4322     if (len) {
4323         char *d;
4324         SvUPGRADE(TARG, SVt_PV);
4325         SvGROW(TARG, (len * 2) + 1);
4326         d = SvPVX(TARG);
4327         if (DO_UTF8(sv)) {
4328             while (len) {
4329                 STRLEN ulen = UTF8SKIP(s);
4330                 bool to_quote = FALSE;
4331
4332                 if (UTF8_IS_INVARIANT(*s)) {
4333                     if (_isQUOTEMETA(*s)) {
4334                         to_quote = TRUE;
4335                     }
4336                 }
4337                 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4338                     if (
4339 #ifdef USE_LOCALE_CTYPE
4340                     /* In locale, we quote all non-ASCII Latin1 chars.
4341                      * Otherwise use the quoting rules */
4342                     
4343                     IN_LC_RUNTIME(LC_CTYPE)
4344                         ||
4345 #endif
4346                         _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
4347                     {
4348                         to_quote = TRUE;
4349                     }
4350                 }
4351                 else if (is_QUOTEMETA_high(s)) {
4352                     to_quote = TRUE;
4353                 }
4354
4355                 if (to_quote) {
4356                     *d++ = '\\';
4357                 }
4358                 if (ulen > len)
4359                     ulen = len;
4360                 len -= ulen;
4361                 while (ulen--)
4362                     *d++ = *s++;
4363             }
4364             SvUTF8_on(TARG);
4365         }
4366         else if (IN_UNI_8_BIT) {
4367             while (len--) {
4368                 if (_isQUOTEMETA(*s))
4369                     *d++ = '\\';
4370                 *d++ = *s++;
4371             }
4372         }
4373         else {
4374             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4375              * including everything above ASCII */
4376             while (len--) {
4377                 if (!isWORDCHAR_A(*s))
4378                     *d++ = '\\';
4379                 *d++ = *s++;
4380             }
4381         }
4382         *d = '\0';
4383         SvCUR_set(TARG, d - SvPVX_const(TARG));
4384         (void)SvPOK_only_UTF8(TARG);
4385     }
4386     else
4387         sv_setpvn(TARG, s, len);
4388     SETTARG;
4389     return NORMAL;
4390 }
4391
4392 PP(pp_fc)
4393 {
4394     dTARGET;
4395     dSP;
4396     SV *source = TOPs;
4397     STRLEN len;
4398     STRLEN min;
4399     SV *dest;
4400     const U8 *s;
4401     const U8 *send;
4402     U8 *d;
4403     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4404     const bool full_folding = TRUE; /* This variable is here so we can easily
4405                                        move to more generality later */
4406     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4407 #ifdef USE_LOCALE_CTYPE
4408                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4409 #endif
4410     ;
4411
4412     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4413      * You are welcome(?) -Hugmeir
4414      */
4415
4416     SvGETMAGIC(source);
4417
4418     dest = TARG;
4419
4420     if (SvOK(source)) {
4421         s = (const U8*)SvPV_nomg_const(source, len);
4422     } else {
4423         if (ckWARN(WARN_UNINITIALIZED))
4424             report_uninit(source);
4425         s = (const U8*)"";
4426         len = 0;
4427     }
4428
4429     min = len + 1;
4430
4431     SvUPGRADE(dest, SVt_PV);
4432     d = (U8*)SvGROW(dest, min);
4433     (void)SvPOK_only(dest);
4434
4435     SETs(dest);
4436
4437     send = s + len;
4438     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4439         while (s < send) {
4440             const STRLEN u = UTF8SKIP(s);
4441             STRLEN ulen;
4442
4443             _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4444
4445             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4446                 const UV o = d - (U8*)SvPVX_const(dest);
4447                 SvGROW(dest, min);
4448                 d = (U8*)SvPVX(dest) + o;
4449             }
4450
4451             Copy(tmpbuf, d, ulen, U8);
4452             d += ulen;
4453             s += u;
4454         }
4455         SvUTF8_on(dest);
4456     } /* Unflagged string */
4457     else if (len) {
4458 #ifdef USE_LOCALE_CTYPE
4459         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4460             if (IN_UTF8_CTYPE_LOCALE) {
4461                 goto do_uni_folding;
4462             }
4463             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4464             for (; s < send; d++, s++)
4465                 *d = (U8) toFOLD_LC(*s);
4466         }
4467         else
4468 #endif
4469         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4470             for (; s < send; d++, s++)
4471                 *d = toFOLD(*s);
4472         }
4473         else {
4474 #ifdef USE_LOCALE_CTYPE
4475       do_uni_folding:
4476 #endif
4477             /* For ASCII and the Latin-1 range, there's only two troublesome
4478              * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4479              * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4480              * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4481              * For the rest, the casefold is their lowercase.  */
4482             for (; s < send; d++, s++) {
4483                 if (*s == MICRO_SIGN) {
4484                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4485                      * which is outside of the latin-1 range. There's a couple
4486                      * of ways to deal with this -- khw discusses them in
4487                      * pp_lc/uc, so go there :) What we do here is upgrade what
4488                      * we had already casefolded, then enter an inner loop that
4489                      * appends the rest of the characters as UTF-8. */
4490                     len = d - (U8*)SvPVX_const(dest);
4491                     SvCUR_set(dest, len);
4492                     len = sv_utf8_upgrade_flags_grow(dest,
4493                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4494                                                 /* The max expansion for latin1
4495                                                  * chars is 1 byte becomes 2 */
4496                                                 (send -s) * 2 + 1);
4497                     d = (U8*)SvPVX(dest) + len;
4498
4499                     Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4500                     d += small_mu_len;
4501                     s++;
4502                     for (; s < send; s++) {
4503                         STRLEN ulen;
4504                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4505                         if UVCHR_IS_INVARIANT(fc) {
4506                             if (full_folding
4507                                 && *s == LATIN_SMALL_LETTER_SHARP_S)
4508                             {
4509                                 *d++ = 's';
4510                                 *d++ = 's';
4511                             }
4512                             else
4513                                 *d++ = (U8)fc;
4514                         }
4515                         else {
4516                             Copy(tmpbuf, d, ulen, U8);
4517                             d += ulen;
4518                         }
4519                     }
4520                     break;
4521                 }
4522                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4523                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4524                      * becomes "ss", which may require growing the SV. */
4525                     if (SvLEN(dest) < ++min) {
4526                         const UV o = d - (U8*)SvPVX_const(dest);
4527                         SvGROW(dest, min);
4528                         d = (U8*)SvPVX(dest) + o;
4529                      }
4530                     *(d)++ = 's';
4531                     *d = 's';
4532                 }
4533                 else { /* If it's not one of those two, the fold is their lower
4534                           case */
4535                     *d = toLOWER_LATIN1(*s);
4536                 }
4537              }
4538         }
4539     }
4540     *d = '\0';
4541     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4542
4543 #ifdef USE_LOCALE_CTYPE
4544     if (IN_LC_RUNTIME(LC_CTYPE)) {
4545         TAINT;
4546         SvTAINTED_on(dest);
4547     }
4548 #endif
4549     if (SvTAINTED(source))
4550         SvTAINT(dest);
4551     SvSETMAGIC(dest);
4552     RETURN;
4553 }
4554
4555 /* Arrays. */
4556
4557 PP(pp_aslice)
4558 {
4559     dSP; dMARK; dORIGMARK;
4560     AV *const av = MUTABLE_AV(POPs);
4561     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4562
4563     if (SvTYPE(av) == SVt_PVAV) {
4564         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4565         bool can_preserve = FALSE;
4566
4567         if (localizing) {
4568             MAGIC *mg;
4569             HV *stash;
4570
4571             can_preserve = SvCANEXISTDELETE(av);
4572         }
4573
4574         if (lval && localizing) {
4575             SV **svp;
4576             SSize_t max = -1;
4577             for (svp = MARK + 1; svp <= SP; svp++) {
4578                 const SSize_t elem = SvIV(*svp);
4579                 if (elem > max)
4580                     max = elem;
4581             }
4582             if (max > AvMAX(av))
4583                 av_extend(av, max);
4584         }
4585
4586         while (++MARK <= SP) {
4587             SV **svp;
4588             SSize_t elem = SvIV(*MARK);
4589             bool preeminent = TRUE;
4590
4591             if (localizing && can_preserve) {
4592                 /* If we can determine whether the element exist,
4593                  * Try to preserve the existenceness of a tied array
4594                  * element by using EXISTS and DELETE if possible.
4595                  * Fallback to FETCH and STORE otherwise. */
4596                 preeminent = av_exists(av, elem);
4597             }
4598
4599             svp = av_fetch(av, elem, lval);
4600             if (lval) {
4601                 if (!svp || !*svp)
4602                     DIE(aTHX_ PL_no_aelem, elem);
4603                 if (localizing) {
4604                     if (preeminent)
4605                         save_aelem(av, elem, svp);
4606                     else
4607                         SAVEADELETE(av, elem);
4608                 }
4609             }
4610             *MARK = svp ? *svp : &PL_sv_undef;
4611         }
4612     }
4613     if (GIMME_V != G_ARRAY) {
4614         MARK = ORIGMARK;
4615         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4616         SP = MARK;
4617     }
4618     RETURN;
4619 }
4620
4621 PP(pp_kvaslice)
4622 {
4623     dSP; dMARK;
4624     AV *const av = MUTABLE_AV(POPs);
4625     I32 lval = (PL_op->op_flags & OPf_MOD);
4626     SSize_t items = SP - MARK;
4627
4628     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4629        const I32 flags = is_lvalue_sub();
4630        if (flags) {
4631            if (!(flags & OPpENTERSUB_INARGS))
4632                /* diag_listed_as: Can't modify %s in %s */
4633                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4634            lval = flags;
4635        }
4636     }
4637
4638     MEXTEND(SP,items);
4639     while (items > 1) {
4640         *(MARK+items*2-1) = *(MARK+items);
4641         items--;
4642     }
4643     items = SP-MARK;
4644     SP += items;
4645
4646     while (++MARK <= SP) {
4647         SV **svp;
4648
4649         svp = av_fetch(av, SvIV(*MARK), lval);
4650         if (lval) {
4651             if (!svp || !*svp || *svp == &PL_sv_undef) {
4652                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4653             }
4654             *MARK = sv_mortalcopy(*MARK);
4655         }
4656         *++MARK = svp ? *svp : &PL_sv_undef;
4657     }
4658     if (GIMME_V != G_ARRAY) {
4659         MARK = SP - items*2;
4660         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4661         SP = MARK;
4662     }
4663     RETURN;
4664 }
4665
4666
4667 /* Smart dereferencing for keys, values and each */
4668
4669 /* also used for: pp_reach() pp_rvalues() */
4670
4671 PP(pp_rkeys)
4672 {
4673     dSP;
4674     dPOPss;
4675
4676     SvGETMAGIC(sv);
4677
4678     if (
4679          !SvROK(sv)
4680       || (sv = SvRV(sv),
4681             (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4682           || SvOBJECT(sv)
4683          )
4684     ) {
4685         DIE(aTHX_
4686            "Type of argument to %s must be unblessed hashref or arrayref",
4687             PL_op_desc[PL_op->op_type] );
4688     }
4689
4690     if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4691         DIE(aTHX_
4692            "Can't modify %s in %s",
4693             PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4694         );
4695
4696     /* Delegate to correct function for op type */
4697     PUSHs(sv);
4698     if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4699         return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4700     }
4701     else {
4702         return (SvTYPE(sv) == SVt_PVHV)
4703                ? Perl_pp_each(aTHX)
4704                : Perl_pp_aeach(aTHX);
4705     }
4706 }
4707
4708 PP(pp_aeach)
4709 {
4710     dSP;
4711     AV *array = MUTABLE_AV(POPs);
4712     const I32 gimme = GIMME_V;
4713     IV *iterp = Perl_av_iter_p(aTHX_ array);
4714     const IV current = (*iterp)++;
4715
4716     if (current > av_tindex(array)) {
4717         *iterp = 0;
4718         if (gimme == G_SCALAR)
4719             RETPUSHUNDEF;
4720         else
4721             RETURN;
4722     }
4723
4724     EXTEND(SP, 2);
4725     mPUSHi(current);
4726     if (gimme == G_ARRAY) {
4727         SV **const element = av_fetch(array, current, 0);
4728         PUSHs(element ? *element : &PL_sv_undef);
4729     }
4730     RETURN;
4731 }
4732
4733 /* also used for: pp_avalues()*/
4734 PP(pp_akeys)
4735 {
4736     dSP;
4737     AV *array = MUTABLE_AV(POPs);
4738     const I32 gimme = GIMME_V;
4739
4740     *Perl_av_iter_p(aTHX_ array) = 0;
4741
4742     if (gimme == G_SCALAR) {
4743         dTARGET;
4744         PUSHi(av_tindex(array) + 1);
4745     }
4746     else if (gimme == G_ARRAY) {
4747         IV n = Perl_av_len(aTHX_ array);
4748         IV i;
4749
4750         EXTEND(SP, n + 1);
4751
4752         if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4753             for (i = 0;  i <= n;  i++) {
4754                 mPUSHi(i);
4755             }
4756         }
4757         else {
4758             for (i = 0;  i <= n;  i++) {
4759                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4760                 PUSHs(elem ? *elem : &PL_sv_undef);
4761             }
4762         }
4763     }
4764     RETURN;
4765 }
4766
4767 /* Associative arrays. */
4768
4769 PP(pp_each)
4770 {
4771     dSP;
4772     HV * hash = MUTABLE_HV(POPs);
4773     HE *entry;
4774     const I32 gimme = GIMME_V;
4775
4776     entry = hv_iternext(hash);
4777
4778     EXTEND(SP, 2);
4779     if (entry) {
4780         SV* const sv = hv_iterkeysv(entry);
4781         PUSHs(sv);
4782         if (gimme == G_ARRAY) {
4783             SV *val;
4784             val = hv_iterval(hash, entry);
4785             PUSHs(val);
4786         }
4787     }
4788     else if (gimme == G_SCALAR)
4789         RETPUSHUNDEF;
4790
4791     RETURN;
4792 }
4793
4794 STATIC OP *
4795 S_do_delete_local(pTHX)
4796 {
4797     dSP;
4798     const I32 gimme = GIMME_V;
4799     const MAGIC *mg;
4800     HV *stash;
4801     const bool sliced = !!(PL_op->op_private & OPpSLICE);
4802     SV **unsliced_keysv = sliced ? NULL : sp--;
4803     SV * const osv = POPs;
4804     SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4805     dORIGMARK;
4806     const bool tied = SvRMAGICAL(osv)
4807                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4808     const bool can_preserve = SvCANEXISTDELETE(osv);
4809     const U32 type = SvTYPE(osv);
4810     SV ** const end = sliced ? SP : unsliced_keysv;
4811
4812     if (type == SVt_PVHV) {                     /* hash element */
4813             HV * const hv = MUTABLE_HV(osv);
4814             while (++MARK <= end) {
4815                 SV * const keysv = *MARK;
4816                 SV *sv = NULL;
4817                 bool preeminent = TRUE;
4818                 if (can_preserve)
4819                     preeminent = hv_exists_ent(hv, keysv, 0);
4820                 if (tied) {
4821                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4822                     if (he)
4823                         sv = HeVAL(he);
4824                     else
4825                         preeminent = FALSE;
4826                 }
4827                 else {
4828                     sv = hv_delete_ent(hv, keysv, 0, 0);
4829                     if (preeminent)
4830                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4831                 }
4832                 if (preeminent) {
4833                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4834                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4835                     if (tied) {
4836                         *MARK = sv_mortalcopy(sv);
4837                         mg_clear(sv);
4838                     } else
4839                         *MARK = sv;
4840                 }
4841                 else {
4842                     SAVEHDELETE(hv, keysv);
4843                     *MARK = &PL_sv_undef;
4844                 }
4845             }
4846     }
4847     else if (type == SVt_PVAV) {                  /* array element */
4848             if (PL_op->op_flags & OPf_SPECIAL) {
4849                 AV * const av = MUTABLE_AV(osv);
4850                 while (++MARK <= end) {
4851                     SSize_t idx = SvIV(*MARK);
4852                     SV *sv = NULL;
4853                     bool preeminent = TRUE;
4854                     if (can_preserve)
4855                         preeminent = av_exists(av, idx);
4856                     if (tied) {
4857                         SV **svp = av_fetch(av, idx, 1);
4858                         if (svp)
4859                             sv = *svp;
4860                         else
4861                             preeminent = FALSE;
4862                     }
4863                     else {
4864                         sv = av_delete(av, idx, 0);
4865                         if (preeminent)
4866                            SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4867                     }
4868                     if (preeminent) {
4869                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4870                         if (tied) {
4871                             *MARK = sv_mortalcopy(sv);
4872                             mg_clear(sv);
4873                         } else
4874                             *MARK = sv;
4875                     }
4876                     else {
4877                         SAVEADELETE(av, idx);
4878                         *MARK = &PL_sv_undef;
4879                     }
4880                 }
4881             }
4882             else
4883                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4884     }
4885     else
4886             DIE(aTHX_ "Not a HASH reference");
4887     if (sliced) {
4888         if (gimme == G_VOID)
4889             SP = ORIGMARK;
4890         else if (gimme == G_SCALAR) {
4891             MARK = ORIGMARK;
4892             if (SP > MARK)
4893                 *++MARK = *SP;
4894             else
4895                 *++MARK = &PL_sv_undef;
4896             SP = MARK;
4897         }
4898     }
4899     else if (gimme != G_VOID)
4900         PUSHs(*unsliced_keysv);
4901
4902     RETURN;
4903 }
4904
4905 PP(pp_delete)
4906 {
4907     dSP;
4908     I32 gimme;
4909     I32 discard;
4910
4911     if (PL_op->op_private & OPpLVAL_INTRO)
4912         return do_delete_local();
4913
4914     gimme = GIMME_V;
4915     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4916
4917     if (PL_op->op_private & OPpSLICE) {
4918         dMARK; dORIGMARK;
4919         HV * const hv = MUTABLE_HV(POPs);
4920         const U32 hvtype = SvTYPE(hv);
4921         if (hvtype == SVt_PVHV) {                       /* hash element */
4922             while (++MARK <= SP) {
4923                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4924                 *MARK = sv ? sv : &PL_sv_undef;
4925             }
4926         }
4927         else if (hvtype == SVt_PVAV) {                  /* array element */
4928             if (PL_op->op_flags & OPf_SPECIAL) {
4929                 while (++MARK <= SP) {
4930                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4931                     *MARK = sv ? sv : &PL_sv_undef;
4932                 }
4933             }
4934         }
4935         else
4936             DIE(aTHX_ "Not a HASH reference");
4937         if (discard)
4938             SP = ORIGMARK;
4939         else if (gimme == G_SCALAR) {
4940             MARK = ORIGMARK;
4941             if (SP > MARK)
4942                 *++MARK = *SP;
4943             else
4944                 *++MARK = &PL_sv_undef;
4945             SP = MARK;
4946         }
4947     }
4948     else {
4949         SV *keysv = POPs;
4950         HV * const hv = MUTABLE_HV(POPs);
4951         SV *sv = NULL;
4952         if (SvTYPE(hv) == SVt_PVHV)
4953             sv = hv_delete_ent(hv, keysv, discard, 0);
4954         else if (SvTYPE(hv) == SVt_PVAV) {
4955             if (PL_op->op_flags & OPf_SPECIAL)
4956                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4957             else
4958                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4959         }
4960         else
4961             DIE(aTHX_ "Not a HASH reference");
4962         if (!sv)
4963             sv = &PL_sv_undef;
4964         if (!discard)
4965             PUSHs(sv);
4966     }
4967     RETURN;
4968 }
4969
4970 PP(pp_exists)
4971 {
4972     dSP;
4973     SV *tmpsv;
4974     HV *hv;
4975
4976     if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
4977         GV *gv;
4978         SV * const sv = POPs;
4979         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4980         if (cv)
4981             RETPUSHYES;
4982         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4983             RETPUSHYES;
4984         RETPUSHNO;
4985     }
4986     tmpsv = POPs;
4987     hv = MUTABLE_HV(POPs);
4988     if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
4989         if (hv_exists_ent(hv, tmpsv, 0))
4990             RETPUSHYES;
4991     }
4992     else if (SvTYPE(hv) == SVt_PVAV) {
4993         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4994             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4995                 RETPUSHYES;
4996         }
4997     }
4998     else {
4999         DIE(aTHX_ "Not a HASH reference");
5000     }
5001     RETPUSHNO;
5002 }
5003
5004 PP(pp_hslice)
5005 {
5006     dSP; dMARK; dORIGMARK;
5007     HV * const hv = MUTABLE_HV(POPs);
5008     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5009     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5010     bool can_preserve = FALSE;
5011
5012     if (localizing) {
5013         MAGIC *mg;
5014         HV *stash;
5015
5016         if (SvCANEXISTDELETE(hv))
5017             can_preserve = TRUE;
5018     }
5019
5020     while (++MARK <= SP) {
5021         SV * const keysv = *MARK;
5022         SV **svp;
5023         HE *he;
5024         bool preeminent = TRUE;
5025
5026         if (localizing && can_preserve) {
5027             /* If we can determine whether the element exist,
5028              * try to preserve the existenceness of a tied hash
5029              * element by using EXISTS and DELETE if possible.
5030              * Fallback to FETCH and STORE otherwise. */
5031             preeminent = hv_exists_ent(hv, keysv, 0);
5032         }
5033
5034         he = hv_fetch_ent(hv, keysv, lval, 0);
5035         svp = he ? &HeVAL(he) : NULL;
5036
5037         if (lval) {
5038             if (!svp || !*svp || *svp == &PL_sv_undef) {
5039                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5040             }
5041             if (localizing) {
5042                 if (HvNAME_get(hv) && isGV(*svp))
5043                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5044                 else if (preeminent)
5045                     save_helem_flags(hv, keysv, svp,
5046                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5047                 else
5048                     SAVEHDELETE(hv, keysv);
5049             }
5050         }
5051         *MARK = svp && *svp ? *svp : &PL_sv_undef;
5052     }
5053     if (GIMME_V != G_ARRAY) {
5054         MARK = ORIGMARK;
5055         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5056         SP = MARK;
5057     }
5058     RETURN;
5059 }
5060
5061 PP(pp_kvhslice)
5062 {
5063     dSP; dMARK;
5064     HV * const hv = MUTABLE_HV(POPs);
5065     I32 lval = (PL_op->op_flags & OPf_MOD);
5066     SSize_t items = SP - MARK;
5067
5068     if (PL_op->op_private & OPpMAYBE_LVSUB) {
5069        const I32 flags = is_lvalue_sub();
5070        if (flags) {
5071            if (!(flags & OPpENTERSUB_INARGS))
5072                /* diag_listed_as: Can't modify %s in %s */
5073                Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
5074            lval = flags;
5075        }
5076     }
5077
5078     MEXTEND(SP,items);
5079     while (items > 1) {
5080         *(MARK+items*2-1) = *(MARK+items);
5081         items--;
5082     }
5083     items = SP-MARK;
5084     SP += items;
5085
5086     while (++MARK <= SP) {
5087         SV * const keysv = *MARK;
5088         SV **svp;
5089         HE *he;
5090
5091         he = hv_fetch_ent(hv, keysv, lval, 0);
5092         svp = he ? &HeVAL(he) : NULL;
5093
5094         if (lval) {
5095             if (!svp || !*svp || *svp == &PL_sv_undef) {
5096                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5097             }
5098             *MARK = sv_mortalcopy(*MARK);
5099         }
5100         *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5101     }
5102     if (GIMME_V != G_ARRAY) {
5103         MARK = SP - items*2;
5104         *++MARK = items > 0 ? *SP : &PL_sv_undef;
5105         SP = MARK;
5106     }
5107     RETURN;
5108 }
5109
5110 /* List operators. */
5111
5112 PP(pp_list)
5113 {
5114     I32 markidx = POPMARK;
5115     if (GIMME_V != G_ARRAY) {
5116         SV **mark = PL_stack_base + markidx;
5117         dSP;
5118         if (++MARK <= SP)
5119             *MARK = *SP;                /* unwanted list, return last item */
5120         else
5121             *MARK = &PL_sv_undef;
5122         SP = MARK;
5123         PUTBACK;
5124     }
5125     return NORMAL;
5126 }
5127
5128 PP(pp_lslice)
5129 {
5130     dSP;
5131     SV ** const lastrelem = PL_stack_sp;
5132     SV ** const lastlelem = PL_stack_base + POPMARK;
5133     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5134     SV ** const firstrelem = lastlelem + 1;
5135     const U8 mod = PL_op->op_flags & OPf_MOD;
5136
5137     const I32 max = lastrelem - lastlelem;
5138     SV **lelem;
5139
5140     if (GIMME_V != G_ARRAY) {
5141         I32 ix = SvIV(*lastlelem);
5142         if (ix < 0)
5143             ix += max;
5144         if (ix < 0 || ix >= max)
5145             *firstlelem = &PL_sv_undef;
5146         else
5147             *firstlelem = firstrelem[ix];
5148         SP = firstlelem;
5149         RETURN;
5150     }
5151
5152     if (max == 0) {
5153         SP = firstlelem - 1;
5154         RETURN;
5155     }
5156
5157     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5158         I32 ix = SvIV(*lelem);
5159         if (ix < 0)
5160             ix += max;
5161         if (ix < 0 || ix >= max)
5162             *lelem = &PL_sv_undef;
5163         else {
5164             if (!(*lelem = firstrelem[ix]))
5165                 *lelem = &PL_sv_undef;
5166             else if (mod && SvPADTMP(*lelem)) {
5167                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5168             }
5169         }
5170     }
5171     SP = lastlelem;
5172     RETURN;
5173 }
5174
5175 PP(pp_anonlist)
5176 {
5177     dSP; dMARK;
5178     const I32 items = SP - MARK;
5179     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5180     SP = MARK;
5181     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5182             ? newRV_noinc(av) : av);
5183     RETURN;
5184 }
5185
5186 PP(pp_anonhash)
5187 {
5188     dSP; dMARK; dORIGMARK;
5189     HV* const hv = newHV();
5190     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5191                                     ? newRV_noinc(MUTABLE_SV(hv))
5192                                     : MUTABLE_SV(hv) );
5193
5194     while (MARK < SP) {
5195         SV * const key =
5196             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5197         SV *val;
5198         if (MARK < SP)
5199         {
5200             MARK++;
5201             SvGETMAGIC(*MARK);
5202             val = newSV(0);
5203             sv_setsv_nomg(val, *MARK);
5204         }
5205         else
5206         {
5207             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5208             val = newSV(0);
5209         }
5210         (void)hv_store_ent(hv,key,val,0);
5211     }
5212     SP = ORIGMARK;
5213     XPUSHs(retval);
5214     RETURN;
5215 }
5216
5217 static AV *
5218 S_deref_plain_array(pTHX_ AV *ary)
5219 {
5220     if (SvTYPE(ary) == SVt_PVAV) return ary;
5221     SvGETMAGIC((SV *)ary);
5222     if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5223         Perl_die(aTHX_ "Not an ARRAY reference");
5224     else if (SvOBJECT(SvRV(ary)))
5225         Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5226     return (AV *)SvRV(ary);
5227 }
5228
5229 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5230 # define DEREF_PLAIN_ARRAY(ary)       \
5231    ({                                  \
5232      AV *aRrRay = ary;                  \
5233      SvTYPE(aRrRay) == SVt_PVAV          \
5234       ? aRrRay                            \
5235       : S_deref_plain_array(aTHX_ aRrRay); \
5236    })
5237 #else
5238 # define DEREF_PLAIN_ARRAY(ary)            \
5239    (                                        \
5240      PL_Sv = (SV *)(ary),                    \
5241      SvTYPE(PL_Sv) == SVt_PVAV                \
5242       ? (AV *)PL_Sv                            \
5243       : S_deref_plain_array(aTHX_ (AV *)PL_Sv)  \
5244    )
5245 #endif
5246
5247 PP(pp_splice)
5248 {
5249     dSP; dMARK; dORIGMARK;
5250     int num_args = (SP - MARK);
5251     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5252     SV **src;
5253     SV **dst;
5254     SSize_t i;
5255     SSize_t offset;
5256     SSize_t length;
5257     SSize_t newlen;
5258     SSize_t after;
5259     SSize_t diff;
5260     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5261
5262     if (mg) {
5263         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5264                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5265                                     sp - mark);
5266     }
5267
5268     SP++;
5269
5270     if (++MARK < SP) {
5271         offset = i = SvIV(*MARK);
5272         if (offset < 0)
5273             offset += AvFILLp(ary) + 1;
5274         if (offset < 0)
5275             DIE(aTHX_ PL_no_aelem, i);
5276         if (++MARK < SP) {
5277             length = SvIVx(*MARK++);
5278             if (length < 0) {
5279                 length += AvFILLp(ary) - offset + 1;
5280                 if (length < 0)
5281                     length = 0;
5282             }
5283         }
5284         else
5285             length = AvMAX(ary) + 1;            /* close enough to infinity */
5286     }
5287     else {
5288         offset = 0;
5289         length = AvMAX(ary) + 1;
5290     }
5291     if (offset > AvFILLp(ary) + 1) {
5292         if (num_args > 2)
5293             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5294         offset = AvFILLp(ary) + 1;
5295     }
5296     after = AvFILLp(ary) + 1 - (offset + length);
5297     if (after < 0) {                            /* not that much array */
5298         length += after;                        /* offset+length now in array */
5299         after = 0;
5300         if (!AvALLOC(ary))
5301             av_extend(ary, 0);
5302     }
5303
5304     /* At this point, MARK .. SP-1 is our new LIST */
5305
5306     newlen = SP - MARK;
5307     diff = newlen - length;
5308     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5309         av_reify(ary);
5310
5311     /* make new elements SVs now: avoid problems if they're from the array */
5312     for (dst = MARK, i = newlen; i; i--) {
5313         SV * const h = *dst;
5314         *dst++ = newSVsv(h);
5315     }
5316
5317     if (diff < 0) {                             /* shrinking the area */
5318         SV **tmparyval = NULL;
5319         if (newlen) {
5320             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5321             Copy(MARK, tmparyval, newlen, SV*);
5322         }
5323
5324         MARK = ORIGMARK + 1;
5325         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5326             const bool real = cBOOL(AvREAL(ary));
5327             MEXTEND(MARK, length);
5328             if (real)
5329                 EXTEND_MORTAL(length);
5330             for (i = 0, dst = MARK; i < length; i++) {
5331                 if ((*dst = AvARRAY(ary)[i+offset])) {
5332                   if (real)
5333                     sv_2mortal(*dst);   /* free them eventually */
5334                 }
5335                 else
5336                     *dst = &PL_sv_undef;
5337                 dst++;
5338             }
5339             MARK += length - 1;
5340         }
5341         else {
5342             *MARK = AvARRAY(ary)[offset+length-1];
5343             if (AvREAL(ary)) {
5344                 sv_2mortal(*MARK);
5345                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5346                     SvREFCNT_dec(*dst++);       /* free them now */
5347             }
5348         }
5349         AvFILLp(ary) += diff;
5350
5351         /* pull up or down? */
5352
5353         if (offset < after) {                   /* easier to pull up */
5354             if (offset) {                       /* esp. if nothing to pull */
5355                 src = &AvARRAY(ary)[offset-1];
5356                 dst = src - diff;               /* diff is negative */
5357                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5358                     *dst-- = *src--;
5359             }
5360             dst = AvARRAY(ary);
5361             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5362             AvMAX(ary) += diff;
5363         }
5364         else {
5365             if (after) {                        /* anything to pull down? */
5366                 src = AvARRAY(ary) + offset + length;
5367                 dst = src + diff;               /* diff is negative */
5368                 Move(src, dst, after, SV*);
5369             }
5370             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5371                                                 /* avoid later double free */
5372         }
5373         i = -diff;
5374         while (i)
5375             dst[--i] = NULL;
5376         
5377         if (newlen) {
5378             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5379             Safefree(tmparyval);
5380         }
5381     }
5382     else {                                      /* no, expanding (or same) */
5383         SV** tmparyval = NULL;
5384         if (length) {
5385             Newx(tmparyval, length, SV*);       /* so remember deletion */
5386             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5387         }
5388
5389         if (diff > 0) {                         /* expanding */
5390             /* push up or down? */
5391             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5392                 if (offset) {
5393                     src = AvARRAY(ary);
5394                     dst = src - diff;
5395                     Move(src, dst, offset, SV*);
5396                 }
5397                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5398                 AvMAX(ary) += diff;
5399                 AvFILLp(ary) += diff;
5400             }
5401             else {
5402                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5403                     av_extend(ary, AvFILLp(ary) + diff);
5404                 AvFILLp(ary) += diff;
5405
5406                 if (after) {
5407                     dst = AvARRAY(ary) + AvFILLp(ary);
5408                     src = dst - diff;
5409                     for (i = after; i; i--) {
5410                         *dst-- = *src--;
5411                     }
5412                 }
5413             }
5414         }
5415
5416         if (newlen) {
5417             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5418         }
5419
5420         MARK = ORIGMARK + 1;
5421         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5422             if (length) {
5423                 const bool real = cBOOL(AvREAL(ary));
5424                 if (real)
5425                     EXTEND_MORTAL(length);
5426                 for (i = 0, dst = MARK; i < length; i++) {
5427                     if ((*dst = tmparyval[i])) {
5428                       if (real)
5429                         sv_2mortal(*dst);       /* free them eventually */
5430                     }
5431                     else *dst = &PL_sv_undef;
5432                     dst++;
5433                 }
5434             }
5435             MARK += length - 1;
5436         }
5437         else if (length--) {
5438             *MARK = tmparyval[length];
5439             if (AvREAL(ary)) {
5440                 sv_2mortal(*MARK);
5441                 while (length-- > 0)
5442                     SvREFCNT_dec(tmparyval[length]);
5443             }
5444         }
5445         else
5446             *MARK = &PL_sv_undef;
5447         Safefree(tmparyval);
5448     }
5449
5450     if (SvMAGICAL(ary))
5451         mg_set(MUTABLE_SV(ary));
5452
5453     SP = MARK;
5454     RETURN;
5455 }
5456
5457 PP(pp_push)
5458 {
5459     dSP; dMARK; dORIGMARK; dTARGET;
5460     AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5461     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5462
5463     if (mg) {
5464         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5465         PUSHMARK(MARK);
5466         PUTBACK;
5467         ENTER_with_name("call_PUSH");
5468         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5469         LEAVE_with_name("call_PUSH");
5470         /* SPAGAIN; not needed: SP is assigned to immediately below */
5471     }
5472     else {
5473         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5474         PL_delaymagic = DM_DELAY;
5475         for (++MARK; MARK <= SP; MARK++) {
5476             SV *sv;
5477             if (*MARK) SvGETMAGIC(*MARK);
5478             sv = newSV(0);
5479             if (*MARK)
5480                 sv_setsv_nomg(sv, *MARK);
5481             av_store(ary, AvFILLp(ary)+1, sv);
5482         }
5483         if (PL_delaymagic & DM_ARRAY_ISA)
5484             mg_set(MUTABLE_SV(ary));
5485
5486         PL_delaymagic = 0;
5487     }
5488     SP = ORIGMARK;
5489     if (OP_GIMME(PL_op, 0) != G_VOID) {
5490         PUSHi( AvFILL(ary) + 1 );
5491     }
5492     RETURN;
5493 }
5494
5495 /* also used for: pp_pop()*/
5496 PP(pp_shift)
5497 {
5498     dSP;
5499     AV * const av = PL_op->op_flags & OPf_SPECIAL
5500         ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5501     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5502     EXTEND(SP, 1);
5503     assert (sv);
5504     if (AvREAL(av))
5505         (void)sv_2mortal(sv);
5506     PUSHs(sv);
5507     RETURN;
5508 }
5509
5510 PP(pp_unshift)
5511 {
5512     dSP; dMARK; dORIGMARK; dTARGET;
5513     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5514     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5515
5516     if (mg) {
5517         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5518         PUSHMARK(MARK);
5519         PUTBACK;
5520         ENTER_with_name("call_UNSHIFT");
5521         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5522         LEAVE_with_name("call_UNSHIFT");
5523         /* SPAGAIN; not needed: SP is assigned to immediately below */
5524     }
5525     else {
5526         SSize_t i = 0;
5527         av_unshift(ary, SP - MARK);
5528         while (MARK < SP) {
5529             SV * const sv = newSVsv(*++MARK);
5530             (void)av_store(ary, i++, sv);
5531         }
5532     }
5533     SP = ORIGMARK;
5534     if (OP_GIMME(PL_op, 0) != G_VOID) {
5535         PUSHi( AvFILL(ary) + 1 );
5536     }
5537     RETURN;
5538 }
5539
5540 PP(pp_reverse)
5541 {
5542     dSP; dMARK;
5543
5544     if (GIMME_V == G_ARRAY) {
5545         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5546             AV *av;
5547
5548             /* See pp_sort() */
5549             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5550             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5551             av = MUTABLE_AV((*SP));
5552             /* In-place reversing only happens in void context for the array
5553              * assignment. We don't need to push anything on the stack. */
5554             SP = MARK;
5555
5556             if (SvMAGICAL(av)) {
5557                 SSize_t i, j;
5558                 SV *tmp = sv_newmortal();
5559                 /* For SvCANEXISTDELETE */
5560                 HV *stash;
5561                 const MAGIC *mg;
5562                 bool can_preserve = SvCANEXISTDELETE(av);
5563
5564                 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5565                     SV *begin, *end;
5566
5567                     if (can_preserve) {
5568                         if (!av_exists(av, i)) {
5569                             if (av_exists(av, j)) {
5570                                 SV *sv = av_delete(av, j, 0);
5571                                 begin = *av_fetch(av, i, TRUE);
5572                                 sv_setsv_mg(begin, sv);
5573                             }
5574                             continue;
5575                         }
5576                         else if (!av_exists(av, j)) {
5577                             SV *sv = av_delete(av, i, 0);
5578                             end = *av_fetch(av, j, TRUE);
5579                             sv_setsv_mg(end, sv);
5580                             continue;
5581                         }
5582                     }
5583
5584                     begin = *av_fetch(av, i, TRUE);
5585                     end   = *av_fetch(av, j, TRUE);
5586                     sv_setsv(tmp,      begin);
5587                     sv_setsv_mg(begin, end);
5588                     sv_setsv_mg(end,   tmp);
5589                 }
5590             }
5591             else {
5592                 SV **begin = AvARRAY(av);
5593
5594                 if (begin) {
5595                     SV **end   = begin + AvFILLp(av);
5596
5597                     while (begin < end) {
5598                         SV * const tmp = *begin;
5599                         *begin++ = *end;
5600                         *end--   = tmp;
5601                     }
5602                 }
5603             }
5604         }
5605         else {
5606             SV **oldsp = SP;
5607             MARK++;
5608             while (MARK < SP) {
5609                 SV * const tmp = *MARK;
5610                 *MARK++ = *SP;
5611                 *SP--   = tmp;
5612             }
5613             /* safe as long as stack cannot get extended in the above */
5614             SP = oldsp;
5615         }
5616     }
5617     else {
5618         char *up;
5619         char *down;
5620         I32 tmp;
5621         dTARGET;
5622         STRLEN len;
5623
5624         SvUTF8_off(TARG);                               /* decontaminate */
5625         if (SP - MARK > 1)
5626             do_join(TARG, &PL_sv_no, MARK, SP);
5627         else {
5628             sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5629         }
5630
5631         up = SvPV_force(TARG, len);
5632         if (len > 1) {
5633             if (DO_UTF8(TARG)) {        /* first reverse each character */
5634                 U8* s = (U8*)SvPVX(TARG);
5635                 const U8* send = (U8*)(s + len);
5636                 while (s < send) {
5637                     if (UTF8_IS_INVARIANT(*s)) {
5638                         s++;
5639                         continue;
5640                     }
5641                     else {
5642                         if (!utf8_to_uvchr_buf(s, send, 0))
5643                             break;
5644                         up = (char*)s;
5645                         s += UTF8SKIP(s);
5646                         down = (char*)(s - 1);
5647                         /* reverse this character */
5648                         while (down > up) {
5649                             tmp = *up;
5650                             *up++ = *down;
5651                             *down-- = (char)tmp;
5652                         }
5653                     }
5654                 }
5655                 up = SvPVX(TARG);
5656             }
5657             down = SvPVX(TARG) + len - 1;
5658             while (down > up) {
5659                 tmp = *up;
5660                 *up++ = *down;
5661                 *down-- = (char)tmp;
5662             }
5663             (void)SvPOK_only_UTF8(TARG);
5664         }
5665         SP = MARK + 1;
5666         SETTARG;
5667     }
5668     RETURN;
5669 }
5670
5671 PP(pp_split)
5672 {
5673     dSP; dTARG;
5674     AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
5675     IV limit = POPi;                    /* note, negative is forever */
5676     SV * const sv = POPs;
5677     STRLEN len;
5678     const char *s = SvPV_const(sv, len);
5679     const bool do_utf8 = DO_UTF8(sv);
5680     const char *strend = s + len;
5681     PMOP *pm;
5682     REGEXP *rx;
5683     SV *dstr;
5684     const char *m;
5685     SSize_t iters = 0;
5686     const STRLEN slen = do_utf8
5687                         ? utf8_length((U8*)s, (U8*)strend)
5688                         : (STRLEN)(strend - s);
5689     SSize_t maxiters = slen + 10;
5690     I32 trailing_empty = 0;
5691     const char *orig;
5692     const I32 origlimit = limit;
5693     I32 realarray = 0;
5694     I32 base;
5695     const I32 gimme = GIMME_V;
5696     bool gimme_scalar;
5697     const I32 oldsave = PL_savestack_ix;
5698     U32 make_mortal = SVs_TEMP;
5699     bool multiline = 0;
5700     MAGIC *mg = NULL;
5701
5702 #ifdef DEBUGGING
5703     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5704 #else
5705     pm = (PMOP*)POPs;
5706 #endif
5707     if (!pm)
5708         DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5709     rx = PM_GETRE(pm);
5710
5711     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5712              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5713
5714 #ifdef USE_ITHREADS
5715     if (pm->op_pmreplrootu.op_pmtargetoff) {
5716         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5717         goto have_av;
5718     }
5719 #else
5720     if (pm->op_pmreplrootu.op_pmtargetgv) {
5721         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5722         goto have_av;
5723     }
5724 #endif
5725     else if (pm->op_targ)
5726         ary = (AV *)PAD_SVl(pm->op_targ);
5727     if (ary) {
5728         have_av:
5729         realarray = 1;
5730         PUTBACK;
5731         av_extend(ary,0);
5732         (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5733         av_clear(ary);
5734         SPAGAIN;
5735         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5736             PUSHMARK(SP);
5737             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5738         }
5739         else {
5740             if (!AvREAL(ary)) {
5741                 I32 i;
5742                 AvREAL_on(ary);
5743                 AvREIFY_off(ary);
5744                 for (i = AvFILLp(ary); i >= 0; i--)
5745                     AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5746             }
5747             /* temporarily switch stacks */
5748             SAVESWITCHSTACK(PL_curstack, ary);
5749             make_mortal = 0;
5750         }
5751     }
5752     base = SP - PL_stack_base;
5753     orig = s;
5754     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5755         if (do_utf8) {
5756             while (isSPACE_utf8(s))
5757                 s += UTF8SKIP(s);
5758         }
5759         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5760             while (isSPACE_LC(*s))
5761                 s++;
5762         }
5763         else {
5764             while (isSPACE(*s))
5765                 s++;
5766         }
5767     }
5768     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5769         multiline = 1;
5770     }
5771
5772     gimme_scalar = gimme == G_SCALAR && !ary;
5773
5774     if (!limit)
5775         limit = maxiters + 2;
5776     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5777         while (--limit) {
5778             m = s;
5779             /* this one uses 'm' and is a negative test */
5780             if (do_utf8) {
5781                 while (m < strend && ! isSPACE_utf8(m) ) {
5782                     const int t = UTF8SKIP(m);
5783                     /* isSPACE_utf8 returns FALSE for malform utf8 */
5784                     if (strend - m < t)
5785                         m = strend;
5786                     else
5787                         m += t;
5788                 }
5789             }
5790             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5791             {
5792                 while (m < strend && !isSPACE_LC(*m))
5793                     ++m;
5794             } else {
5795                 while (m < strend && !isSPACE(*m))
5796                     ++m;
5797             }  
5798             if (m >= strend)
5799                 break;
5800
5801             if (gimme_scalar) {
5802                 iters++;
5803                 if (m-s == 0)
5804                     trailing_empty++;
5805                 else
5806                     trailing_empty = 0;
5807             } else {
5808                 dstr = newSVpvn_flags(s, m-s,
5809                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5810                 XPUSHs(dstr);
5811             }
5812
5813             /* skip the whitespace found last */
5814             if (do_utf8)
5815                 s = m + UTF8SKIP(m);
5816             else
5817                 s = m + 1;
5818
5819             /* this one uses 's' and is a positive test */
5820             if (do_utf8) {
5821                 while (s < strend && isSPACE_utf8(s) )
5822                     s +=  UTF8SKIP(s);
5823             }
5824             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5825             {
5826                 while (s < strend && isSPACE_LC(*s))
5827                     ++s;
5828             } else {
5829                 while (s < strend && isSPACE(*s))
5830                     ++s;
5831             }       
5832         }
5833     }
5834     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5835         while (--limit) {
5836             for (m = s; m < strend && *m != '\n'; m++)
5837                 ;
5838             m++;
5839             if (m >= strend)
5840                 break;
5841
5842             if (gimme_scalar) {
5843                 iters++;
5844                 if (m-s == 0)
5845                     trailing_empty++;
5846                 else
5847                     trailing_empty = 0;
5848             } else {
5849                 dstr = newSVpvn_flags(s, m-s,
5850                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5851                 XPUSHs(dstr);
5852             }
5853             s = m;
5854         }
5855     }
5856     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5857         /*
5858           Pre-extend the stack, either the number of bytes or
5859           characters in the string or a limited amount, triggered by:
5860
5861           my ($x, $y) = split //, $str;
5862             or
5863           split //, $str, $i;
5864         */
5865         if (!gimme_scalar) {
5866             const U32 items = limit - 1;
5867             if (items < slen)
5868                 EXTEND(SP, items);
5869             else
5870                 EXTEND(SP, slen);
5871         }
5872
5873         if (do_utf8) {
5874             while (--limit) {
5875                 /* keep track of how many bytes we skip over */
5876                 m = s;
5877                 s += UTF8SKIP(s);
5878                 if (gimme_scalar) {
5879                     iters++;
5880                     if (s-m == 0)
5881                         trailing_empty++;
5882                     else
5883                         trailing_empty = 0;
5884                 } else {
5885                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5886
5887                     PUSHs(dstr);
5888                 }
5889
5890                 if (s >= strend)
5891                     break;
5892             }
5893         } else {
5894             while (--limit) {
5895                 if (gimme_scalar) {
5896                     iters++;
5897                 } else {
5898                     dstr = newSVpvn(s, 1);
5899
5900
5901                     if (make_mortal)
5902                         sv_2mortal(dstr);
5903
5904                     PUSHs(dstr);
5905                 }
5906
5907                 s++;
5908
5909                 if (s >= strend)
5910                     break;
5911             }
5912         }
5913     }
5914     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5915              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5916              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5917              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5918         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5919         SV * const csv = CALLREG_INTUIT_STRING(rx);
5920
5921         len = RX_MINLENRET(rx);
5922         if (len == 1 && !RX_UTF8(rx) && !tail) {
5923             const char c = *SvPV_nolen_const(csv);
5924             while (--limit) {
5925                 for (m = s; m < strend && *m != c; m++)
5926                     ;
5927                 if (m >= strend)
5928                     break;
5929                 if (gimme_scalar) {
5930                     iters++;
5931                     if (m-s == 0)
5932                         trailing_empty++;
5933                     else
5934                         trailing_empty = 0;
5935                 } else {
5936                     dstr = newSVpvn_flags(s, m-s,
5937                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5938                     XPUSHs(dstr);
5939                 }
5940                 /* The rx->minlen is in characters but we want to step
5941                  * s ahead by bytes. */
5942                 if (do_utf8)
5943                     s = (char*)utf8_hop((U8*)m, len);
5944                 else
5945                     s = m + len; /* Fake \n at the end */
5946             }
5947         }
5948         else {
5949             while (s < strend && --limit &&
5950               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5951                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5952             {
5953                 if (gimme_scalar) {
5954                     iters++;
5955                     if (m-s == 0)
5956                         trailing_empty++;
5957                     else
5958                         trailing_empty = 0;
5959                 } else {
5960                     dstr = newSVpvn_flags(s, m-s,
5961                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5962                     XPUSHs(dstr);
5963                 }
5964                 /* The rx->minlen is in characters but we want to step
5965                  * s ahead by bytes. */
5966                 if (do_utf8)
5967                     s = (char*)utf8_hop((U8*)m, len);
5968                 else
5969                     s = m + len; /* Fake \n at the end */
5970             }
5971         }
5972     }
5973     else {
5974         maxiters += slen * RX_NPARENS(rx);
5975         while (s < strend && --limit)
5976         {
5977             I32 rex_return;
5978             PUTBACK;
5979             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5980                                      sv, NULL, 0);
5981             SPAGAIN;
5982             if (rex_return == 0)
5983                 break;
5984             TAINT_IF(RX_MATCH_TAINTED(rx));
5985             /* we never pass the REXEC_COPY_STR flag, so it should
5986              * never get copied */
5987             assert(!RX_MATCH_COPIED(rx));
5988             m = RX_OFFS(rx)[0].start + orig;
5989
5990             if (gimme_scalar) {
5991                 iters++;
5992                 if (m-s == 0)
5993                     trailing_empty++;
5994                 else
5995                     trailing_empty = 0;
5996             } else {
5997                 dstr = newSVpvn_flags(s, m-s,
5998                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5999                 XPUSHs(dstr);
6000             }
6001             if (RX_NPARENS(rx)) {
6002                 I32 i;
6003                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6004                     s = RX_OFFS(rx)[i].start + orig;
6005                     m = RX_OFFS(rx)[i].end + orig;
6006
6007                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
6008                        parens that didn't match -- they should be set to
6009                        undef, not the empty string */
6010                     if (gimme_scalar) {
6011                         iters++;
6012                         if (m-s == 0)
6013                             trailing_empty++;
6014                         else
6015                             trailing_empty = 0;
6016                     } else {
6017                         if (m >= orig && s >= orig) {
6018                             dstr = newSVpvn_flags(s, m-s,
6019                                                  (do_utf8 ? SVf_UTF8 : 0)
6020                                                   | make_mortal);
6021                         }
6022                         else
6023                             dstr = &PL_sv_undef;  /* undef, not "" */
6024                         XPUSHs(dstr);
6025                     }
6026
6027                 }
6028             }
6029             s = RX_OFFS(rx)[0].end + orig;
6030         }
6031     }
6032
6033     if (!gimme_scalar) {
6034         iters = (SP - PL_stack_base) - base;
6035     }
6036     if (iters > maxiters)
6037         DIE(aTHX_ "Split loop");
6038
6039     /* keep field after final delim? */
6040     if (s < strend || (iters && origlimit)) {
6041         if (!gimme_scalar) {
6042             const STRLEN l = strend - s;
6043             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6044             XPUSHs(dstr);
6045         }
6046         iters++;
6047     }
6048     else if (!origlimit) {
6049         if (gimme_scalar) {
6050             iters -= trailing_empty;
6051         } else {
6052             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6053                 if (TOPs && !make_mortal)
6054                     sv_2mortal(TOPs);
6055                 *SP-- = &PL_sv_undef;
6056                 iters--;
6057             }
6058         }
6059     }
6060
6061     PUTBACK;
6062     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6063     SPAGAIN;
6064     if (realarray) {
6065         if (!mg) {
6066             if (SvSMAGICAL(ary)) {
6067                 PUTBACK;
6068                 mg_set(MUTABLE_SV(ary));
6069                 SPAGAIN;
6070             }
6071             if (gimme == G_ARRAY) {
6072                 EXTEND(SP, iters);
6073                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6074                 SP += iters;
6075                 RETURN;
6076             }
6077         }
6078         else {
6079             PUTBACK;
6080             ENTER_with_name("call_PUSH");
6081             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6082             LEAVE_with_name("call_PUSH");
6083             SPAGAIN;
6084             if (gimme == G_ARRAY) {
6085                 SSize_t i;
6086                 /* EXTEND should not be needed - we just popped them */
6087                 EXTEND(SP, iters);
6088                 for (i=0; i < iters; i++) {
6089                     SV **svp = av_fetch(ary, i, FALSE);
6090                     PUSHs((svp) ? *svp : &PL_sv_undef);
6091                 }
6092                 RETURN;
6093             }
6094         }
6095     }
6096     else {
6097         if (gimme == G_ARRAY)
6098             RETURN;
6099     }
6100
6101     GETTARGET;
6102     PUSHi(iters);
6103     RETURN;
6104 }
6105
6106 PP(pp_once)
6107 {
6108     dSP;
6109     SV *const sv = PAD_SVl(PL_op->op_targ);
6110
6111     if (SvPADSTALE(sv)) {
6112         /* First time. */
6113         SvPADSTALE_off(sv);
6114         RETURNOP(cLOGOP->op_other);
6115     }
6116     RETURNOP(cLOGOP->op_next);
6117 }
6118
6119 PP(pp_lock)
6120 {
6121     dSP;
6122     dTOPss;
6123     SV *retsv = sv;
6124     SvLOCK(sv);
6125     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6126      || SvTYPE(retsv) == SVt_PVCV) {
6127         retsv = refto(retsv);
6128     }
6129     SETs(retsv);
6130     RETURN;
6131 }
6132
6133
6134 /* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
6135  * that aren't implemented on a particular platform */
6136
6137 PP(unimplemented_op)
6138 {
6139     const Optype op_type = PL_op->op_type;
6140     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6141        with out of range op numbers - it only "special" cases op_custom.
6142        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6143        if we get here for a custom op then that means that the custom op didn't
6144        have an implementation. Given that OP_NAME() looks up the custom op
6145        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6146        registers &PL_unimplemented_op as the address of their custom op.
6147        NULL doesn't generate a useful error message. "custom" does. */
6148     const char *const name = op_type >= OP_max
6149         ? "[out of range]" : PL_op_name[PL_op->op_type];
6150     if(OP_IS_SOCKET(op_type))
6151         DIE(aTHX_ PL_no_sock_func, name);
6152     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
6153 }
6154
6155 /* For sorting out arguments passed to a &CORE:: subroutine */
6156 PP(pp_coreargs)
6157 {
6158     dSP;
6159     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6160     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6161     AV * const at_ = GvAV(PL_defgv);
6162     SV **svp = at_ ? AvARRAY(at_) : NULL;
6163     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6164     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6165     bool seen_question = 0;
6166     const char *err = NULL;
6167     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6168
6169     /* Count how many args there are first, to get some idea how far to
6170        extend the stack. */
6171     while (oa) {
6172         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6173         maxargs++;
6174         if (oa & OA_OPTIONAL) seen_question = 1;
6175         if (!seen_question) minargs++;
6176         oa >>= 4;
6177     }
6178
6179     if(numargs < minargs) err = "Not enough";
6180     else if(numargs > maxargs) err = "Too many";
6181     if (err)
6182         /* diag_listed_as: Too many arguments for %s */
6183         Perl_croak(aTHX_
6184           "%s arguments for %s", err,
6185            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6186         );
6187
6188     /* Reset the stack pointer.  Without this, we end up returning our own
6189        arguments in list context, in addition to the values we are supposed
6190        to return.  nextstate usually does this on sub entry, but we need
6191        to run the next op with the caller's hints, so we cannot have a
6192        nextstate. */
6193     SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
6194
6195     if(!maxargs) RETURN;
6196
6197     /* We do this here, rather than with a separate pushmark op, as it has
6198        to come in between two things this function does (stack reset and
6199        arg pushing).  This seems the easiest way to do it. */
6200     if (pushmark) {
6201         PUTBACK;
6202         (void)Perl_pp_pushmark(aTHX);
6203     }
6204
6205     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6206     PUTBACK; /* The code below can die in various places. */
6207
6208     oa = PL_opargs[opnum] >> OASHIFT;
6209     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6210         whicharg++;
6211         switch (oa & 7) {
6212         case OA_SCALAR:
6213           try_defsv:
6214             if (!numargs && defgv && whicharg == minargs + 1) {
6215                 PUSHs(find_rundefsv2(
6216                     find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
6217                     cxstack[cxstack_ix].blk_oldcop->cop_seq
6218                 ));
6219             }
6220             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6221             break;
6222         case OA_LIST:
6223             while (numargs--) {
6224                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6225                 svp++;
6226             }
6227             RETURN;
6228         case OA_HVREF:
6229             if (!svp || !*svp || !SvROK(*svp)
6230              || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6231                 DIE(aTHX_
6232                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6233                  "Type of arg %d to &CORE::%s must be hash reference",
6234                   whicharg, OP_DESC(PL_op->op_next)
6235                 );
6236             PUSHs(SvRV(*svp));
6237             break;
6238         case OA_FILEREF:
6239             if (!numargs) PUSHs(NULL);
6240             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6241                 /* no magic here, as the prototype will have added an extra
6242                    refgen and we just want what was there before that */
6243                 PUSHs(SvRV(*svp));
6244             else {
6245                 const bool constr = PL_op->op_private & whicharg;
6246                 PUSHs(S_rv2gv(aTHX_
6247                     svp && *svp ? *svp : &PL_sv_undef,
6248                     constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6249                     !constr
6250                 ));
6251             }
6252             break;
6253         case OA_SCALARREF:
6254           if (!numargs) goto try_defsv;
6255           else {
6256             const bool wantscalar =
6257                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6258             if (!svp || !*svp || !SvROK(*svp)
6259                 /* We have to permit globrefs even for the \$ proto, as
6260                    *foo is indistinguishable from ${\*foo}, and the proto-
6261                    type permits the latter. */
6262              || SvTYPE(SvRV(*svp)) > (
6263                      wantscalar       ? SVt_PVLV
6264                    : opnum == OP_LOCK || opnum == OP_UNDEF
6265                                       ? SVt_PVCV
6266                    :                    SVt_PVHV
6267                 )
6268                )
6269                 DIE(aTHX_
6270                  "Type of arg %d to &CORE::%s must be %s",
6271                   whicharg, PL_op_name[opnum],
6272                   wantscalar
6273                     ? "scalar reference"
6274                     : opnum == OP_LOCK || opnum == OP_UNDEF
6275                        ? "reference to one of [$@%&*]"
6276                        : "reference to one of [$@%*]"
6277                 );
6278             PUSHs(SvRV(*svp));
6279             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6280              && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6281                 /* Undo @_ localisation, so that sub exit does not undo
6282                    part of our undeffing. */
6283                 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6284                 POP_SAVEARRAY();
6285                 cx->cx_type &= ~ CXp_HASARGS;
6286                 assert(!AvREAL(cx->blk_sub.argarray));
6287             }
6288           }
6289           break;
6290         default:
6291             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6292         }
6293         oa = oa >> 4;
6294     }
6295
6296     RETURN;
6297 }
6298
6299 PP(pp_runcv)
6300 {
6301     dSP;
6302     CV *cv;
6303     if (PL_op->op_private & OPpOFFBYONE) {
6304         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6305     }
6306     else cv = find_runcv(NULL);
6307     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6308     RETURN;
6309 }
6310
6311 static void
6312 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6313                             const bool can_preserve)
6314 {
6315     const SSize_t ix = SvIV(keysv);
6316     if (can_preserve ? av_exists(av, ix) : TRUE) {
6317         SV ** const svp = av_fetch(av, ix, 1);
6318         if (!svp || !*svp)
6319             Perl_croak(aTHX_ PL_no_aelem, ix);
6320         save_aelem(av, ix, svp);
6321     }
6322     else
6323         SAVEADELETE(av, ix);
6324 }
6325
6326 static void
6327 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6328                             const bool can_preserve)
6329 {
6330     if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6331         HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6332         SV ** const svp = he ? &HeVAL(he) : NULL;
6333         if (!svp || !*svp)
6334             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6335         save_helem_flags(hv, keysv, svp, 0);
6336     }
6337     else
6338         SAVEHDELETE(hv, keysv);
6339 }
6340
6341 static void
6342 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6343 {
6344     if (type == OPpLVREF_SV) {
6345         save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6346         GvSV(gv) = 0;
6347     }
6348     else if (type == OPpLVREF_AV)
6349         /* XXX Inefficient, as it creates a new AV, which we are
6350                about to clobber.  */
6351         save_ary(gv);
6352     else {
6353         assert(type == OPpLVREF_HV);
6354         /* XXX Likewise inefficient.  */
6355         save_hash(gv);
6356     }
6357 }
6358
6359
6360 PP(pp_refassign)
6361 {
6362     dSP;
6363     SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6364     SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6365     dTOPss;
6366     const char *bad = NULL;
6367     const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6368     if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6369     switch (type) {
6370     case OPpLVREF_SV: