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