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