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