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