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