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