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