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