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