This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Create fcn for lossless conversion of NV to IV
[perl5.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 "invlist_inline.h"
32 #include "reentr.h"
33 #include "regcharclass.h"
34
35 /* variations on pp_null */
36
37 PP(pp_stub)
38 {
39     dSP;
40     if (GIMME_V == G_SCALAR)
41         XPUSHs(&PL_sv_undef);
42     RETURN;
43 }
44
45 /* Pushy stuff. */
46
47
48
49 PP(pp_padcv)
50 {
51     dSP; dTARGET;
52     assert(SvTYPE(TARG) == SVt_PVCV);
53     XPUSHs(TARG);
54     RETURN;
55 }
56
57 PP(pp_introcv)
58 {
59     dTARGET;
60     SvPADSTALE_off(TARG);
61     return NORMAL;
62 }
63
64 PP(pp_clonecv)
65 {
66     dTARGET;
67     CV * const protocv = PadnamePROTOCV(
68         PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
69     );
70     assert(SvTYPE(TARG) == SVt_PVCV);
71     assert(protocv);
72     if (CvISXSUB(protocv)) { /* constant */
73         /* XXX Should we clone it here? */
74         /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
75            to introcv and remove the SvPADSTALE_off. */
76         SAVEPADSVANDMORTALIZE(ARGTARG);
77         PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
78     }
79     else {
80         if (CvROOT(protocv)) {
81             assert(CvCLONE(protocv));
82             assert(!CvCLONED(protocv));
83         }
84         cv_clone_into(protocv,(CV *)TARG);
85         SAVECLEARSV(PAD_SVl(ARGTARG));
86     }
87     return NORMAL;
88 }
89
90 /* Translations. */
91
92 /* In some cases this function inspects PL_op.  If this function is called
93    for new op types, more bool parameters may need to be added in place of
94    the checks.
95
96    When noinit is true, the absence of a gv will cause a retval of undef.
97    This is unrelated to the cv-to-gv assignment case.
98 */
99
100 static SV *
101 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
102               const bool noinit)
103 {
104     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
105     if (SvROK(sv)) {
106         if (SvAMAGIC(sv)) {
107             sv = amagic_deref_call(sv, to_gv_amg);
108         }
109       wasref:
110         sv = SvRV(sv);
111         if (SvTYPE(sv) == SVt_PVIO) {
112             GV * const gv = MUTABLE_GV(sv_newmortal());
113             gv_init(gv, 0, "__ANONIO__", 10, 0);
114             GvIOp(gv) = MUTABLE_IO(sv);
115             SvREFCNT_inc_void_NN(sv);
116             sv = MUTABLE_SV(gv);
117         }
118         else if (!isGV_with_GP(sv)) {
119             Perl_die(aTHX_ "Not a GLOB reference");
120         }
121     }
122     else {
123         if (!isGV_with_GP(sv)) {
124             if (!SvOK(sv)) {
125                 /* If this is a 'my' scalar and flag is set then vivify
126                  * NI-S 1999/05/07
127                  */
128                 if (vivify_sv && sv != &PL_sv_undef) {
129                     GV *gv;
130                     HV *stash;
131                     if (SvREADONLY(sv))
132                         Perl_croak_no_modify();
133                     gv = MUTABLE_GV(newSV(0));
134                     stash = CopSTASH(PL_curcop);
135                     if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
136                     if (cUNOP->op_targ) {
137                         SV * const namesv = PAD_SV(cUNOP->op_targ);
138                         gv_init_sv(gv, stash, namesv, 0);
139                     }
140                     else {
141                         gv_init_pv(gv, stash, "__ANONIO__", 0);
142                     }
143                     prepare_SV_for_RV(sv);
144                     SvRV_set(sv, MUTABLE_SV(gv));
145                     SvROK_on(sv);
146                     SvSETMAGIC(sv);
147                     goto wasref;
148                 }
149                 if (PL_op->op_flags & OPf_REF || strict) {
150                     Perl_die(aTHX_ PL_no_usym, "a symbol");
151                 }
152                 if (ckWARN(WARN_UNINITIALIZED))
153                     report_uninit(sv);
154                 return &PL_sv_undef;
155             }
156             if (noinit)
157             {
158                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
159                            sv, GV_ADDMG, SVt_PVGV
160                    ))))
161                     return &PL_sv_undef;
162             }
163             else {
164                 if (strict) {
165                     Perl_die(aTHX_
166                              PL_no_symref_sv,
167                              sv,
168                              (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
169                              "a symbol"
170                              );
171                 }
172                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
173                     == OPpDONT_INIT_GV) {
174                     /* We are the target of a coderef assignment.  Return
175                        the scalar unchanged, and let pp_sasssign deal with
176                        things.  */
177                     return sv;
178                 }
179                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
180             }
181             /* FAKE globs in the symbol table cause weird bugs (#77810) */
182             SvFAKE_off(sv);
183         }
184     }
185     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
186         SV *newsv = sv_newmortal();
187         sv_setsv_flags(newsv, sv, 0);
188         SvFAKE_off(newsv);
189         sv = newsv;
190     }
191     return sv;
192 }
193
194 PP(pp_rv2gv)
195 {
196     dSP; dTOPss;
197
198     sv = S_rv2gv(aTHX_
199           sv, PL_op->op_private & OPpDEREF,
200           PL_op->op_private & HINT_STRICT_REFS,
201           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
202              || PL_op->op_type == OP_READLINE
203          );
204     if (PL_op->op_private & OPpLVAL_INTRO)
205         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
206     SETs(sv);
207     RETURN;
208 }
209
210 /* Helper function for pp_rv2sv and pp_rv2av  */
211 GV *
212 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
213                 const svtype type, SV ***spp)
214 {
215     GV *gv;
216
217     PERL_ARGS_ASSERT_SOFTREF2XV;
218
219     if (PL_op->op_private & HINT_STRICT_REFS) {
220         if (SvOK(sv))
221             Perl_die(aTHX_ PL_no_symref_sv, sv,
222                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
223         else
224             Perl_die(aTHX_ PL_no_usym, what);
225     }
226     if (!SvOK(sv)) {
227         if (
228           PL_op->op_flags & OPf_REF
229         )
230             Perl_die(aTHX_ PL_no_usym, what);
231         if (ckWARN(WARN_UNINITIALIZED))
232             report_uninit(sv);
233         if (type != SVt_PV && GIMME_V == G_ARRAY) {
234             (*spp)--;
235             return NULL;
236         }
237         **spp = &PL_sv_undef;
238         return NULL;
239     }
240     if ((PL_op->op_flags & OPf_SPECIAL) &&
241         !(PL_op->op_flags & OPf_MOD))
242         {
243             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
244                 {
245                     **spp = &PL_sv_undef;
246                     return NULL;
247                 }
248         }
249     else {
250         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
251     }
252     return gv;
253 }
254
255 PP(pp_rv2sv)
256 {
257     dSP; dTOPss;
258     GV *gv = NULL;
259
260     SvGETMAGIC(sv);
261     if (SvROK(sv)) {
262         if (SvAMAGIC(sv)) {
263             sv = amagic_deref_call(sv, to_sv_amg);
264         }
265
266         sv = SvRV(sv);
267         if (SvTYPE(sv) >= SVt_PVAV)
268             DIE(aTHX_ "Not a SCALAR reference");
269     }
270     else {
271         gv = MUTABLE_GV(sv);
272
273         if (!isGV_with_GP(gv)) {
274             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
275             if (!gv)
276                 RETURN;
277         }
278         sv = GvSVn(gv);
279     }
280     if (PL_op->op_flags & OPf_MOD) {
281         if (PL_op->op_private & OPpLVAL_INTRO) {
282             if (cUNOP->op_first->op_type == OP_NULL)
283                 sv = save_scalar(MUTABLE_GV(TOPs));
284             else if (gv)
285                 sv = save_scalar(gv);
286             else
287                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
288         }
289         else if (PL_op->op_private & OPpDEREF)
290             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
291     }
292     SPAGAIN; /* in case chasing soft refs reallocated the stack */
293     SETs(sv);
294     RETURN;
295 }
296
297 PP(pp_av2arylen)
298 {
299     dSP;
300     AV * const av = MUTABLE_AV(TOPs);
301     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
302     if (lvalue) {
303         SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
304         if (!*svp) {
305             *svp = newSV_type(SVt_PVMG);
306             sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
307         }
308         SETs(*svp);
309     } else {
310         SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
311     }
312     RETURN;
313 }
314
315 PP(pp_pos)
316 {
317     dSP; dTOPss;
318
319     if (PL_op->op_flags & OPf_MOD || LVRET) {
320         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
321         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
322         LvTYPE(ret) = '.';
323         LvTARG(ret) = SvREFCNT_inc_simple(sv);
324         SETs(ret);    /* no SvSETMAGIC */
325     }
326     else {
327             const MAGIC * const mg = mg_find_mglob(sv);
328             if (mg && mg->mg_len != -1) {
329                 STRLEN i = mg->mg_len;
330                 if (PL_op->op_private & OPpTRUEBOOL)
331                     SETs(i ? &PL_sv_yes : &PL_sv_zero);
332                 else {
333                     dTARGET;
334                     if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
335                         i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
336                     SETu(i);
337                 }
338                 return NORMAL;
339             }
340             SETs(&PL_sv_undef);
341     }
342     return NORMAL;
343 }
344
345 PP(pp_rv2cv)
346 {
347     dSP;
348     GV *gv;
349     HV *stash_unused;
350     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
351         ? GV_ADDMG
352         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
353                                                     == OPpMAY_RETURN_CONSTANT)
354             ? GV_ADD|GV_NOEXPAND
355             : GV_ADD;
356     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
357     /* (But not in defined().) */
358
359     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
360     if (cv) NOOP;
361     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
362         cv = SvTYPE(SvRV(gv)) == SVt_PVCV
363             ? MUTABLE_CV(SvRV(gv))
364             : MUTABLE_CV(gv);
365     }
366     else
367         cv = MUTABLE_CV(&PL_sv_undef);
368     SETs(MUTABLE_SV(cv));
369     return NORMAL;
370 }
371
372 PP(pp_prototype)
373 {
374     dSP;
375     CV *cv;
376     HV *stash;
377     GV *gv;
378     SV *ret = &PL_sv_undef;
379
380     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
381     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
382         const char * s = SvPVX_const(TOPs);
383         if (memBEGINs(s, SvCUR(TOPs), "CORE::")) {
384             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
385             if (!code)
386                 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
387                    UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
388             {
389                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
390                 if (sv) ret = sv;
391             }
392             goto set;
393         }
394     }
395     cv = sv_2cv(TOPs, &stash, &gv, 0);
396     if (cv && SvPOK(cv))
397         ret = newSVpvn_flags(
398             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
399         );
400   set:
401     SETs(ret);
402     RETURN;
403 }
404
405 PP(pp_anoncode)
406 {
407     dSP;
408     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
409     if (CvCLONE(cv))
410         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
411     EXTEND(SP,1);
412     PUSHs(MUTABLE_SV(cv));
413     RETURN;
414 }
415
416 PP(pp_srefgen)
417 {
418     dSP;
419     *SP = refto(*SP);
420     return NORMAL;
421 }
422
423 PP(pp_refgen)
424 {
425     dSP; dMARK;
426     if (GIMME_V != G_ARRAY) {
427         if (++MARK <= SP)
428             *MARK = *SP;
429         else
430         {
431             MEXTEND(SP, 1);
432             *MARK = &PL_sv_undef;
433         }
434         *MARK = refto(*MARK);
435         SP = MARK;
436         RETURN;
437     }
438     EXTEND_MORTAL(SP - MARK);
439     while (++MARK <= SP)
440         *MARK = refto(*MARK);
441     RETURN;
442 }
443
444 STATIC SV*
445 S_refto(pTHX_ SV *sv)
446 {
447     SV* rv;
448
449     PERL_ARGS_ASSERT_REFTO;
450
451     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
452         if (LvTARGLEN(sv))
453             vivify_defelem(sv);
454         if (!(sv = LvTARG(sv)))
455             sv = &PL_sv_undef;
456         else
457             SvREFCNT_inc_void_NN(sv);
458     }
459     else if (SvTYPE(sv) == SVt_PVAV) {
460         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
461             av_reify(MUTABLE_AV(sv));
462         SvTEMP_off(sv);
463         SvREFCNT_inc_void_NN(sv);
464     }
465     else if (SvPADTMP(sv)) {
466         sv = newSVsv(sv);
467     }
468     else if (UNLIKELY(SvSMAGICAL(sv) && mg_find(sv, PERL_MAGIC_nonelem)))
469         sv_unmagic(SvREFCNT_inc_simple_NN(sv), PERL_MAGIC_nonelem);
470     else {
471         SvTEMP_off(sv);
472         SvREFCNT_inc_void_NN(sv);
473     }
474     rv = sv_newmortal();
475     sv_upgrade(rv, SVt_IV);
476     SvRV_set(rv, sv);
477     SvROK_on(rv);
478     return rv;
479 }
480
481 PP(pp_ref)
482 {
483     dSP;
484     SV * const sv = TOPs;
485
486     SvGETMAGIC(sv);
487     if (!SvROK(sv)) {
488         SETs(&PL_sv_no);
489         return NORMAL;
490     }
491
492     /* op is in boolean context? */
493     if (   (PL_op->op_private & OPpTRUEBOOL)
494         || (   (PL_op->op_private & OPpMAYBE_TRUEBOOL)
495             && block_gimme() == G_VOID))
496     {
497         /* refs are always true - unless it's to an object blessed into a
498          * class with a false name, i.e. "0". So we have to check for
499          * that remote possibility. The following is is basically an
500          * unrolled SvTRUE(sv_reftype(rv)) */
501         SV * const rv = SvRV(sv);
502         if (SvOBJECT(rv)) {
503             HV *stash = SvSTASH(rv);
504             HEK *hek = HvNAME_HEK(stash);
505             if (hek) {
506                 I32 len = HEK_LEN(hek);
507                 /* bail out and do it the hard way? */
508                 if (UNLIKELY(
509                        len == HEf_SVKEY
510                     || (len == 1 && HEK_KEY(hek)[0] == '0')
511                 ))
512                     goto do_sv_ref;
513             }
514         }
515         SETs(&PL_sv_yes);
516         return NORMAL;
517     }
518
519   do_sv_ref:
520     {
521         dTARGET;
522         SETs(TARG);
523         sv_ref(TARG, SvRV(sv), TRUE);
524         SvSETMAGIC(TARG);
525         return NORMAL;
526     }
527
528 }
529
530
531 PP(pp_bless)
532 {
533     dSP;
534     HV *stash;
535
536     if (MAXARG == 1)
537     {
538       curstash:
539         stash = CopSTASH(PL_curcop);
540         if (SvTYPE(stash) != SVt_PVHV)
541             Perl_croak(aTHX_ "Attempt to bless into a freed package");
542     }
543     else {
544         SV * const ssv = POPs;
545         STRLEN len;
546         const char *ptr;
547
548         if (!ssv) goto curstash;
549         SvGETMAGIC(ssv);
550         if (SvROK(ssv)) {
551           if (!SvAMAGIC(ssv)) {
552            frog:
553             Perl_croak(aTHX_ "Attempt to bless into a reference");
554           }
555           /* SvAMAGIC is on here, but it only means potentially overloaded,
556              so after stringification: */
557           ptr = SvPV_nomg_const(ssv,len);
558           /* We need to check the flag again: */
559           if (!SvAMAGIC(ssv)) goto frog;
560         }
561         else ptr = SvPV_nomg_const(ssv,len);
562         if (len == 0)
563             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
564                            "Explicit blessing to '' (assuming package main)");
565         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
566     }
567
568     (void)sv_bless(TOPs, stash);
569     RETURN;
570 }
571
572 PP(pp_gelem)
573 {
574     dSP;
575
576     SV *sv = POPs;
577     STRLEN len;
578     const char * const elem = SvPV_const(sv, len);
579     GV * const gv = MUTABLE_GV(TOPs);
580     SV * tmpRef = NULL;
581
582     sv = NULL;
583     if (elem) {
584         /* elem will always be NUL terminated.  */
585         switch (*elem) {
586         case 'A':
587             if (memEQs(elem, len, "ARRAY"))
588             {
589                 tmpRef = MUTABLE_SV(GvAV(gv));
590                 if (tmpRef && !AvREAL((const AV *)tmpRef)
591                  && AvREIFY((const AV *)tmpRef))
592                     av_reify(MUTABLE_AV(tmpRef));
593             }
594             break;
595         case 'C':
596             if (memEQs(elem, len, "CODE"))
597                 tmpRef = MUTABLE_SV(GvCVu(gv));
598             break;
599         case 'F':
600             if (memEQs(elem, len, "FILEHANDLE")) {
601                 tmpRef = MUTABLE_SV(GvIOp(gv));
602             }
603             else
604                 if (memEQs(elem, len, "FORMAT"))
605                     tmpRef = MUTABLE_SV(GvFORM(gv));
606             break;
607         case 'G':
608             if (memEQs(elem, len, "GLOB"))
609                 tmpRef = MUTABLE_SV(gv);
610             break;
611         case 'H':
612             if (memEQs(elem, len, "HASH"))
613                 tmpRef = MUTABLE_SV(GvHV(gv));
614             break;
615         case 'I':
616             if (memEQs(elem, len, "IO"))
617                 tmpRef = MUTABLE_SV(GvIOp(gv));
618             break;
619         case 'N':
620             if (memEQs(elem, len, "NAME"))
621                 sv = newSVhek(GvNAME_HEK(gv));
622             break;
623         case 'P':
624             if (memEQs(elem, len, "PACKAGE")) {
625                 const HV * const stash = GvSTASH(gv);
626                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
627                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
628             }
629             break;
630         case 'S':
631             if (memEQs(elem, len, "SCALAR"))
632                 tmpRef = GvSVn(gv);
633             break;
634         }
635     }
636     if (tmpRef)
637         sv = newRV(tmpRef);
638     if (sv)
639         sv_2mortal(sv);
640     else
641         sv = &PL_sv_undef;
642     SETs(sv);
643     RETURN;
644 }
645
646 /* Pattern matching */
647
648 PP(pp_study)
649 {
650     dSP; dTOPss;
651     STRLEN len;
652
653     (void)SvPV(sv, len);
654     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
655         /* Historically, study was skipped in these cases. */
656         SETs(&PL_sv_no);
657         return NORMAL;
658     }
659
660     /* Make study a no-op. It's no longer useful and its existence
661        complicates matters elsewhere. */
662     SETs(&PL_sv_yes);
663     return NORMAL;
664 }
665
666
667 /* also used for: pp_transr() */
668
669 PP(pp_trans)
670 {
671     dSP;
672     SV *sv;
673
674     if (PL_op->op_flags & OPf_STACKED)
675         sv = POPs;
676     else {
677         EXTEND(SP,1);
678         if (ARGTARG)
679             sv = PAD_SV(ARGTARG);
680         else {
681             sv = DEFSV;
682         }
683     }
684     if(PL_op->op_type == OP_TRANSR) {
685         STRLEN len;
686         const char * const pv = SvPV(sv,len);
687         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
688         do_trans(newsv);
689         PUSHs(newsv);
690     }
691     else {
692         Size_t i = do_trans(sv);
693         mPUSHi((UV)i);
694     }
695     RETURN;
696 }
697
698 /* Lvalue operators. */
699
700 static size_t
701 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
702 {
703     STRLEN len;
704     char *s;
705     size_t count = 0;
706
707     PERL_ARGS_ASSERT_DO_CHOMP;
708
709     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
710         return 0;
711     if (SvTYPE(sv) == SVt_PVAV) {
712         I32 i;
713         AV *const av = MUTABLE_AV(sv);
714         const I32 max = AvFILL(av);
715
716         for (i = 0; i <= max; i++) {
717             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
718             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
719                 count += do_chomp(retval, sv, chomping);
720         }
721         return count;
722     }
723     else if (SvTYPE(sv) == SVt_PVHV) {
724         HV* const hv = MUTABLE_HV(sv);
725         HE* entry;
726         (void)hv_iterinit(hv);
727         while ((entry = hv_iternext(hv)))
728             count += do_chomp(retval, hv_iterval(hv,entry), chomping);
729         return count;
730     }
731     else if (SvREADONLY(sv)) {
732             Perl_croak_no_modify();
733     }
734
735     s = SvPV(sv, len);
736     if (chomping) {
737         if (s && len) {
738             char *temp_buffer = NULL;
739             SV *svrecode = NULL;
740             s += --len;
741             if (RsPARA(PL_rs)) {
742                 if (*s != '\n')
743                     goto nope_free_nothing;
744                 ++count;
745                 while (len && s[-1] == '\n') {
746                     --len;
747                     --s;
748                     ++count;
749                 }
750             }
751             else {
752                 STRLEN rslen, rs_charlen;
753                 const char *rsptr = SvPV_const(PL_rs, rslen);
754
755                 rs_charlen = SvUTF8(PL_rs)
756                     ? sv_len_utf8(PL_rs)
757                     : rslen;
758
759                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
760                     /* Assumption is that rs is shorter than the scalar.  */
761                     if (SvUTF8(PL_rs)) {
762                         /* RS is utf8, scalar is 8 bit.  */
763                         bool is_utf8 = TRUE;
764                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
765                                                              &rslen, &is_utf8);
766                         if (is_utf8) {
767                             /* Cannot downgrade, therefore cannot possibly match.
768                                At this point, temp_buffer is not alloced, and
769                                is the buffer inside PL_rs, so dont free it.
770                              */
771                             assert (temp_buffer == rsptr);
772                             goto nope_free_sv;
773                         }
774                         rsptr = temp_buffer;
775                     }
776                     else {
777                         /* RS is 8 bit, scalar is utf8.  */
778                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
779                         rsptr = temp_buffer;
780                     }
781                 }
782                 if (rslen == 1) {
783                     if (*s != *rsptr)
784                         goto nope_free_all;
785                     ++count;
786                 }
787                 else {
788                     if (len < rslen - 1)
789                         goto nope_free_all;
790                     len -= rslen - 1;
791                     s -= rslen - 1;
792                     if (memNE(s, rsptr, rslen))
793                         goto nope_free_all;
794                     count += rs_charlen;
795                 }
796             }
797             SvPV_force_nomg_nolen(sv);
798             SvCUR_set(sv, len);
799             *SvEND(sv) = '\0';
800             SvNIOK_off(sv);
801             SvSETMAGIC(sv);
802
803             nope_free_all:
804             Safefree(temp_buffer);
805             nope_free_sv:
806             SvREFCNT_dec(svrecode);
807             nope_free_nothing: ;
808         }
809     } else {
810         if (len && (!SvPOK(sv) || SvIsCOW(sv)))
811             s = SvPV_force_nomg(sv, len);
812         if (DO_UTF8(sv)) {
813             if (s && len) {
814                 char * const send = s + len;
815                 char * const start = s;
816                 s = send - 1;
817                 while (s > start && UTF8_IS_CONTINUATION(*s))
818                     s--;
819                 if (is_utf8_string((U8*)s, send - s)) {
820                     sv_setpvn(retval, s, send - s);
821                     *s = '\0';
822                     SvCUR_set(sv, s - start);
823                     SvNIOK_off(sv);
824                     SvUTF8_on(retval);
825                 }
826             }
827             else
828                 SvPVCLEAR(retval);
829         }
830         else if (s && len) {
831             s += --len;
832             sv_setpvn(retval, s, 1);
833             *s = '\0';
834             SvCUR_set(sv, len);
835             SvUTF8_off(sv);
836             SvNIOK_off(sv);
837         }
838         else
839             SvPVCLEAR(retval);
840         SvSETMAGIC(sv);
841     }
842     return count;
843 }
844
845
846 /* also used for: pp_schomp() */
847
848 PP(pp_schop)
849 {
850     dSP; dTARGET;
851     const bool chomping = PL_op->op_type == OP_SCHOMP;
852
853     const size_t count = do_chomp(TARG, TOPs, chomping);
854     if (chomping)
855         sv_setiv(TARG, count);
856     SETTARG;
857     return NORMAL;
858 }
859
860
861 /* also used for: pp_chomp() */
862
863 PP(pp_chop)
864 {
865     dSP; dMARK; dTARGET; dORIGMARK;
866     const bool chomping = PL_op->op_type == OP_CHOMP;
867     size_t count = 0;
868
869     while (MARK < SP)
870         count += do_chomp(TARG, *++MARK, chomping);
871     if (chomping)
872         sv_setiv(TARG, count);
873     SP = ORIGMARK;
874     XPUSHTARG;
875     RETURN;
876 }
877
878 PP(pp_undef)
879 {
880     dSP;
881     SV *sv;
882
883     if (!PL_op->op_private) {
884         EXTEND(SP, 1);
885         RETPUSHUNDEF;
886     }
887
888     sv = TOPs;
889     if (!sv)
890     {
891         SETs(&PL_sv_undef);
892         return NORMAL;
893     }
894
895     if (SvTHINKFIRST(sv))
896         sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
897
898     switch (SvTYPE(sv)) {
899     case SVt_NULL:
900         break;
901     case SVt_PVAV:
902         av_undef(MUTABLE_AV(sv));
903         break;
904     case SVt_PVHV:
905         hv_undef(MUTABLE_HV(sv));
906         break;
907     case SVt_PVCV:
908         if (cv_const_sv((const CV *)sv))
909             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
910                           "Constant subroutine %" SVf " undefined",
911                            SVfARG(CvANON((const CV *)sv)
912                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
913                              : sv_2mortal(newSVhek(
914                                 CvNAMED(sv)
915                                  ? CvNAME_HEK((CV *)sv)
916                                  : GvENAME_HEK(CvGV((const CV *)sv))
917                                ))
918                            ));
919         /* FALLTHROUGH */
920     case SVt_PVFM:
921             /* let user-undef'd sub keep its identity */
922         cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
923         break;
924     case SVt_PVGV:
925         assert(isGV_with_GP(sv));
926         assert(!SvFAKE(sv));
927         {
928             GP *gp;
929             HV *stash;
930
931             /* undef *Pkg::meth_name ... */
932             bool method_changed
933              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
934               && HvENAME_get(stash);
935             /* undef *Foo:: */
936             if((stash = GvHV((const GV *)sv))) {
937                 if(HvENAME_get(stash))
938                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
939                 else stash = NULL;
940             }
941
942             SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
943             gp_free(MUTABLE_GV(sv));
944             Newxz(gp, 1, GP);
945             GvGP_set(sv, gp_ref(gp));
946 #ifndef PERL_DONT_CREATE_GVSV
947             GvSV(sv) = newSV(0);
948 #endif
949             GvLINE(sv) = CopLINE(PL_curcop);
950             GvEGV(sv) = MUTABLE_GV(sv);
951             GvMULTI_on(sv);
952
953             if(stash)
954                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
955             stash = NULL;
956             /* undef *Foo::ISA */
957             if( strEQ(GvNAME((const GV *)sv), "ISA")
958              && (stash = GvSTASH((const GV *)sv))
959              && (method_changed || HvENAME(stash)) )
960                 mro_isa_changed_in(stash);
961             else if(method_changed)
962                 mro_method_changed_in(
963                  GvSTASH((const GV *)sv)
964                 );
965
966             break;
967         }
968     default:
969         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
970             SvPV_free(sv);
971             SvPV_set(sv, NULL);
972             SvLEN_set(sv, 0);
973         }
974         SvOK_off(sv);
975         SvSETMAGIC(sv);
976     }
977
978     SETs(&PL_sv_undef);
979     return NORMAL;
980 }
981
982
983 /* common "slow" code for pp_postinc and pp_postdec */
984
985 static OP *
986 S_postincdec_common(pTHX_ SV *sv, SV *targ)
987 {
988     dSP;
989     const bool inc =
990         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
991
992     if (SvROK(sv))
993         TARG = sv_newmortal();
994     sv_setsv(TARG, sv);
995     if (inc)
996         sv_inc_nomg(sv);
997     else
998         sv_dec_nomg(sv);
999     SvSETMAGIC(sv);
1000     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1001     if (inc && !SvOK(TARG))
1002         sv_setiv(TARG, 0);
1003     SETTARG;
1004     return NORMAL;
1005 }
1006
1007
1008 /* also used for: pp_i_postinc() */
1009
1010 PP(pp_postinc)
1011 {
1012     dSP; dTARGET;
1013     SV *sv = TOPs;
1014
1015     /* special-case sv being a simple integer */
1016     if (LIKELY(((sv->sv_flags &
1017                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1018                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1019                 == SVf_IOK))
1020         && SvIVX(sv) != IV_MAX)
1021     {
1022         IV iv = SvIVX(sv);
1023         SvIV_set(sv,  iv + 1);
1024         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1025         SETs(TARG);
1026         return NORMAL;
1027     }
1028
1029     return S_postincdec_common(aTHX_ sv, TARG);
1030 }
1031
1032
1033 /* also used for: pp_i_postdec() */
1034
1035 PP(pp_postdec)
1036 {
1037     dSP; dTARGET;
1038     SV *sv = TOPs;
1039
1040     /* special-case sv being a simple integer */
1041     if (LIKELY(((sv->sv_flags &
1042                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1043                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1044                 == SVf_IOK))
1045         && SvIVX(sv) != IV_MIN)
1046     {
1047         IV iv = SvIVX(sv);
1048         SvIV_set(sv,  iv - 1);
1049         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1050         SETs(TARG);
1051         return NORMAL;
1052     }
1053
1054     return S_postincdec_common(aTHX_ sv, TARG);
1055 }
1056
1057
1058 /* Ordinary operators. */
1059
1060 PP(pp_pow)
1061 {
1062     dSP; dATARGET; SV *svl, *svr;
1063 #ifdef PERL_PRESERVE_IVUV
1064     bool is_int = 0;
1065 #endif
1066     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1067     svr = TOPs;
1068     svl = TOPm1s;
1069 #ifdef PERL_PRESERVE_IVUV
1070     /* For integer to integer power, we do the calculation by hand wherever
1071        we're sure it is safe; otherwise we call pow() and try to convert to
1072        integer afterwards. */
1073     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1074                 UV power;
1075                 bool baseuok;
1076                 UV baseuv;
1077
1078                 if (SvUOK(svr)) {
1079                     power = SvUVX(svr);
1080                 } else {
1081                     const IV iv = SvIVX(svr);
1082                     if (iv >= 0) {
1083                         power = iv;
1084                     } else {
1085                         goto float_it; /* Can't do negative powers this way.  */
1086                     }
1087                 }
1088
1089                 baseuok = SvUOK(svl);
1090                 if (baseuok) {
1091                     baseuv = SvUVX(svl);
1092                 } else {
1093                     const IV iv = SvIVX(svl);
1094                     if (iv >= 0) {
1095                         baseuv = iv;
1096                         baseuok = TRUE; /* effectively it's a UV now */
1097                     } else {
1098                         baseuv = -iv; /* abs, baseuok == false records sign */
1099                     }
1100                 }
1101                 /* now we have integer ** positive integer. */
1102                 is_int = 1;
1103
1104                 /* foo & (foo - 1) is zero only for a power of 2.  */
1105                 if (!(baseuv & (baseuv - 1))) {
1106                     /* We are raising power-of-2 to a positive integer.
1107                        The logic here will work for any base (even non-integer
1108                        bases) but it can be less accurate than
1109                        pow (base,power) or exp (power * log (base)) when the
1110                        intermediate values start to spill out of the mantissa.
1111                        With powers of 2 we know this can't happen.
1112                        And powers of 2 are the favourite thing for perl
1113                        programmers to notice ** not doing what they mean. */
1114                     NV result = 1.0;
1115                     NV base = baseuok ? baseuv : -(NV)baseuv;
1116
1117                     if (power & 1) {
1118                         result *= base;
1119                     }
1120                     while (power >>= 1) {
1121                         base *= base;
1122                         if (power & 1) {
1123                             result *= base;
1124                         }
1125                     }
1126                     SP--;
1127                     SETn( result );
1128                     SvIV_please_nomg(svr);
1129                     RETURN;
1130                 } else {
1131                     unsigned int highbit = 8 * sizeof(UV);
1132                     unsigned int diff = 8 * sizeof(UV);
1133                     while (diff >>= 1) {
1134                         highbit -= diff;
1135                         if (baseuv >> highbit) {
1136                             highbit += diff;
1137                         }
1138                     }
1139                     /* we now have baseuv < 2 ** highbit */
1140                     if (power * highbit <= 8 * sizeof(UV)) {
1141                         /* result will definitely fit in UV, so use UV math
1142                            on same algorithm as above */
1143                         UV result = 1;
1144                         UV base = baseuv;
1145                         const bool odd_power = cBOOL(power & 1);
1146                         if (odd_power) {
1147                             result *= base;
1148                         }
1149                         while (power >>= 1) {
1150                             base *= base;
1151                             if (power & 1) {
1152                                 result *= base;
1153                             }
1154                         }
1155                         SP--;
1156                         if (baseuok || !odd_power)
1157                             /* answer is positive */
1158                             SETu( result );
1159                         else if (result <= (UV)IV_MAX)
1160                             /* answer negative, fits in IV */
1161                             SETi( -(IV)result );
1162                         else if (result == (UV)IV_MIN)
1163                             /* 2's complement assumption: special case IV_MIN */
1164                             SETi( IV_MIN );
1165                         else
1166                             /* answer negative, doesn't fit */
1167                             SETn( -(NV)result );
1168                         RETURN;
1169                     }
1170                 }
1171     }
1172   float_it:
1173 #endif
1174     {
1175         NV right = SvNV_nomg(svr);
1176         NV left  = SvNV_nomg(svl);
1177         (void)POPs;
1178
1179 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1180     /*
1181     We are building perl with long double support and are on an AIX OS
1182     afflicted with a powl() function that wrongly returns NaNQ for any
1183     negative base.  This was reported to IBM as PMR #23047-379 on
1184     03/06/2006.  The problem exists in at least the following versions
1185     of AIX and the libm fileset, and no doubt others as well:
1186
1187         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1188         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1189         AIX 5.2.0           bos.adt.libm 5.2.0.85
1190
1191     So, until IBM fixes powl(), we provide the following workaround to
1192     handle the problem ourselves.  Our logic is as follows: for
1193     negative bases (left), we use fmod(right, 2) to check if the
1194     exponent is an odd or even integer:
1195
1196         - if odd,  powl(left, right) == -powl(-left, right)
1197         - if even, powl(left, right) ==  powl(-left, right)
1198
1199     If the exponent is not an integer, the result is rightly NaNQ, so
1200     we just return that (as NV_NAN).
1201     */
1202
1203         if (left < 0.0) {
1204             NV mod2 = Perl_fmod( right, 2.0 );
1205             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1206                 SETn( -Perl_pow( -left, right) );
1207             } else if (mod2 == 0.0) {           /* even integer */
1208                 SETn( Perl_pow( -left, right) );
1209             } else {                            /* fractional power */
1210                 SETn( NV_NAN );
1211             }
1212         } else {
1213             SETn( Perl_pow( left, right) );
1214         }
1215 #else
1216         SETn( Perl_pow( left, right) );
1217 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1218
1219 #ifdef PERL_PRESERVE_IVUV
1220         if (is_int)
1221             SvIV_please_nomg(svr);
1222 #endif
1223         RETURN;
1224     }
1225 }
1226
1227 PP(pp_multiply)
1228 {
1229     dSP; dATARGET; SV *svl, *svr;
1230     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1231     svr = TOPs;
1232     svl = TOPm1s;
1233
1234 #ifdef PERL_PRESERVE_IVUV
1235
1236     /* special-case some simple common cases */
1237     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1238         IV il, ir;
1239         U32 flags = (svl->sv_flags & svr->sv_flags);
1240         if (flags & SVf_IOK) {
1241             /* both args are simple IVs */
1242             UV topl, topr;
1243             il = SvIVX(svl);
1244             ir = SvIVX(svr);
1245           do_iv:
1246             topl = ((UV)il) >> (UVSIZE * 4 - 1);
1247             topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1248
1249             /* if both are in a range that can't under/overflow, do a
1250              * simple integer multiply: if the top halves(*) of both numbers
1251              * are 00...00  or 11...11, then it's safe.
1252              * (*) for 32-bits, the "top half" is the top 17 bits,
1253              *     for 64-bits, its 33 bits */
1254             if (!(
1255                       ((topl+1) | (topr+1))
1256                     & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1257             )) {
1258                 SP--;
1259                 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1260                 SETs(TARG);
1261                 RETURN;
1262             }
1263             goto generic;
1264         }
1265         else if (flags & SVf_NOK) {
1266             /* both args are NVs */
1267             NV nl = SvNVX(svl);
1268             NV nr = SvNVX(svr);
1269             NV result;
1270
1271             if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1272                 /* nothing was lost by converting to IVs */
1273                 goto do_iv;
1274             }
1275             SP--;
1276             result = nl * nr;
1277 #  if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1278             if (Perl_isinf(result)) {
1279                 Zero((U8*)&result + 8, 8, U8);
1280             }
1281 #  endif
1282             TARGn(result, 0); /* args not GMG, so can't be tainted */
1283             SETs(TARG);
1284             RETURN;
1285         }
1286     }
1287
1288   generic:
1289
1290     if (SvIV_please_nomg(svr)) {
1291         /* Unless the left argument is integer in range we are going to have to
1292            use NV maths. Hence only attempt to coerce the right argument if
1293            we know the left is integer.  */
1294         /* Left operand is defined, so is it IV? */
1295         if (SvIV_please_nomg(svl)) {
1296             bool auvok = SvUOK(svl);
1297             bool buvok = SvUOK(svr);
1298             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1299             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1300             UV alow;
1301             UV ahigh;
1302             UV blow;
1303             UV bhigh;
1304
1305             if (auvok) {
1306                 alow = SvUVX(svl);
1307             } else {
1308                 const IV aiv = SvIVX(svl);
1309                 if (aiv >= 0) {
1310                     alow = aiv;
1311                     auvok = TRUE; /* effectively it's a UV now */
1312                 } else {
1313                     /* abs, auvok == false records sign; Using 0- here and
1314                      * later to silence bogus warning from MS VC */
1315                     alow = (UV) (0 - (UV) aiv);
1316                 }
1317             }
1318             if (buvok) {
1319                 blow = SvUVX(svr);
1320             } else {
1321                 const IV biv = SvIVX(svr);
1322                 if (biv >= 0) {
1323                     blow = biv;
1324                     buvok = TRUE; /* effectively it's a UV now */
1325                 } else {
1326                     /* abs, buvok == false records sign */
1327                     blow = (UV) (0 - (UV) biv);
1328                 }
1329             }
1330
1331             /* If this does sign extension on unsigned it's time for plan B  */
1332             ahigh = alow >> (4 * sizeof (UV));
1333             alow &= botmask;
1334             bhigh = blow >> (4 * sizeof (UV));
1335             blow &= botmask;
1336             if (ahigh && bhigh) {
1337                 NOOP;
1338                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1339                    which is overflow. Drop to NVs below.  */
1340             } else if (!ahigh && !bhigh) {
1341                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1342                    so the unsigned multiply cannot overflow.  */
1343                 const UV product = alow * blow;
1344                 if (auvok == buvok) {
1345                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1346                     SP--;
1347                     SETu( product );
1348                     RETURN;
1349                 } else if (product <= (UV)IV_MIN) {
1350                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1351                     /* -ve result, which could overflow an IV  */
1352                     SP--;
1353                     /* can't negate IV_MIN, but there are aren't two
1354                      * integers such that !ahigh && !bhigh, where the
1355                      * product equals 0x800....000 */
1356                     assert(product != (UV)IV_MIN);
1357                     SETi( -(IV)product );
1358                     RETURN;
1359                 } /* else drop to NVs below. */
1360             } else {
1361                 /* One operand is large, 1 small */
1362                 UV product_middle;
1363                 if (bhigh) {
1364                     /* swap the operands */
1365                     ahigh = bhigh;
1366                     bhigh = blow; /* bhigh now the temp var for the swap */
1367                     blow = alow;
1368                     alow = bhigh;
1369                 }
1370                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1371                    multiplies can't overflow. shift can, add can, -ve can.  */
1372                 product_middle = ahigh * blow;
1373                 if (!(product_middle & topmask)) {
1374                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1375                     UV product_low;
1376                     product_middle <<= (4 * sizeof (UV));
1377                     product_low = alow * blow;
1378
1379                     /* as for pp_add, UV + something mustn't get smaller.
1380                        IIRC ANSI mandates this wrapping *behaviour* for
1381                        unsigned whatever the actual representation*/
1382                     product_low += product_middle;
1383                     if (product_low >= product_middle) {
1384                         /* didn't overflow */
1385                         if (auvok == buvok) {
1386                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1387                             SP--;
1388                             SETu( product_low );
1389                             RETURN;
1390                         } else if (product_low <= (UV)IV_MIN) {
1391                             /* 2s complement assumption again  */
1392                             /* -ve result, which could overflow an IV  */
1393                             SP--;
1394                             SETi(product_low == (UV)IV_MIN
1395                                     ? IV_MIN : -(IV)product_low);
1396                             RETURN;
1397                         } /* else drop to NVs below. */
1398                     }
1399                 } /* product_middle too large */
1400             } /* ahigh && bhigh */
1401         } /* SvIOK(svl) */
1402     } /* SvIOK(svr) */
1403 #endif
1404     {
1405       NV right = SvNV_nomg(svr);
1406       NV left  = SvNV_nomg(svl);
1407       NV result = left * right;
1408
1409       (void)POPs;
1410 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1411       if (Perl_isinf(result)) {
1412           Zero((U8*)&result + 8, 8, U8);
1413       }
1414 #endif
1415       SETn(result);
1416       RETURN;
1417     }
1418 }
1419
1420 PP(pp_divide)
1421 {
1422     dSP; dATARGET; SV *svl, *svr;
1423     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1424     svr = TOPs;
1425     svl = TOPm1s;
1426     /* Only try to do UV divide first
1427        if ((SLOPPYDIVIDE is true) or
1428            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1429             to preserve))
1430        The assumption is that it is better to use floating point divide
1431        whenever possible, only doing integer divide first if we can't be sure.
1432        If NV_PRESERVES_UV is true then we know at compile time that no UV
1433        can be too large to preserve, so don't need to compile the code to
1434        test the size of UVs.  */
1435
1436 #if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV))
1437 #  define PERL_TRY_UV_DIVIDE
1438     /* ensure that 20./5. == 4. */
1439 #endif
1440
1441 #ifdef PERL_TRY_UV_DIVIDE
1442     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1443             bool left_non_neg = SvUOK(svl);
1444             bool right_non_neg = SvUOK(svr);
1445             UV left;
1446             UV right;
1447
1448             if (right_non_neg) {
1449                 right = SvUVX(svr);
1450             }
1451             else {
1452                 const IV biv = SvIVX(svr);
1453                 if (biv >= 0) {
1454                     right = biv;
1455                     right_non_neg = TRUE; /* effectively it's a UV now */
1456                 }
1457                 else {
1458                     right = -(UV)biv;
1459                 }
1460             }
1461             /* historically undef()/0 gives a "Use of uninitialized value"
1462                warning before dieing, hence this test goes here.
1463                If it were immediately before the second SvIV_please, then
1464                DIE() would be invoked before left was even inspected, so
1465                no inspection would give no warning.  */
1466             if (right == 0)
1467                 DIE(aTHX_ "Illegal division by zero");
1468
1469             if (left_non_neg) {
1470                 left = SvUVX(svl);
1471             }
1472             else {
1473                 const IV aiv = SvIVX(svl);
1474                 if (aiv >= 0) {
1475                     left = aiv;
1476                     left_non_neg = TRUE; /* effectively it's a UV now */
1477                 }
1478                 else {
1479                     left = -(UV)aiv;
1480                 }
1481             }
1482
1483             if (left >= right
1484 #ifdef SLOPPYDIVIDE
1485                 /* For sloppy divide we always attempt integer division.  */
1486 #else
1487                 /* Otherwise we only attempt it if either or both operands
1488                    would not be preserved by an NV.  If both fit in NVs
1489                    we fall through to the NV divide code below.  However,
1490                    as left >= right to ensure integer result here, we know that
1491                    we can skip the test on the right operand - right big
1492                    enough not to be preserved can't get here unless left is
1493                    also too big.  */
1494
1495                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1496 #endif
1497                 ) {
1498                 /* Integer division can't overflow, but it can be imprecise.  */
1499
1500                 /* Modern compilers optimize division followed by
1501                  * modulo into a single div instruction */
1502                 const UV result = left / right;
1503                 if (left % right == 0) {
1504                     SP--; /* result is valid */
1505                     if (left_non_neg == right_non_neg) {
1506                         /* signs identical, result is positive.  */
1507                         SETu( result );
1508                         RETURN;
1509                     }
1510                     /* 2s complement assumption */
1511                     if (result <= (UV)IV_MIN)
1512                         SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1513                     else {
1514                         /* It's exact but too negative for IV. */
1515                         SETn( -(NV)result );
1516                     }
1517                     RETURN;
1518                 } /* tried integer divide but it was not an integer result */
1519             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1520     } /* one operand wasn't SvIOK */
1521 #endif /* PERL_TRY_UV_DIVIDE */
1522     {
1523         NV right = SvNV_nomg(svr);
1524         NV left  = SvNV_nomg(svl);
1525         (void)POPs;(void)POPs;
1526 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1527         if (! Perl_isnan(right) && right == 0.0)
1528 #else
1529         if (right == 0.0)
1530 #endif
1531             DIE(aTHX_ "Illegal division by zero");
1532         PUSHn( left / right );
1533         RETURN;
1534     }
1535 }
1536
1537 PP(pp_modulo)
1538 {
1539     dSP; dATARGET;
1540     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1541     {
1542         UV left  = 0;
1543         UV right = 0;
1544         bool left_neg = FALSE;
1545         bool right_neg = FALSE;
1546         bool use_double = FALSE;
1547         bool dright_valid = FALSE;
1548         NV dright = 0.0;
1549         NV dleft  = 0.0;
1550         SV * const svr = TOPs;
1551         SV * const svl = TOPm1s;
1552         if (SvIV_please_nomg(svr)) {
1553             right_neg = !SvUOK(svr);
1554             if (!right_neg) {
1555                 right = SvUVX(svr);
1556             } else {
1557                 const IV biv = SvIVX(svr);
1558                 if (biv >= 0) {
1559                     right = biv;
1560                     right_neg = FALSE; /* effectively it's a UV now */
1561                 } else {
1562                     right = (UV) (0 - (UV) biv);
1563                 }
1564             }
1565         }
1566         else {
1567             dright = SvNV_nomg(svr);
1568             right_neg = dright < 0;
1569             if (right_neg)
1570                 dright = -dright;
1571             if (dright < UV_MAX_P1) {
1572                 right = U_V(dright);
1573                 dright_valid = TRUE; /* In case we need to use double below.  */
1574             } else {
1575                 use_double = TRUE;
1576             }
1577         }
1578
1579         /* At this point use_double is only true if right is out of range for
1580            a UV.  In range NV has been rounded down to nearest UV and
1581            use_double false.  */
1582         if (!use_double && SvIV_please_nomg(svl)) {
1583                 left_neg = !SvUOK(svl);
1584                 if (!left_neg) {
1585                     left = SvUVX(svl);
1586                 } else {
1587                     const IV aiv = SvIVX(svl);
1588                     if (aiv >= 0) {
1589                         left = aiv;
1590                         left_neg = FALSE; /* effectively it's a UV now */
1591                     } else {
1592                         left = (UV) (0 - (UV) aiv);
1593                     }
1594                 }
1595         }
1596         else {
1597             dleft = SvNV_nomg(svl);
1598             left_neg = dleft < 0;
1599             if (left_neg)
1600                 dleft = -dleft;
1601
1602             /* This should be exactly the 5.6 behaviour - if left and right are
1603                both in range for UV then use U_V() rather than floor.  */
1604             if (!use_double) {
1605                 if (dleft < UV_MAX_P1) {
1606                     /* right was in range, so is dleft, so use UVs not double.
1607                      */
1608                     left = U_V(dleft);
1609                 }
1610                 /* left is out of range for UV, right was in range, so promote
1611                    right (back) to double.  */
1612                 else {
1613                     /* The +0.5 is used in 5.6 even though it is not strictly
1614                        consistent with the implicit +0 floor in the U_V()
1615                        inside the #if 1. */
1616                     dleft = Perl_floor(dleft + 0.5);
1617                     use_double = TRUE;
1618                     if (dright_valid)
1619                         dright = Perl_floor(dright + 0.5);
1620                     else
1621                         dright = right;
1622                 }
1623             }
1624         }
1625         sp -= 2;
1626         if (use_double) {
1627             NV dans;
1628
1629             if (!dright)
1630                 DIE(aTHX_ "Illegal modulus zero");
1631
1632             dans = Perl_fmod(dleft, dright);
1633             if ((left_neg != right_neg) && dans)
1634                 dans = dright - dans;
1635             if (right_neg)
1636                 dans = -dans;
1637             sv_setnv(TARG, dans);
1638         }
1639         else {
1640             UV ans;
1641
1642             if (!right)
1643                 DIE(aTHX_ "Illegal modulus zero");
1644
1645             ans = left % right;
1646             if ((left_neg != right_neg) && ans)
1647                 ans = right - ans;
1648             if (right_neg) {
1649                 /* XXX may warn: unary minus operator applied to unsigned type */
1650                 /* could change -foo to be (~foo)+1 instead     */
1651                 if (ans <= ~((UV)IV_MAX)+1)
1652                     sv_setiv(TARG, ~ans+1);
1653                 else
1654                     sv_setnv(TARG, -(NV)ans);
1655             }
1656             else
1657                 sv_setuv(TARG, ans);
1658         }
1659         PUSHTARG;
1660         RETURN;
1661     }
1662 }
1663
1664 PP(pp_repeat)
1665 {
1666     dSP; dATARGET;
1667     IV count;
1668     SV *sv;
1669     bool infnan = FALSE;
1670     const U8 gimme = GIMME_V;
1671
1672     if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1673         /* TODO: think of some way of doing list-repeat overloading ??? */
1674         sv = POPs;
1675         SvGETMAGIC(sv);
1676     }
1677     else {
1678         if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1679             /* The parser saw this as a list repeat, and there
1680                are probably several items on the stack. But we're
1681                in scalar/void context, and there's no pp_list to save us
1682                now. So drop the rest of the items -- robin@kitsite.com
1683              */
1684             dMARK;
1685             if (MARK + 1 < SP) {
1686                 MARK[1] = TOPm1s;
1687                 MARK[2] = TOPs;
1688             }
1689             else {
1690                 dTOPss;
1691                 ASSUME(MARK + 1 == SP);
1692                 MEXTEND(SP, 1);
1693                 PUSHs(sv);
1694                 MARK[1] = &PL_sv_undef;
1695             }
1696             SP = MARK + 2;
1697         }
1698         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1699         sv = POPs;
1700     }
1701
1702     if (SvIOKp(sv)) {
1703          if (SvUOK(sv)) {
1704               const UV uv = SvUV_nomg(sv);
1705               if (uv > IV_MAX)
1706                    count = IV_MAX; /* The best we can do? */
1707               else
1708                    count = uv;
1709          } else {
1710               count = SvIV_nomg(sv);
1711          }
1712     }
1713     else if (SvNOKp(sv)) {
1714         const NV nv = SvNV_nomg(sv);
1715         infnan = Perl_isinfnan(nv);
1716         if (UNLIKELY(infnan)) {
1717             count = 0;
1718         } else {
1719             if (nv < 0.0)
1720                 count = -1;   /* An arbitrary negative integer */
1721             else
1722                 count = (IV)nv;
1723         }
1724     }
1725     else
1726         count = SvIV_nomg(sv);
1727
1728     if (infnan) {
1729         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1730                        "Non-finite repeat count does nothing");
1731     } else if (count < 0) {
1732         count = 0;
1733         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1734                        "Negative repeat count does nothing");
1735     }
1736
1737     if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1738         dMARK;
1739         const SSize_t items = SP - MARK;
1740         const U8 mod = PL_op->op_flags & OPf_MOD;
1741
1742         if (count > 1) {
1743             SSize_t max;
1744
1745             if (  items > SSize_t_MAX / count   /* max would overflow */
1746                                                 /* repeatcpy would overflow */
1747                || items > I32_MAX / (I32)sizeof(SV *)
1748             )
1749                Perl_croak(aTHX_ "%s","Out of memory during list extend");
1750             max = items * count;
1751             MEXTEND(MARK, max);
1752
1753             while (SP > MARK) {
1754                 if (*SP) {
1755                    if (mod && SvPADTMP(*SP)) {
1756                        *SP = sv_mortalcopy(*SP);
1757                    }
1758                    SvTEMP_off((*SP));
1759                 }
1760                 SP--;
1761             }
1762             MARK++;
1763             repeatcpy((char*)(MARK + items), (char*)MARK,
1764                 items * sizeof(const SV *), count - 1);
1765             SP += max;
1766         }
1767         else if (count <= 0)
1768             SP = MARK;
1769     }
1770     else {      /* Note: mark already snarfed by pp_list */
1771         SV * const tmpstr = POPs;
1772         STRLEN len;
1773         bool isutf;
1774
1775         if (TARG != tmpstr)
1776             sv_setsv_nomg(TARG, tmpstr);
1777         SvPV_force_nomg(TARG, len);
1778         isutf = DO_UTF8(TARG);
1779         if (count != 1) {
1780             if (count < 1)
1781                 SvCUR_set(TARG, 0);
1782             else {
1783                 STRLEN max;
1784
1785                 if (   len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1786                     || len > (U32)I32_MAX  /* repeatcpy would overflow */
1787                 )
1788                      Perl_croak(aTHX_ "%s",
1789                                         "Out of memory during string extend");
1790                 max = (UV)count * len + 1;
1791                 SvGROW(TARG, max);
1792
1793                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1794                 SvCUR_set(TARG, SvCUR(TARG) * count);
1795             }
1796             *SvEND(TARG) = '\0';
1797         }
1798         if (isutf)
1799             (void)SvPOK_only_UTF8(TARG);
1800         else
1801             (void)SvPOK_only(TARG);
1802
1803         PUSHTARG;
1804     }
1805     RETURN;
1806 }
1807
1808 PP(pp_subtract)
1809 {
1810     dSP; dATARGET; bool useleft; SV *svl, *svr;
1811     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1812     svr = TOPs;
1813     svl = TOPm1s;
1814
1815 #ifdef PERL_PRESERVE_IVUV
1816
1817     /* special-case some simple common cases */
1818     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1819         IV il, ir;
1820         U32 flags = (svl->sv_flags & svr->sv_flags);
1821         if (flags & SVf_IOK) {
1822             /* both args are simple IVs */
1823             UV topl, topr;
1824             il = SvIVX(svl);
1825             ir = SvIVX(svr);
1826           do_iv:
1827             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1828             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1829
1830             /* if both are in a range that can't under/overflow, do a
1831              * simple integer subtract: if the top of both numbers
1832              * are 00  or 11, then it's safe */
1833             if (!( ((topl+1) | (topr+1)) & 2)) {
1834                 SP--;
1835                 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1836                 SETs(TARG);
1837                 RETURN;
1838             }
1839             goto generic;
1840         }
1841         else if (flags & SVf_NOK) {
1842             /* both args are NVs */
1843             NV nl = SvNVX(svl);
1844             NV nr = SvNVX(svr);
1845
1846             if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1847                 /* nothing was lost by converting to IVs */
1848                 goto do_iv;
1849             }
1850             SP--;
1851             TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1852             SETs(TARG);
1853             RETURN;
1854         }
1855     }
1856
1857   generic:
1858
1859     useleft = USE_LEFT(svl);
1860     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1861        "bad things" happen if you rely on signed integers wrapping.  */
1862     if (SvIV_please_nomg(svr)) {
1863         /* Unless the left argument is integer in range we are going to have to
1864            use NV maths. Hence only attempt to coerce the right argument if
1865            we know the left is integer.  */
1866         UV auv = 0;
1867         bool auvok = FALSE;
1868         bool a_valid = 0;
1869
1870         if (!useleft) {
1871             auv = 0;
1872             a_valid = auvok = 1;
1873             /* left operand is undef, treat as zero.  */
1874         } else {
1875             /* Left operand is defined, so is it IV? */
1876             if (SvIV_please_nomg(svl)) {
1877                 if ((auvok = SvUOK(svl)))
1878                     auv = SvUVX(svl);
1879                 else {
1880                     const IV aiv = SvIVX(svl);
1881                     if (aiv >= 0) {
1882                         auv = aiv;
1883                         auvok = 1;      /* Now acting as a sign flag.  */
1884                     } else {
1885                         auv = (UV) (0 - (UV) aiv);
1886                     }
1887                 }
1888                 a_valid = 1;
1889             }
1890         }
1891         if (a_valid) {
1892             bool result_good = 0;
1893             UV result;
1894             UV buv;
1895             bool buvok = SvUOK(svr);
1896
1897             if (buvok)
1898                 buv = SvUVX(svr);
1899             else {
1900                 const IV biv = SvIVX(svr);
1901                 if (biv >= 0) {
1902                     buv = biv;
1903                     buvok = 1;
1904                 } else
1905                     buv = (UV) (0 - (UV) biv);
1906             }
1907             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1908                else "IV" now, independent of how it came in.
1909                if a, b represents positive, A, B negative, a maps to -A etc
1910                a - b =>  (a - b)
1911                A - b => -(a + b)
1912                a - B =>  (a + b)
1913                A - B => -(a - b)
1914                all UV maths. negate result if A negative.
1915                subtract if signs same, add if signs differ. */
1916
1917             if (auvok ^ buvok) {
1918                 /* Signs differ.  */
1919                 result = auv + buv;
1920                 if (result >= auv)
1921                     result_good = 1;
1922             } else {
1923                 /* Signs same */
1924                 if (auv >= buv) {
1925                     result = auv - buv;
1926                     /* Must get smaller */
1927                     if (result <= auv)
1928                         result_good = 1;
1929                 } else {
1930                     result = buv - auv;
1931                     if (result <= buv) {
1932                         /* result really should be -(auv-buv). as its negation
1933                            of true value, need to swap our result flag  */
1934                         auvok = !auvok;
1935                         result_good = 1;
1936                     }
1937                 }
1938             }
1939             if (result_good) {
1940                 SP--;
1941                 if (auvok)
1942                     SETu( result );
1943                 else {
1944                     /* Negate result */
1945                     if (result <= (UV)IV_MIN)
1946                         SETi(result == (UV)IV_MIN
1947                                 ? IV_MIN : -(IV)result);
1948                     else {
1949                         /* result valid, but out of range for IV.  */
1950                         SETn( -(NV)result );
1951                     }
1952                 }
1953                 RETURN;
1954             } /* Overflow, drop through to NVs.  */
1955         }
1956     }
1957 #else
1958     useleft = USE_LEFT(svl);
1959 #endif
1960     {
1961         NV value = SvNV_nomg(svr);
1962         (void)POPs;
1963
1964         if (!useleft) {
1965             /* left operand is undef, treat as zero - value */
1966             SETn(-value);
1967             RETURN;
1968         }
1969         SETn( SvNV_nomg(svl) - value );
1970         RETURN;
1971     }
1972 }
1973
1974 #define IV_BITS (IVSIZE * 8)
1975
1976 static UV S_uv_shift(UV uv, int shift, bool left)
1977 {
1978    if (shift < 0) {
1979        shift = -shift;
1980        left = !left;
1981    }
1982    if (shift >= IV_BITS) {
1983        return 0;
1984    }
1985    return left ? uv << shift : uv >> shift;
1986 }
1987
1988 static IV S_iv_shift(IV iv, int shift, bool left)
1989 {
1990     if (shift < 0) {
1991         shift = -shift;
1992         left = !left;
1993     }
1994     if (shift >= IV_BITS) {
1995         return iv < 0 && !left ? -1 : 0;
1996     }
1997
1998     return left ? iv << shift : iv >> shift;
1999 }
2000
2001 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2002 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2003 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2004 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2005
2006 PP(pp_left_shift)
2007 {
2008     dSP; dATARGET; SV *svl, *svr;
2009     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2010     svr = POPs;
2011     svl = TOPs;
2012     {
2013       const IV shift = SvIV_nomg(svr);
2014       if (PL_op->op_private & HINT_INTEGER) {
2015           SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2016       }
2017       else {
2018           SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2019       }
2020       RETURN;
2021     }
2022 }
2023
2024 PP(pp_right_shift)
2025 {
2026     dSP; dATARGET; SV *svl, *svr;
2027     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2028     svr = POPs;
2029     svl = TOPs;
2030     {
2031       const IV shift = SvIV_nomg(svr);
2032       if (PL_op->op_private & HINT_INTEGER) {
2033           SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2034       }
2035       else {
2036           SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2037       }
2038       RETURN;
2039     }
2040 }
2041
2042 PP(pp_lt)
2043 {
2044     dSP;
2045     SV *left, *right;
2046
2047     tryAMAGICbin_MG(lt_amg, AMGf_numeric);
2048     right = POPs;
2049     left  = TOPs;
2050     SETs(boolSV(
2051         (SvIOK_notUV(left) && SvIOK_notUV(right))
2052         ? (SvIVX(left) < SvIVX(right))
2053         : (do_ncmp(left, right) == -1)
2054     ));
2055     RETURN;
2056 }
2057
2058 PP(pp_gt)
2059 {
2060     dSP;
2061     SV *left, *right;
2062
2063     tryAMAGICbin_MG(gt_amg, AMGf_numeric);
2064     right = POPs;
2065     left  = TOPs;
2066     SETs(boolSV(
2067         (SvIOK_notUV(left) && SvIOK_notUV(right))
2068         ? (SvIVX(left) > SvIVX(right))
2069         : (do_ncmp(left, right) == 1)
2070     ));
2071     RETURN;
2072 }
2073
2074 PP(pp_le)
2075 {
2076     dSP;
2077     SV *left, *right;
2078
2079     tryAMAGICbin_MG(le_amg, AMGf_numeric);
2080     right = POPs;
2081     left  = TOPs;
2082     SETs(boolSV(
2083         (SvIOK_notUV(left) && SvIOK_notUV(right))
2084         ? (SvIVX(left) <= SvIVX(right))
2085         : (do_ncmp(left, right) <= 0)
2086     ));
2087     RETURN;
2088 }
2089
2090 PP(pp_ge)
2091 {
2092     dSP;
2093     SV *left, *right;
2094
2095     tryAMAGICbin_MG(ge_amg, AMGf_numeric);
2096     right = POPs;
2097     left  = TOPs;
2098     SETs(boolSV(
2099         (SvIOK_notUV(left) && SvIOK_notUV(right))
2100         ? (SvIVX(left) >= SvIVX(right))
2101         : ( (do_ncmp(left, right) & 2) == 0)
2102     ));
2103     RETURN;
2104 }
2105
2106 PP(pp_ne)
2107 {
2108     dSP;
2109     SV *left, *right;
2110
2111     tryAMAGICbin_MG(ne_amg, AMGf_numeric);
2112     right = POPs;
2113     left  = TOPs;
2114     SETs(boolSV(
2115         (SvIOK_notUV(left) && SvIOK_notUV(right))
2116         ? (SvIVX(left) != SvIVX(right))
2117         : (do_ncmp(left, right) != 0)
2118     ));
2119     RETURN;
2120 }
2121
2122 /* compare left and right SVs. Returns:
2123  * -1: <
2124  *  0: ==
2125  *  1: >
2126  *  2: left or right was a NaN
2127  */
2128 I32
2129 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2130 {
2131     PERL_ARGS_ASSERT_DO_NCMP;
2132 #ifdef PERL_PRESERVE_IVUV
2133     /* Fortunately it seems NaN isn't IOK */
2134     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2135             if (!SvUOK(left)) {
2136                 const IV leftiv = SvIVX(left);
2137                 if (!SvUOK(right)) {
2138                     /* ## IV <=> IV ## */
2139                     const IV rightiv = SvIVX(right);
2140                     return (leftiv > rightiv) - (leftiv < rightiv);
2141                 }
2142                 /* ## IV <=> UV ## */
2143                 if (leftiv < 0)
2144                     /* As (b) is a UV, it's >=0, so it must be < */
2145                     return -1;
2146                 {
2147                     const UV rightuv = SvUVX(right);
2148                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2149                 }
2150             }
2151
2152             if (SvUOK(right)) {
2153                 /* ## UV <=> UV ## */
2154                 const UV leftuv = SvUVX(left);
2155                 const UV rightuv = SvUVX(right);
2156                 return (leftuv > rightuv) - (leftuv < rightuv);
2157             }
2158             /* ## UV <=> IV ## */
2159             {
2160                 const IV rightiv = SvIVX(right);
2161                 if (rightiv < 0)
2162                     /* As (a) is a UV, it's >=0, so it cannot be < */
2163                     return 1;
2164                 {
2165                     const UV leftuv = SvUVX(left);
2166                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2167                 }
2168             }
2169             NOT_REACHED; /* NOTREACHED */
2170     }
2171 #endif
2172     {
2173       NV const rnv = SvNV_nomg(right);
2174       NV const lnv = SvNV_nomg(left);
2175
2176 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2177       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2178           return 2;
2179        }
2180       return (lnv > rnv) - (lnv < rnv);
2181 #else
2182       if (lnv < rnv)
2183         return -1;
2184       if (lnv > rnv)
2185         return 1;
2186       if (lnv == rnv)
2187         return 0;
2188       return 2;
2189 #endif
2190     }
2191 }
2192
2193
2194 PP(pp_ncmp)
2195 {
2196     dSP;
2197     SV *left, *right;
2198     I32 value;
2199     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2200     right = POPs;
2201     left  = TOPs;
2202     value = do_ncmp(left, right);
2203     if (value == 2) {
2204         SETs(&PL_sv_undef);
2205     }
2206     else {
2207         dTARGET;
2208         SETi(value);
2209     }
2210     RETURN;
2211 }
2212
2213
2214 /* also used for: pp_sge() pp_sgt() pp_slt() */
2215
2216 PP(pp_sle)
2217 {
2218     dSP;
2219
2220     int amg_type = sle_amg;
2221     int multiplier = 1;
2222     int rhs = 1;
2223
2224     switch (PL_op->op_type) {
2225     case OP_SLT:
2226         amg_type = slt_amg;
2227         /* cmp < 0 */
2228         rhs = 0;
2229         break;
2230     case OP_SGT:
2231         amg_type = sgt_amg;
2232         /* cmp > 0 */
2233         multiplier = -1;
2234         rhs = 0;
2235         break;
2236     case OP_SGE:
2237         amg_type = sge_amg;
2238         /* cmp >= 0 */
2239         multiplier = -1;
2240         break;
2241     }
2242
2243     tryAMAGICbin_MG(amg_type, 0);
2244     {
2245       dPOPTOPssrl;
2246       const int cmp =
2247 #ifdef USE_LOCALE_COLLATE
2248                       (IN_LC_RUNTIME(LC_COLLATE))
2249                       ? sv_cmp_locale_flags(left, right, 0)
2250                       :
2251 #endif
2252                         sv_cmp_flags(left, right, 0);
2253       SETs(boolSV(cmp * multiplier < rhs));
2254       RETURN;
2255     }
2256 }
2257
2258 PP(pp_seq)
2259 {
2260     dSP;
2261     tryAMAGICbin_MG(seq_amg, 0);
2262     {
2263       dPOPTOPssrl;
2264       SETs(boolSV(sv_eq_flags(left, right, 0)));
2265       RETURN;
2266     }
2267 }
2268
2269 PP(pp_sne)
2270 {
2271     dSP;
2272     tryAMAGICbin_MG(sne_amg, 0);
2273     {
2274       dPOPTOPssrl;
2275       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2276       RETURN;
2277     }
2278 }
2279
2280 PP(pp_scmp)
2281 {
2282     dSP; dTARGET;
2283     tryAMAGICbin_MG(scmp_amg, 0);
2284     {
2285       dPOPTOPssrl;
2286       const int cmp =
2287 #ifdef USE_LOCALE_COLLATE
2288                       (IN_LC_RUNTIME(LC_COLLATE))
2289                       ? sv_cmp_locale_flags(left, right, 0)
2290                       :
2291 #endif
2292                         sv_cmp_flags(left, right, 0);
2293       SETi( cmp );
2294       RETURN;
2295     }
2296 }
2297
2298 PP(pp_bit_and)
2299 {
2300     dSP; dATARGET;
2301     tryAMAGICbin_MG(band_amg, AMGf_assign);
2302     {
2303       dPOPTOPssrl;
2304       if (SvNIOKp(left) || SvNIOKp(right)) {
2305         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2306         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2307         if (PL_op->op_private & HINT_INTEGER) {
2308           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2309           SETi(i);
2310         }
2311         else {
2312           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2313           SETu(u);
2314         }
2315         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2316         if (right_ro_nonnum) SvNIOK_off(right);
2317       }
2318       else {
2319         do_vop(PL_op->op_type, TARG, left, right);
2320         SETTARG;
2321       }
2322       RETURN;
2323     }
2324 }
2325
2326 PP(pp_nbit_and)
2327 {
2328     dSP;
2329     tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2330     {
2331         dATARGET; dPOPTOPssrl;
2332         if (PL_op->op_private & HINT_INTEGER) {
2333           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2334           SETi(i);
2335         }
2336         else {
2337           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2338           SETu(u);
2339         }
2340     }
2341     RETURN;
2342 }
2343
2344 PP(pp_sbit_and)
2345 {
2346     dSP;
2347     tryAMAGICbin_MG(sband_amg, AMGf_assign);
2348     {
2349         dATARGET; dPOPTOPssrl;
2350         do_vop(OP_BIT_AND, TARG, left, right);
2351         RETSETTARG;
2352     }
2353 }
2354
2355 /* also used for: pp_bit_xor() */
2356
2357 PP(pp_bit_or)
2358 {
2359     dSP; dATARGET;
2360     const int op_type = PL_op->op_type;
2361
2362     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2363     {
2364       dPOPTOPssrl;
2365       if (SvNIOKp(left) || SvNIOKp(right)) {
2366         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2367         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2368         if (PL_op->op_private & HINT_INTEGER) {
2369           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2370           const IV r = SvIV_nomg(right);
2371           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2372           SETi(result);
2373         }
2374         else {
2375           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2376           const UV r = SvUV_nomg(right);
2377           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2378           SETu(result);
2379         }
2380         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2381         if (right_ro_nonnum) SvNIOK_off(right);
2382       }
2383       else {
2384         do_vop(op_type, TARG, left, right);
2385         SETTARG;
2386       }
2387       RETURN;
2388     }
2389 }
2390
2391 /* also used for: pp_nbit_xor() */
2392
2393 PP(pp_nbit_or)
2394 {
2395     dSP;
2396     const int op_type = PL_op->op_type;
2397
2398     tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2399                     AMGf_assign|AMGf_numarg);
2400     {
2401         dATARGET; dPOPTOPssrl;
2402         if (PL_op->op_private & HINT_INTEGER) {
2403           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2404           const IV r = SvIV_nomg(right);
2405           const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2406           SETi(result);
2407         }
2408         else {
2409           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2410           const UV r = SvUV_nomg(right);
2411           const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2412           SETu(result);
2413         }
2414     }
2415     RETURN;
2416 }
2417
2418 /* also used for: pp_sbit_xor() */
2419
2420 PP(pp_sbit_or)
2421 {
2422     dSP;
2423     const int op_type = PL_op->op_type;
2424
2425     tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2426                     AMGf_assign);
2427     {
2428         dATARGET; dPOPTOPssrl;
2429         do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2430                right);
2431         RETSETTARG;
2432     }
2433 }
2434
2435 PERL_STATIC_INLINE bool
2436 S_negate_string(pTHX)
2437 {
2438     dTARGET; dSP;
2439     STRLEN len;
2440     const char *s;
2441     SV * const sv = TOPs;
2442     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2443         return FALSE;
2444     s = SvPV_nomg_const(sv, len);
2445     if (isIDFIRST(*s)) {
2446         sv_setpvs(TARG, "-");
2447         sv_catsv(TARG, sv);
2448     }
2449     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2450         sv_setsv_nomg(TARG, sv);
2451         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2452     }
2453     else return FALSE;
2454     SETTARG;
2455     return TRUE;
2456 }
2457
2458 PP(pp_negate)
2459 {
2460     dSP; dTARGET;
2461     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2462     if (S_negate_string(aTHX)) return NORMAL;
2463     {
2464         SV * const sv = TOPs;
2465
2466         if (SvIOK(sv)) {
2467             /* It's publicly an integer */
2468         oops_its_an_int:
2469             if (SvIsUV(sv)) {
2470                 if (SvIVX(sv) == IV_MIN) {
2471                     /* 2s complement assumption. */
2472                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2473                                            IV_MIN */
2474                     return NORMAL;
2475                 }
2476                 else if (SvUVX(sv) <= IV_MAX) {
2477                     SETi(-SvIVX(sv));
2478                     return NORMAL;
2479                 }
2480             }
2481             else if (SvIVX(sv) != IV_MIN) {
2482                 SETi(-SvIVX(sv));
2483                 return NORMAL;
2484             }
2485 #ifdef PERL_PRESERVE_IVUV
2486             else {
2487                 SETu((UV)IV_MIN);
2488                 return NORMAL;
2489             }
2490 #endif
2491         }
2492         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2493             SETn(-SvNV_nomg(sv));
2494         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2495                   goto oops_its_an_int;
2496         else
2497             SETn(-SvNV_nomg(sv));
2498     }
2499     return NORMAL;
2500 }
2501
2502 PP(pp_not)
2503 {
2504     dSP;
2505     SV *sv;
2506
2507     tryAMAGICun_MG(not_amg, 0);
2508     sv = *PL_stack_sp;
2509     *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
2510     return NORMAL;
2511 }
2512
2513 static void
2514 S_scomplement(pTHX_ SV *targ, SV *sv)
2515 {
2516         U8 *tmps;
2517         I32 anum;
2518         STRLEN len;
2519
2520         sv_copypv_nomg(TARG, sv);
2521         tmps = (U8*)SvPV_nomg(TARG, len);
2522
2523         if (SvUTF8(TARG)) {
2524             if (len && ! utf8_to_bytes(tmps, &len)) {
2525                 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]);
2526             }
2527             SvCUR(TARG) = len;
2528             SvUTF8_off(TARG);
2529         }
2530
2531         anum = len;
2532
2533 #ifdef LIBERAL
2534         {
2535             long *tmpl;
2536             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2537                 *tmps = ~*tmps;
2538             tmpl = (long*)tmps;
2539             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2540                 *tmpl = ~*tmpl;
2541             tmps = (U8*)tmpl;
2542         }
2543 #endif
2544         for ( ; anum > 0; anum--, tmps++)
2545             *tmps = ~*tmps;
2546 }
2547
2548 PP(pp_complement)
2549 {
2550     dSP; dTARGET;
2551     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2552     {
2553       dTOPss;
2554       if (SvNIOKp(sv)) {
2555         if (PL_op->op_private & HINT_INTEGER) {
2556           const IV i = ~SvIV_nomg(sv);
2557           SETi(i);
2558         }
2559         else {
2560           const UV u = ~SvUV_nomg(sv);
2561           SETu(u);
2562         }
2563       }
2564       else {
2565         S_scomplement(aTHX_ TARG, sv);
2566         SETTARG;
2567       }
2568       return NORMAL;
2569     }
2570 }
2571
2572 PP(pp_ncomplement)
2573 {
2574     dSP;
2575     tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2576     {
2577         dTARGET; dTOPss;
2578         if (PL_op->op_private & HINT_INTEGER) {
2579           const IV i = ~SvIV_nomg(sv);
2580           SETi(i);
2581         }
2582         else {
2583           const UV u = ~SvUV_nomg(sv);
2584           SETu(u);
2585         }
2586     }
2587     return NORMAL;
2588 }
2589
2590 PP(pp_scomplement)
2591 {
2592     dSP;
2593     tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2594     {
2595         dTARGET; dTOPss;
2596         S_scomplement(aTHX_ TARG, sv);
2597         SETTARG;
2598         return NORMAL;
2599     }
2600 }
2601
2602 /* integer versions of some of the above */
2603
2604 PP(pp_i_multiply)
2605 {
2606     dSP; dATARGET;
2607     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2608     {
2609       dPOPTOPiirl_nomg;
2610       SETi( left * right );
2611       RETURN;
2612     }
2613 }
2614
2615 PP(pp_i_divide)
2616 {
2617     IV num;
2618     dSP; dATARGET;
2619     tryAMAGICbin_MG(div_amg, AMGf_assign);
2620     {
2621       dPOPTOPssrl;
2622       IV value = SvIV_nomg(right);
2623       if (value == 0)
2624           DIE(aTHX_ "Illegal division by zero");
2625       num = SvIV_nomg(left);
2626
2627       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2628       if (value == -1)
2629           value = - num;
2630       else
2631           value = num / value;
2632       SETi(value);
2633       RETURN;
2634     }
2635 }
2636
2637 PP(pp_i_modulo)
2638 {
2639      /* This is the vanilla old i_modulo. */
2640      dSP; dATARGET;
2641      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2642      {
2643           dPOPTOPiirl_nomg;
2644           if (!right)
2645                DIE(aTHX_ "Illegal modulus zero");
2646           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2647           if (right == -1)
2648               SETi( 0 );
2649           else
2650               SETi( left % right );
2651           RETURN;
2652      }
2653 }
2654
2655 #if defined(__GLIBC__) && IVSIZE == 8 \
2656     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2657
2658 PP(pp_i_modulo_glibc_bugfix)
2659 {
2660      /* This is the i_modulo with the workaround for the _moddi3 bug
2661       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2662       * See below for pp_i_modulo. */
2663      dSP; dATARGET;
2664      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2665      {
2666           dPOPTOPiirl_nomg;
2667           if (!right)
2668                DIE(aTHX_ "Illegal modulus zero");
2669           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2670           if (right == -1)
2671               SETi( 0 );
2672           else
2673               SETi( left % PERL_ABS(right) );
2674           RETURN;
2675      }
2676 }
2677 #endif
2678
2679 PP(pp_i_add)
2680 {
2681     dSP; dATARGET;
2682     tryAMAGICbin_MG(add_amg, AMGf_assign);
2683     {
2684       dPOPTOPiirl_ul_nomg;
2685       SETi( left + right );
2686       RETURN;
2687     }
2688 }
2689
2690 PP(pp_i_subtract)
2691 {
2692     dSP; dATARGET;
2693     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2694     {
2695       dPOPTOPiirl_ul_nomg;
2696       SETi( left - right );
2697       RETURN;
2698     }
2699 }
2700
2701 PP(pp_i_lt)
2702 {
2703     dSP;
2704     tryAMAGICbin_MG(lt_amg, 0);
2705     {
2706       dPOPTOPiirl_nomg;
2707       SETs(boolSV(left < right));
2708       RETURN;
2709     }
2710 }
2711
2712 PP(pp_i_gt)
2713 {
2714     dSP;
2715     tryAMAGICbin_MG(gt_amg, 0);
2716     {
2717       dPOPTOPiirl_nomg;
2718       SETs(boolSV(left > right));
2719       RETURN;
2720     }
2721 }
2722
2723 PP(pp_i_le)
2724 {
2725     dSP;
2726     tryAMAGICbin_MG(le_amg, 0);
2727     {
2728       dPOPTOPiirl_nomg;
2729       SETs(boolSV(left <= right));
2730       RETURN;
2731     }
2732 }
2733
2734 PP(pp_i_ge)
2735 {
2736     dSP;
2737     tryAMAGICbin_MG(ge_amg, 0);
2738     {
2739       dPOPTOPiirl_nomg;
2740       SETs(boolSV(left >= right));
2741       RETURN;
2742     }
2743 }
2744
2745 PP(pp_i_eq)
2746 {
2747     dSP;
2748     tryAMAGICbin_MG(eq_amg, 0);
2749     {
2750       dPOPTOPiirl_nomg;
2751       SETs(boolSV(left == right));
2752       RETURN;
2753     }
2754 }
2755
2756 PP(pp_i_ne)
2757 {
2758     dSP;
2759     tryAMAGICbin_MG(ne_amg, 0);
2760     {
2761       dPOPTOPiirl_nomg;
2762       SETs(boolSV(left != right));
2763       RETURN;
2764     }
2765 }
2766
2767 PP(pp_i_ncmp)
2768 {
2769     dSP; dTARGET;
2770     tryAMAGICbin_MG(ncmp_amg, 0);
2771     {
2772       dPOPTOPiirl_nomg;
2773       I32 value;
2774
2775       if (left > right)
2776         value = 1;
2777       else if (left < right)
2778         value = -1;
2779       else
2780         value = 0;
2781       SETi(value);
2782       RETURN;
2783     }
2784 }
2785
2786 PP(pp_i_negate)
2787 {
2788     dSP; dTARGET;
2789     tryAMAGICun_MG(neg_amg, 0);
2790     if (S_negate_string(aTHX)) return NORMAL;
2791     {
2792         SV * const sv = TOPs;
2793         IV const i = SvIV_nomg(sv);
2794         SETi(-i);
2795         return NORMAL;
2796     }
2797 }
2798
2799 /* High falutin' math. */
2800
2801 PP(pp_atan2)
2802 {
2803     dSP; dTARGET;
2804     tryAMAGICbin_MG(atan2_amg, 0);
2805     {
2806       dPOPTOPnnrl_nomg;
2807       SETn(Perl_atan2(left, right));
2808       RETURN;
2809     }
2810 }
2811
2812
2813 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2814
2815 PP(pp_sin)
2816 {
2817     dSP; dTARGET;
2818     int amg_type = fallback_amg;
2819     const char *neg_report = NULL;
2820     const int op_type = PL_op->op_type;
2821
2822     switch (op_type) {
2823     case OP_SIN:  amg_type = sin_amg; break;
2824     case OP_COS:  amg_type = cos_amg; break;
2825     case OP_EXP:  amg_type = exp_amg; break;
2826     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2827     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2828     }
2829
2830     assert(amg_type != fallback_amg);
2831
2832     tryAMAGICun_MG(amg_type, 0);
2833     {
2834       SV * const arg = TOPs;
2835       const NV value = SvNV_nomg(arg);
2836 #ifdef NV_NAN
2837       NV result = NV_NAN;
2838 #else
2839       NV result = 0.0;
2840 #endif
2841       if (neg_report) { /* log or sqrt */
2842           if (
2843 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2844               ! Perl_isnan(value) &&
2845 #endif
2846               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2847               SET_NUMERIC_STANDARD();
2848               /* diag_listed_as: Can't take log of %g */
2849               DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2850           }
2851       }
2852       switch (op_type) {
2853       default:
2854       case OP_SIN:  result = Perl_sin(value);  break;
2855       case OP_COS:  result = Perl_cos(value);  break;
2856       case OP_EXP:  result = Perl_exp(value);  break;
2857       case OP_LOG:  result = Perl_log(value);  break;
2858       case OP_SQRT: result = Perl_sqrt(value); break;
2859       }
2860       SETn(result);
2861       return NORMAL;
2862     }
2863 }
2864
2865 /* Support Configure command-line overrides for rand() functions.
2866    After 5.005, perhaps we should replace this by Configure support
2867    for drand48(), random(), or rand().  For 5.005, though, maintain
2868    compatibility by calling rand() but allow the user to override it.
2869    See INSTALL for details.  --Andy Dougherty  15 July 1998
2870 */
2871 /* Now it's after 5.005, and Configure supports drand48() and random(),
2872    in addition to rand().  So the overrides should not be needed any more.
2873    --Jarkko Hietaniemi  27 September 1998
2874  */
2875
2876 PP(pp_rand)
2877 {
2878     if (!PL_srand_called) {
2879         (void)seedDrand01((Rand_seed_t)seed());
2880         PL_srand_called = TRUE;
2881     }
2882     {
2883         dSP;
2884         NV value;
2885
2886         if (MAXARG < 1)
2887         {
2888             EXTEND(SP, 1);
2889             value = 1.0;
2890         }
2891         else {
2892             SV * const sv = POPs;
2893             if(!sv)
2894                 value = 1.0;
2895             else
2896                 value = SvNV(sv);
2897         }
2898     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2899 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2900         if (! Perl_isnan(value) && value == 0.0)
2901 #else
2902         if (value == 0.0)
2903 #endif
2904             value = 1.0;
2905         {
2906             dTARGET;
2907             PUSHs(TARG);
2908             PUTBACK;
2909             value *= Drand01();
2910             sv_setnv_mg(TARG, value);
2911         }
2912     }
2913     return NORMAL;
2914 }
2915
2916 PP(pp_srand)
2917 {
2918     dSP; dTARGET;
2919     UV anum;
2920
2921     if (MAXARG >= 1 && (TOPs || POPs)) {
2922         SV *top;
2923         char *pv;
2924         STRLEN len;
2925         int flags;
2926
2927         top = POPs;
2928         pv = SvPV(top, len);
2929         flags = grok_number(pv, len, &anum);
2930
2931         if (!(flags & IS_NUMBER_IN_UV)) {
2932             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2933                              "Integer overflow in srand");
2934             anum = UV_MAX;
2935         }
2936     }
2937     else {
2938         anum = seed();
2939     }
2940
2941     (void)seedDrand01((Rand_seed_t)anum);
2942     PL_srand_called = TRUE;
2943     if (anum)
2944         XPUSHu(anum);
2945     else {
2946         /* Historically srand always returned true. We can avoid breaking
2947            that like this:  */
2948         sv_setpvs(TARG, "0 but true");
2949         XPUSHTARG;
2950     }
2951     RETURN;
2952 }
2953
2954 PP(pp_int)
2955 {
2956     dSP; dTARGET;
2957     tryAMAGICun_MG(int_amg, AMGf_numeric);
2958     {
2959       SV * const sv = TOPs;
2960       const IV iv = SvIV_nomg(sv);
2961       /* XXX it's arguable that compiler casting to IV might be subtly
2962          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2963          else preferring IV has introduced a subtle behaviour change bug. OTOH
2964          relying on floating point to be accurate is a bug.  */
2965
2966       if (!SvOK(sv)) {
2967         SETu(0);
2968       }
2969       else if (SvIOK(sv)) {
2970         if (SvIsUV(sv))
2971             SETu(SvUV_nomg(sv));
2972         else
2973             SETi(iv);
2974       }
2975       else {
2976           const NV value = SvNV_nomg(sv);
2977           if (UNLIKELY(Perl_isinfnan(value)))
2978               SETn(value);
2979           else if (value >= 0.0) {
2980               if (value < (NV)UV_MAX + 0.5) {
2981                   SETu(U_V(value));
2982               } else {
2983                   SETn(Perl_floor(value));
2984               }
2985           }
2986           else {
2987               if (value > (NV)IV_MIN - 0.5) {
2988                   SETi(I_V(value));
2989               } else {
2990                   SETn(Perl_ceil(value));
2991               }
2992           }
2993       }
2994     }
2995     return NORMAL;
2996 }
2997
2998 PP(pp_abs)
2999 {
3000     dSP; dTARGET;
3001     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3002     {
3003       SV * const sv = TOPs;
3004       /* This will cache the NV value if string isn't actually integer  */
3005       const IV iv = SvIV_nomg(sv);
3006
3007       if (!SvOK(sv)) {
3008         SETu(0);
3009       }
3010       else if (SvIOK(sv)) {
3011         /* IVX is precise  */
3012         if (SvIsUV(sv)) {
3013           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3014         } else {
3015           if (iv >= 0) {
3016             SETi(iv);
3017           } else {
3018             if (iv != IV_MIN) {
3019               SETi(-iv);
3020             } else {
3021               /* 2s complement assumption. Also, not really needed as
3022                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3023               SETu((UV)IV_MIN);
3024             }
3025           }
3026         }
3027       } else{
3028         const NV value = SvNV_nomg(sv);
3029         if (value < 0.0)
3030           SETn(-value);
3031         else
3032           SETn(value);
3033       }
3034     }
3035     return NORMAL;
3036 }
3037
3038
3039 /* also used for: pp_hex() */
3040
3041 PP(pp_oct)
3042 {
3043     dSP; dTARGET;
3044     const char *tmps;
3045     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3046     STRLEN len;
3047     NV result_nv;
3048     UV result_uv;
3049     SV* const sv = TOPs;
3050
3051     tmps = (SvPV_const(sv, len));
3052     if (DO_UTF8(sv)) {
3053          /* If Unicode, try to downgrade
3054           * If not possible, croak. */
3055          SV* const tsv = sv_2mortal(newSVsv(sv));
3056
3057          SvUTF8_on(tsv);
3058          sv_utf8_downgrade(tsv, FALSE);
3059          tmps = SvPV_const(tsv, len);
3060     }
3061     if (PL_op->op_type == OP_HEX)
3062         goto hex;
3063
3064     while (*tmps && len && isSPACE(*tmps))
3065         tmps++, len--;
3066     if (*tmps == '0')
3067         tmps++, len--;
3068     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3069     hex:
3070         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3071     }
3072     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3073         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3074     else
3075         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3076
3077     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3078         SETn(result_nv);
3079     }
3080     else {
3081         SETu(result_uv);
3082     }
3083     return NORMAL;
3084 }
3085
3086 /* String stuff. */
3087
3088
3089 PP(pp_length)
3090 {
3091     dSP; dTARGET;
3092     SV * const sv = TOPs;
3093
3094     U32 in_bytes = IN_BYTES;
3095     /* Simplest case shortcut:
3096      * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3097      * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3098      * set)
3099      */
3100     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3101
3102     STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3103     SETs(TARG);
3104
3105     if (LIKELY(svflags == SVf_POK))
3106         goto simple_pv;
3107
3108     if (svflags & SVs_GMG)
3109         mg_get(sv);
3110
3111     if (SvOK(sv)) {
3112         STRLEN len;
3113         if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3114             if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3115                 goto simple_pv;
3116             if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3117                 /* no need to convert from bytes to chars */
3118                 len = SvCUR(sv);
3119                 goto return_bool;
3120             }
3121             len = sv_len_utf8_nomg(sv);
3122         }
3123         else {
3124             /* unrolled SvPV_nomg_const(sv,len) */
3125             if (SvPOK_nog(sv)) {
3126               simple_pv:
3127                 len = SvCUR(sv);
3128                 if (PL_op->op_private & OPpTRUEBOOL) {
3129                   return_bool:
3130                     SETs(len ? &PL_sv_yes : &PL_sv_zero);
3131                     return NORMAL;
3132                 }
3133             }
3134             else {
3135                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3136             }
3137         }
3138         TARGi((IV)(len), 1);
3139     }
3140     else {
3141         if (!SvPADTMP(TARG)) {
3142             /* OPpTARGET_MY: targ is var in '$lex = length()' */
3143             sv_set_undef(TARG);
3144             SvSETMAGIC(TARG);
3145         }
3146         else
3147             /* TARG is on stack at this point and is overwriten by SETs.
3148              * This branch is the odd one out, so put TARG by default on
3149              * stack earlier to let local SP go out of liveness sooner */
3150             SETs(&PL_sv_undef);
3151     }
3152     return NORMAL; /* no putback, SP didn't move in this opcode */
3153 }
3154
3155
3156 /* Returns false if substring is completely outside original string.
3157    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3158    always be true for an explicit 0.
3159 */
3160 bool
3161 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3162                                 bool pos1_is_uv, IV len_iv,
3163                                 bool len_is_uv, STRLEN *posp,
3164                                 STRLEN *lenp)
3165 {
3166     IV pos2_iv;
3167     int    pos2_is_uv;
3168
3169     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3170
3171     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3172         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3173         pos1_iv += curlen;
3174     }
3175     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3176         return FALSE;
3177
3178     if (len_iv || len_is_uv) {
3179         if (!len_is_uv && len_iv < 0) {
3180             pos2_iv = curlen + len_iv;
3181             if (curlen)
3182                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3183             else
3184                 pos2_is_uv = 0;
3185         } else {  /* len_iv >= 0 */
3186             if (!pos1_is_uv && pos1_iv < 0) {
3187                 pos2_iv = pos1_iv + len_iv;
3188                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3189             } else {
3190                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3191                     pos2_iv = curlen;
3192                 else
3193                     pos2_iv = pos1_iv+len_iv;
3194                 pos2_is_uv = 1;
3195             }
3196         }
3197     }
3198     else {
3199         pos2_iv = curlen;
3200         pos2_is_uv = 1;
3201     }
3202
3203     if (!pos2_is_uv && pos2_iv < 0) {
3204         if (!pos1_is_uv && pos1_iv < 0)
3205             return FALSE;
3206         pos2_iv = 0;
3207     }
3208     else if (!pos1_is_uv && pos1_iv < 0)
3209         pos1_iv = 0;
3210
3211     if ((UV)pos2_iv < (UV)pos1_iv)
3212         pos2_iv = pos1_iv;
3213     if ((UV)pos2_iv > curlen)
3214         pos2_iv = curlen;
3215
3216     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3217     *posp = (STRLEN)( (UV)pos1_iv );
3218     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3219
3220     return TRUE;
3221 }
3222
3223 PP(pp_substr)
3224 {
3225     dSP; dTARGET;
3226     SV *sv;
3227     STRLEN curlen;
3228     STRLEN utf8_curlen;
3229     SV *   pos_sv;
3230     IV     pos1_iv;
3231     int    pos1_is_uv;
3232     SV *   len_sv;
3233     IV     len_iv = 0;
3234     int    len_is_uv = 0;
3235     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3236     const bool rvalue = (GIMME_V != G_VOID);
3237     const char *tmps;
3238     SV *repl_sv = NULL;
3239     const char *repl = NULL;
3240     STRLEN repl_len;
3241     int num_args = PL_op->op_private & 7;
3242     bool repl_need_utf8_upgrade = FALSE;
3243
3244     if (num_args > 2) {
3245         if (num_args > 3) {
3246           if(!(repl_sv = POPs)) num_args--;
3247         }
3248         if ((len_sv = POPs)) {
3249             len_iv    = SvIV(len_sv);
3250             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3251         }
3252         else num_args--;
3253     }
3254     pos_sv     = POPs;
3255     pos1_iv    = SvIV(pos_sv);
3256     pos1_is_uv = SvIOK_UV(pos_sv);
3257     sv = POPs;
3258     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3259         assert(!repl_sv);
3260         repl_sv = POPs;
3261     }
3262     if (lvalue && !repl_sv) {
3263         SV * ret;
3264         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3265         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3266         LvTYPE(ret) = 'x';
3267         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3268         LvTARGOFF(ret) =
3269             pos1_is_uv || pos1_iv >= 0
3270                 ? (STRLEN)(UV)pos1_iv
3271                 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3272         LvTARGLEN(ret) =
3273             len_is_uv || len_iv > 0
3274                 ? (STRLEN)(UV)len_iv
3275                 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3276
3277         PUSHs(ret);    /* avoid SvSETMAGIC here */
3278         RETURN;
3279     }
3280     if (repl_sv) {
3281         repl = SvPV_const(repl_sv, repl_len);
3282         SvGETMAGIC(sv);
3283         if (SvROK(sv))
3284             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3285                             "Attempt to use reference as lvalue in substr"
3286             );
3287         tmps = SvPV_force_nomg(sv, curlen);
3288         if (DO_UTF8(repl_sv) && repl_len) {
3289             if (!DO_UTF8(sv)) {
3290                 /* Upgrade the dest, and recalculate tmps in case the buffer
3291                  * got reallocated; curlen may also have been changed */
3292                 sv_utf8_upgrade_nomg(sv);
3293                 tmps = SvPV_nomg(sv, curlen);
3294             }
3295         }
3296         else if (DO_UTF8(sv))
3297             repl_need_utf8_upgrade = TRUE;
3298     }
3299     else tmps = SvPV_const(sv, curlen);
3300     if (DO_UTF8(sv)) {
3301         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3302         if (utf8_curlen == curlen)
3303             utf8_curlen = 0;
3304         else
3305             curlen = utf8_curlen;
3306     }
3307     else
3308         utf8_curlen = 0;
3309
3310     {
3311         STRLEN pos, len, byte_len, byte_pos;
3312
3313         if (!translate_substr_offsets(
3314                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3315         )) goto bound_fail;
3316
3317         byte_len = len;
3318         byte_pos = utf8_curlen
3319             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3320
3321         tmps += byte_pos;
3322
3323         if (rvalue) {
3324             SvTAINTED_off(TARG);                        /* decontaminate */
3325             SvUTF8_off(TARG);                   /* decontaminate */
3326             sv_setpvn(TARG, tmps, byte_len);
3327 #ifdef USE_LOCALE_COLLATE
3328             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3329 #endif
3330             if (utf8_curlen)
3331                 SvUTF8_on(TARG);
3332         }
3333
3334         if (repl) {
3335             SV* repl_sv_copy = NULL;
3336
3337             if (repl_need_utf8_upgrade) {
3338                 repl_sv_copy = newSVsv(repl_sv);
3339                 sv_utf8_upgrade(repl_sv_copy);
3340                 repl = SvPV_const(repl_sv_copy, repl_len);
3341             }
3342             if (!SvOK(sv))
3343                 SvPVCLEAR(sv);
3344             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3345             SvREFCNT_dec(repl_sv_copy);
3346         }
3347     }
3348     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3349         SP++;
3350     else if (rvalue) {
3351         SvSETMAGIC(TARG);
3352         PUSHs(TARG);
3353     }
3354     RETURN;
3355
3356   bound_fail:
3357     if (repl)
3358         Perl_croak(aTHX_ "substr outside of string");
3359     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3360     RETPUSHUNDEF;
3361 }
3362
3363 PP(pp_vec)
3364 {
3365     dSP;
3366     const IV size   = POPi;
3367     SV* offsetsv   = POPs;
3368     SV * const src = POPs;
3369     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3370     SV * ret;
3371     UV   retuv;
3372     STRLEN offset = 0;
3373     char errflags = 0;
3374
3375     /* extract a STRLEN-ranged integer value from offsetsv into offset,
3376      * or flag that its out of range */
3377     {
3378         IV iv = SvIV(offsetsv);
3379
3380         /* avoid a large UV being wrapped to a negative value */
3381         if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3382             errflags = LVf_OUT_OF_RANGE;
3383         else if (iv < 0)
3384             errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3385 #if PTRSIZE < IVSIZE
3386         else if (iv > Size_t_MAX)
3387             errflags = LVf_OUT_OF_RANGE;
3388 #endif
3389         else
3390             offset = (STRLEN)iv;
3391     }
3392
3393     retuv = errflags ? 0 : do_vecget(src, offset, size);
3394
3395     if (lvalue) {                       /* it's an lvalue! */
3396         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3397         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3398         LvTYPE(ret) = 'v';
3399         LvTARG(ret) = SvREFCNT_inc_simple(src);
3400         LvTARGOFF(ret) = offset;
3401         LvTARGLEN(ret) = size;
3402         LvFLAGS(ret)   = errflags;
3403     }
3404     else {
3405         dTARGET;
3406         SvTAINTED_off(TARG);            /* decontaminate */
3407         ret = TARG;
3408     }
3409
3410     sv_setuv(ret, retuv);
3411     if (!lvalue)
3412         SvSETMAGIC(ret);
3413     PUSHs(ret);
3414     RETURN;
3415 }
3416
3417
3418 /* also used for: pp_rindex() */
3419
3420 PP(pp_index)
3421 {
3422     dSP; dTARGET;
3423     SV *big;
3424     SV *little;
3425     SV *temp = NULL;
3426     STRLEN biglen;
3427     STRLEN llen = 0;
3428     SSize_t offset = 0;
3429     SSize_t retval;
3430     const char *big_p;
3431     const char *little_p;
3432     bool big_utf8;
3433     bool little_utf8;
3434     const bool is_index = PL_op->op_type == OP_INDEX;
3435     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3436
3437     if (threeargs)
3438         offset = POPi;
3439     little = POPs;
3440     big = POPs;
3441     big_p = SvPV_const(big, biglen);
3442     little_p = SvPV_const(little, llen);
3443
3444     big_utf8 = DO_UTF8(big);
3445     little_utf8 = DO_UTF8(little);
3446     if (big_utf8 ^ little_utf8) {
3447         /* One needs to be upgraded.  */
3448         if (little_utf8) {
3449             /* Well, maybe instead we might be able to downgrade the small
3450                string?  */
3451             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3452                                                      &little_utf8);
3453             if (little_utf8) {
3454                 /* If the large string is ISO-8859-1, and it's not possible to
3455                    convert the small string to ISO-8859-1, then there is no
3456                    way that it could be found anywhere by index.  */
3457                 retval = -1;
3458                 goto push_result;
3459             }
3460
3461             /* At this point, pv is a malloc()ed string. So donate it to temp
3462                to ensure it will get free()d  */
3463             little = temp = newSV(0);
3464             sv_usepvn(temp, pv, llen);
3465             little_p = SvPVX(little);
3466         } else {
3467             temp = newSVpvn(little_p, llen);
3468
3469             sv_utf8_upgrade(temp);
3470             little = temp;
3471             little_p = SvPV_const(little, llen);
3472         }
3473     }
3474     if (SvGAMAGIC(big)) {
3475         /* Life just becomes a lot easier if I use a temporary here.
3476            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3477            will trigger magic and overloading again, as will fbm_instr()
3478         */
3479         big = newSVpvn_flags(big_p, biglen,
3480                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3481         big_p = SvPVX(big);
3482     }
3483     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3484         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3485            warn on undef, and we've already triggered a warning with the
3486            SvPV_const some lines above. We can't remove that, as we need to
3487            call some SvPV to trigger overloading early and find out if the
3488            string is UTF-8.
3489            This is all getting too messy. The API isn't quite clean enough,
3490            because data access has side effects.
3491         */
3492         little = newSVpvn_flags(little_p, llen,
3493                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3494         little_p = SvPVX(little);
3495     }
3496
3497     if (!threeargs)
3498         offset = is_index ? 0 : biglen;
3499     else {
3500         if (big_utf8 && offset > 0)
3501             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3502         if (!is_index)
3503             offset += llen;
3504     }
3505     if (offset < 0)
3506         offset = 0;
3507     else if (offset > (SSize_t)biglen)
3508         offset = biglen;
3509     if (!(little_p = is_index
3510           ? fbm_instr((unsigned char*)big_p + offset,
3511                       (unsigned char*)big_p + biglen, little, 0)
3512           : rninstr(big_p,  big_p  + offset,
3513                     little_p, little_p + llen)))
3514         retval = -1;
3515     else {
3516         retval = little_p - big_p;
3517         if (retval > 1 && big_utf8)
3518             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3519     }
3520     SvREFCNT_dec(temp);
3521
3522   push_result:
3523     /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3524     if (PL_op->op_private & OPpTRUEBOOL) {
3525         PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3526                     ? &PL_sv_yes : &PL_sv_no);
3527         if (PL_op->op_private & OPpTARGET_MY)
3528             /* $lex = (index() == -1) */
3529             sv_setsv(TARG, TOPs);
3530     }
3531     else
3532         PUSHi(retval);
3533     RETURN;
3534 }
3535
3536 PP(pp_sprintf)
3537 {
3538     dSP; dMARK; dORIGMARK; dTARGET;
3539     SvTAINTED_off(TARG);
3540     do_sprintf(TARG, SP-MARK, MARK+1);
3541     TAINT_IF(SvTAINTED(TARG));
3542     SP = ORIGMARK;
3543     PUSHTARG;
3544     RETURN;
3545 }
3546
3547 PP(pp_ord)
3548 {
3549     dSP; dTARGET;
3550
3551     SV *argsv = TOPs;
3552     STRLEN len;
3553     const U8 *s = (U8*)SvPV_const(argsv, len);
3554
3555     SETu(DO_UTF8(argsv)
3556            ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3557            : (UV)(*s));
3558
3559     return NORMAL;
3560 }
3561
3562 PP(pp_chr)
3563 {
3564     dSP; dTARGET;
3565     char *tmps;
3566     UV value;
3567     SV *top = TOPs;
3568
3569     SvGETMAGIC(top);
3570     if (UNLIKELY(SvAMAGIC(top)))
3571         top = sv_2num(top);
3572     if (UNLIKELY(isinfnansv(top)))
3573         Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3574     else {
3575         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3576             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3577                 ||
3578                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3579                  && SvNV_nomg(top) < 0.0)))
3580         {
3581             if (ckWARN(WARN_UTF8)) {
3582                 if (SvGMAGICAL(top)) {
3583                     SV *top2 = sv_newmortal();
3584                     sv_setsv_nomg(top2, top);
3585                     top = top2;
3586                 }
3587                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3588                             "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3589             }
3590             value = UNICODE_REPLACEMENT;
3591         } else {
3592             value = SvUV_nomg(top);
3593         }
3594     }
3595
3596     SvUPGRADE(TARG,SVt_PV);
3597
3598     if (value > 255 && !IN_BYTES) {
3599         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3600         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3601         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3602         *tmps = '\0';
3603         (void)SvPOK_only(TARG);
3604         SvUTF8_on(TARG);
3605         SETTARG;
3606         return NORMAL;
3607     }
3608
3609     SvGROW(TARG,2);
3610     SvCUR_set(TARG, 1);
3611     tmps = SvPVX(TARG);
3612     *tmps++ = (char)value;
3613     *tmps = '\0';
3614     (void)SvPOK_only(TARG);
3615
3616     SETTARG;
3617     return NORMAL;
3618 }
3619
3620 PP(pp_crypt)
3621 {
3622 #ifdef HAS_CRYPT
3623     dSP; dTARGET;
3624     dPOPTOPssrl;
3625     STRLEN len;
3626     const char *tmps = SvPV_const(left, len);
3627
3628     if (DO_UTF8(left)) {
3629          /* If Unicode, try to downgrade.
3630           * If not possible, croak.
3631           * Yes, we made this up.  */
3632          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3633
3634          sv_utf8_downgrade(tsv, FALSE);
3635          tmps = SvPV_const(tsv, len);
3636     }
3637 #   ifdef USE_ITHREADS
3638 #     ifdef HAS_CRYPT_R
3639     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3640       /* This should be threadsafe because in ithreads there is only
3641        * one thread per interpreter.  If this would not be true,
3642        * we would need a mutex to protect this malloc. */
3643         PL_reentrant_buffer->_crypt_struct_buffer =
3644           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3645 #if defined(__GLIBC__) || defined(__EMX__)
3646         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3647             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3648 #if (defined(__GLIBC__) && __GLIBC__ == 2) && \
3649     (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4)
3650             /* work around glibc-2.2.5 bug, has been fixed at some
3651              * time in glibc-2.3.X */
3652             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3653 #endif
3654         }
3655 #endif
3656     }
3657 #     endif /* HAS_CRYPT_R */
3658 #   endif /* USE_ITHREADS */
3659 #   ifdef FCRYPT
3660     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3661 #   else
3662     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3663 #   endif
3664     SvUTF8_off(TARG);
3665     SETTARG;
3666     RETURN;
3667 #else
3668     DIE(aTHX_
3669       "The crypt() function is unimplemented due to excessive paranoia.");
3670 #endif
3671 }
3672
3673 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3674  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3675
3676
3677 /* also used for: pp_lcfirst() */
3678
3679 PP(pp_ucfirst)
3680 {
3681     /* Actually is both lcfirst() and ucfirst().  Only the first character
3682      * changes.  This means that possibly we can change in-place, ie., just
3683      * take the source and change that one character and store it back, but not
3684      * if read-only etc, or if the length changes */
3685
3686     dSP;
3687     SV *source = TOPs;
3688     STRLEN slen; /* slen is the byte length of the whole SV. */
3689     STRLEN need;
3690     SV *dest;
3691     bool inplace;   /* ? Convert first char only, in-place */
3692     bool doing_utf8 = FALSE;               /* ? using utf8 */
3693     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3694     const int op_type = PL_op->op_type;
3695     const U8 *s;
3696     U8 *d;
3697     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3698     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3699                      * stored as UTF-8 at s. */
3700     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3701                      * lowercased) character stored in tmpbuf.  May be either
3702                      * UTF-8 or not, but in either case is the number of bytes */
3703     bool remove_dot_above = FALSE;
3704
3705     s = (const U8*)SvPV_const(source, slen);
3706
3707     /* We may be able to get away with changing only the first character, in
3708      * place, but not if read-only, etc.  Later we may discover more reasons to
3709      * not convert in-place. */
3710     inplace = !SvREADONLY(source) && SvPADTMP(source);
3711
3712 #ifdef USE_LOCALE_CTYPE
3713
3714     if (IN_LC_RUNTIME(LC_CTYPE)) {
3715         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3716     }
3717
3718 #endif
3719
3720     /* First calculate what the changed first character should be.  This affects
3721      * whether we can just swap it out, leaving the rest of the string unchanged,
3722      * or even if have to convert the dest to UTF-8 when the source isn't */
3723
3724     if (! slen) {   /* If empty */
3725         need = 1; /* still need a trailing NUL */
3726         ulen = 0;
3727         *tmpbuf = '\0';
3728     }
3729     else if (DO_UTF8(source)) { /* Is the source utf8? */
3730         doing_utf8 = TRUE;
3731         ulen = UTF8SKIP(s);
3732
3733         if (op_type == OP_UCFIRST) {
3734 #ifdef USE_LOCALE_CTYPE
3735             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3736 #else
3737             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3738 #endif
3739         }
3740         else {
3741
3742 #ifdef USE_LOCALE_CTYPE
3743
3744             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3745
3746             /* In turkic locales, lower casing an 'I' normally yields U+0131,
3747              * LATIN SMALL LETTER DOTLESS I, but not if the grapheme also
3748              * contains a COMBINING DOT ABOVE.  Instead it is treated like
3749              * LATIN CAPITAL LETTER I WITH DOT ABOVE lowercased to 'i'.  The
3750              * call to lowercase above has handled this.  But SpecialCasing.txt
3751              * says we are supposed to remove the COMBINING DOT ABOVE.  We can
3752              * tell if we have this situation if I ==> i in a turkic locale. */
3753             if (   UNLIKELY(PL_in_utf8_turkic_locale)
3754                 && IN_LC_RUNTIME(LC_CTYPE)
3755                 && (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')))
3756             {
3757                 /* Here, we know there was a COMBINING DOT ABOVE.  We won't be
3758                  * able to handle this in-place. */
3759                 inplace = FALSE;
3760
3761                 /* It seems likely that the DOT will immediately follow the
3762                  * 'I'.  If so, we can remove it simply by indicating to the
3763                  * code below to start copying the source just beyond the DOT.
3764                  * We know its length is 2 */
3765                 if (LIKELY(memBEGINs(s + 1, s + slen, COMBINING_DOT_ABOVE_UTF8))) {
3766                     ulen += 2;
3767                 }
3768                 else {  /* But if it doesn't follow immediately, set a flag for
3769                            the code below */
3770                     remove_dot_above = TRUE;
3771                 }
3772             }
3773 #else
3774             PERL_UNUSED_VAR(remove_dot_above);
3775
3776             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3777 #endif
3778
3779         }
3780
3781         /* we can't do in-place if the length changes.  */
3782         if (ulen != tculen) inplace = FALSE;
3783         need = slen + 1 - ulen + tculen;
3784     }
3785     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3786             * latin1 is treated as caseless.  Note that a locale takes
3787             * precedence */
3788         ulen = 1;       /* Original character is 1 byte */
3789         tculen = 1;     /* Most characters will require one byte, but this will
3790                          * need to be overridden for the tricky ones */
3791         need = slen + 1;
3792
3793
3794 #ifdef USE_LOCALE_CTYPE
3795
3796         if (IN_LC_RUNTIME(LC_CTYPE)) {
3797             if (    UNLIKELY(PL_in_utf8_turkic_locale)
3798                 && (   (op_type == OP_LCFIRST && UNLIKELY(*s == 'I'))
3799                     || (op_type == OP_UCFIRST && UNLIKELY(*s == 'i'))))
3800             {
3801                 if (*s == 'I') { /* lcfirst('I') */
3802                     tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
3803                     tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
3804                 }
3805                 else {  /* ucfirst('i') */
3806                     tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3807                     tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3808                 }
3809                 tculen = 2;
3810                 inplace = FALSE;
3811                 doing_utf8 = TRUE;
3812                 convert_source_to_utf8 = TRUE;
3813                 need += variant_under_utf8_count(s, s + slen);
3814             }
3815             else if (op_type == OP_LCFIRST) {
3816
3817                 /* For lc, there are no gotchas for UTF-8 locales (other than
3818                  * the turkish ones already handled above) */
3819                 *tmpbuf = toLOWER_LC(*s);
3820             }
3821             else { /* ucfirst */
3822
3823                 /* But for uc, some characters require special handling */
3824                 if (IN_UTF8_CTYPE_LOCALE) {
3825                     goto do_uni_rules;
3826                 }
3827
3828                 /* This would be a bug if any locales have upper and title case
3829                  * different */
3830                 *tmpbuf = (U8) toUPPER_LC(*s);
3831             }
3832         }
3833         else
3834 #endif
3835         /* Here, not in locale.  If not using Unicode rules, is a simple
3836          * lower/upper, depending */
3837         if (! IN_UNI_8_BIT) {
3838             *tmpbuf = (op_type == OP_LCFIRST)
3839                       ? toLOWER(*s)
3840                       : toUPPER(*s);
3841         }
3842         else if (op_type == OP_LCFIRST) {
3843             /* lower case the first letter: no trickiness for any character */
3844             *tmpbuf = toLOWER_LATIN1(*s);
3845         }
3846         else {
3847             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3848              * non-turkic UTF-8, which we treat as not in locale), and cased
3849              * latin1 */
3850             UV title_ord;
3851 #ifdef USE_LOCALE_CTYPE
3852       do_uni_rules:
3853 #endif
3854
3855             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3856             if (tculen > 1) {
3857                 assert(tculen == 2);
3858
3859                 /* If the result is an upper Latin1-range character, it can
3860                  * still be represented in one byte, which is its ordinal */
3861                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3862                     *tmpbuf = (U8) title_ord;
3863                     tculen = 1;
3864                 }
3865                 else {
3866                     /* Otherwise it became more than one ASCII character (in
3867                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3868                      * beyond Latin1, so the number of bytes changed, so can't
3869                      * replace just the first character in place. */
3870                     inplace = FALSE;
3871
3872                     /* If the result won't fit in a byte, the entire result
3873                      * will have to be in UTF-8.  Allocate enough space for the
3874                      * expanded first byte, and if UTF-8, the rest of the input
3875                      * string, some or all of which may also expand to two
3876                      * bytes, plus the terminating NUL. */
3877                     if (title_ord > 255) {
3878                         doing_utf8 = TRUE;
3879                         convert_source_to_utf8 = TRUE;
3880                         need = slen
3881                             + variant_under_utf8_count(s, s + slen)
3882                             + 1;
3883
3884                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3885                          * characters whose title case is above 255 is
3886                          * 2. */
3887                         ulen = 2;
3888                     }
3889                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3890                         need = slen + 1 + 1;
3891                     }
3892                 }
3893             }
3894         } /* End of use Unicode (Latin1) semantics */
3895     } /* End of changing the case of the first character */
3896
3897     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3898      * generate the result */
3899     if (inplace) {
3900
3901         /* We can convert in place.  This means we change just the first
3902          * character without disturbing the rest; no need to grow */
3903         dest = source;
3904         s = d = (U8*)SvPV_force_nomg(source, slen);
3905     } else {
3906         dTARGET;
3907
3908         dest = TARG;
3909
3910         /* Here, we can't convert in place; we earlier calculated how much
3911          * space we will need, so grow to accommodate that */
3912         SvUPGRADE(dest, SVt_PV);
3913         d = (U8*)SvGROW(dest, need);
3914         (void)SvPOK_only(dest);
3915
3916         SETs(dest);
3917     }
3918
3919     if (doing_utf8) {
3920         if (! inplace) {
3921             if (! convert_source_to_utf8) {
3922
3923                 /* Here  both source and dest are in UTF-8, but have to create
3924                  * the entire output.  We initialize the result to be the
3925                  * title/lower cased first character, and then append the rest
3926                  * of the string. */
3927                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3928                 if (slen > ulen) {
3929
3930                     /* But this boolean being set means we are in a turkic
3931                      * locale, and there is a DOT character that needs to be
3932                      * removed, and it isn't immediately after the current
3933                      * character.  Keep concatenating characters to the output
3934                      * one at a time, until we find the DOT, which we simply
3935                      * skip */
3936                     if (UNLIKELY(remove_dot_above)) {
3937                         do {
3938                             Size_t this_len = UTF8SKIP(s + ulen);
3939
3940                             sv_catpvn(dest, (char*)(s + ulen), this_len);
3941
3942                             ulen += this_len;
3943                             if (memBEGINs(s + ulen, s + slen, COMBINING_DOT_ABOVE_UTF8)) {
3944                                 ulen += 2;
3945                                 break;
3946                             }
3947                         } while (s + ulen < s + slen);
3948                     }
3949
3950                     /* The rest of the string can be concatenated unchanged,
3951                      * all at once */
3952                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3953                 }
3954             }
3955             else {
3956                 const U8 *const send = s + slen;
3957
3958                 /* Here the dest needs to be in UTF-8, but the source isn't,
3959                  * except we earlier UTF-8'd the first character of the source
3960                  * into tmpbuf.  First put that into dest, and then append the
3961                  * rest of the source, converting it to UTF-8 as we go. */
3962
3963                 /* Assert tculen is 2 here because the only characters that
3964                  * get to this part of the code have 2-byte UTF-8 equivalents */
3965                 assert(tculen == 2);
3966                 *d++ = *tmpbuf;
3967                 *d++ = *(tmpbuf + 1);
3968                 s++;    /* We have just processed the 1st char */
3969
3970                 while (s < send) {
3971                     append_utf8_from_native_byte(*s, &d);
3972                     s++;
3973                 }
3974
3975                 *d = '\0';
3976                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3977             }
3978             SvUTF8_on(dest);
3979         }
3980         else {   /* in-place UTF-8.  Just overwrite the first character */
3981             Copy(tmpbuf, d, tculen, U8);
3982             SvCUR_set(dest, need - 1);
3983         }
3984
3985     }
3986     else {  /* Neither source nor dest are, nor need to be UTF-8 */
3987         if (slen) {
3988             if (inplace) {  /* in-place, only need to change the 1st char */
3989                 *d = *tmpbuf;
3990             }
3991             else {      /* Not in-place */
3992
3993                 /* Copy the case-changed character(s) from tmpbuf */
3994                 Copy(tmpbuf, d, tculen, U8);
3995                 d += tculen - 1; /* Code below expects d to point to final
3996                                   * character stored */
3997             }
3998         }
3999         else {  /* empty source */
4000             /* See bug #39028: Don't taint if empty  */
4001             *d = *s;
4002         }
4003
4004         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4005          * the destination to retain that flag */
4006         if (DO_UTF8(source))
4007             SvUTF8_on(dest);
4008
4009         if (!inplace) { /* Finish the rest of the string, unchanged */
4010             /* This will copy the trailing NUL  */
4011             Copy(s + 1, d + 1, slen, U8);
4012             SvCUR_set(dest, need - 1);
4013         }
4014     }
4015 #ifdef USE_LOCALE_CTYPE
4016     if (IN_LC_RUNTIME(LC_CTYPE)) {
4017         TAINT;
4018         SvTAINTED_on(dest);
4019     }
4020 #endif
4021     if (dest != source && SvTAINTED(source))
4022         SvTAINT(dest);
4023     SvSETMAGIC(dest);
4024     return NORMAL;
4025 }
4026
4027 PP(pp_uc)
4028 {
4029     dVAR;
4030     dSP;
4031     SV *source = TOPs;
4032     STRLEN len;
4033     STRLEN min;
4034     SV *dest;
4035     const U8 *s;
4036     U8 *d;
4037
4038     SvGETMAGIC(source);
4039
4040     if (   SvPADTMP(source)
4041         && !SvREADONLY(source) && SvPOK(source)
4042         && !DO_UTF8(source)
4043         && (
4044 #ifdef USE_LOCALE_CTYPE
4045             (IN_LC_RUNTIME(LC_CTYPE))
4046             ? ! IN_UTF8_CTYPE_LOCALE
4047             :
4048 #endif
4049               ! IN_UNI_8_BIT))
4050     {
4051
4052         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4053          * make the loop tight, so we overwrite the source with the dest before
4054          * looking at it, and we need to look at the original source
4055          * afterwards.  There would also need to be code added to handle
4056          * switching to not in-place in midstream if we run into characters
4057          * that change the length.  Since being in locale overrides UNI_8_BIT,
4058          * that latter becomes irrelevant in the above test; instead for
4059          * locale, the size can't normally change, except if the locale is a
4060          * UTF-8 one */
4061         dest = source;
4062         s = d = (U8*)SvPV_force_nomg(source, len);
4063         min = len + 1;
4064     } else {
4065         dTARGET;
4066
4067         dest = TARG;
4068
4069         s = (const U8*)SvPV_nomg_const(source, len);
4070         min = len + 1;
4071
4072         SvUPGRADE(dest, SVt_PV);
4073         d = (U8*)SvGROW(dest, min);
4074         (void)SvPOK_only(dest);
4075
4076         SETs(dest);
4077     }
4078
4079 #ifdef USE_LOCALE_CTYPE
4080
4081     if (IN_LC_RUNTIME(LC_CTYPE)) {
4082         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4083     }
4084
4085 #endif
4086
4087     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4088        to check DO_UTF8 again here.  */
4089
4090     if (DO_UTF8(source)) {
4091         const U8 *const send = s + len;
4092         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4093
4094 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4095 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4096         /* All occurrences of these are to be moved to follow any other marks.
4097          * This is context-dependent.  We may not be passed enough context to
4098          * move the iota subscript beyond all of them, but we do the best we can
4099          * with what we're given.  The result is always better than if we
4100          * hadn't done this.  And, the problem would only arise if we are
4101          * passed a character without all its combining marks, which would be
4102          * the caller's mistake.  The information this is based on comes from a
4103          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4104          * itself) and so can't be checked properly to see if it ever gets
4105          * revised.  But the likelihood of it changing is remote */
4106         bool in_iota_subscript = FALSE;
4107
4108         while (s < send) {
4109             STRLEN u;
4110             STRLEN ulen;
4111             UV uv;
4112             if (UNLIKELY(in_iota_subscript)) {
4113                 UV cp = utf8_to_uvchr_buf(s, send, NULL);
4114
4115                 if (! _invlist_contains_cp(PL_utf8_mark, cp)) {
4116
4117                     /* A non-mark.  Time to output the iota subscript */
4118                     *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4119                     *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4120                     in_iota_subscript = FALSE;
4121                 }
4122             }
4123
4124             /* Then handle the current character.  Get the changed case value
4125              * and copy it to the output buffer */
4126
4127             u = UTF8SKIP(s);
4128 #ifdef USE_LOCALE_CTYPE
4129             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4130 #else
4131             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4132 #endif
4133             if (uv == GREEK_CAPITAL_LETTER_IOTA
4134                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4135             {
4136                 in_iota_subscript = TRUE;
4137             }
4138             else {
4139                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4140                     /* If the eventually required minimum size outgrows the
4141                      * available space, we need to grow. */
4142                     const UV o = d - (U8*)SvPVX_const(dest);
4143
4144                     /* If someone uppercases one million U+03B0s we SvGROW()
4145                      * one million times.  Or we could try guessing how much to
4146                      * allocate without allocating too much.  But we can't
4147                      * really guess without examining the rest of the string.
4148                      * Such is life.  See corresponding comment in lc code for
4149                      * another option */
4150                     d = o + (U8*) SvGROW(dest, min);
4151                 }
4152                 Copy(tmpbuf, d, ulen, U8);
4153                 d += ulen;
4154             }
4155             s += u;
4156         }
4157         if (in_iota_subscript) {
4158             *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4159             *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4160         }
4161         SvUTF8_on(dest);
4162         *d = '\0';
4163
4164         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4165     }
4166     else {      /* Not UTF-8 */
4167         if (len) {
4168             const U8 *const send = s + len;
4169
4170             /* Use locale casing if in locale; regular style if not treating
4171              * latin1 as having case; otherwise the latin1 casing.  Do the
4172              * whole thing in a tight loop, for speed, */
4173 #ifdef USE_LOCALE_CTYPE
4174             if (IN_LC_RUNTIME(LC_CTYPE)) {
4175                 if (IN_UTF8_CTYPE_LOCALE) {
4176                     goto do_uni_rules;
4177                 }
4178                 for (; s < send; d++, s++)
4179                     *d = (U8) toUPPER_LC(*s);
4180             }
4181             else
4182 #endif
4183                  if (! IN_UNI_8_BIT) {
4184                 for (; s < send; d++, s++) {
4185                     *d = toUPPER(*s);
4186                 }
4187             }
4188             else {
4189 #ifdef USE_LOCALE_CTYPE
4190           do_uni_rules:
4191 #endif
4192                 for (; s < send; d++, s++) {
4193                     Size_t extra;
4194
4195                     *d = toUPPER_LATIN1_MOD(*s);
4196                     if (   LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)
4197
4198 #ifdef USE_LOCALE_CTYPE
4199
4200                         && (LIKELY(   ! PL_in_utf8_turkic_locale
4201                                    || ! IN_LC_RUNTIME(LC_CTYPE))
4202                                    || *s != 'i')
4203 #endif
4204
4205                     ) {
4206                         continue;
4207                     }
4208
4209                     /* The mainstream case is the tight loop above.  To avoid
4210                      * extra tests in that, all three characters that always
4211                      * require special handling are mapped by the MOD to the
4212                      * one tested just above.  Use the source to distinguish
4213                      * between those cases */
4214
4215 #if    UNICODE_MAJOR_VERSION > 2                                        \
4216    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4217                                   && UNICODE_DOT_DOT_VERSION >= 8)
4218                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4219
4220                         /* uc() of this requires 2 characters, but they are
4221                          * ASCII.  If not enough room, grow the string */
4222                         if (SvLEN(dest) < ++min) {
4223                             const UV o = d - (U8*)SvPVX_const(dest);
4224                             d = o + (U8*) SvGROW(dest, min);
4225                         }
4226                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4227                         continue;   /* Back to the tight loop; still in ASCII */
4228                     }
4229 #endif
4230
4231                     /* The other special handling characters have their
4232                      * upper cases outside the latin1 range, hence need to be
4233                      * in UTF-8, so the whole result needs to be in UTF-8.
4234                      *
4235                      * So, here we are somewhere in the middle of processing a
4236                      * non-UTF-8 string, and realize that we will have to
4237                      * convert the whole thing to UTF-8.  What to do?  There
4238                      * are several possibilities.  The simplest to code is to
4239                      * convert what we have so far, set a flag, and continue on
4240                      * in the loop.  The flag would be tested each time through
4241                      * the loop, and if set, the next character would be
4242                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4243                      * to slow down the mainstream case at all for this fairly
4244                      * rare case, so I didn't want to add a test that didn't
4245                      * absolutely have to be there in the loop, besides the
4246                      * possibility that it would get too complicated for
4247                      * optimizers to deal with.  Another possibility is to just
4248                      * give up, convert the source to UTF-8, and restart the
4249                      * function that way.  Another possibility is to convert
4250                      * both what has already been processed and what is yet to
4251                      * come separately to UTF-8, then jump into the loop that
4252                      * handles UTF-8.  But the most efficient time-wise of the
4253                      * ones I could think of is what follows, and turned out to
4254                      * not require much extra code.
4255                      *
4256                      * First, calculate the extra space needed for the
4257                      * remainder of the source needing to be in UTF-8.  Except
4258                      * for the 'i' in Turkic locales, in UTF-8 strings, the
4259                      * uppercase of a character below 256 occupies the same
4260                      * number of bytes as the original.  Therefore, the space
4261                      * needed is the that number plus the number of characters
4262                      * that become two bytes when converted to UTF-8, plus, in
4263                      * turkish locales, the number of 'i's. */
4264
4265                     extra = send - s + variant_under_utf8_count(s, send);
4266
4267 #ifdef USE_LOCALE_CTYPE
4268
4269                     if (UNLIKELY(*s == 'i')) {  /* We wouldn't get an 'i' here
4270                                                    unless are in a Turkic
4271                                                    locale */
4272                         const U8 * s_peek = s;
4273
4274                         do {
4275                             extra++;
4276
4277                             s_peek = (U8 *) memchr(s_peek + 1, 'i',
4278                                                    send - (s_peek + 1));
4279                         } while (s_peek != NULL);
4280                     }
4281 #endif
4282
4283                     /* Convert what we have so far into UTF-8, telling the
4284                      * function that we know it should be converted, and to
4285                      * allow extra space for what we haven't processed yet.
4286                      *
4287                      * This may cause the string pointer to move, so need to
4288                      * save and re-find it. */
4289
4290                     len = d - (U8*)SvPVX_const(dest);
4291                     SvCUR_set(dest, len);
4292                     len = sv_utf8_upgrade_flags_grow(dest,
4293                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4294                                                 extra
4295                                               + 1 /* trailing NUL */ );
4296                     d = (U8*)SvPVX(dest) + len;
4297
4298                     /* Now process the remainder of the source, simultaneously
4299                      * converting to upper and UTF-8.
4300                      *
4301                      * To avoid extra tests in the loop body, and since the
4302                      * loop is so simple, split out the rare Turkic case into
4303                      * its own loop */
4304
4305 #ifdef USE_LOCALE_CTYPE
4306                     if (   UNLIKELY(PL_in_utf8_turkic_locale)
4307                         && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE)))
4308                     {
4309                         for (; s < send; s++) {
4310                             if (*s == 'i') {
4311                                 *d++ = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4312                                 *d++ = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4313                             }
4314                             else {
4315                                 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4316                                 d += len;
4317                             }
4318                         }
4319                     }
4320                     else
4321 #endif
4322                         for (; s < send; s++) {
4323                             (void) _to_upper_title_latin1(*s, d, &len, 'S');
4324                             d += len;
4325                         }
4326
4327                     /* Here have processed the whole source; no need to
4328                      * continue with the outer loop.  Each character has been
4329                      * converted to upper case and converted to UTF-8. */
4330                     break;
4331                 } /* End of processing all latin1-style chars */
4332             } /* End of processing all chars */
4333         } /* End of source is not empty */
4334
4335         if (source != dest) {
4336             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4337             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4338         }
4339     } /* End of isn't utf8 */
4340 #ifdef USE_LOCALE_CTYPE
4341     if (IN_LC_RUNTIME(LC_CTYPE)) {
4342         TAINT;
4343         SvTAINTED_on(dest);
4344     }
4345 #endif
4346     if (dest != source && SvTAINTED(source))
4347         SvTAINT(dest);
4348     SvSETMAGIC(dest);
4349     return NORMAL;
4350 }
4351
4352 PP(pp_lc)
4353 {
4354     dSP;
4355     SV *source = TOPs;
4356     STRLEN len;
4357     STRLEN min;
4358     SV *dest;
4359     const U8 *s;
4360     U8 *d;
4361     bool has_turkic_I = FALSE;
4362
4363     SvGETMAGIC(source);
4364
4365     if (   SvPADTMP(source)
4366         && !SvREADONLY(source) && SvPOK(source)
4367         && !DO_UTF8(source)
4368
4369 #ifdef USE_LOCALE_CTYPE
4370
4371         && (   LIKELY(! IN_LC_RUNTIME(LC_CTYPE))
4372             || LIKELY(! PL_in_utf8_turkic_locale))
4373
4374 #endif
4375
4376     ) {
4377
4378         /* We can convert in place, as, outside of Turkic UTF-8 locales,
4379          * lowercasing anything in the latin1 range (or else DO_UTF8 would have
4380          * been on) doesn't lengthen it. */
4381         dest = source;
4382         s = d = (U8*)SvPV_force_nomg(source, len);
4383         min = len + 1;
4384     } else {
4385         dTARGET;
4386
4387         dest = TARG;
4388
4389         s = (const U8*)SvPV_nomg_const(source, len);
4390         min = len + 1;
4391
4392         SvUPGRADE(dest, SVt_PV);
4393         d = (U8*)SvGROW(dest, min);
4394         (void)SvPOK_only(dest);
4395
4396         SETs(dest);
4397     }
4398
4399 #ifdef USE_LOCALE_CTYPE
4400
4401     if (IN_LC_RUNTIME(LC_CTYPE)) {
4402         const U8 * next_I;
4403
4404         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4405
4406         /* Lowercasing in a Turkic locale can cause non-UTF-8 to need to become
4407          * UTF-8 for the single case of the character 'I' */
4408         if (     UNLIKELY(PL_in_utf8_turkic_locale)
4409             && ! DO_UTF8(source)
4410             &&   (next_I = (U8 *) memchr(s, 'I', len)))
4411         {
4412             Size_t I_count = 0;
4413             const U8 *const send = s + len;
4414
4415             do {
4416                 I_count++;
4417
4418                 next_I = (U8 *) memchr(next_I + 1, 'I',
4419                                         send - (next_I + 1));
4420             } while (next_I != NULL);
4421
4422             /* Except for the 'I', in UTF-8 strings, the lower case of a
4423              * character below 256 occupies the same number of bytes as the
4424              * original.  Therefore, the space needed is the original length
4425              * plus I_count plus the number of characters that become two bytes
4426              * when converted to UTF-8 */
4427             sv_utf8_upgrade_flags_grow(dest, 0, len
4428                                               + I_count
4429                                               + variant_under_utf8_count(s, send)
4430                                               + 1 /* Trailing NUL */ );
4431             d = (U8*)SvPVX(dest);
4432             has_turkic_I = TRUE;
4433         }
4434     }
4435
4436 #endif
4437
4438     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4439        to check DO_UTF8 again here.  */
4440
4441     if (DO_UTF8(source)) {
4442         const U8 *const send = s + len;
4443         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4444         bool remove_dot_above = FALSE;
4445
4446         while (s < send) {
4447             const STRLEN u = UTF8SKIP(s);
4448             STRLEN ulen;
4449
4450 #ifdef USE_LOCALE_CTYPE
4451
4452             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4453
4454             /* If we are in a Turkic locale, we have to do more work.  As noted
4455              * in the comments for lcfirst, there is a special case if a 'I'
4456              * is in a grapheme with COMBINING DOT ABOVE UTF8.  It turns into a
4457              * 'i', and the DOT must be removed.  We check for that situation,
4458              * and set a flag if the DOT is there.  Then each time through the
4459              * loop, we have to see if we need to remove the next DOT above,
4460              * and if so, do it.  We know that there is a DOT because
4461              * _toLOWER_utf8_flags() wouldn't have returned 'i' unless there
4462              * was one in a proper position. */
4463             if (   UNLIKELY(PL_in_utf8_turkic_locale)
4464                 && IN_LC_RUNTIME(LC_CTYPE))
4465             {
4466                 if (   UNLIKELY(remove_dot_above)
4467                     && memBEGINs(tmpbuf, sizeof(tmpbuf), COMBINING_DOT_ABOVE_UTF8))
4468                 {
4469                     s += u;
4470                     remove_dot_above = FALSE;
4471                     continue;
4472                 }
4473                 else if (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')) {
4474                     remove_dot_above = TRUE;
4475                 }
4476             }
4477 #else
4478             PERL_UNUSED_VAR(remove_dot_above);
4479
4480             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4481 #endif
4482
4483             /* Here is where we would do context-sensitive actions for the
4484              * Greek final sigma.  See the commit message for 86510fb15 for why
4485              * there isn't any */
4486
4487             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4488
4489                 /* If the eventually required minimum size outgrows the
4490                  * available space, we need to grow. */
4491                 const UV o = d - (U8*)SvPVX_const(dest);
4492
4493                 /* If someone lowercases one million U+0130s we SvGROW() one
4494                  * million times.  Or we could try guessing how much to
4495                  * allocate without allocating too much.  Such is life.
4496                  * Another option would be to grow an extra byte or two more
4497                  * each time we need to grow, which would cut down the million
4498                  * to 500K, with little waste */
4499                 d = o + (U8*) SvGROW(dest, min);
4500             }
4501
4502             /* Copy the newly lowercased letter to the output buffer we're
4503              * building */
4504             Copy(tmpbuf, d, ulen, U8);
4505             d += ulen;
4506             s += u;
4507         }   /* End of looping through the source string */
4508         SvUTF8_on(dest);
4509         *d = '\0';
4510         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4511     } else {    /* 'source' not utf8 */
4512         if (len) {
4513             const U8 *const send = s + len;
4514
4515             /* Use locale casing if in locale; regular style if not treating
4516              * latin1 as having case; otherwise the latin1 casing.  Do the
4517              * whole thing in a tight loop, for speed, */
4518 #ifdef USE_LOCALE_CTYPE
4519             if (IN_LC_RUNTIME(LC_CTYPE)) {
4520                 if (LIKELY( ! has_turkic_I)) {
4521                     for (; s < send; d++, s++)
4522                         *d = toLOWER_LC(*s);
4523                 }
4524                 else {  /* This is the only case where lc() converts 'dest'
4525                            into UTF-8 from a non-UTF-8 'source' */
4526                     for (; s < send; s++) {
4527                         if (*s == 'I') {
4528                             *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4529                             *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4530                         }
4531                         else {
4532                             append_utf8_from_native_byte(toLOWER_LATIN1(*s), &d);
4533                         }
4534                     }
4535                 }
4536             }
4537             else
4538 #endif
4539             if (! IN_UNI_8_BIT) {
4540                 for (; s < send; d++, s++) {
4541                     *d = toLOWER(*s);
4542                 }
4543             }
4544             else {
4545                 for (; s < send; d++, s++) {
4546                     *d = toLOWER_LATIN1(*s);
4547                 }
4548             }
4549         }
4550         if (source != dest) {
4551             *d = '\0';
4552             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4553         }
4554     }
4555 #ifdef USE_LOCALE_CTYPE
4556     if (IN_LC_RUNTIME(LC_CTYPE)) {
4557         TAINT;
4558         SvTAINTED_on(dest);
4559     }
4560 #endif
4561     if (dest != source && SvTAINTED(source))
4562         SvTAINT(dest);
4563     SvSETMAGIC(dest);
4564     return NORMAL;
4565 }
4566
4567 PP(pp_quotemeta)
4568 {
4569     dSP; dTARGET;
4570     SV * const sv = TOPs;
4571     STRLEN len;
4572     const char *s = SvPV_const(sv,len);
4573
4574     SvUTF8_off(TARG);                           /* decontaminate */
4575     if (len) {
4576         char *d;
4577         SvUPGRADE(TARG, SVt_PV);
4578         SvGROW(TARG, (len * 2) + 1);
4579         d = SvPVX(TARG);
4580         if (DO_UTF8(sv)) {
4581             while (len) {
4582                 STRLEN ulen = UTF8SKIP(s);
4583                 bool to_quote = FALSE;
4584
4585                 if (UTF8_IS_INVARIANT(*s)) {
4586                     if (_isQUOTEMETA(*s)) {
4587                         to_quote = TRUE;
4588                     }
4589                 }
4590                 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4591                     if (
4592 #ifdef USE_LOCALE_CTYPE
4593                     /* In locale, we quote all non-ASCII Latin1 chars.
4594                      * Otherwise use the quoting rules */
4595
4596                     IN_LC_RUNTIME(LC_CTYPE)
4597                         ||
4598 #endif
4599                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4600                     {
4601                         to_quote = TRUE;
4602                     }
4603                 }
4604                 else if (is_QUOTEMETA_high(s)) {
4605                     to_quote = TRUE;
4606                 }
4607
4608                 if (to_quote) {
4609                     *d++ = '\\';
4610                 }
4611                 if (ulen > len)
4612                     ulen = len;
4613                 len -= ulen;
4614                 while (ulen--)
4615                     *d++ = *s++;
4616             }
4617             SvUTF8_on(TARG);
4618         }
4619         else if (IN_UNI_8_BIT) {
4620             while (len--) {
4621                 if (_isQUOTEMETA(*s))
4622                     *d++ = '\\';
4623                 *d++ = *s++;
4624             }
4625         }
4626         else {
4627             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4628              * including everything above ASCII */
4629             while (len--) {
4630                 if (!isWORDCHAR_A(*s))
4631                     *d++ = '\\';
4632                 *d++ = *s++;
4633             }
4634         }
4635         *d = '\0';
4636         SvCUR_set(TARG, d - SvPVX_const(TARG));
4637         (void)SvPOK_only_UTF8(TARG);
4638     }
4639     else
4640         sv_setpvn(TARG, s, len);
4641     SETTARG;
4642     return NORMAL;
4643 }
4644
4645 PP(pp_fc)
4646 {
4647     dTARGET;