Deparse.pm: bump version
[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 = (aiv == IV_MIN) ? (UV)aiv : (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 = (biv == IV_MIN) ? (UV)biv : (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 = (biv == IV_MIN) ? (UV)biv : (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 = (aiv == IV_MIN) ? (UV)aiv : (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                 const UV result = left / right;
1507                 if (result * right == left) {
1508                     SP--; /* result is valid */
1509                     if (left_non_neg == right_non_neg) {
1510                         /* signs identical, result is positive.  */
1511                         SETu( result );
1512                         RETURN;
1513                     }
1514                     /* 2s complement assumption */
1515                     if (result <= (UV)IV_MIN)
1516                         SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1517                     else {
1518                         /* It's exact but too negative for IV. */
1519                         SETn( -(NV)result );
1520                     }
1521                     RETURN;
1522                 } /* tried integer divide but it was not an integer result */
1523             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1524     } /* one operand wasn't SvIOK */
1525 #endif /* PERL_TRY_UV_DIVIDE */
1526     {
1527         NV right = SvNV_nomg(svr);
1528         NV left  = SvNV_nomg(svl);
1529         (void)POPs;(void)POPs;
1530 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1531         if (! Perl_isnan(right) && right == 0.0)
1532 #else
1533         if (right == 0.0)
1534 #endif
1535             DIE(aTHX_ "Illegal division by zero");
1536         PUSHn( left / right );
1537         RETURN;
1538     }
1539 }
1540
1541 PP(pp_modulo)
1542 {
1543     dSP; dATARGET;
1544     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1545     {
1546         UV left  = 0;
1547         UV right = 0;
1548         bool left_neg = FALSE;
1549         bool right_neg = FALSE;
1550         bool use_double = FALSE;
1551         bool dright_valid = FALSE;
1552         NV dright = 0.0;
1553         NV dleft  = 0.0;
1554         SV * const svr = TOPs;
1555         SV * const svl = TOPm1s;
1556         if (SvIV_please_nomg(svr)) {
1557             right_neg = !SvUOK(svr);
1558             if (!right_neg) {
1559                 right = SvUVX(svr);
1560             } else {
1561                 const IV biv = SvIVX(svr);
1562                 if (biv >= 0) {
1563                     right = biv;
1564                     right_neg = FALSE; /* effectively it's a UV now */
1565                 } else {
1566                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1567                 }
1568             }
1569         }
1570         else {
1571             dright = SvNV_nomg(svr);
1572             right_neg = dright < 0;
1573             if (right_neg)
1574                 dright = -dright;
1575             if (dright < UV_MAX_P1) {
1576                 right = U_V(dright);
1577                 dright_valid = TRUE; /* In case we need to use double below.  */
1578             } else {
1579                 use_double = TRUE;
1580             }
1581         }
1582
1583         /* At this point use_double is only true if right is out of range for
1584            a UV.  In range NV has been rounded down to nearest UV and
1585            use_double false.  */
1586         if (!use_double && SvIV_please_nomg(svl)) {
1587                 left_neg = !SvUOK(svl);
1588                 if (!left_neg) {
1589                     left = SvUVX(svl);
1590                 } else {
1591                     const IV aiv = SvIVX(svl);
1592                     if (aiv >= 0) {
1593                         left = aiv;
1594                         left_neg = FALSE; /* effectively it's a UV now */
1595                     } else {
1596                         left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1597                     }
1598                 }
1599         }
1600         else {
1601             dleft = SvNV_nomg(svl);
1602             left_neg = dleft < 0;
1603             if (left_neg)
1604                 dleft = -dleft;
1605
1606             /* This should be exactly the 5.6 behaviour - if left and right are
1607                both in range for UV then use U_V() rather than floor.  */
1608             if (!use_double) {
1609                 if (dleft < UV_MAX_P1) {
1610                     /* right was in range, so is dleft, so use UVs not double.
1611                      */
1612                     left = U_V(dleft);
1613                 }
1614                 /* left is out of range for UV, right was in range, so promote
1615                    right (back) to double.  */
1616                 else {
1617                     /* The +0.5 is used in 5.6 even though it is not strictly
1618                        consistent with the implicit +0 floor in the U_V()
1619                        inside the #if 1. */
1620                     dleft = Perl_floor(dleft + 0.5);
1621                     use_double = TRUE;
1622                     if (dright_valid)
1623                         dright = Perl_floor(dright + 0.5);
1624                     else
1625                         dright = right;
1626                 }
1627             }
1628         }
1629         sp -= 2;
1630         if (use_double) {
1631             NV dans;
1632
1633             if (!dright)
1634                 DIE(aTHX_ "Illegal modulus zero");
1635
1636             dans = Perl_fmod(dleft, dright);
1637             if ((left_neg != right_neg) && dans)
1638                 dans = dright - dans;
1639             if (right_neg)
1640                 dans = -dans;
1641             sv_setnv(TARG, dans);
1642         }
1643         else {
1644             UV ans;
1645
1646             if (!right)
1647                 DIE(aTHX_ "Illegal modulus zero");
1648
1649             ans = left % right;
1650             if ((left_neg != right_neg) && ans)
1651                 ans = right - ans;
1652             if (right_neg) {
1653                 /* XXX may warn: unary minus operator applied to unsigned type */
1654                 /* could change -foo to be (~foo)+1 instead     */
1655                 if (ans <= ~((UV)IV_MAX)+1)
1656                     sv_setiv(TARG, ~ans+1);
1657                 else
1658                     sv_setnv(TARG, -(NV)ans);
1659             }
1660             else
1661                 sv_setuv(TARG, ans);
1662         }
1663         PUSHTARG;
1664         RETURN;
1665     }
1666 }
1667
1668 PP(pp_repeat)
1669 {
1670     dSP; dATARGET;
1671     IV count;
1672     SV *sv;
1673     bool infnan = FALSE;
1674     const U8 gimme = GIMME_V;
1675
1676     if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1677         /* TODO: think of some way of doing list-repeat overloading ??? */
1678         sv = POPs;
1679         SvGETMAGIC(sv);
1680     }
1681     else {
1682         if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1683             /* The parser saw this as a list repeat, and there
1684                are probably several items on the stack. But we're
1685                in scalar/void context, and there's no pp_list to save us
1686                now. So drop the rest of the items -- robin@kitsite.com
1687              */
1688             dMARK;
1689             if (MARK + 1 < SP) {
1690                 MARK[1] = TOPm1s;
1691                 MARK[2] = TOPs;
1692             }
1693             else {
1694                 dTOPss;
1695                 ASSUME(MARK + 1 == SP);
1696                 XPUSHs(sv);
1697                 MARK[1] = &PL_sv_undef;
1698             }
1699             SP = MARK + 2;
1700         }
1701         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1702         sv = POPs;
1703     }
1704
1705     if (SvIOKp(sv)) {
1706          if (SvUOK(sv)) {
1707               const UV uv = SvUV_nomg(sv);
1708               if (uv > IV_MAX)
1709                    count = IV_MAX; /* The best we can do? */
1710               else
1711                    count = uv;
1712          } else {
1713               count = SvIV_nomg(sv);
1714          }
1715     }
1716     else if (SvNOKp(sv)) {
1717         const NV nv = SvNV_nomg(sv);
1718         infnan = Perl_isinfnan(nv);
1719         if (UNLIKELY(infnan)) {
1720             count = 0;
1721         } else {
1722             if (nv < 0.0)
1723                 count = -1;   /* An arbitrary negative integer */
1724             else
1725                 count = (IV)nv;
1726         }
1727     }
1728     else
1729         count = SvIV_nomg(sv);
1730
1731     if (infnan) {
1732         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1733                        "Non-finite repeat count does nothing");
1734     } else if (count < 0) {
1735         count = 0;
1736         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1737                        "Negative repeat count does nothing");
1738     }
1739
1740     if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1741         dMARK;
1742         const SSize_t items = SP - MARK;
1743         const U8 mod = PL_op->op_flags & OPf_MOD;
1744
1745         if (count > 1) {
1746             SSize_t max;
1747
1748             if (  items > SSize_t_MAX / count   /* max would overflow */
1749                                                 /* repeatcpy would overflow */
1750                || items > I32_MAX / (I32)sizeof(SV *)
1751             )
1752                Perl_croak(aTHX_ "%s","Out of memory during list extend");
1753             max = items * count;
1754             MEXTEND(MARK, max);
1755
1756             while (SP > MARK) {
1757                 if (*SP) {
1758                    if (mod && SvPADTMP(*SP)) {
1759                        *SP = sv_mortalcopy(*SP);
1760                    }
1761                    SvTEMP_off((*SP));
1762                 }
1763                 SP--;
1764             }
1765             MARK++;
1766             repeatcpy((char*)(MARK + items), (char*)MARK,
1767                 items * sizeof(const SV *), count - 1);
1768             SP += max;
1769         }
1770         else if (count <= 0)
1771             SP = MARK;
1772     }
1773     else {      /* Note: mark already snarfed by pp_list */
1774         SV * const tmpstr = POPs;
1775         STRLEN len;
1776         bool isutf;
1777
1778         if (TARG != tmpstr)
1779             sv_setsv_nomg(TARG, tmpstr);
1780         SvPV_force_nomg(TARG, len);
1781         isutf = DO_UTF8(TARG);
1782         if (count != 1) {
1783             if (count < 1)
1784                 SvCUR_set(TARG, 0);
1785             else {
1786                 STRLEN max;
1787
1788                 if (   len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1789                     || len > (U32)I32_MAX  /* repeatcpy would overflow */
1790                 )
1791                      Perl_croak(aTHX_ "%s",
1792                                         "Out of memory during string extend");
1793                 max = (UV)count * len + 1;
1794                 SvGROW(TARG, max);
1795
1796                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1797                 SvCUR_set(TARG, SvCUR(TARG) * count);
1798             }
1799             *SvEND(TARG) = '\0';
1800         }
1801         if (isutf)
1802             (void)SvPOK_only_UTF8(TARG);
1803         else
1804             (void)SvPOK_only(TARG);
1805
1806         PUSHTARG;
1807     }
1808     RETURN;
1809 }
1810
1811 PP(pp_subtract)
1812 {
1813     dSP; dATARGET; bool useleft; SV *svl, *svr;
1814     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1815     svr = TOPs;
1816     svl = TOPm1s;
1817
1818 #ifdef PERL_PRESERVE_IVUV
1819
1820     /* special-case some simple common cases */
1821     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1822         IV il, ir;
1823         U32 flags = (svl->sv_flags & svr->sv_flags);
1824         if (flags & SVf_IOK) {
1825             /* both args are simple IVs */
1826             UV topl, topr;
1827             il = SvIVX(svl);
1828             ir = SvIVX(svr);
1829           do_iv:
1830             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1831             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1832
1833             /* if both are in a range that can't under/overflow, do a
1834              * simple integer subtract: if the top of both numbers
1835              * are 00  or 11, then it's safe */
1836             if (!( ((topl+1) | (topr+1)) & 2)) {
1837                 SP--;
1838                 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1839                 SETs(TARG);
1840                 RETURN;
1841             }
1842             goto generic;
1843         }
1844         else if (flags & SVf_NOK) {
1845             /* both args are NVs */
1846             NV nl = SvNVX(svl);
1847             NV nr = SvNVX(svr);
1848
1849             if (
1850 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1851                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1852                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1853 #else
1854                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1855 #endif
1856                 )
1857                 /* nothing was lost by converting to IVs */
1858                 goto do_iv;
1859             SP--;
1860             TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1861             SETs(TARG);
1862             RETURN;
1863         }
1864     }
1865
1866   generic:
1867
1868     useleft = USE_LEFT(svl);
1869     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1870        "bad things" happen if you rely on signed integers wrapping.  */
1871     if (SvIV_please_nomg(svr)) {
1872         /* Unless the left argument is integer in range we are going to have to
1873            use NV maths. Hence only attempt to coerce the right argument if
1874            we know the left is integer.  */
1875         UV auv = 0;
1876         bool auvok = FALSE;
1877         bool a_valid = 0;
1878
1879         if (!useleft) {
1880             auv = 0;
1881             a_valid = auvok = 1;
1882             /* left operand is undef, treat as zero.  */
1883         } else {
1884             /* Left operand is defined, so is it IV? */
1885             if (SvIV_please_nomg(svl)) {
1886                 if ((auvok = SvUOK(svl)))
1887                     auv = SvUVX(svl);
1888                 else {
1889                     const IV aiv = SvIVX(svl);
1890                     if (aiv >= 0) {
1891                         auv = aiv;
1892                         auvok = 1;      /* Now acting as a sign flag.  */
1893                     } else { /* 2s complement assumption for IV_MIN */
1894                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
1895                     }
1896                 }
1897                 a_valid = 1;
1898             }
1899         }
1900         if (a_valid) {
1901             bool result_good = 0;
1902             UV result;
1903             UV buv;
1904             bool buvok = SvUOK(svr);
1905         
1906             if (buvok)
1907                 buv = SvUVX(svr);
1908             else {
1909                 const IV biv = SvIVX(svr);
1910                 if (biv >= 0) {
1911                     buv = biv;
1912                     buvok = 1;
1913                 } else
1914                     buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
1915             }
1916             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1917                else "IV" now, independent of how it came in.
1918                if a, b represents positive, A, B negative, a maps to -A etc
1919                a - b =>  (a - b)
1920                A - b => -(a + b)
1921                a - B =>  (a + b)
1922                A - B => -(a - b)
1923                all UV maths. negate result if A negative.
1924                subtract if signs same, add if signs differ. */
1925
1926             if (auvok ^ buvok) {
1927                 /* Signs differ.  */
1928                 result = auv + buv;
1929                 if (result >= auv)
1930                     result_good = 1;
1931             } else {
1932                 /* Signs same */
1933                 if (auv >= buv) {
1934                     result = auv - buv;
1935                     /* Must get smaller */
1936                     if (result <= auv)
1937                         result_good = 1;
1938                 } else {
1939                     result = buv - auv;
1940                     if (result <= buv) {
1941                         /* result really should be -(auv-buv). as its negation
1942                            of true value, need to swap our result flag  */
1943                         auvok = !auvok;
1944                         result_good = 1;
1945                     }
1946                 }
1947             }
1948             if (result_good) {
1949                 SP--;
1950                 if (auvok)
1951                     SETu( result );
1952                 else {
1953                     /* Negate result */
1954                     if (result <= (UV)IV_MIN)
1955                         SETi(result == (UV)IV_MIN
1956                                 ? IV_MIN : -(IV)result);
1957                     else {
1958                         /* result valid, but out of range for IV.  */
1959                         SETn( -(NV)result );
1960                     }
1961                 }
1962                 RETURN;
1963             } /* Overflow, drop through to NVs.  */
1964         }
1965     }
1966 #else
1967     useleft = USE_LEFT(svl);
1968 #endif
1969     {
1970         NV value = SvNV_nomg(svr);
1971         (void)POPs;
1972
1973         if (!useleft) {
1974             /* left operand is undef, treat as zero - value */
1975             SETn(-value);
1976             RETURN;
1977         }
1978         SETn( SvNV_nomg(svl) - value );
1979         RETURN;
1980     }
1981 }
1982
1983 #define IV_BITS (IVSIZE * 8)
1984
1985 static UV S_uv_shift(UV uv, int shift, bool left)
1986 {
1987    if (shift < 0) {
1988        shift = -shift;
1989        left = !left;
1990    }
1991    if (shift >= IV_BITS) {
1992        return 0;
1993    }
1994    return left ? uv << shift : uv >> shift;
1995 }
1996
1997 static IV S_iv_shift(IV iv, int shift, bool left)
1998 {
1999    if (shift < 0) {
2000        shift = -shift;
2001        left = !left;
2002    }
2003    if (shift >= IV_BITS) {
2004        return iv < 0 && !left ? -1 : 0;
2005    }
2006    return left ? iv << shift : iv >> shift;
2007 }
2008
2009 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2010 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2011 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2012 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2013
2014 PP(pp_left_shift)
2015 {
2016     dSP; dATARGET; SV *svl, *svr;
2017     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2018     svr = POPs;
2019     svl = TOPs;
2020     {
2021       const IV shift = SvIV_nomg(svr);
2022       if (PL_op->op_private & HINT_INTEGER) {
2023           SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2024       }
2025       else {
2026           SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2027       }
2028       RETURN;
2029     }
2030 }
2031
2032 PP(pp_right_shift)
2033 {
2034     dSP; dATARGET; SV *svl, *svr;
2035     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2036     svr = POPs;
2037     svl = TOPs;
2038     {
2039       const IV shift = SvIV_nomg(svr);
2040       if (PL_op->op_private & HINT_INTEGER) {
2041           SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2042       }
2043       else {
2044           SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2045       }
2046       RETURN;
2047     }
2048 }
2049
2050 PP(pp_lt)
2051 {
2052     dSP;
2053     SV *left, *right;
2054
2055     tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2056     right = POPs;
2057     left  = TOPs;
2058     SETs(boolSV(
2059         (SvIOK_notUV(left) && SvIOK_notUV(right))
2060         ? (SvIVX(left) < SvIVX(right))
2061         : (do_ncmp(left, right) == -1)
2062     ));
2063     RETURN;
2064 }
2065
2066 PP(pp_gt)
2067 {
2068     dSP;
2069     SV *left, *right;
2070
2071     tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2072     right = POPs;
2073     left  = TOPs;
2074     SETs(boolSV(
2075         (SvIOK_notUV(left) && SvIOK_notUV(right))
2076         ? (SvIVX(left) > SvIVX(right))
2077         : (do_ncmp(left, right) == 1)
2078     ));
2079     RETURN;
2080 }
2081
2082 PP(pp_le)
2083 {
2084     dSP;
2085     SV *left, *right;
2086
2087     tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2088     right = POPs;
2089     left  = TOPs;
2090     SETs(boolSV(
2091         (SvIOK_notUV(left) && SvIOK_notUV(right))
2092         ? (SvIVX(left) <= SvIVX(right))
2093         : (do_ncmp(left, right) <= 0)
2094     ));
2095     RETURN;
2096 }
2097
2098 PP(pp_ge)
2099 {
2100     dSP;
2101     SV *left, *right;
2102
2103     tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2104     right = POPs;
2105     left  = TOPs;
2106     SETs(boolSV(
2107         (SvIOK_notUV(left) && SvIOK_notUV(right))
2108         ? (SvIVX(left) >= SvIVX(right))
2109         : ( (do_ncmp(left, right) & 2) == 0)
2110     ));
2111     RETURN;
2112 }
2113
2114 PP(pp_ne)
2115 {
2116     dSP;
2117     SV *left, *right;
2118
2119     tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2120     right = POPs;
2121     left  = TOPs;
2122     SETs(boolSV(
2123         (SvIOK_notUV(left) && SvIOK_notUV(right))
2124         ? (SvIVX(left) != SvIVX(right))
2125         : (do_ncmp(left, right) != 0)
2126     ));
2127     RETURN;
2128 }
2129
2130 /* compare left and right SVs. Returns:
2131  * -1: <
2132  *  0: ==
2133  *  1: >
2134  *  2: left or right was a NaN
2135  */
2136 I32
2137 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2138 {
2139     PERL_ARGS_ASSERT_DO_NCMP;
2140 #ifdef PERL_PRESERVE_IVUV
2141     /* Fortunately it seems NaN isn't IOK */
2142     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2143             if (!SvUOK(left)) {
2144                 const IV leftiv = SvIVX(left);
2145                 if (!SvUOK(right)) {
2146                     /* ## IV <=> IV ## */
2147                     const IV rightiv = SvIVX(right);
2148                     return (leftiv > rightiv) - (leftiv < rightiv);
2149                 }
2150                 /* ## IV <=> UV ## */
2151                 if (leftiv < 0)
2152                     /* As (b) is a UV, it's >=0, so it must be < */
2153                     return -1;
2154                 {
2155                     const UV rightuv = SvUVX(right);
2156                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2157                 }
2158             }
2159
2160             if (SvUOK(right)) {
2161                 /* ## UV <=> UV ## */
2162                 const UV leftuv = SvUVX(left);
2163                 const UV rightuv = SvUVX(right);
2164                 return (leftuv > rightuv) - (leftuv < rightuv);
2165             }
2166             /* ## UV <=> IV ## */
2167             {
2168                 const IV rightiv = SvIVX(right);
2169                 if (rightiv < 0)
2170                     /* As (a) is a UV, it's >=0, so it cannot be < */
2171                     return 1;
2172                 {
2173                     const UV leftuv = SvUVX(left);
2174                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2175                 }
2176             }
2177             NOT_REACHED; /* NOTREACHED */
2178     }
2179 #endif
2180     {
2181       NV const rnv = SvNV_nomg(right);
2182       NV const lnv = SvNV_nomg(left);
2183
2184 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2185       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2186           return 2;
2187        }
2188       return (lnv > rnv) - (lnv < rnv);
2189 #else
2190       if (lnv < rnv)
2191         return -1;
2192       if (lnv > rnv)
2193         return 1;
2194       if (lnv == rnv)
2195         return 0;
2196       return 2;
2197 #endif
2198     }
2199 }
2200
2201
2202 PP(pp_ncmp)
2203 {
2204     dSP;
2205     SV *left, *right;
2206     I32 value;
2207     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2208     right = POPs;
2209     left  = TOPs;
2210     value = do_ncmp(left, right);
2211     if (value == 2) {
2212         SETs(&PL_sv_undef);
2213     }
2214     else {
2215         dTARGET;
2216         SETi(value);
2217     }
2218     RETURN;
2219 }
2220
2221
2222 /* also used for: pp_sge() pp_sgt() pp_slt() */
2223
2224 PP(pp_sle)
2225 {
2226     dSP;
2227
2228     int amg_type = sle_amg;
2229     int multiplier = 1;
2230     int rhs = 1;
2231
2232     switch (PL_op->op_type) {
2233     case OP_SLT:
2234         amg_type = slt_amg;
2235         /* cmp < 0 */
2236         rhs = 0;
2237         break;
2238     case OP_SGT:
2239         amg_type = sgt_amg;
2240         /* cmp > 0 */
2241         multiplier = -1;
2242         rhs = 0;
2243         break;
2244     case OP_SGE:
2245         amg_type = sge_amg;
2246         /* cmp >= 0 */
2247         multiplier = -1;
2248         break;
2249     }
2250
2251     tryAMAGICbin_MG(amg_type, AMGf_set);
2252     {
2253       dPOPTOPssrl;
2254       const int cmp =
2255 #ifdef USE_LOCALE_COLLATE
2256                       (IN_LC_RUNTIME(LC_COLLATE))
2257                       ? sv_cmp_locale_flags(left, right, 0)
2258                       :
2259 #endif
2260                         sv_cmp_flags(left, right, 0);
2261       SETs(boolSV(cmp * multiplier < rhs));
2262       RETURN;
2263     }
2264 }
2265
2266 PP(pp_seq)
2267 {
2268     dSP;
2269     tryAMAGICbin_MG(seq_amg, AMGf_set);
2270     {
2271       dPOPTOPssrl;
2272       SETs(boolSV(sv_eq_flags(left, right, 0)));
2273       RETURN;
2274     }
2275 }
2276
2277 PP(pp_sne)
2278 {
2279     dSP;
2280     tryAMAGICbin_MG(sne_amg, AMGf_set);
2281     {
2282       dPOPTOPssrl;
2283       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2284       RETURN;
2285     }
2286 }
2287
2288 PP(pp_scmp)
2289 {
2290     dSP; dTARGET;
2291     tryAMAGICbin_MG(scmp_amg, 0);
2292     {
2293       dPOPTOPssrl;
2294       const int cmp =
2295 #ifdef USE_LOCALE_COLLATE
2296                       (IN_LC_RUNTIME(LC_COLLATE))
2297                       ? sv_cmp_locale_flags(left, right, 0)
2298                       :
2299 #endif
2300                         sv_cmp_flags(left, right, 0);
2301       SETi( cmp );
2302       RETURN;
2303     }
2304 }
2305
2306 PP(pp_bit_and)
2307 {
2308     dSP; dATARGET;
2309     tryAMAGICbin_MG(band_amg, AMGf_assign);
2310     {
2311       dPOPTOPssrl;
2312       if (SvNIOKp(left) || SvNIOKp(right)) {
2313         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2314         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2315         if (PL_op->op_private & HINT_INTEGER) {
2316           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2317           SETi(i);
2318         }
2319         else {
2320           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2321           SETu(u);
2322         }
2323         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2324         if (right_ro_nonnum) SvNIOK_off(right);
2325       }
2326       else {
2327         do_vop(PL_op->op_type, TARG, left, right);
2328         SETTARG;
2329       }
2330       RETURN;
2331     }
2332 }
2333
2334 PP(pp_nbit_and)
2335 {
2336     dSP;
2337     tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2338     {
2339         dATARGET; dPOPTOPssrl;
2340         if (PL_op->op_private & HINT_INTEGER) {
2341           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2342           SETi(i);
2343         }
2344         else {
2345           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2346           SETu(u);
2347         }
2348     }
2349     RETURN;
2350 }
2351
2352 PP(pp_sbit_and)
2353 {
2354     dSP;
2355     tryAMAGICbin_MG(sband_amg, AMGf_assign);
2356     {
2357         dATARGET; dPOPTOPssrl;
2358         do_vop(OP_BIT_AND, TARG, left, right);
2359         RETSETTARG;
2360     }
2361 }
2362
2363 /* also used for: pp_bit_xor() */
2364
2365 PP(pp_bit_or)
2366 {
2367     dSP; dATARGET;
2368     const int op_type = PL_op->op_type;
2369
2370     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2371     {
2372       dPOPTOPssrl;
2373       if (SvNIOKp(left) || SvNIOKp(right)) {
2374         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2375         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2376         if (PL_op->op_private & HINT_INTEGER) {
2377           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2378           const IV r = SvIV_nomg(right);
2379           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2380           SETi(result);
2381         }
2382         else {
2383           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2384           const UV r = SvUV_nomg(right);
2385           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2386           SETu(result);
2387         }
2388         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2389         if (right_ro_nonnum) SvNIOK_off(right);
2390       }
2391       else {
2392         do_vop(op_type, TARG, left, right);
2393         SETTARG;
2394       }
2395       RETURN;
2396     }
2397 }
2398
2399 /* also used for: pp_nbit_xor() */
2400
2401 PP(pp_nbit_or)
2402 {
2403     dSP;
2404     const int op_type = PL_op->op_type;
2405
2406     tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2407                     AMGf_assign|AMGf_numarg);
2408     {
2409         dATARGET; dPOPTOPssrl;
2410         if (PL_op->op_private & HINT_INTEGER) {
2411           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2412           const IV r = SvIV_nomg(right);
2413           const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2414           SETi(result);
2415         }
2416         else {
2417           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2418           const UV r = SvUV_nomg(right);
2419           const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2420           SETu(result);
2421         }
2422     }
2423     RETURN;
2424 }
2425
2426 /* also used for: pp_sbit_xor() */
2427
2428 PP(pp_sbit_or)
2429 {
2430     dSP;
2431     const int op_type = PL_op->op_type;
2432
2433     tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2434                     AMGf_assign);
2435     {
2436         dATARGET; dPOPTOPssrl;
2437         do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2438                right);
2439         RETSETTARG;
2440     }
2441 }
2442
2443 PERL_STATIC_INLINE bool
2444 S_negate_string(pTHX)
2445 {
2446     dTARGET; dSP;
2447     STRLEN len;
2448     const char *s;
2449     SV * const sv = TOPs;
2450     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2451         return FALSE;
2452     s = SvPV_nomg_const(sv, len);
2453     if (isIDFIRST(*s)) {
2454         sv_setpvs(TARG, "-");
2455         sv_catsv(TARG, sv);
2456     }
2457     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2458         sv_setsv_nomg(TARG, sv);
2459         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2460     }
2461     else return FALSE;
2462     SETTARG;
2463     return TRUE;
2464 }
2465
2466 PP(pp_negate)
2467 {
2468     dSP; dTARGET;
2469     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2470     if (S_negate_string(aTHX)) return NORMAL;
2471     {
2472         SV * const sv = TOPs;
2473
2474         if (SvIOK(sv)) {
2475             /* It's publicly an integer */
2476         oops_its_an_int:
2477             if (SvIsUV(sv)) {
2478                 if (SvIVX(sv) == IV_MIN) {
2479                     /* 2s complement assumption. */
2480                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2481                                            IV_MIN */
2482                     return NORMAL;
2483                 }
2484                 else if (SvUVX(sv) <= IV_MAX) {
2485                     SETi(-SvIVX(sv));
2486                     return NORMAL;
2487                 }
2488             }
2489             else if (SvIVX(sv) != IV_MIN) {
2490                 SETi(-SvIVX(sv));
2491                 return NORMAL;
2492             }
2493 #ifdef PERL_PRESERVE_IVUV
2494             else {
2495                 SETu((UV)IV_MIN);
2496                 return NORMAL;
2497             }
2498 #endif
2499         }
2500         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2501             SETn(-SvNV_nomg(sv));
2502         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2503                   goto oops_its_an_int;
2504         else
2505             SETn(-SvNV_nomg(sv));
2506     }
2507     return NORMAL;
2508 }
2509
2510 PP(pp_not)
2511 {
2512     dSP;
2513     SV *sv;
2514
2515     tryAMAGICun_MG(not_amg, AMGf_set);
2516     sv = *PL_stack_sp;
2517     *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
2518     return NORMAL;
2519 }
2520
2521 static void
2522 S_scomplement(pTHX_ SV *targ, SV *sv)
2523 {
2524         U8 *tmps;
2525         I32 anum;
2526         STRLEN len;
2527
2528         sv_copypv_nomg(TARG, sv);
2529         tmps = (U8*)SvPV_nomg(TARG, len);
2530
2531         if (SvUTF8(TARG)) {
2532             if (len && ! utf8_to_bytes(tmps, &len)) {
2533                 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]);
2534             }
2535             SvCUR(TARG) = len;
2536             SvUTF8_off(TARG);
2537         }
2538
2539         anum = len;
2540
2541 #ifdef LIBERAL
2542         {
2543             long *tmpl;
2544             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2545                 *tmps = ~*tmps;
2546             tmpl = (long*)tmps;
2547             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2548                 *tmpl = ~*tmpl;
2549             tmps = (U8*)tmpl;
2550         }
2551 #endif
2552         for ( ; anum > 0; anum--, tmps++)
2553             *tmps = ~*tmps;
2554 }
2555
2556 PP(pp_complement)
2557 {
2558     dSP; dTARGET;
2559     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2560     {
2561       dTOPss;
2562       if (SvNIOKp(sv)) {
2563         if (PL_op->op_private & HINT_INTEGER) {
2564           const IV i = ~SvIV_nomg(sv);
2565           SETi(i);
2566         }
2567         else {
2568           const UV u = ~SvUV_nomg(sv);
2569           SETu(u);
2570         }
2571       }
2572       else {
2573         S_scomplement(aTHX_ TARG, sv);
2574         SETTARG;
2575       }
2576       return NORMAL;
2577     }
2578 }
2579
2580 PP(pp_ncomplement)
2581 {
2582     dSP;
2583     tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2584     {
2585         dTARGET; dTOPss;
2586         if (PL_op->op_private & HINT_INTEGER) {
2587           const IV i = ~SvIV_nomg(sv);
2588           SETi(i);
2589         }
2590         else {
2591           const UV u = ~SvUV_nomg(sv);
2592           SETu(u);
2593         }
2594     }
2595     return NORMAL;
2596 }
2597
2598 PP(pp_scomplement)
2599 {
2600     dSP;
2601     tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2602     {
2603         dTARGET; dTOPss;
2604         S_scomplement(aTHX_ TARG, sv);
2605         SETTARG;
2606         return NORMAL;
2607     }
2608 }
2609
2610 /* integer versions of some of the above */
2611
2612 PP(pp_i_multiply)
2613 {
2614     dSP; dATARGET;
2615     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2616     {
2617       dPOPTOPiirl_nomg;
2618       SETi( left * right );
2619       RETURN;
2620     }
2621 }
2622
2623 PP(pp_i_divide)
2624 {
2625     IV num;
2626     dSP; dATARGET;
2627     tryAMAGICbin_MG(div_amg, AMGf_assign);
2628     {
2629       dPOPTOPssrl;
2630       IV value = SvIV_nomg(right);
2631       if (value == 0)
2632           DIE(aTHX_ "Illegal division by zero");
2633       num = SvIV_nomg(left);
2634
2635       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2636       if (value == -1)
2637           value = - num;
2638       else
2639           value = num / value;
2640       SETi(value);
2641       RETURN;
2642     }
2643 }
2644
2645 PP(pp_i_modulo)
2646 {
2647      /* This is the vanilla old i_modulo. */
2648      dSP; dATARGET;
2649      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2650      {
2651           dPOPTOPiirl_nomg;
2652           if (!right)
2653                DIE(aTHX_ "Illegal modulus zero");
2654           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2655           if (right == -1)
2656               SETi( 0 );
2657           else
2658               SETi( left % right );
2659           RETURN;
2660      }
2661 }
2662
2663 #if defined(__GLIBC__) && IVSIZE == 8 \
2664     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2665
2666 PP(pp_i_modulo_glibc_bugfix)
2667 {
2668      /* This is the i_modulo with the workaround for the _moddi3 bug
2669       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2670       * See below for pp_i_modulo. */
2671      dSP; dATARGET;
2672      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2673      {
2674           dPOPTOPiirl_nomg;
2675           if (!right)
2676                DIE(aTHX_ "Illegal modulus zero");
2677           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2678           if (right == -1)
2679               SETi( 0 );
2680           else
2681               SETi( left % PERL_ABS(right) );
2682           RETURN;
2683      }
2684 }
2685 #endif
2686
2687 PP(pp_i_add)
2688 {
2689     dSP; dATARGET;
2690     tryAMAGICbin_MG(add_amg, AMGf_assign);
2691     {
2692       dPOPTOPiirl_ul_nomg;
2693       SETi( left + right );
2694       RETURN;
2695     }
2696 }
2697
2698 PP(pp_i_subtract)
2699 {
2700     dSP; dATARGET;
2701     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2702     {
2703       dPOPTOPiirl_ul_nomg;
2704       SETi( left - right );
2705       RETURN;
2706     }
2707 }
2708
2709 PP(pp_i_lt)
2710 {
2711     dSP;
2712     tryAMAGICbin_MG(lt_amg, AMGf_set);
2713     {
2714       dPOPTOPiirl_nomg;
2715       SETs(boolSV(left < right));
2716       RETURN;
2717     }
2718 }
2719
2720 PP(pp_i_gt)
2721 {
2722     dSP;
2723     tryAMAGICbin_MG(gt_amg, AMGf_set);
2724     {
2725       dPOPTOPiirl_nomg;
2726       SETs(boolSV(left > right));
2727       RETURN;
2728     }
2729 }
2730
2731 PP(pp_i_le)
2732 {
2733     dSP;
2734     tryAMAGICbin_MG(le_amg, AMGf_set);
2735     {
2736       dPOPTOPiirl_nomg;
2737       SETs(boolSV(left <= right));
2738       RETURN;
2739     }
2740 }
2741
2742 PP(pp_i_ge)
2743 {
2744     dSP;
2745     tryAMAGICbin_MG(ge_amg, AMGf_set);
2746     {
2747       dPOPTOPiirl_nomg;
2748       SETs(boolSV(left >= right));
2749       RETURN;
2750     }
2751 }
2752
2753 PP(pp_i_eq)
2754 {
2755     dSP;
2756     tryAMAGICbin_MG(eq_amg, AMGf_set);
2757     {
2758       dPOPTOPiirl_nomg;
2759       SETs(boolSV(left == right));
2760       RETURN;
2761     }
2762 }
2763
2764 PP(pp_i_ne)
2765 {
2766     dSP;
2767     tryAMAGICbin_MG(ne_amg, AMGf_set);
2768     {
2769       dPOPTOPiirl_nomg;
2770       SETs(boolSV(left != right));
2771       RETURN;
2772     }
2773 }
2774
2775 PP(pp_i_ncmp)
2776 {
2777     dSP; dTARGET;
2778     tryAMAGICbin_MG(ncmp_amg, 0);
2779     {
2780       dPOPTOPiirl_nomg;
2781       I32 value;
2782
2783       if (left > right)
2784         value = 1;
2785       else if (left < right)
2786         value = -1;
2787       else
2788         value = 0;
2789       SETi(value);
2790       RETURN;
2791     }
2792 }
2793
2794 PP(pp_i_negate)
2795 {
2796     dSP; dTARGET;
2797     tryAMAGICun_MG(neg_amg, 0);
2798     if (S_negate_string(aTHX)) return NORMAL;
2799     {
2800         SV * const sv = TOPs;
2801         IV const i = SvIV_nomg(sv);
2802         SETi(-i);
2803         return NORMAL;
2804     }
2805 }
2806
2807 /* High falutin' math. */
2808
2809 PP(pp_atan2)
2810 {
2811     dSP; dTARGET;
2812     tryAMAGICbin_MG(atan2_amg, 0);
2813     {
2814       dPOPTOPnnrl_nomg;
2815       SETn(Perl_atan2(left, right));
2816       RETURN;
2817     }
2818 }
2819
2820
2821 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2822
2823 PP(pp_sin)
2824 {
2825     dSP; dTARGET;
2826     int amg_type = fallback_amg;
2827     const char *neg_report = NULL;
2828     const int op_type = PL_op->op_type;
2829
2830     switch (op_type) {
2831     case OP_SIN:  amg_type = sin_amg; break;
2832     case OP_COS:  amg_type = cos_amg; break;
2833     case OP_EXP:  amg_type = exp_amg; break;
2834     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2835     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2836     }
2837
2838     assert(amg_type != fallback_amg);
2839
2840     tryAMAGICun_MG(amg_type, 0);
2841     {
2842       SV * const arg = TOPs;
2843       const NV value = SvNV_nomg(arg);
2844 #ifdef NV_NAN
2845       NV result = NV_NAN;
2846 #else
2847       NV result = 0.0;
2848 #endif
2849       if (neg_report) { /* log or sqrt */
2850           if (
2851 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2852               ! Perl_isnan(value) &&
2853 #endif
2854               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2855               SET_NUMERIC_STANDARD();
2856               /* diag_listed_as: Can't take log of %g */
2857               DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2858           }
2859       }
2860       switch (op_type) {
2861       default:
2862       case OP_SIN:  result = Perl_sin(value);  break;
2863       case OP_COS:  result = Perl_cos(value);  break;
2864       case OP_EXP:  result = Perl_exp(value);  break;
2865       case OP_LOG:  result = Perl_log(value);  break;
2866       case OP_SQRT: result = Perl_sqrt(value); break;
2867       }
2868       SETn(result);
2869       return NORMAL;
2870     }
2871 }
2872
2873 /* Support Configure command-line overrides for rand() functions.
2874    After 5.005, perhaps we should replace this by Configure support
2875    for drand48(), random(), or rand().  For 5.005, though, maintain
2876    compatibility by calling rand() but allow the user to override it.
2877    See INSTALL for details.  --Andy Dougherty  15 July 1998
2878 */
2879 /* Now it's after 5.005, and Configure supports drand48() and random(),
2880    in addition to rand().  So the overrides should not be needed any more.
2881    --Jarkko Hietaniemi  27 September 1998
2882  */
2883
2884 PP(pp_rand)
2885 {
2886     if (!PL_srand_called) {
2887         (void)seedDrand01((Rand_seed_t)seed());
2888         PL_srand_called = TRUE;
2889     }
2890     {
2891         dSP;
2892         NV value;
2893     
2894         if (MAXARG < 1)
2895         {
2896             EXTEND(SP, 1);
2897             value = 1.0;
2898         }
2899         else {
2900             SV * const sv = POPs;
2901             if(!sv)
2902                 value = 1.0;
2903             else
2904                 value = SvNV(sv);
2905         }
2906     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2907 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2908         if (! Perl_isnan(value) && value == 0.0)
2909 #else
2910         if (value == 0.0)
2911 #endif
2912             value = 1.0;
2913         {
2914             dTARGET;
2915             PUSHs(TARG);
2916             PUTBACK;
2917             value *= Drand01();
2918             sv_setnv_mg(TARG, value);
2919         }
2920     }
2921     return NORMAL;
2922 }
2923
2924 PP(pp_srand)
2925 {
2926     dSP; dTARGET;
2927     UV anum;
2928
2929     if (MAXARG >= 1 && (TOPs || POPs)) {
2930         SV *top;
2931         char *pv;
2932         STRLEN len;
2933         int flags;
2934
2935         top = POPs;
2936         pv = SvPV(top, len);
2937         flags = grok_number(pv, len, &anum);
2938
2939         if (!(flags & IS_NUMBER_IN_UV)) {
2940             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2941                              "Integer overflow in srand");
2942             anum = UV_MAX;
2943         }
2944     }
2945     else {
2946         anum = seed();
2947     }
2948
2949     (void)seedDrand01((Rand_seed_t)anum);
2950     PL_srand_called = TRUE;
2951     if (anum)
2952         XPUSHu(anum);
2953     else {
2954         /* Historically srand always returned true. We can avoid breaking
2955            that like this:  */
2956         sv_setpvs(TARG, "0 but true");
2957         XPUSHTARG;
2958     }
2959     RETURN;
2960 }
2961
2962 PP(pp_int)
2963 {
2964     dSP; dTARGET;
2965     tryAMAGICun_MG(int_amg, AMGf_numeric);
2966     {
2967       SV * const sv = TOPs;
2968       const IV iv = SvIV_nomg(sv);
2969       /* XXX it's arguable that compiler casting to IV might be subtly
2970          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2971          else preferring IV has introduced a subtle behaviour change bug. OTOH
2972          relying on floating point to be accurate is a bug.  */
2973
2974       if (!SvOK(sv)) {
2975         SETu(0);
2976       }
2977       else if (SvIOK(sv)) {
2978         if (SvIsUV(sv))
2979             SETu(SvUV_nomg(sv));
2980         else
2981             SETi(iv);
2982       }
2983       else {
2984           const NV value = SvNV_nomg(sv);
2985           if (UNLIKELY(Perl_isinfnan(value)))
2986               SETn(value);
2987           else if (value >= 0.0) {
2988               if (value < (NV)UV_MAX + 0.5) {
2989                   SETu(U_V(value));
2990               } else {
2991                   SETn(Perl_floor(value));
2992               }
2993           }
2994           else {
2995               if (value > (NV)IV_MIN - 0.5) {
2996                   SETi(I_V(value));
2997               } else {
2998                   SETn(Perl_ceil(value));
2999               }
3000           }
3001       }
3002     }
3003     return NORMAL;
3004 }
3005
3006 PP(pp_abs)
3007 {
3008     dSP; dTARGET;
3009     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3010     {
3011       SV * const sv = TOPs;
3012       /* This will cache the NV value if string isn't actually integer  */
3013       const IV iv = SvIV_nomg(sv);
3014
3015       if (!SvOK(sv)) {
3016         SETu(0);
3017       }
3018       else if (SvIOK(sv)) {
3019         /* IVX is precise  */
3020         if (SvIsUV(sv)) {
3021           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3022         } else {
3023           if (iv >= 0) {
3024             SETi(iv);
3025           } else {
3026             if (iv != IV_MIN) {
3027               SETi(-iv);
3028             } else {
3029               /* 2s complement assumption. Also, not really needed as
3030                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3031               SETu((UV)IV_MIN);
3032             }
3033           }
3034         }
3035       } else{
3036         const NV value = SvNV_nomg(sv);
3037         if (value < 0.0)
3038           SETn(-value);
3039         else
3040           SETn(value);
3041       }
3042     }
3043     return NORMAL;
3044 }
3045
3046
3047 /* also used for: pp_hex() */
3048
3049 PP(pp_oct)
3050 {
3051     dSP; dTARGET;
3052     const char *tmps;
3053     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3054     STRLEN len;
3055     NV result_nv;
3056     UV result_uv;
3057     SV* const sv = TOPs;
3058
3059     tmps = (SvPV_const(sv, len));
3060     if (DO_UTF8(sv)) {
3061          /* If Unicode, try to downgrade
3062           * If not possible, croak. */
3063          SV* const tsv = sv_2mortal(newSVsv(sv));
3064         
3065          SvUTF8_on(tsv);
3066          sv_utf8_downgrade(tsv, FALSE);
3067          tmps = SvPV_const(tsv, len);
3068     }
3069     if (PL_op->op_type == OP_HEX)
3070         goto hex;
3071
3072     while (*tmps && len && isSPACE(*tmps))
3073         tmps++, len--;
3074     if (*tmps == '0')
3075         tmps++, len--;
3076     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3077     hex:
3078         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3079     }
3080     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3081         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3082     else
3083         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3084
3085     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3086         SETn(result_nv);
3087     }
3088     else {
3089         SETu(result_uv);
3090     }
3091     return NORMAL;
3092 }
3093
3094 /* String stuff. */
3095
3096
3097 PP(pp_length)
3098 {
3099     dSP; dTARGET;
3100     SV * const sv = TOPs;
3101
3102     U32 in_bytes = IN_BYTES;
3103     /* Simplest case shortcut:
3104      * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3105      * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3106      * set)
3107      */
3108     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3109
3110     STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3111     SETs(TARG);
3112
3113     if (LIKELY(svflags == SVf_POK))
3114         goto simple_pv;
3115
3116     if (svflags & SVs_GMG)
3117         mg_get(sv);
3118
3119     if (SvOK(sv)) {
3120         STRLEN len;
3121         if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3122             if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3123                 goto simple_pv;
3124             if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3125                 /* no need to convert from bytes to chars */
3126                 len = SvCUR(sv);
3127                 goto return_bool;
3128             }
3129             len = sv_len_utf8_nomg(sv);
3130         }
3131         else {
3132             /* unrolled SvPV_nomg_const(sv,len) */
3133             if (SvPOK_nog(sv)) {
3134               simple_pv:
3135                 len = SvCUR(sv);
3136                 if (PL_op->op_private & OPpTRUEBOOL) {
3137                   return_bool:
3138                     SETs(len ? &PL_sv_yes : &PL_sv_zero);
3139                     return NORMAL;
3140                 }
3141             }
3142             else {
3143                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3144             }
3145         }
3146         TARGi((IV)(len), 1);
3147     }
3148     else {
3149         if (!SvPADTMP(TARG)) {
3150             /* OPpTARGET_MY: targ is var in '$lex = length()' */
3151             sv_set_undef(TARG);
3152             SvSETMAGIC(TARG);
3153         }
3154         else
3155             /* TARG is on stack at this point and is overwriten by SETs.
3156              * This branch is the odd one out, so put TARG by default on
3157              * stack earlier to let local SP go out of liveness sooner */
3158             SETs(&PL_sv_undef);
3159     }
3160     return NORMAL; /* no putback, SP didn't move in this opcode */
3161 }
3162
3163
3164 /* Returns false if substring is completely outside original string.
3165    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3166    always be true for an explicit 0.
3167 */
3168 bool
3169 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3170                                 bool pos1_is_uv, IV len_iv,
3171                                 bool len_is_uv, STRLEN *posp,
3172                                 STRLEN *lenp)
3173 {
3174     IV pos2_iv;
3175     int    pos2_is_uv;
3176
3177     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3178
3179     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3180         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3181         pos1_iv += curlen;
3182     }
3183     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3184         return FALSE;
3185
3186     if (len_iv || len_is_uv) {
3187         if (!len_is_uv && len_iv < 0) {
3188             pos2_iv = curlen + len_iv;
3189             if (curlen)
3190                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3191             else
3192                 pos2_is_uv = 0;
3193         } else {  /* len_iv >= 0 */
3194             if (!pos1_is_uv && pos1_iv < 0) {
3195                 pos2_iv = pos1_iv + len_iv;
3196                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3197             } else {
3198                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3199                     pos2_iv = curlen;
3200                 else
3201                     pos2_iv = pos1_iv+len_iv;
3202                 pos2_is_uv = 1;
3203             }
3204         }
3205     }
3206     else {
3207         pos2_iv = curlen;
3208         pos2_is_uv = 1;
3209     }
3210
3211     if (!pos2_is_uv && pos2_iv < 0) {
3212         if (!pos1_is_uv && pos1_iv < 0)
3213             return FALSE;
3214         pos2_iv = 0;
3215     }
3216     else if (!pos1_is_uv && pos1_iv < 0)
3217         pos1_iv = 0;
3218
3219     if ((UV)pos2_iv < (UV)pos1_iv)
3220         pos2_iv = pos1_iv;
3221     if ((UV)pos2_iv > curlen)
3222         pos2_iv = curlen;
3223
3224     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3225     *posp = (STRLEN)( (UV)pos1_iv );
3226     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3227
3228     return TRUE;
3229 }
3230
3231 PP(pp_substr)
3232 {
3233     dSP; dTARGET;
3234     SV *sv;
3235     STRLEN curlen;
3236     STRLEN utf8_curlen;
3237     SV *   pos_sv;
3238     IV     pos1_iv;
3239     int    pos1_is_uv;
3240     SV *   len_sv;
3241     IV     len_iv = 0;
3242     int    len_is_uv = 0;
3243     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3244     const bool rvalue = (GIMME_V != G_VOID);
3245     const char *tmps;
3246     SV *repl_sv = NULL;
3247     const char *repl = NULL;
3248     STRLEN repl_len;
3249     int num_args = PL_op->op_private & 7;
3250     bool repl_need_utf8_upgrade = FALSE;
3251
3252     if (num_args > 2) {
3253         if (num_args > 3) {
3254           if(!(repl_sv = POPs)) num_args--;
3255         }
3256         if ((len_sv = POPs)) {
3257             len_iv    = SvIV(len_sv);
3258             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3259         }
3260         else num_args--;
3261     }
3262     pos_sv     = POPs;
3263     pos1_iv    = SvIV(pos_sv);
3264     pos1_is_uv = SvIOK_UV(pos_sv);
3265     sv = POPs;
3266     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3267         assert(!repl_sv);
3268         repl_sv = POPs;
3269     }
3270     if (lvalue && !repl_sv) {
3271         SV * ret;
3272         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3273         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3274         LvTYPE(ret) = 'x';
3275         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3276         LvTARGOFF(ret) =
3277             pos1_is_uv || pos1_iv >= 0
3278                 ? (STRLEN)(UV)pos1_iv
3279                 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3280         LvTARGLEN(ret) =
3281             len_is_uv || len_iv > 0
3282                 ? (STRLEN)(UV)len_iv
3283                 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3284
3285         PUSHs(ret);    /* avoid SvSETMAGIC here */
3286         RETURN;
3287     }
3288     if (repl_sv) {
3289         repl = SvPV_const(repl_sv, repl_len);
3290         SvGETMAGIC(sv);
3291         if (SvROK(sv))
3292             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3293                             "Attempt to use reference as lvalue in substr"
3294             );
3295         tmps = SvPV_force_nomg(sv, curlen);
3296         if (DO_UTF8(repl_sv) && repl_len) {
3297             if (!DO_UTF8(sv)) {
3298                 /* Upgrade the dest, and recalculate tmps in case the buffer
3299                  * got reallocated; curlen may also have been changed */
3300                 sv_utf8_upgrade_nomg(sv);
3301                 tmps = SvPV_nomg(sv, curlen);
3302             }
3303         }
3304         else if (DO_UTF8(sv))
3305             repl_need_utf8_upgrade = TRUE;
3306     }
3307     else tmps = SvPV_const(sv, curlen);
3308     if (DO_UTF8(sv)) {
3309         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3310         if (utf8_curlen == curlen)
3311             utf8_curlen = 0;
3312         else
3313             curlen = utf8_curlen;
3314     }
3315     else
3316         utf8_curlen = 0;
3317
3318     {
3319         STRLEN pos, len, byte_len, byte_pos;
3320
3321         if (!translate_substr_offsets(
3322                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3323         )) goto bound_fail;
3324
3325         byte_len = len;
3326         byte_pos = utf8_curlen
3327             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3328
3329         tmps += byte_pos;
3330
3331         if (rvalue) {
3332             SvTAINTED_off(TARG);                        /* decontaminate */
3333             SvUTF8_off(TARG);                   /* decontaminate */
3334             sv_setpvn(TARG, tmps, byte_len);
3335 #ifdef USE_LOCALE_COLLATE
3336             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3337 #endif
3338             if (utf8_curlen)
3339                 SvUTF8_on(TARG);
3340         }
3341
3342         if (repl) {
3343             SV* repl_sv_copy = NULL;
3344
3345             if (repl_need_utf8_upgrade) {
3346                 repl_sv_copy = newSVsv(repl_sv);
3347                 sv_utf8_upgrade(repl_sv_copy);
3348                 repl = SvPV_const(repl_sv_copy, repl_len);
3349             }
3350             if (!SvOK(sv))
3351                 SvPVCLEAR(sv);
3352             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3353             SvREFCNT_dec(repl_sv_copy);
3354         }
3355     }
3356     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3357         SP++;
3358     else if (rvalue) {
3359         SvSETMAGIC(TARG);
3360         PUSHs(TARG);
3361     }
3362     RETURN;
3363
3364   bound_fail:
3365     if (repl)
3366         Perl_croak(aTHX_ "substr outside of string");
3367     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3368     RETPUSHUNDEF;
3369 }
3370
3371 PP(pp_vec)
3372 {
3373     dSP;
3374     const IV size   = POPi;
3375     SV* offsetsv   = POPs;
3376     SV * const src = POPs;
3377     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3378     SV * ret;
3379     UV   retuv;
3380     STRLEN offset = 0;
3381     char errflags = 0;
3382
3383     /* extract a STRLEN-ranged integer value from offsetsv into offset,
3384      * or flag that its out of range */
3385     {
3386         IV iv = SvIV(offsetsv);
3387
3388         /* avoid a large UV being wrapped to a negative value */
3389         if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3390             errflags = LVf_OUT_OF_RANGE;
3391         else if (iv < 0)
3392             errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3393 #if PTRSIZE < IVSIZE
3394         else if (iv > Size_t_MAX)
3395             errflags = LVf_OUT_OF_RANGE;
3396 #endif
3397         else
3398             offset = (STRLEN)iv;
3399     }
3400
3401     retuv = errflags ? 0 : do_vecget(src, offset, size);
3402
3403     if (lvalue) {                       /* it's an lvalue! */
3404         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3405         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3406         LvTYPE(ret) = 'v';
3407         LvTARG(ret) = SvREFCNT_inc_simple(src);
3408         LvTARGOFF(ret) = offset;
3409         LvTARGLEN(ret) = size;
3410         LvFLAGS(ret)   = errflags;
3411     }
3412     else {
3413         dTARGET;
3414         SvTAINTED_off(TARG);            /* decontaminate */
3415         ret = TARG;
3416     }
3417
3418     sv_setuv(ret, retuv);
3419     if (!lvalue)
3420         SvSETMAGIC(ret);
3421     PUSHs(ret);
3422     RETURN;
3423 }
3424
3425
3426 /* also used for: pp_rindex() */
3427
3428 PP(pp_index)
3429 {
3430     dSP; dTARGET;
3431     SV *big;
3432     SV *little;
3433     SV *temp = NULL;
3434     STRLEN biglen;
3435     STRLEN llen = 0;
3436     SSize_t offset = 0;
3437     SSize_t retval;
3438     const char *big_p;
3439     const char *little_p;
3440     bool big_utf8;
3441     bool little_utf8;
3442     const bool is_index = PL_op->op_type == OP_INDEX;
3443     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3444
3445     if (threeargs)
3446         offset = POPi;
3447     little = POPs;
3448     big = POPs;
3449     big_p = SvPV_const(big, biglen);
3450     little_p = SvPV_const(little, llen);
3451
3452     big_utf8 = DO_UTF8(big);
3453     little_utf8 = DO_UTF8(little);
3454     if (big_utf8 ^ little_utf8) {
3455         /* One needs to be upgraded.  */
3456         if (little_utf8) {
3457             /* Well, maybe instead we might be able to downgrade the small
3458                string?  */
3459             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3460                                                      &little_utf8);
3461             if (little_utf8) {
3462                 /* If the large string is ISO-8859-1, and it's not possible to
3463                    convert the small string to ISO-8859-1, then there is no
3464                    way that it could be found anywhere by index.  */
3465                 retval = -1;
3466                 goto push_result;
3467             }
3468
3469             /* At this point, pv is a malloc()ed string. So donate it to temp
3470                to ensure it will get free()d  */
3471             little = temp = newSV(0);
3472             sv_usepvn(temp, pv, llen);
3473             little_p = SvPVX(little);
3474         } else {
3475             temp = newSVpvn(little_p, llen);
3476
3477             sv_utf8_upgrade(temp);
3478             little = temp;
3479             little_p = SvPV_const(little, llen);
3480         }
3481     }
3482     if (SvGAMAGIC(big)) {
3483         /* Life just becomes a lot easier if I use a temporary here.
3484            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3485            will trigger magic and overloading again, as will fbm_instr()
3486         */
3487         big = newSVpvn_flags(big_p, biglen,
3488                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3489         big_p = SvPVX(big);
3490     }
3491     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3492         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3493            warn on undef, and we've already triggered a warning with the
3494            SvPV_const some lines above. We can't remove that, as we need to
3495            call some SvPV to trigger overloading early and find out if the
3496            string is UTF-8.
3497            This is all getting too messy. The API isn't quite clean enough,
3498            because data access has side effects.
3499         */
3500         little = newSVpvn_flags(little_p, llen,
3501                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3502         little_p = SvPVX(little);
3503     }
3504
3505     if (!threeargs)
3506         offset = is_index ? 0 : biglen;
3507     else {
3508         if (big_utf8 && offset > 0)
3509             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3510         if (!is_index)
3511             offset += llen;
3512     }
3513     if (offset < 0)
3514         offset = 0;
3515     else if (offset > (SSize_t)biglen)
3516         offset = biglen;
3517     if (!(little_p = is_index
3518           ? fbm_instr((unsigned char*)big_p + offset,
3519                       (unsigned char*)big_p + biglen, little, 0)
3520           : rninstr(big_p,  big_p  + offset,
3521                     little_p, little_p + llen)))
3522         retval = -1;
3523     else {
3524         retval = little_p - big_p;
3525         if (retval > 1 && big_utf8)
3526             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3527     }
3528     SvREFCNT_dec(temp);
3529
3530   push_result:
3531     /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3532     if (PL_op->op_private & OPpTRUEBOOL) {
3533         PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3534                     ? &PL_sv_yes : &PL_sv_no);
3535         if (PL_op->op_private & OPpTARGET_MY)
3536             /* $lex = (index() == -1) */
3537             sv_setsv(TARG, TOPs);
3538     }
3539     else 
3540         PUSHi(retval);
3541     RETURN;
3542 }
3543
3544 PP(pp_sprintf)
3545 {
3546     dSP; dMARK; dORIGMARK; dTARGET;
3547     SvTAINTED_off(TARG);
3548     do_sprintf(TARG, SP-MARK, MARK+1);
3549     TAINT_IF(SvTAINTED(TARG));
3550     SP = ORIGMARK;
3551     PUSHTARG;
3552     RETURN;
3553 }
3554
3555 PP(pp_ord)
3556 {
3557     dSP; dTARGET;
3558
3559     SV *argsv = TOPs;
3560     STRLEN len;
3561     const U8 *s = (U8*)SvPV_const(argsv, len);
3562
3563     SETu(DO_UTF8(argsv)
3564            ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3565            : (UV)(*s));
3566
3567     return NORMAL;
3568 }
3569
3570 PP(pp_chr)
3571 {
3572     dSP; dTARGET;
3573     char *tmps;
3574     UV value;
3575     SV *top = TOPs;
3576
3577     SvGETMAGIC(top);
3578     if (UNLIKELY(SvAMAGIC(top)))
3579         top = sv_2num(top);
3580     if (UNLIKELY(isinfnansv(top)))
3581         Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3582     else {
3583         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3584             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3585                 ||
3586                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3587                  && SvNV_nomg(top) < 0.0)))
3588         {
3589             if (ckWARN(WARN_UTF8)) {
3590                 if (SvGMAGICAL(top)) {
3591                     SV *top2 = sv_newmortal();
3592                     sv_setsv_nomg(top2, top);
3593                     top = top2;
3594                 }
3595                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3596                             "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3597             }
3598             value = UNICODE_REPLACEMENT;
3599         } else {
3600             value = SvUV_nomg(top);
3601         }
3602     }
3603
3604     SvUPGRADE(TARG,SVt_PV);
3605
3606     if (value > 255 && !IN_BYTES) {
3607         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3608         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3609         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3610         *tmps = '\0';
3611         (void)SvPOK_only(TARG);
3612         SvUTF8_on(TARG);
3613         SETTARG;
3614         return NORMAL;
3615     }
3616
3617     SvGROW(TARG,2);
3618     SvCUR_set(TARG, 1);
3619     tmps = SvPVX(TARG);
3620     *tmps++ = (char)value;
3621     *tmps = '\0';
3622     (void)SvPOK_only(TARG);
3623
3624     SETTARG;
3625     return NORMAL;
3626 }
3627
3628 PP(pp_crypt)
3629 {
3630 #ifdef HAS_CRYPT
3631     dSP; dTARGET;
3632     dPOPTOPssrl;
3633     STRLEN len;
3634     const char *tmps = SvPV_const(left, len);
3635
3636     if (DO_UTF8(left)) {
3637          /* If Unicode, try to downgrade.
3638           * If not possible, croak.
3639           * Yes, we made this up.  */
3640          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3641
3642          sv_utf8_downgrade(tsv, FALSE);
3643          tmps = SvPV_const(tsv, len);
3644     }
3645 #   ifdef USE_ITHREADS
3646 #     ifdef HAS_CRYPT_R
3647     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3648       /* This should be threadsafe because in ithreads there is only
3649        * one thread per interpreter.  If this would not be true,
3650        * we would need a mutex to protect this malloc. */
3651         PL_reentrant_buffer->_crypt_struct_buffer =
3652           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3653 #if defined(__GLIBC__) || defined(__EMX__)
3654         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3655             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3656             /* work around glibc-2.2.5 bug */
3657             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3658         }
3659 #endif
3660     }
3661 #     endif /* HAS_CRYPT_R */
3662 #   endif /* USE_ITHREADS */
3663 #   ifdef FCRYPT
3664     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3665 #   else
3666     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3667 #   endif
3668     SvUTF8_off(TARG);
3669     SETTARG;
3670     RETURN;
3671 #else
3672     DIE(aTHX_
3673       "The crypt() function is unimplemented due to excessive paranoia.");
3674 #endif
3675 }
3676
3677 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So 
3678  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3679
3680
3681 /* also used for: pp_lcfirst() */
3682
3683 PP(pp_ucfirst)
3684 {
3685     /* Actually is both lcfirst() and ucfirst().  Only the first character
3686      * changes.  This means that possibly we can change in-place, ie., just
3687      * take the source and change that one character and store it back, but not
3688      * if read-only etc, or if the length changes */
3689
3690     dSP;
3691     SV *source = TOPs;
3692     STRLEN slen; /* slen is the byte length of the whole SV. */
3693     STRLEN need;
3694     SV *dest;
3695     bool inplace;   /* ? Convert first char only, in-place */
3696     bool doing_utf8 = FALSE;               /* ? using utf8 */
3697     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3698     const int op_type = PL_op->op_type;
3699     const U8 *s;
3700     U8 *d;
3701     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3702     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3703                      * stored as UTF-8 at s. */
3704     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3705                      * lowercased) character stored in tmpbuf.  May be either
3706                      * UTF-8 or not, but in either case is the number of bytes */
3707
3708     s = (const U8*)SvPV_const(source, slen);
3709
3710     /* We may be able to get away with changing only the first character, in
3711      * place, but not if read-only, etc.  Later we may discover more reasons to
3712      * not convert in-place. */
3713     inplace = !SvREADONLY(source) && SvPADTMP(source);
3714
3715 #ifdef USE_LOCALE_CTYPE
3716
3717     if (IN_LC_RUNTIME(LC_CTYPE)) {
3718         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3719     }
3720
3721 #endif
3722
3723     /* First calculate what the changed first character should be.  This affects
3724      * whether we can just swap it out, leaving the rest of the string unchanged,
3725      * or even if have to convert the dest to UTF-8 when the source isn't */
3726
3727     if (! slen) {   /* If empty */
3728         need = 1; /* still need a trailing NUL */
3729         ulen = 0;
3730     }
3731     else if (DO_UTF8(source)) { /* Is the source utf8? */
3732         doing_utf8 = TRUE;
3733         ulen = UTF8SKIP(s);
3734         if (op_type == OP_UCFIRST) {
3735 #ifdef USE_LOCALE_CTYPE
3736             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3737 #else
3738             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3739 #endif
3740         }
3741         else {
3742 #ifdef USE_LOCALE_CTYPE
3743             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3744 #else
3745             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3746 #endif
3747         }
3748
3749         /* we can't do in-place if the length changes.  */
3750         if (ulen != tculen) inplace = FALSE;
3751         need = slen + 1 - ulen + tculen;
3752     }
3753     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3754             * latin1 is treated as caseless.  Note that a locale takes
3755             * precedence */ 
3756         ulen = 1;       /* Original character is 1 byte */
3757         tculen = 1;     /* Most characters will require one byte, but this will
3758                          * need to be overridden for the tricky ones */
3759         need = slen + 1;
3760
3761         if (op_type == OP_LCFIRST) {
3762
3763             /* lower case the first letter: no trickiness for any character */
3764 #ifdef USE_LOCALE_CTYPE
3765             if (IN_LC_RUNTIME(LC_CTYPE)) {
3766                 *tmpbuf = toLOWER_LC(*s);
3767             }
3768             else
3769 #endif
3770             {
3771                 *tmpbuf = (IN_UNI_8_BIT)
3772                           ? toLOWER_LATIN1(*s)
3773                           : toLOWER(*s);
3774             }
3775         }
3776 #ifdef USE_LOCALE_CTYPE
3777         /* is ucfirst() */
3778         else if (IN_LC_RUNTIME(LC_CTYPE)) {
3779             if (IN_UTF8_CTYPE_LOCALE) {
3780                 goto do_uni_rules;
3781             }
3782
3783             *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3784                                               locales have upper and title case
3785                                               different */
3786         }
3787 #endif
3788         else if (! IN_UNI_8_BIT) {
3789             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3790                                          * on EBCDIC machines whatever the
3791                                          * native function does */
3792         }
3793         else {
3794             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3795              * UTF-8, which we treat as not in locale), and cased latin1 */
3796             UV title_ord;
3797 #ifdef USE_LOCALE_CTYPE
3798       do_uni_rules:
3799 #endif
3800
3801             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3802             if (tculen > 1) {
3803                 assert(tculen == 2);
3804
3805                 /* If the result is an upper Latin1-range character, it can
3806                  * still be represented in one byte, which is its ordinal */
3807                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3808                     *tmpbuf = (U8) title_ord;
3809                     tculen = 1;
3810                 }
3811                 else {
3812                     /* Otherwise it became more than one ASCII character (in
3813                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3814                      * beyond Latin1, so the number of bytes changed, so can't
3815                      * replace just the first character in place. */
3816                     inplace = FALSE;
3817
3818                     /* If the result won't fit in a byte, the entire result
3819                      * will have to be in UTF-8.  Assume worst case sizing in
3820                      * conversion. (all latin1 characters occupy at most two
3821                      * bytes in utf8) */
3822                     if (title_ord > 255) {
3823                         doing_utf8 = TRUE;
3824                         convert_source_to_utf8 = TRUE;
3825                         need = slen * 2 + 1;
3826
3827                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3828                          * (both) characters whose title case is above 255 is
3829                          * 2. */
3830                         ulen = 2;
3831                     }
3832                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3833                         need = slen + 1 + 1;
3834                     }
3835                 }
3836             }
3837         } /* End of use Unicode (Latin1) semantics */
3838     } /* End of changing the case of the first character */
3839
3840     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3841      * generate the result */
3842     if (inplace) {
3843
3844         /* We can convert in place.  This means we change just the first
3845          * character without disturbing the rest; no need to grow */
3846         dest = source;
3847         s = d = (U8*)SvPV_force_nomg(source, slen);
3848     } else {
3849         dTARGET;
3850
3851         dest = TARG;
3852
3853         /* Here, we can't convert in place; we earlier calculated how much
3854          * space we will need, so grow to accommodate that */
3855         SvUPGRADE(dest, SVt_PV);
3856         d = (U8*)SvGROW(dest, need);
3857         (void)SvPOK_only(dest);
3858
3859         SETs(dest);
3860     }
3861
3862     if (doing_utf8) {
3863         if (! inplace) {
3864             if (! convert_source_to_utf8) {
3865
3866                 /* Here  both source and dest are in UTF-8, but have to create
3867                  * the entire output.  We initialize the result to be the
3868                  * title/lower cased first character, and then append the rest
3869                  * of the string. */
3870                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3871                 if (slen > ulen) {
3872                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3873                 }
3874             }
3875             else {
3876                 const U8 *const send = s + slen;
3877
3878                 /* Here the dest needs to be in UTF-8, but the source isn't,
3879                  * except we earlier UTF-8'd the first character of the source
3880                  * into tmpbuf.  First put that into dest, and then append the
3881                  * rest of the source, converting it to UTF-8 as we go. */
3882
3883                 /* Assert tculen is 2 here because the only two characters that
3884                  * get to this part of the code have 2-byte UTF-8 equivalents */
3885                 *d++ = *tmpbuf;
3886                 *d++ = *(tmpbuf + 1);
3887                 s++;    /* We have just processed the 1st char */
3888
3889                 for (; s < send; s++) {
3890                     d = uvchr_to_utf8(d, *s);
3891                 }
3892                 *d = '\0';
3893                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3894             }
3895             SvUTF8_on(dest);
3896         }
3897         else {   /* in-place UTF-8.  Just overwrite the first character */
3898             Copy(tmpbuf, d, tculen, U8);
3899             SvCUR_set(dest, need - 1);
3900         }
3901
3902     }
3903     else {  /* Neither source nor dest are in or need to be UTF-8 */
3904         if (slen) {
3905             if (inplace) {  /* in-place, only need to change the 1st char */
3906                 *d = *tmpbuf;
3907             }
3908             else {      /* Not in-place */
3909
3910                 /* Copy the case-changed character(s) from tmpbuf */
3911                 Copy(tmpbuf, d, tculen, U8);
3912                 d += tculen - 1; /* Code below expects d to point to final
3913                                   * character stored */
3914             }
3915         }
3916         else {  /* empty source */
3917             /* See bug #39028: Don't taint if empty  */
3918             *d = *s;
3919         }
3920
3921         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3922          * the destination to retain that flag */
3923         if (SvUTF8(source) && ! IN_BYTES)
3924             SvUTF8_on(dest);
3925
3926         if (!inplace) { /* Finish the rest of the string, unchanged */
3927             /* This will copy the trailing NUL  */
3928             Copy(s + 1, d + 1, slen, U8);
3929             SvCUR_set(dest, need - 1);
3930         }
3931     }
3932 #ifdef USE_LOCALE_CTYPE
3933     if (IN_LC_RUNTIME(LC_CTYPE)) {
3934         TAINT;
3935         SvTAINTED_on(dest);
3936     }
3937 #endif
3938     if (dest != source && SvTAINTED(source))
3939         SvTAINT(dest);
3940     SvSETMAGIC(dest);
3941     return NORMAL;
3942 }
3943
3944 /* There's so much setup/teardown code common between uc and lc, I wonder if
3945    it would be worth merging the two, and just having a switch outside each
3946    of the three tight loops.  There is less and less commonality though */
3947 PP(pp_uc)
3948 {
3949     dSP;
3950     SV *source = TOPs;
3951     STRLEN len;
3952     STRLEN min;
3953     SV *dest;
3954     const U8 *s;
3955     U8 *d;
3956
3957     SvGETMAGIC(source);
3958
3959     if (   SvPADTMP(source)
3960         && !SvREADONLY(source) && SvPOK(source)
3961         && !DO_UTF8(source)
3962         && (
3963 #ifdef USE_LOCALE_CTYPE
3964             (IN_LC_RUNTIME(LC_CTYPE))
3965             ? ! IN_UTF8_CTYPE_LOCALE
3966             :
3967 #endif
3968               ! IN_UNI_8_BIT))
3969     {
3970
3971         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
3972          * make the loop tight, so we overwrite the source with the dest before
3973          * looking at it, and we need to look at the original source
3974          * afterwards.  There would also need to be code added to handle
3975          * switching to not in-place in midstream if we run into characters
3976          * that change the length.  Since being in locale overrides UNI_8_BIT,
3977          * that latter becomes irrelevant in the above test; instead for
3978          * locale, the size can't normally change, except if the locale is a
3979          * UTF-8 one */
3980         dest = source;
3981         s = d = (U8*)SvPV_force_nomg(source, len);
3982         min = len + 1;
3983     } else {
3984         dTARGET;
3985
3986         dest = TARG;
3987
3988         s = (const U8*)SvPV_nomg_const(source, len);
3989         min = len + 1;
3990
3991         SvUPGRADE(dest, SVt_PV);
3992         d = (U8*)SvGROW(dest, min);
3993         (void)SvPOK_only(dest);
3994
3995         SETs(dest);
3996     }
3997
3998 #ifdef USE_LOCALE_CTYPE
3999
4000     if (IN_LC_RUNTIME(LC_CTYPE)) {
4001         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4002     }
4003
4004 #endif
4005
4006     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4007        to check DO_UTF8 again here.  */
4008
4009     if (DO_UTF8(source)) {
4010         const U8 *const send = s + len;
4011         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4012
4013         /* All occurrences of these are to be moved to follow any other marks.
4014          * This is context-dependent.  We may not be passed enough context to
4015          * move the iota subscript beyond all of them, but we do the best we can
4016          * with what we're given.  The result is always better than if we
4017          * hadn't done this.  And, the problem would only arise if we are
4018          * passed a character without all its combining marks, which would be
4019          * the caller's mistake.  The information this is based on comes from a
4020          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4021          * itself) and so can't be checked properly to see if it ever gets
4022          * revised.  But the likelihood of it changing is remote */
4023         bool in_iota_subscript = FALSE;
4024
4025         while (s < send) {
4026             STRLEN u;
4027             STRLEN ulen;
4028             UV uv;
4029             if (in_iota_subscript && ! _is_utf8_mark(s)) {
4030
4031                 /* A non-mark.  Time to output the iota subscript */
4032                 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4033                 d += capital_iota_len;
4034                 in_iota_subscript = FALSE;
4035             }
4036
4037             /* Then handle the current character.  Get the changed case value
4038              * and copy it to the output buffer */
4039
4040             u = UTF8SKIP(s);
4041 #ifdef USE_LOCALE_CTYPE
4042             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4043 #else
4044             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4045 #endif
4046 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4047 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4048             if (uv == GREEK_CAPITAL_LETTER_IOTA
4049                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4050             {
4051                 in_iota_subscript = TRUE;
4052             }
4053             else {
4054                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4055                     /* If the eventually required minimum size outgrows the
4056                      * available space, we need to grow. */
4057                     const UV o = d - (U8*)SvPVX_const(dest);
4058
4059                     /* If someone uppercases one million U+03B0s we SvGROW()
4060                      * one million times.  Or we could try guessing how much to
4061                      * allocate without allocating too much.  Such is life.
4062                      * See corresponding comment in lc code for another option
4063                      * */
4064                     d = o + (U8*) SvGROW(dest, min);
4065                 }
4066                 Copy(tmpbuf, d, ulen, U8);
4067                 d += ulen;
4068             }
4069             s += u;
4070         }
4071         if (in_iota_subscript) {
4072             Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4073             d += capital_iota_len;
4074         }
4075         SvUTF8_on(dest);
4076         *d = '\0';
4077
4078         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4079     }
4080     else {      /* Not UTF-8 */
4081         if (len) {
4082             const U8 *const send = s + len;
4083
4084             /* Use locale casing if in locale; regular style if not treating
4085              * latin1 as having case; otherwise the latin1 casing.  Do the
4086              * whole thing in a tight loop, for speed, */
4087 #ifdef USE_LOCALE_CTYPE
4088             if (IN_LC_RUNTIME(LC_CTYPE)) {
4089                 if (IN_UTF8_CTYPE_LOCALE) {
4090                     goto do_uni_rules;
4091                 }
4092                 for (; s < send; d++, s++)
4093                     *d = (U8) toUPPER_LC(*s);
4094             }
4095             else
4096 #endif
4097                  if (! IN_UNI_8_BIT) {
4098                 for (; s < send; d++, s++) {
4099                     *d = toUPPER(*s);
4100                 }
4101             }
4102             else {
4103 #ifdef USE_LOCALE_CTYPE
4104           do_uni_rules:
4105 #endif
4106                 for (; s < send; d++, s++) {
4107                     *d = toUPPER_LATIN1_MOD(*s);
4108                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4109                         continue;
4110                     }
4111
4112                     /* The mainstream case is the tight loop above.  To avoid
4113                      * extra tests in that, all three characters that require
4114                      * special handling are mapped by the MOD to the one tested
4115                      * just above.  
4116                      * Use the source to distinguish between the three cases */
4117
4118 #if    UNICODE_MAJOR_VERSION > 2                                        \
4119    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4120                                   && UNICODE_DOT_DOT_VERSION >= 8)
4121                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4122
4123                         /* uc() of this requires 2 characters, but they are
4124                          * ASCII.  If not enough room, grow the string */
4125                         if (SvLEN(dest) < ++min) {      
4126                             const UV o = d - (U8*)SvPVX_const(dest);
4127                             d = o + (U8*) SvGROW(dest, min);
4128                         }
4129                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4130                         continue;   /* Back to the tight loop; still in ASCII */
4131                     }
4132 #endif
4133
4134                     /* The other two special handling characters have their
4135                      * upper cases outside the latin1 range, hence need to be
4136                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4137                      * here we are somewhere in the middle of processing a
4138                      * non-UTF-8 string, and realize that we will have to convert
4139                      * the whole thing to UTF-8.  What to do?  There are
4140                      * several possibilities.  The simplest to code is to
4141                      * convert what we have so far, set a flag, and continue on
4142                      * in the loop.  The flag would be tested each time through
4143                      * the loop, and if set, the next character would be
4144                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4145                      * to slow down the mainstream case at all for this fairly
4146                      * rare case, so I didn't want to add a test that didn't
4147                      * absolutely have to be there in the loop, besides the
4148                      * possibility that it would get too complicated for
4149                      * optimizers to deal with.  Another possibility is to just
4150                      * give up, convert the source to UTF-8, and restart the
4151                      * function that way.  Another possibility is to convert
4152                      * both what has already been processed and what is yet to
4153                      * come separately to UTF-8, then jump into the loop that
4154                      * handles UTF-8.  But the most efficient time-wise of the
4155                      * ones I could think of is what follows, and turned out to
4156                      * not require much extra code.  */
4157
4158                     /* Convert what we have so far into UTF-8, telling the
4159                      * function that we know it should be converted, and to
4160                      * allow extra space for what we haven't processed yet.
4161                      * Assume the worst case space requirements for converting
4162                      * what we haven't processed so far: that it will require
4163                      * two bytes for each remaining source character, plus the
4164                      * NUL at the end.  This may cause the string pointer to
4165                      * move, so re-find it. */
4166
4167                     len = d - (U8*)SvPVX_const(dest);
4168                     SvCUR_set(dest, len);
4169                     len = sv_utf8_upgrade_flags_grow(dest,
4170                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4171                                                 (send -s) * 2 + 1);
4172                     d = (U8*)SvPVX(dest) + len;
4173
4174                     /* Now process the remainder of the source, converting to
4175                      * upper and UTF-8.  If a resulting byte is invariant in
4176                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4177                      * append it to the output. */
4178                     for (; s < send; s++) {
4179                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
4180                         d += len;
4181                     }
4182
4183                     /* Here have processed the whole source; no need to continue
4184                      * with the outer loop.  Each character has been converted
4185                      * to upper case and converted to UTF-8 */
4186
4187                     break;
4188                 } /* End of processing all latin1-style chars */
4189             } /* End of processing all chars */
4190         } /* End of source is not empty */
4191
4192         if (source != dest) {
4193             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4194             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4195         }
4196     } /* End of isn't utf8 */
4197 #ifdef USE_LOCALE_CTYPE
4198     if (IN_LC_RUNTIME(LC_CTYPE)) {
4199         TAINT;
4200         SvTAINTED_on(dest);
4201     }
4202 #endif
4203     if (dest != source && SvTAINTED(source))
4204         SvTAINT(dest);
4205     SvSETMAGIC(dest);
4206     return NORMAL;
4207 }
4208
4209 PP(pp_lc)
4210 {
4211     dSP;
4212     SV *source = TOPs;
4213     STRLEN len;
4214     STRLEN min;
4215     SV *dest;
4216     const U8 *s;
4217     U8 *d;
4218
4219     SvGETMAGIC(source);
4220
4221     if (   SvPADTMP(source)
4222         && !SvREADONLY(source) && SvPOK(source)
4223         && !DO_UTF8(source)) {
4224
4225         /* We can convert in place, as lowercasing anything in the latin1 range
4226          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4227         dest = source;
4228         s = d = (U8*)SvPV_force_nomg(source, len);
4229         min = len + 1;
4230     } else {
4231         dTARGET;
4232
4233         dest = TARG;
4234
4235         s = (const U8*)SvPV_nomg_const(source, len);
4236         min = len + 1;
4237
4238         SvUPGRADE(dest, SVt_PV);
4239         d = (U8*)SvGROW(dest, min);
4240         (void)SvPOK_only(dest);
4241
4242         SETs(dest);
4243     }
4244
4245 #ifdef USE_LOCALE_CTYPE
4246
4247     if (IN_LC_RUNTIME(LC_CTYPE)) {
4248         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4249     }
4250
4251 #endif
4252
4253     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4254        to check DO_UTF8 again here.  */
4255
4256     if (DO_UTF8(source)) {
4257         const U8 *const send = s + len;
4258         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4259
4260         while (s < send) {
4261             const STRLEN u = UTF8SKIP(s);
4262             STRLEN ulen;
4263
4264 #ifdef USE_LOCALE_CTYPE
4265             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4266 #else
4267             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4268 #endif
4269
4270             /* Here is where we would do context-sensitive actions.  See the
4271              * commit message for 86510fb15 for why there isn't any */
4272
4273             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4274
4275                 /* If the eventually required minimum size outgrows the
4276                  * available space, we need to grow. */
4277                 const UV o = d - (U8*)SvPVX_const(dest);
4278
4279                 /* If someone lowercases one million U+0130s we SvGROW() one
4280                  * million times.  Or we could try guessing how much to
4281                  * allocate without allocating too much.  Such is life.
4282                  * Another option would be to grow an extra byte or two more
4283                  * each time we need to grow, which would cut down the million
4284                  * to 500K, with little waste */
4285                 d = o + (U8*) SvGROW(dest, min);
4286             }
4287
4288             /* Copy the newly lowercased letter to the output buffer we're
4289              * building */
4290             Copy(tmpbuf, d, ulen, U8);
4291             d += ulen;
4292             s += u;
4293         }   /* End of looping through the source string */
4294         SvUTF8_on(dest);
4295         *d = '\0';
4296         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4297     } else {    /* Not utf8 */
4298         if (len) {
4299             const U8 *const send = s + len;
4300
4301             /* Use locale casing if in locale; regular style if not treating
4302              * latin1 as having case; otherwise the latin1 casing.  Do the
4303              * whole thing in a tight loop, for speed, */
4304 #ifdef USE_LOCALE_CTYPE
4305             if (IN_LC_RUNTIME(LC_CTYPE)) {
4306                 for (; s < send; d++, s++)
4307                     *d = toLOWER_LC(*s);
4308             }
4309             else
4310 #endif
4311             if (! IN_UNI_8_BIT) {
4312                 for (; s < send; d++, s++) {
4313                     *d = toLOWER(*s);
4314                 }
4315             }
4316             else {
4317                 for (; s < send; d++, s++) {
4318                     *d = toLOWER_LATIN1(*s);
4319                 }
4320             }
4321         }
4322         if (source != dest) {
4323             *d = '\0';
4324             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4325         }
4326     }
4327 #ifdef USE_LOCALE_CTYPE
4328     if (IN_LC_RUNTIME(LC_CTYPE)) {
4329         TAINT;
4330         SvTAINTED_on(dest);
4331     }
4332 #endif
4333     if (dest != source && SvTAINTED(source))
4334         SvTAINT(dest);
4335     SvSETMAGIC(dest);
4336     return NORMAL;
4337 }
4338
4339 PP(pp_quotemeta)
4340 {
4341     dSP; dTARGET;
4342     SV * const sv = TOPs;
4343     STRLEN len;
4344     const char *s = SvPV_const(sv,len);
4345
4346     SvUTF8_off(TARG);                           /* decontaminate */
4347     if (len) {
4348         char *d;
4349         SvUPGRADE(TARG, SVt_PV);
4350         SvGROW(TARG, (len * 2) + 1);
4351         d = SvPVX(TARG);
4352         if (DO_UTF8(sv)) {
4353             while (len) {
4354                 STRLEN ulen = UTF8SKIP(s);
4355                 bool to_quote = FALSE;
4356
4357                 if (UTF8_IS_INVARIANT(*s)) {
4358                     if (_isQUOTEMETA(*s)) {
4359                         to_quote = TRUE;
4360                     }
4361                 }
4362                 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4363                     if (
4364 #ifdef USE_LOCALE_CTYPE
4365                     /* In locale, we quote all non-ASCII Latin1 chars.
4366                      * Otherwise use the quoting rules */
4367                     
4368                     IN_LC_RUNTIME(LC_CTYPE)
4369                         ||
4370 #endif
4371                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4372                     {
4373                         to_quote = TRUE;
4374                     }
4375                 }
4376                 else if (is_QUOTEMETA_high(s)) {
4377                     to_quote = TRUE;
4378                 }
4379
4380                 if (to_quote) {
4381                     *d++ = '\\';
4382                 }
4383                 if (ulen > len)
4384                     ulen = len;
4385                 len -= ulen;
4386                 while (ulen--)
4387                     *d++ = *s++;
4388             }
4389             SvUTF8_on(TARG);
4390         }
4391         else if (IN_UNI_8_BIT) {
4392             while (len--) {
4393                 if (_isQUOTEMETA(*s))
4394                     *d++ = '\\';
4395                 *d++ = *s++;
4396             }
4397         }
4398         else {
4399             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4400              * including everything above ASCII */
4401             while (len--) {
4402                 if (!isWORDCHAR_A(*s))
4403                     *d++ = '\\';
4404                 *d++ = *s++;
4405             }
4406         }
4407         *d = '\0';
4408         SvCUR_set(TARG, d - SvPVX_const(TARG));
4409         (void)SvPOK_only_UTF8(TARG);
4410     }
4411     else
4412         sv_setpvn(TARG, s, len);
4413     SETTARG;
4414     return NORMAL;
4415 }
4416
4417 PP(pp_fc)
4418 {
4419     dTARGET;
4420     dSP;
4421     SV *source = TOPs;
4422     STRLEN len;
4423     STRLEN min;
4424     SV *dest;
4425     const U8 *s;
4426     const U8 *send;
4427     U8 *d;
4428     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4429 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4430    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4431                                       || UNICODE_DOT_DOT_VERSION > 0)
4432     const bool full_folding = TRUE; /* This variable is here so we can easily
4433                                        move to more generality later */
4434 #else
4435     const bool full_folding = FALSE;
4436 #endif
4437     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4438 #ifdef USE_LOCALE_CTYPE
4439                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4440 #endif
4441     ;
4442
4443     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4444      * You are welcome(?) -Hugmeir
4445      */
4446
4447     SvGETMAGIC(source);
4448
4449     dest = TARG;
4450
4451     if (SvOK(source)) {
4452         s = (const U8*)SvPV_nomg_const(source, len);
4453     } else {
4454         if (ckWARN(WARN_UNINITIALIZED))
4455             report_uninit(source);
4456         s = (const U8*)"";
4457         len = 0;
4458     }
4459
4460     min = len + 1;
4461
4462     SvUPGRADE(dest, SVt_PV);
4463     d = (U8*)SvGROW(dest, min);
4464     (void)SvPOK_only(dest);
4465
4466     SETs(dest);
4467
4468     send = s + len;
4469
4470 #ifdef USE_LOCALE_CTYPE
4471
4472     if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4473         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4474     }
4475
4476 #endif
4477
4478     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4479         while (s < send) {
4480             const STRLEN u = UTF8SKIP(s);
4481             STRLEN ulen;
4482
4483             _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4484
4485             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4486                 const UV o = d - (U8*)SvPVX_const(dest);
4487                 d = o + (U8*) SvGROW(dest, min);
4488             }
4489
4490             Copy(tmpbuf, d, ulen, U8);
4491             d += ulen;
4492             s += u;
4493         }
4494         SvUTF8_on(dest);
4495     } /* Unflagged string */
4496     else if (len) {
4497 #ifdef USE_LOCALE_CTYPE
4498         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4499             if (IN_UTF8_CTYPE_LOCALE) {
4500                 goto do_uni_folding;
4501             }
4502             for (; s < send; d++, s++)
4503                 *d = (U8) toFOLD_LC(*s);
4504         }
4505         else
4506 #endif
4507         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4508             for (; s < send; d++, s++)
4509                 *d = toFOLD(*s);
4510         }
4511         else {
4512 #ifdef USE_LOCALE_CTYPE
4513       do_uni_folding:
4514 #endif
4515             /* For ASCII and the Latin-1 range, there's only two troublesome
4516              * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4517              * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4518              * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4519              * For the rest, the casefold is their lowercase.  */
4520             for (; s < send; d++, s++) {
4521                 if (*s == MICRO_SIGN) {
4522                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4523                      * which is outside of the latin-1 range. There's a couple
4524                      * of ways to deal with this -- khw discusses them in
4525                      * pp_lc/uc, so go there :) What we do here is upgrade what
4526                      * we had already casefolded, then enter an inner loop that
4527                      * appends the rest of the characters as UTF-8. */
4528                     len = d - (U8*)SvPVX_const(dest);
4529                     SvCUR_set(dest, len);
4530                     len = sv_utf8_upgrade_flags_grow(dest,
4531                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4532                                                 /* The max expansion for latin1
4533                                                  * chars is 1 byte becomes 2 */
4534                                                 (send -s) * 2 + 1);
4535                     d = (U8*)SvPVX(dest) + len;
4536
4537                     Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4538                     d += small_mu_len;
4539                     s++;
4540                     for (; s < send; s++) {
4541                         STRLEN ulen;
4542                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4543                         if UVCHR_IS_INVARIANT(fc) {
4544                             if (full_folding
4545                                 && *s == LATIN_SMALL_LETTER_SHARP_S)
4546                             {
4547                                 *d++ = 's';
4548                                 *d++ = 's';
4549                             }
4550                             else
4551                                 *d++ = (U8)fc;
4552                         }
4553                         else {
4554                             Copy(tmpbuf, d, ulen, U8);
4555                             d += ulen;
4556                         }
4557                     }
4558                     break;
4559                 }
4560                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4561                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4562                      * becomes "ss", which may require growing the SV. */
4563                     if (SvLEN(dest) < ++min) {
4564                         const UV o = d - (U8*)SvPVX_const(dest);
4565                         d = o + (U8*) SvGROW(dest, min);
4566                      }
4567                     *(d)++ = 's';
4568                     *d = 's';
4569                 }
4570                 else { /* If it's not one of those two, the fold is their lower
4571                           case */
4572                     *d = toLOWER_LATIN1(*s);
4573                 }
4574              }
4575         }
4576     }
4577     *d = '\0';
4578     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4579
4580 #ifdef USE_LOCALE_CTYPE
4581     if (IN_LC_RUNTIME(LC_CTYPE)) {
4582         TAINT;
4583         SvTAINTED_on(dest);
4584     }
4585 #endif
4586     if (SvTAINTED(source))
4587         SvTAINT(dest);
4588     SvSETMAGIC(dest);
4589     RETURN;
4590 }
4591
4592 /* Arrays. */
4593
4594 PP(pp_aslice)
4595 {
4596     dSP; dMARK; dORIGMARK;
4597     AV *const av = MUTABLE_AV(POPs);
4598     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4599
4600     if (SvTYPE(av) == SVt_PVAV) {
4601         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4602         bool can_preserve = FALSE;
4603
4604         if (localizing) {
4605             MAGIC *mg;
4606             HV *stash;
4607
4608             can_preserve = SvCANEXISTDELETE(av);
4609         }
4610
4611         if (lval && localizing) {
4612             SV **svp;
4613             SSize_t max = -1;
4614             for (svp = MARK + 1; svp <= SP; svp++) {
4615                 const SSize_t elem = SvIV(*svp);
4616                 if (elem > max)
4617                     max = elem;
4618             }
4619             if (max > AvMAX(av))
4620                 av_extend(av, max);
4621         }
4622
4623         while (++MARK <= SP) {
4624             SV **svp;
4625             SSize_t elem = SvIV(*MARK);
4626             bool preeminent = TRUE;
4627
4628             if (localizing && can_preserve) {
4629                 /* If we can determine whether the element exist,
4630                  * Try to preserve the existenceness of a tied array
4631                  * element by using EXISTS and DELETE if possible.
4632                  * Fallback to FETCH and STORE otherwise. */
4633                 preeminent = av_exists(av, elem);
4634             }
4635
4636             svp = av_fetch(av, elem, lval);
4637             if (lval) {
4638                 if (!svp || !*svp)
4639                     DIE(aTHX_ PL_no_aelem, elem);
4640                 if (localizing) {
4641                     if (preeminent)
4642                         save_aelem(av, elem, svp);
4643                     else
4644                         SAVEADELETE(av, elem);
4645                 }
4646             }
4647             *MARK = svp ? *svp : &PL_sv_undef;
4648         }
4649     }
4650     if (GIMME_V != G_ARRAY) {
4651         MARK = ORIGMARK;
4652         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4653         SP = MARK;
4654     }
4655     RETURN;
4656 }
4657
4658 PP(pp_kvaslice)
4659 {
4660     dSP; dMARK;
4661     AV *const av = MUTABLE_AV(POPs);
4662     I32 lval = (PL_op->op_flags & OPf_MOD);
4663     SSize_t items = SP - MARK;
4664
4665     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4666        const I32 flags = is_lvalue_sub();
4667        if (flags) {
4668            if (!(flags & OPpENTERSUB_INARGS))
4669                /* diag_listed_as: Can't modify %s in %s */
4670                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4671            lval = flags;
4672        }
4673     }
4674
4675     MEXTEND(SP,items);
4676     while (items > 1) {
4677         *(MARK+items*2-1) = *(MARK+items);
4678         items--;
4679     }
4680     items = SP-MARK;
4681     SP += items;
4682
4683     while (++MARK <= SP) {
4684         SV **svp;
4685
4686         svp = av_fetch(av, SvIV(*MARK), lval);
4687         if (lval) {
4688             if (!svp || !*svp || *svp == &PL_sv_undef) {
4689                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4690             }
4691             *MARK = sv_mortalcopy(*MARK);
4692         }
4693         *++MARK = svp ? *svp : &PL_sv_undef;
4694     }
4695     if (GIMME_V != G_ARRAY) {
4696         MARK = SP - items*2;
4697         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4698         SP = MARK;
4699     }
4700     RETURN;
4701 }
4702
4703
4704 PP(pp_aeach)
4705 {
4706     dSP;
4707     AV *array = MUTABLE_AV(POPs);
4708     const U8 gimme = GIMME_V;