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