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