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