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