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