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