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