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