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