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