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