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