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