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