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