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