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