This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e587f7d1c3449c65bddb53a27b2cb9b96432ce28
[perl5.git] / pp.c
1 /*    pp.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * 'It's a big house this, and very peculiar.  Always a bit more
13  *  to discover, and no knowing what you'll find round a corner.
14  *  And Elves, sir!'                            --Samwise Gamgee
15  *
16  *     [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
17  */
18
19 /* This file contains general pp ("push/pop") functions that execute the
20  * opcodes that make up a perl program. A typical pp function expects to
21  * find its arguments on the stack, and usually pushes its results onto
22  * the stack, hence the 'pp' terminology. Each OP structure contains
23  * a pointer to the relevant pp_foo() function.
24  */
25
26 #include "EXTERN.h"
27 #define PERL_IN_PP_C
28 #include "perl.h"
29 #include "keywords.h"
30
31 #include "reentr.h"
32 #include "regcharclass.h"
33
34 /* XXX I can't imagine anyone who doesn't have this actually _needs_
35    it, since pid_t is an integral type.
36    --AD  2/20/1998
37 */
38 #ifdef NEED_GETPID_PROTO
39 extern Pid_t getpid (void);
40 #endif
41
42 /*
43  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44  * This switches them over to IEEE.
45  */
46 #if defined(LIBM_LIB_VERSION)
47     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
48 #endif
49
50 /* variations on pp_null */
51
52 PP(pp_stub)
53 {
54     dVAR;
55     dSP;
56     if (GIMME_V == G_SCALAR)
57         XPUSHs(&PL_sv_undef);
58     RETURN;
59 }
60
61 /* Pushy stuff. */
62
63 PP(pp_padav)
64 {
65     dVAR; dSP; dTARGET;
66     I32 gimme;
67     assert(SvTYPE(TARG) == SVt_PVAV);
68     if (PL_op->op_private & OPpLVAL_INTRO)
69         if (!(PL_op->op_private & OPpPAD_STATE))
70             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
71     EXTEND(SP, 1);
72     if (PL_op->op_flags & OPf_REF) {
73         PUSHs(TARG);
74         RETURN;
75     } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
76        const I32 flags = is_lvalue_sub();
77        if (flags && !(flags & OPpENTERSUB_INARGS)) {
78         if (GIMME == G_SCALAR)
79             /* diag_listed_as: Can't return %s to lvalue scalar context */
80             Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
81         PUSHs(TARG);
82         RETURN;
83        }
84     }
85     gimme = GIMME_V;
86     if (gimme == G_ARRAY) {
87         const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
88         EXTEND(SP, maxarg);
89         if (SvMAGICAL(TARG)) {
90             U32 i;
91             for (i=0; i < (U32)maxarg; i++) {
92                 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
93                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
94             }
95         }
96         else {
97             Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
98         }
99         SP += maxarg;
100     }
101     else if (gimme == G_SCALAR) {
102         SV* const sv = sv_newmortal();
103         const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
104         sv_setiv(sv, maxarg);
105         PUSHs(sv);
106     }
107     RETURN;
108 }
109
110 PP(pp_padhv)
111 {
112     dVAR; dSP; dTARGET;
113     I32 gimme;
114
115     assert(SvTYPE(TARG) == SVt_PVHV);
116     XPUSHs(TARG);
117     if (PL_op->op_private & OPpLVAL_INTRO)
118         if (!(PL_op->op_private & OPpPAD_STATE))
119             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
120     if (PL_op->op_flags & OPf_REF)
121         RETURN;
122     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
123       const I32 flags = is_lvalue_sub();
124       if (flags && !(flags & OPpENTERSUB_INARGS)) {
125         if (GIMME == G_SCALAR)
126             /* diag_listed_as: Can't return %s to lvalue scalar context */
127             Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
128         RETURN;
129       }
130     }
131     gimme = GIMME_V;
132     if (gimme == G_ARRAY) {
133         RETURNOP(Perl_do_kv(aTHX));
134     }
135     else if ((PL_op->op_private & OPpTRUEBOOL
136           || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
137              && block_gimme() == G_VOID  ))
138           && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
139         SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
140     else if (gimme == G_SCALAR) {
141         SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
142         SETs(sv);
143     }
144     RETURN;
145 }
146
147 PP(pp_padcv)
148 {
149     dVAR; dSP; dTARGET;
150     assert(SvTYPE(TARG) == SVt_PVCV);
151     XPUSHs(TARG);
152     RETURN;
153 }
154
155 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(AvARRAY(PL_comppad_name)[ARGTARG], PERL_MAGIC_proto);
167     assert(SvTYPE(TARG) == SVt_PVCV);
168     assert(mg);
169     assert(mg->mg_obj);
170     if (CvISXSUB(mg->mg_obj)) { /* constant */
171         /* XXX Should we clone it here? */
172         /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
173            to introcv and remove the SvPADSTALE_off. */
174         SAVEPADSVANDMORTALIZE(ARGTARG);
175         PAD_SVl(ARGTARG) = mg->mg_obj;
176     }
177     else {
178         if (CvROOT(mg->mg_obj)) {
179             assert(CvCLONE(mg->mg_obj));
180             assert(!CvCLONED(mg->mg_obj));
181         }
182         cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
183         SAVECLEARSV(PAD_SVl(ARGTARG));
184     }
185     return NORMAL;
186 }
187
188 /* Translations. */
189
190 static const char S_no_symref_sv[] =
191     "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
192
193 /* In some cases this function inspects PL_op.  If this function is called
194    for new op types, more bool parameters may need to be added in place of
195    the checks.
196
197    When noinit is true, the absence of a gv will cause a retval of undef.
198    This is unrelated to the cv-to-gv assignment case.
199 */
200
201 static SV *
202 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
203               const bool noinit)
204 {
205     dVAR;
206     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
207     if (SvROK(sv)) {
208         if (SvAMAGIC(sv)) {
209             sv = amagic_deref_call(sv, to_gv_amg);
210         }
211       wasref:
212         sv = SvRV(sv);
213         if (SvTYPE(sv) == SVt_PVIO) {
214             GV * const gv = MUTABLE_GV(sv_newmortal());
215             gv_init(gv, 0, "__ANONIO__", 10, 0);
216             GvIOp(gv) = MUTABLE_IO(sv);
217             SvREFCNT_inc_void_NN(sv);
218             sv = MUTABLE_SV(gv);
219         }
220         else if (!isGV_with_GP(sv))
221             return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
222     }
223     else {
224         if (!isGV_with_GP(sv)) {
225             if (!SvOK(sv)) {
226                 /* If this is a 'my' scalar and flag is set then vivify
227                  * NI-S 1999/05/07
228                  */
229                 if (vivify_sv && sv != &PL_sv_undef) {
230                     GV *gv;
231                     if (SvREADONLY(sv))
232                         Perl_croak_no_modify(aTHX);
233                     if (cUNOP->op_targ) {
234                         SV * const namesv = PAD_SV(cUNOP->op_targ);
235                         gv = MUTABLE_GV(newSV(0));
236                         gv_init_sv(gv, CopSTASH(PL_curcop), namesv, 0);
237                     }
238                     else {
239                         const char * const name = CopSTASHPV(PL_curcop);
240                         gv = newGVgen_flags(name,
241                                         HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
242                     }
243                     prepare_SV_for_RV(sv);
244                     SvRV_set(sv, MUTABLE_SV(gv));
245                     SvROK_on(sv);
246                     SvSETMAGIC(sv);
247                     goto wasref;
248                 }
249                 if (PL_op->op_flags & OPf_REF || strict)
250                     return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
251                 if (ckWARN(WARN_UNINITIALIZED))
252                     report_uninit(sv);
253                 return &PL_sv_undef;
254             }
255             if (noinit)
256             {
257                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
258                            sv, GV_ADDMG, SVt_PVGV
259                    ))))
260                     return &PL_sv_undef;
261             }
262             else {
263                 if (strict)
264                     return
265                      (SV *)Perl_die(aTHX_
266                             S_no_symref_sv,
267                             sv,
268                             (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
269                             "a symbol"
270                            );
271                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
272                     == OPpDONT_INIT_GV) {
273                     /* We are the target of a coderef assignment.  Return
274                        the scalar unchanged, and let pp_sasssign deal with
275                        things.  */
276                     return sv;
277                 }
278                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
279             }
280             /* FAKE globs in the symbol table cause weird bugs (#77810) */
281             SvFAKE_off(sv);
282         }
283     }
284     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
285         SV *newsv = sv_newmortal();
286         sv_setsv_flags(newsv, sv, 0);
287         SvFAKE_off(newsv);
288         sv = newsv;
289     }
290     return sv;
291 }
292
293 PP(pp_rv2gv)
294 {
295     dVAR; dSP; dTOPss;
296
297     sv = S_rv2gv(aTHX_
298           sv, PL_op->op_private & OPpDEREF,
299           PL_op->op_private & HINT_STRICT_REFS,
300           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
301              || PL_op->op_type == OP_READLINE
302          );
303     if (PL_op->op_private & OPpLVAL_INTRO)
304         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
305     SETs(sv);
306     RETURN;
307 }
308
309 /* Helper function for pp_rv2sv and pp_rv2av  */
310 GV *
311 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
312                 const svtype type, SV ***spp)
313 {
314     dVAR;
315     GV *gv;
316
317     PERL_ARGS_ASSERT_SOFTREF2XV;
318
319     if (PL_op->op_private & HINT_STRICT_REFS) {
320         if (SvOK(sv))
321             Perl_die(aTHX_ S_no_symref_sv, sv,
322                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
323         else
324             Perl_die(aTHX_ PL_no_usym, what);
325     }
326     if (!SvOK(sv)) {
327         if (
328           PL_op->op_flags & OPf_REF
329         )
330             Perl_die(aTHX_ PL_no_usym, what);
331         if (ckWARN(WARN_UNINITIALIZED))
332             report_uninit(sv);
333         if (type != SVt_PV && GIMME_V == G_ARRAY) {
334             (*spp)--;
335             return NULL;
336         }
337         **spp = &PL_sv_undef;
338         return NULL;
339     }
340     if ((PL_op->op_flags & OPf_SPECIAL) &&
341         !(PL_op->op_flags & OPf_MOD))
342         {
343             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
344                 {
345                     **spp = &PL_sv_undef;
346                     return NULL;
347                 }
348         }
349     else {
350         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
351     }
352     return gv;
353 }
354
355 PP(pp_rv2sv)
356 {
357     dVAR; dSP; dTOPss;
358     GV *gv = NULL;
359
360     SvGETMAGIC(sv);
361     if (SvROK(sv)) {
362         if (SvAMAGIC(sv)) {
363             sv = amagic_deref_call(sv, to_sv_amg);
364         }
365
366         sv = SvRV(sv);
367         switch (SvTYPE(sv)) {
368         case SVt_PVAV:
369         case SVt_PVHV:
370         case SVt_PVCV:
371         case SVt_PVFM:
372         case SVt_PVIO:
373             DIE(aTHX_ "Not a SCALAR reference");
374         default: NOOP;
375         }
376     }
377     else {
378         gv = MUTABLE_GV(sv);
379
380         if (!isGV_with_GP(gv)) {
381             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
382             if (!gv)
383                 RETURN;
384         }
385         sv = GvSVn(gv);
386     }
387     if (PL_op->op_flags & OPf_MOD) {
388         if (PL_op->op_private & OPpLVAL_INTRO) {
389             if (cUNOP->op_first->op_type == OP_NULL)
390                 sv = save_scalar(MUTABLE_GV(TOPs));
391             else if (gv)
392                 sv = save_scalar(gv);
393             else
394                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
395         }
396         else if (PL_op->op_private & OPpDEREF)
397             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
398     }
399     SETs(sv);
400     RETURN;
401 }
402
403 PP(pp_av2arylen)
404 {
405     dVAR; dSP;
406     AV * const av = MUTABLE_AV(TOPs);
407     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
408     if (lvalue) {
409         SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
410         if (!*sv) {
411             *sv = newSV_type(SVt_PVMG);
412             sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
413         }
414         SETs(*sv);
415     } else {
416         SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
417     }
418     RETURN;
419 }
420
421 PP(pp_pos)
422 {
423     dVAR; dSP; dPOPss;
424
425     if (PL_op->op_flags & OPf_MOD || LVRET) {
426         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
427         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
428         LvTYPE(ret) = '.';
429         LvTARG(ret) = SvREFCNT_inc_simple(sv);
430         PUSHs(ret);    /* no SvSETMAGIC */
431         RETURN;
432     }
433     else {
434         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
435             const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
436             if (mg && mg->mg_len >= 0) {
437                 dTARGET;
438                 I32 i = mg->mg_len;
439                 if (DO_UTF8(sv))
440                     sv_pos_b2u(sv, &i);
441                 PUSHi(i);
442                 RETURN;
443             }
444         }
445         RETPUSHUNDEF;
446     }
447 }
448
449 PP(pp_rv2cv)
450 {
451     dVAR; dSP;
452     GV *gv;
453     HV *stash_unused;
454     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
455         ? GV_ADDMG
456         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
457             ? GV_ADD|GV_NOEXPAND
458             : GV_ADD;
459     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
460     /* (But not in defined().) */
461
462     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
463     if (cv) NOOP;
464     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
465         cv = MUTABLE_CV(gv);
466     }    
467     else
468         cv = MUTABLE_CV(&PL_sv_undef);
469     SETs(MUTABLE_SV(cv));
470     RETURN;
471 }
472
473 PP(pp_prototype)
474 {
475     dVAR; dSP;
476     CV *cv;
477     HV *stash;
478     GV *gv;
479     SV *ret = &PL_sv_undef;
480
481     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
482     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
483         const char * s = SvPVX_const(TOPs);
484         if (strnEQ(s, "CORE::", 6)) {
485             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
486             if (!code || code == -KEY_CORE)
487                 DIE(aTHX_ "Can't find an opnumber for \"%"SVf"\"",
488                     SVfARG(newSVpvn_flags(
489                         s+6, SvCUR(TOPs)-6, SvFLAGS(TOPs) & SVf_UTF8
490                     )));
491             {
492                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
493                 if (sv) ret = sv;
494             }
495             goto set;
496         }
497     }
498     cv = sv_2cv(TOPs, &stash, &gv, 0);
499     if (cv && SvPOK(cv))
500         ret = newSVpvn_flags(
501             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
502         );
503   set:
504     SETs(ret);
505     RETURN;
506 }
507
508 PP(pp_anoncode)
509 {
510     dVAR; dSP;
511     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
512     if (CvCLONE(cv))
513         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
514     EXTEND(SP,1);
515     PUSHs(MUTABLE_SV(cv));
516     RETURN;
517 }
518
519 PP(pp_srefgen)
520 {
521     dVAR; dSP;
522     *SP = refto(*SP);
523     RETURN;
524 }
525
526 PP(pp_refgen)
527 {
528     dVAR; dSP; dMARK;
529     if (GIMME != G_ARRAY) {
530         if (++MARK <= SP)
531             *MARK = *SP;
532         else
533             *MARK = &PL_sv_undef;
534         *MARK = refto(*MARK);
535         SP = MARK;
536         RETURN;
537     }
538     EXTEND_MORTAL(SP - MARK);
539     while (++MARK <= SP)
540         *MARK = refto(*MARK);
541     RETURN;
542 }
543
544 STATIC SV*
545 S_refto(pTHX_ SV *sv)
546 {
547     dVAR;
548     SV* rv;
549
550     PERL_ARGS_ASSERT_REFTO;
551
552     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
553         if (LvTARGLEN(sv))
554             vivify_defelem(sv);
555         if (!(sv = LvTARG(sv)))
556             sv = &PL_sv_undef;
557         else
558             SvREFCNT_inc_void_NN(sv);
559     }
560     else if (SvTYPE(sv) == SVt_PVAV) {
561         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
562             av_reify(MUTABLE_AV(sv));
563         SvTEMP_off(sv);
564         SvREFCNT_inc_void_NN(sv);
565     }
566     else if (SvPADTMP(sv) && !IS_PADGV(sv))
567         sv = newSVsv(sv);
568     else {
569         SvTEMP_off(sv);
570         SvREFCNT_inc_void_NN(sv);
571     }
572     rv = sv_newmortal();
573     sv_upgrade(rv, SVt_IV);
574     SvRV_set(rv, sv);
575     SvROK_on(rv);
576     return rv;
577 }
578
579 PP(pp_ref)
580 {
581     dVAR; dSP; dTARGET;
582     SV * const sv = POPs;
583
584     if (sv)
585         SvGETMAGIC(sv);
586
587     if (!sv || !SvROK(sv))
588         RETPUSHNO;
589
590     (void)sv_ref(TARG,SvRV(sv),TRUE);
591     PUSHTARG;
592     RETURN;
593 }
594
595 PP(pp_bless)
596 {
597     dVAR; dSP;
598     HV *stash;
599
600     if (MAXARG == 1)
601       curstash:
602         stash = CopSTASH(PL_curcop);
603     else {
604         SV * const ssv = POPs;
605         STRLEN len;
606         const char *ptr;
607
608         if (!ssv) goto curstash;
609         if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
610             Perl_croak(aTHX_ "Attempt to bless into a reference");
611         ptr = SvPV_const(ssv,len);
612         if (len == 0)
613             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
614                            "Explicit blessing to '' (assuming package main)");
615         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
616     }
617
618     (void)sv_bless(TOPs, stash);
619     RETURN;
620 }
621
622 PP(pp_gelem)
623 {
624     dVAR; dSP;
625
626     SV *sv = POPs;
627     STRLEN len;
628     const char * const elem = SvPV_const(sv, len);
629     GV * const gv = MUTABLE_GV(POPs);
630     SV * tmpRef = NULL;
631
632     sv = NULL;
633     if (elem) {
634         /* elem will always be NUL terminated.  */
635         const char * const second_letter = elem + 1;
636         switch (*elem) {
637         case 'A':
638             if (len == 5 && strEQ(second_letter, "RRAY"))
639                 tmpRef = MUTABLE_SV(GvAV(gv));
640             break;
641         case 'C':
642             if (len == 4 && strEQ(second_letter, "ODE"))
643                 tmpRef = MUTABLE_SV(GvCVu(gv));
644             break;
645         case 'F':
646             if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
647                 /* finally deprecated in 5.8.0 */
648                 deprecate("*glob{FILEHANDLE}");
649                 tmpRef = MUTABLE_SV(GvIOp(gv));
650             }
651             else
652                 if (len == 6 && strEQ(second_letter, "ORMAT"))
653                     tmpRef = MUTABLE_SV(GvFORM(gv));
654             break;
655         case 'G':
656             if (len == 4 && strEQ(second_letter, "LOB"))
657                 tmpRef = MUTABLE_SV(gv);
658             break;
659         case 'H':
660             if (len == 4 && strEQ(second_letter, "ASH"))
661                 tmpRef = MUTABLE_SV(GvHV(gv));
662             break;
663         case 'I':
664             if (*second_letter == 'O' && !elem[2] && len == 2)
665                 tmpRef = MUTABLE_SV(GvIOp(gv));
666             break;
667         case 'N':
668             if (len == 4 && strEQ(second_letter, "AME"))
669                 sv = newSVhek(GvNAME_HEK(gv));
670             break;
671         case 'P':
672             if (len == 7 && strEQ(second_letter, "ACKAGE")) {
673                 const HV * const stash = GvSTASH(gv);
674                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
675                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
676             }
677             break;
678         case 'S':
679             if (len == 6 && strEQ(second_letter, "CALAR"))
680                 tmpRef = GvSVn(gv);
681             break;
682         }
683     }
684     if (tmpRef)
685         sv = newRV(tmpRef);
686     if (sv)
687         sv_2mortal(sv);
688     else
689         sv = &PL_sv_undef;
690     XPUSHs(sv);
691     RETURN;
692 }
693
694 /* Pattern matching */
695
696 PP(pp_study)
697 {
698     dVAR; dSP; dPOPss;
699     STRLEN len;
700
701     (void)SvPV(sv, len);
702     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
703         /* Historically, study was skipped in these cases. */
704         RETPUSHNO;
705     }
706
707     /* Make study a no-op. It's no longer useful and its existence
708        complicates matters elsewhere. */
709     RETPUSHYES;
710 }
711
712 PP(pp_trans)
713 {
714     dVAR; dSP; dTARG;
715     SV *sv;
716
717     if (PL_op->op_flags & OPf_STACKED)
718         sv = POPs;
719     else if (PL_op->op_private & OPpTARGET_MY)
720         sv = GETTARGET;
721     else {
722         sv = DEFSV;
723         EXTEND(SP,1);
724     }
725     if(PL_op->op_type == OP_TRANSR) {
726         STRLEN len;
727         const char * const pv = SvPV(sv,len);
728         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
729         do_trans(newsv);
730         PUSHs(newsv);
731     }
732     else {
733         TARG = sv_newmortal();
734         PUSHi(do_trans(sv));
735     }
736     RETURN;
737 }
738
739 /* Lvalue operators. */
740
741 static void
742 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
743 {
744     dVAR;
745     STRLEN len;
746     char *s;
747
748     PERL_ARGS_ASSERT_DO_CHOMP;
749
750     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
751         return;
752     if (SvTYPE(sv) == SVt_PVAV) {
753         I32 i;
754         AV *const av = MUTABLE_AV(sv);
755         const I32 max = AvFILL(av);
756
757         for (i = 0; i <= max; i++) {
758             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
759             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
760                 do_chomp(retval, sv, chomping);
761         }
762         return;
763     }
764     else if (SvTYPE(sv) == SVt_PVHV) {
765         HV* const hv = MUTABLE_HV(sv);
766         HE* entry;
767         (void)hv_iterinit(hv);
768         while ((entry = hv_iternext(hv)))
769             do_chomp(retval, hv_iterval(hv,entry), chomping);
770         return;
771     }
772     else if (SvREADONLY(sv)) {
773         if (SvFAKE(sv)) {
774             /* SV is copy-on-write */
775             sv_force_normal_flags(sv, 0);
776         }
777         else
778             Perl_croak_no_modify(aTHX);
779     }
780
781     if (PL_encoding) {
782         if (!SvUTF8(sv)) {
783             /* XXX, here sv is utf8-ized as a side-effect!
784                If encoding.pm is used properly, almost string-generating
785                operations, including literal strings, chr(), input data, etc.
786                should have been utf8-ized already, right?
787             */
788             sv_recode_to_utf8(sv, PL_encoding);
789         }
790     }
791
792     s = SvPV(sv, len);
793     if (chomping) {
794         char *temp_buffer = NULL;
795         SV *svrecode = NULL;
796
797         if (s && len) {
798             s += --len;
799             if (RsPARA(PL_rs)) {
800                 if (*s != '\n')
801                     goto nope;
802                 ++SvIVX(retval);
803                 while (len && s[-1] == '\n') {
804                     --len;
805                     --s;
806                     ++SvIVX(retval);
807                 }
808             }
809             else {
810                 STRLEN rslen, rs_charlen;
811                 const char *rsptr = SvPV_const(PL_rs, rslen);
812
813                 rs_charlen = SvUTF8(PL_rs)
814                     ? sv_len_utf8(PL_rs)
815                     : rslen;
816
817                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
818                     /* Assumption is that rs is shorter than the scalar.  */
819                     if (SvUTF8(PL_rs)) {
820                         /* RS is utf8, scalar is 8 bit.  */
821                         bool is_utf8 = TRUE;
822                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
823                                                              &rslen, &is_utf8);
824                         if (is_utf8) {
825                             /* Cannot downgrade, therefore cannot possibly match
826                              */
827                             assert (temp_buffer == rsptr);
828                             temp_buffer = NULL;
829                             goto nope;
830                         }
831                         rsptr = temp_buffer;
832                     }
833                     else if (PL_encoding) {
834                         /* RS is 8 bit, encoding.pm is used.
835                          * Do not recode PL_rs as a side-effect. */
836                         svrecode = newSVpvn(rsptr, rslen);
837                         sv_recode_to_utf8(svrecode, PL_encoding);
838                         rsptr = SvPV_const(svrecode, rslen);
839                         rs_charlen = sv_len_utf8(svrecode);
840                     }
841                     else {
842                         /* RS is 8 bit, scalar is utf8.  */
843                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
844                         rsptr = temp_buffer;
845                     }
846                 }
847                 if (rslen == 1) {
848                     if (*s != *rsptr)
849                         goto nope;
850                     ++SvIVX(retval);
851                 }
852                 else {
853                     if (len < rslen - 1)
854                         goto nope;
855                     len -= rslen - 1;
856                     s -= rslen - 1;
857                     if (memNE(s, rsptr, rslen))
858                         goto nope;
859                     SvIVX(retval) += rs_charlen;
860                 }
861             }
862             s = SvPV_force_nomg_nolen(sv);
863             SvCUR_set(sv, len);
864             *SvEND(sv) = '\0';
865             SvNIOK_off(sv);
866             SvSETMAGIC(sv);
867         }
868     nope:
869
870         SvREFCNT_dec(svrecode);
871
872         Safefree(temp_buffer);
873     } else {
874         if (len && !SvPOK(sv))
875             s = SvPV_force_nomg(sv, len);
876         if (DO_UTF8(sv)) {
877             if (s && len) {
878                 char * const send = s + len;
879                 char * const start = s;
880                 s = send - 1;
881                 while (s > start && UTF8_IS_CONTINUATION(*s))
882                     s--;
883                 if (is_utf8_string((U8*)s, send - s)) {
884                     sv_setpvn(retval, s, send - s);
885                     *s = '\0';
886                     SvCUR_set(sv, s - start);
887                     SvNIOK_off(sv);
888                     SvUTF8_on(retval);
889                 }
890             }
891             else
892                 sv_setpvs(retval, "");
893         }
894         else if (s && len) {
895             s += --len;
896             sv_setpvn(retval, s, 1);
897             *s = '\0';
898             SvCUR_set(sv, len);
899             SvUTF8_off(sv);
900             SvNIOK_off(sv);
901         }
902         else
903             sv_setpvs(retval, "");
904         SvSETMAGIC(sv);
905     }
906 }
907
908 PP(pp_schop)
909 {
910     dVAR; dSP; dTARGET;
911     const bool chomping = PL_op->op_type == OP_SCHOMP;
912
913     if (chomping)
914         sv_setiv(TARG, 0);
915     do_chomp(TARG, TOPs, chomping);
916     SETTARG;
917     RETURN;
918 }
919
920 PP(pp_chop)
921 {
922     dVAR; dSP; dMARK; dTARGET; dORIGMARK;
923     const bool chomping = PL_op->op_type == OP_CHOMP;
924
925     if (chomping)
926         sv_setiv(TARG, 0);
927     while (MARK < SP)
928         do_chomp(TARG, *++MARK, chomping);
929     SP = ORIGMARK;
930     XPUSHTARG;
931     RETURN;
932 }
933
934 PP(pp_undef)
935 {
936     dVAR; dSP;
937     SV *sv;
938
939     if (!PL_op->op_private) {
940         EXTEND(SP, 1);
941         RETPUSHUNDEF;
942     }
943
944     sv = POPs;
945     if (!sv)
946         RETPUSHUNDEF;
947
948     SV_CHECK_THINKFIRST_COW_DROP(sv);
949
950     switch (SvTYPE(sv)) {
951     case SVt_NULL:
952         break;
953     case SVt_PVAV:
954         av_undef(MUTABLE_AV(sv));
955         break;
956     case SVt_PVHV:
957         hv_undef(MUTABLE_HV(sv));
958         break;
959     case SVt_PVCV:
960         if (cv_const_sv((const CV *)sv))
961             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
962                           "Constant subroutine %"SVf" undefined",
963                            SVfARG(CvANON((const CV *)sv)
964                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
965                              : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV *)sv))))));
966         /* FALLTHROUGH */
967     case SVt_PVFM:
968         {
969             /* let user-undef'd sub keep its identity */
970             GV* const gv = CvGV((const CV *)sv);
971             HEK * const hek = CvNAME_HEK((CV *)sv);
972             if (hek) share_hek_hek(hek);
973             cv_undef(MUTABLE_CV(sv));
974             if (gv) CvGV_set(MUTABLE_CV(sv), gv);
975             else if (hek) {
976                 SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
977                 CvNAMED_on(sv);
978             }
979         }
980         break;
981     case SVt_PVGV:
982         if (SvFAKE(sv)) {
983             SvSetMagicSV(sv, &PL_sv_undef);
984             break;
985         }
986         else if (isGV_with_GP(sv)) {
987             GP *gp;
988             HV *stash;
989
990             /* undef *Pkg::meth_name ... */
991             bool method_changed
992              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
993               && HvENAME_get(stash);
994             /* undef *Foo:: */
995             if((stash = GvHV((const GV *)sv))) {
996                 if(HvENAME_get(stash))
997                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
998                 else stash = NULL;
999             }
1000
1001             gp_free(MUTABLE_GV(sv));
1002             Newxz(gp, 1, GP);
1003             GvGP_set(sv, gp_ref(gp));
1004             GvSV(sv) = newSV(0);
1005             GvLINE(sv) = CopLINE(PL_curcop);
1006             GvEGV(sv) = MUTABLE_GV(sv);
1007             GvMULTI_on(sv);
1008
1009             if(stash)
1010                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1011             stash = NULL;
1012             /* undef *Foo::ISA */
1013             if( strEQ(GvNAME((const GV *)sv), "ISA")
1014              && (stash = GvSTASH((const GV *)sv))
1015              && (method_changed || HvENAME(stash)) )
1016                 mro_isa_changed_in(stash);
1017             else if(method_changed)
1018                 mro_method_changed_in(
1019                  GvSTASH((const GV *)sv)
1020                 );
1021
1022             break;
1023         }
1024         /* FALL THROUGH */
1025     default:
1026         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1027             SvPV_free(sv);
1028             SvPV_set(sv, NULL);
1029             SvLEN_set(sv, 0);
1030         }
1031         SvOK_off(sv);
1032         SvSETMAGIC(sv);
1033     }
1034
1035     RETPUSHUNDEF;
1036 }
1037
1038 PP(pp_postinc)
1039 {
1040     dVAR; dSP; dTARGET;
1041     const bool inc =
1042         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1043     if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1044         Perl_croak_no_modify(aTHX);
1045     if (SvROK(TOPs))
1046         TARG = sv_newmortal();
1047     sv_setsv(TARG, TOPs);
1048     if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1049         && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1050     {
1051         SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1052         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1053     }
1054     else if (inc)
1055         sv_inc_nomg(TOPs);
1056     else sv_dec_nomg(TOPs);
1057     SvSETMAGIC(TOPs);
1058     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1059     if (inc && !SvOK(TARG))
1060         sv_setiv(TARG, 0);
1061     SETs(TARG);
1062     return NORMAL;
1063 }
1064
1065 /* Ordinary operators. */
1066
1067 PP(pp_pow)
1068 {
1069     dVAR; dSP; dATARGET; SV *svl, *svr;
1070 #ifdef PERL_PRESERVE_IVUV
1071     bool is_int = 0;
1072 #endif
1073     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1074     svr = TOPs;
1075     svl = TOPm1s;
1076 #ifdef PERL_PRESERVE_IVUV
1077     /* For integer to integer power, we do the calculation by hand wherever
1078        we're sure it is safe; otherwise we call pow() and try to convert to
1079        integer afterwards. */
1080     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1081                 UV power;
1082                 bool baseuok;
1083                 UV baseuv;
1084
1085                 if (SvUOK(svr)) {
1086                     power = SvUVX(svr);
1087                 } else {
1088                     const IV iv = SvIVX(svr);
1089                     if (iv >= 0) {
1090                         power = iv;
1091                     } else {
1092                         goto float_it; /* Can't do negative powers this way.  */
1093                     }
1094                 }
1095
1096                 baseuok = SvUOK(svl);
1097                 if (baseuok) {
1098                     baseuv = SvUVX(svl);
1099                 } else {
1100                     const IV iv = SvIVX(svl);
1101                     if (iv >= 0) {
1102                         baseuv = iv;
1103                         baseuok = TRUE; /* effectively it's a UV now */
1104                     } else {
1105                         baseuv = -iv; /* abs, baseuok == false records sign */
1106                     }
1107                 }
1108                 /* now we have integer ** positive integer. */
1109                 is_int = 1;
1110
1111                 /* foo & (foo - 1) is zero only for a power of 2.  */
1112                 if (!(baseuv & (baseuv - 1))) {
1113                     /* We are raising power-of-2 to a positive integer.
1114                        The logic here will work for any base (even non-integer
1115                        bases) but it can be less accurate than
1116                        pow (base,power) or exp (power * log (base)) when the
1117                        intermediate values start to spill out of the mantissa.
1118                        With powers of 2 we know this can't happen.
1119                        And powers of 2 are the favourite thing for perl
1120                        programmers to notice ** not doing what they mean. */
1121                     NV result = 1.0;
1122                     NV base = baseuok ? baseuv : -(NV)baseuv;
1123
1124                     if (power & 1) {
1125                         result *= base;
1126                     }
1127                     while (power >>= 1) {
1128                         base *= base;
1129                         if (power & 1) {
1130                             result *= base;
1131                         }
1132                     }
1133                     SP--;
1134                     SETn( result );
1135                     SvIV_please_nomg(svr);
1136                     RETURN;
1137                 } else {
1138                     unsigned int highbit = 8 * sizeof(UV);
1139                     unsigned int diff = 8 * sizeof(UV);
1140                     while (diff >>= 1) {
1141                         highbit -= diff;
1142                         if (baseuv >> highbit) {
1143                             highbit += diff;
1144                         }
1145                     }
1146                     /* we now have baseuv < 2 ** highbit */
1147                     if (power * highbit <= 8 * sizeof(UV)) {
1148                         /* result will definitely fit in UV, so use UV math
1149                            on same algorithm as above */
1150                         UV result = 1;
1151                         UV base = baseuv;
1152                         const bool odd_power = cBOOL(power & 1);
1153                         if (odd_power) {
1154                             result *= base;
1155                         }
1156                         while (power >>= 1) {
1157                             base *= base;
1158                             if (power & 1) {
1159                                 result *= base;
1160                             }
1161                         }
1162                         SP--;
1163                         if (baseuok || !odd_power)
1164                             /* answer is positive */
1165                             SETu( result );
1166                         else if (result <= (UV)IV_MAX)
1167                             /* answer negative, fits in IV */
1168                             SETi( -(IV)result );
1169                         else if (result == (UV)IV_MIN) 
1170                             /* 2's complement assumption: special case IV_MIN */
1171                             SETi( IV_MIN );
1172                         else
1173                             /* answer negative, doesn't fit */
1174                             SETn( -(NV)result );
1175                         RETURN;
1176                     } 
1177                 }
1178     }
1179   float_it:
1180 #endif    
1181     {
1182         NV right = SvNV_nomg(svr);
1183         NV left  = SvNV_nomg(svl);
1184         (void)POPs;
1185
1186 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1187     /*
1188     We are building perl with long double support and are on an AIX OS
1189     afflicted with a powl() function that wrongly returns NaNQ for any
1190     negative base.  This was reported to IBM as PMR #23047-379 on
1191     03/06/2006.  The problem exists in at least the following versions
1192     of AIX and the libm fileset, and no doubt others as well:
1193
1194         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1195         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1196         AIX 5.2.0           bos.adt.libm 5.2.0.85
1197
1198     So, until IBM fixes powl(), we provide the following workaround to
1199     handle the problem ourselves.  Our logic is as follows: for
1200     negative bases (left), we use fmod(right, 2) to check if the
1201     exponent is an odd or even integer:
1202
1203         - if odd,  powl(left, right) == -powl(-left, right)
1204         - if even, powl(left, right) ==  powl(-left, right)
1205
1206     If the exponent is not an integer, the result is rightly NaNQ, so
1207     we just return that (as NV_NAN).
1208     */
1209
1210         if (left < 0.0) {
1211             NV mod2 = Perl_fmod( right, 2.0 );
1212             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1213                 SETn( -Perl_pow( -left, right) );
1214             } else if (mod2 == 0.0) {           /* even integer */
1215                 SETn( Perl_pow( -left, right) );
1216             } else {                            /* fractional power */
1217                 SETn( NV_NAN );
1218             }
1219         } else {
1220             SETn( Perl_pow( left, right) );
1221         }
1222 #else
1223         SETn( Perl_pow( left, right) );
1224 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1225
1226 #ifdef PERL_PRESERVE_IVUV
1227         if (is_int)
1228             SvIV_please_nomg(svr);
1229 #endif
1230         RETURN;
1231     }
1232 }
1233
1234 PP(pp_multiply)
1235 {
1236     dVAR; dSP; dATARGET; SV *svl, *svr;
1237     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1238     svr = TOPs;
1239     svl = TOPm1s;
1240 #ifdef PERL_PRESERVE_IVUV
1241     if (SvIV_please_nomg(svr)) {
1242         /* Unless the left argument is integer in range we are going to have to
1243            use NV maths. Hence only attempt to coerce the right argument if
1244            we know the left is integer.  */
1245         /* Left operand is defined, so is it IV? */
1246         if (SvIV_please_nomg(svl)) {
1247             bool auvok = SvUOK(svl);
1248             bool buvok = SvUOK(svr);
1249             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1250             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1251             UV alow;
1252             UV ahigh;
1253             UV blow;
1254             UV bhigh;
1255
1256             if (auvok) {
1257                 alow = SvUVX(svl);
1258             } else {
1259                 const IV aiv = SvIVX(svl);
1260                 if (aiv >= 0) {
1261                     alow = aiv;
1262                     auvok = TRUE; /* effectively it's a UV now */
1263                 } else {
1264                     alow = -aiv; /* abs, auvok == false records sign */
1265                 }
1266             }
1267             if (buvok) {
1268                 blow = SvUVX(svr);
1269             } else {
1270                 const IV biv = SvIVX(svr);
1271                 if (biv >= 0) {
1272                     blow = biv;
1273                     buvok = TRUE; /* effectively it's a UV now */
1274                 } else {
1275                     blow = -biv; /* abs, buvok == false records sign */
1276                 }
1277             }
1278
1279             /* If this does sign extension on unsigned it's time for plan B  */
1280             ahigh = alow >> (4 * sizeof (UV));
1281             alow &= botmask;
1282             bhigh = blow >> (4 * sizeof (UV));
1283             blow &= botmask;
1284             if (ahigh && bhigh) {
1285                 NOOP;
1286                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1287                    which is overflow. Drop to NVs below.  */
1288             } else if (!ahigh && !bhigh) {
1289                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1290                    so the unsigned multiply cannot overflow.  */
1291                 const UV product = alow * blow;
1292                 if (auvok == buvok) {
1293                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1294                     SP--;
1295                     SETu( product );
1296                     RETURN;
1297                 } else if (product <= (UV)IV_MIN) {
1298                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1299                     /* -ve result, which could overflow an IV  */
1300                     SP--;
1301                     SETi( -(IV)product );
1302                     RETURN;
1303                 } /* else drop to NVs below. */
1304             } else {
1305                 /* One operand is large, 1 small */
1306                 UV product_middle;
1307                 if (bhigh) {
1308                     /* swap the operands */
1309                     ahigh = bhigh;
1310                     bhigh = blow; /* bhigh now the temp var for the swap */
1311                     blow = alow;
1312                     alow = bhigh;
1313                 }
1314                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1315                    multiplies can't overflow. shift can, add can, -ve can.  */
1316                 product_middle = ahigh * blow;
1317                 if (!(product_middle & topmask)) {
1318                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1319                     UV product_low;
1320                     product_middle <<= (4 * sizeof (UV));
1321                     product_low = alow * blow;
1322
1323                     /* as for pp_add, UV + something mustn't get smaller.
1324                        IIRC ANSI mandates this wrapping *behaviour* for
1325                        unsigned whatever the actual representation*/
1326                     product_low += product_middle;
1327                     if (product_low >= product_middle) {
1328                         /* didn't overflow */
1329                         if (auvok == buvok) {
1330                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1331                             SP--;
1332                             SETu( product_low );
1333                             RETURN;
1334                         } else if (product_low <= (UV)IV_MIN) {
1335                             /* 2s complement assumption again  */
1336                             /* -ve result, which could overflow an IV  */
1337                             SP--;
1338                             SETi( -(IV)product_low );
1339                             RETURN;
1340                         } /* else drop to NVs below. */
1341                     }
1342                 } /* product_middle too large */
1343             } /* ahigh && bhigh */
1344         } /* SvIOK(svl) */
1345     } /* SvIOK(svr) */
1346 #endif
1347     {
1348       NV right = SvNV_nomg(svr);
1349       NV left  = SvNV_nomg(svl);
1350       (void)POPs;
1351       SETn( left * right );
1352       RETURN;
1353     }
1354 }
1355
1356 PP(pp_divide)
1357 {
1358     dVAR; dSP; dATARGET; SV *svl, *svr;
1359     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1360     svr = TOPs;
1361     svl = TOPm1s;
1362     /* Only try to do UV divide first
1363        if ((SLOPPYDIVIDE is true) or
1364            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1365             to preserve))
1366        The assumption is that it is better to use floating point divide
1367        whenever possible, only doing integer divide first if we can't be sure.
1368        If NV_PRESERVES_UV is true then we know at compile time that no UV
1369        can be too large to preserve, so don't need to compile the code to
1370        test the size of UVs.  */
1371
1372 #ifdef SLOPPYDIVIDE
1373 #  define PERL_TRY_UV_DIVIDE
1374     /* ensure that 20./5. == 4. */
1375 #else
1376 #  ifdef PERL_PRESERVE_IVUV
1377 #    ifndef NV_PRESERVES_UV
1378 #      define PERL_TRY_UV_DIVIDE
1379 #    endif
1380 #  endif
1381 #endif
1382
1383 #ifdef PERL_TRY_UV_DIVIDE
1384     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1385             bool left_non_neg = SvUOK(svl);
1386             bool right_non_neg = SvUOK(svr);
1387             UV left;
1388             UV right;
1389
1390             if (right_non_neg) {
1391                 right = SvUVX(svr);
1392             }
1393             else {
1394                 const IV biv = SvIVX(svr);
1395                 if (biv >= 0) {
1396                     right = biv;
1397                     right_non_neg = TRUE; /* effectively it's a UV now */
1398                 }
1399                 else {
1400                     right = -biv;
1401                 }
1402             }
1403             /* historically undef()/0 gives a "Use of uninitialized value"
1404                warning before dieing, hence this test goes here.
1405                If it were immediately before the second SvIV_please, then
1406                DIE() would be invoked before left was even inspected, so
1407                no inspection would give no warning.  */
1408             if (right == 0)
1409                 DIE(aTHX_ "Illegal division by zero");
1410
1411             if (left_non_neg) {
1412                 left = SvUVX(svl);
1413             }
1414             else {
1415                 const IV aiv = SvIVX(svl);
1416                 if (aiv >= 0) {
1417                     left = aiv;
1418                     left_non_neg = TRUE; /* effectively it's a UV now */
1419                 }
1420                 else {
1421                     left = -aiv;
1422                 }
1423             }
1424
1425             if (left >= right
1426 #ifdef SLOPPYDIVIDE
1427                 /* For sloppy divide we always attempt integer division.  */
1428 #else
1429                 /* Otherwise we only attempt it if either or both operands
1430                    would not be preserved by an NV.  If both fit in NVs
1431                    we fall through to the NV divide code below.  However,
1432                    as left >= right to ensure integer result here, we know that
1433                    we can skip the test on the right operand - right big
1434                    enough not to be preserved can't get here unless left is
1435                    also too big.  */
1436
1437                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1438 #endif
1439                 ) {
1440                 /* Integer division can't overflow, but it can be imprecise.  */
1441                 const UV result = left / right;
1442                 if (result * right == left) {
1443                     SP--; /* result is valid */
1444                     if (left_non_neg == right_non_neg) {
1445                         /* signs identical, result is positive.  */
1446                         SETu( result );
1447                         RETURN;
1448                     }
1449                     /* 2s complement assumption */
1450                     if (result <= (UV)IV_MIN)
1451                         SETi( -(IV)result );
1452                     else {
1453                         /* It's exact but too negative for IV. */
1454                         SETn( -(NV)result );
1455                     }
1456                     RETURN;
1457                 } /* tried integer divide but it was not an integer result */
1458             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1459     } /* one operand wasn't SvIOK */
1460 #endif /* PERL_TRY_UV_DIVIDE */
1461     {
1462         NV right = SvNV_nomg(svr);
1463         NV left  = SvNV_nomg(svl);
1464         (void)POPs;(void)POPs;
1465 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1466         if (! Perl_isnan(right) && right == 0.0)
1467 #else
1468         if (right == 0.0)
1469 #endif
1470             DIE(aTHX_ "Illegal division by zero");
1471         PUSHn( left / right );
1472         RETURN;
1473     }
1474 }
1475
1476 PP(pp_modulo)
1477 {
1478     dVAR; dSP; dATARGET;
1479     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1480     {
1481         UV left  = 0;
1482         UV right = 0;
1483         bool left_neg = FALSE;
1484         bool right_neg = FALSE;
1485         bool use_double = FALSE;
1486         bool dright_valid = FALSE;
1487         NV dright = 0.0;
1488         NV dleft  = 0.0;
1489         SV * const svr = TOPs;
1490         SV * const svl = TOPm1s;
1491         if (SvIV_please_nomg(svr)) {
1492             right_neg = !SvUOK(svr);
1493             if (!right_neg) {
1494                 right = SvUVX(svr);
1495             } else {
1496                 const IV biv = SvIVX(svr);
1497                 if (biv >= 0) {
1498                     right = biv;
1499                     right_neg = FALSE; /* effectively it's a UV now */
1500                 } else {
1501                     right = -biv;
1502                 }
1503             }
1504         }
1505         else {
1506             dright = SvNV_nomg(svr);
1507             right_neg = dright < 0;
1508             if (right_neg)
1509                 dright = -dright;
1510             if (dright < UV_MAX_P1) {
1511                 right = U_V(dright);
1512                 dright_valid = TRUE; /* In case we need to use double below.  */
1513             } else {
1514                 use_double = TRUE;
1515             }
1516         }
1517
1518         /* At this point use_double is only true if right is out of range for
1519            a UV.  In range NV has been rounded down to nearest UV and
1520            use_double false.  */
1521         if (!use_double && SvIV_please_nomg(svl)) {
1522                 left_neg = !SvUOK(svl);
1523                 if (!left_neg) {
1524                     left = SvUVX(svl);
1525                 } else {
1526                     const IV aiv = SvIVX(svl);
1527                     if (aiv >= 0) {
1528                         left = aiv;
1529                         left_neg = FALSE; /* effectively it's a UV now */
1530                     } else {
1531                         left = -aiv;
1532                     }
1533                 }
1534         }
1535         else {
1536             dleft = SvNV_nomg(svl);
1537             left_neg = dleft < 0;
1538             if (left_neg)
1539                 dleft = -dleft;
1540
1541             /* This should be exactly the 5.6 behaviour - if left and right are
1542                both in range for UV then use U_V() rather than floor.  */
1543             if (!use_double) {
1544                 if (dleft < UV_MAX_P1) {
1545                     /* right was in range, so is dleft, so use UVs not double.
1546                      */
1547                     left = U_V(dleft);
1548                 }
1549                 /* left is out of range for UV, right was in range, so promote
1550                    right (back) to double.  */
1551                 else {
1552                     /* The +0.5 is used in 5.6 even though it is not strictly
1553                        consistent with the implicit +0 floor in the U_V()
1554                        inside the #if 1. */
1555                     dleft = Perl_floor(dleft + 0.5);
1556                     use_double = TRUE;
1557                     if (dright_valid)
1558                         dright = Perl_floor(dright + 0.5);
1559                     else
1560                         dright = right;
1561                 }
1562             }
1563         }
1564         sp -= 2;
1565         if (use_double) {
1566             NV dans;
1567
1568             if (!dright)
1569                 DIE(aTHX_ "Illegal modulus zero");
1570
1571             dans = Perl_fmod(dleft, dright);
1572             if ((left_neg != right_neg) && dans)
1573                 dans = dright - dans;
1574             if (right_neg)
1575                 dans = -dans;
1576             sv_setnv(TARG, dans);
1577         }
1578         else {
1579             UV ans;
1580
1581             if (!right)
1582                 DIE(aTHX_ "Illegal modulus zero");
1583
1584             ans = left % right;
1585             if ((left_neg != right_neg) && ans)
1586                 ans = right - ans;
1587             if (right_neg) {
1588                 /* XXX may warn: unary minus operator applied to unsigned type */
1589                 /* could change -foo to be (~foo)+1 instead     */
1590                 if (ans <= ~((UV)IV_MAX)+1)
1591                     sv_setiv(TARG, ~ans+1);
1592                 else
1593                     sv_setnv(TARG, -(NV)ans);
1594             }
1595             else
1596                 sv_setuv(TARG, ans);
1597         }
1598         PUSHTARG;
1599         RETURN;
1600     }
1601 }
1602
1603 PP(pp_repeat)
1604 {
1605     dVAR; dSP; dATARGET;
1606     IV count;
1607     SV *sv;
1608
1609     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1610         /* TODO: think of some way of doing list-repeat overloading ??? */
1611         sv = POPs;
1612         SvGETMAGIC(sv);
1613     }
1614     else {
1615         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1616         sv = POPs;
1617     }
1618
1619     if (SvIOKp(sv)) {
1620          if (SvUOK(sv)) {
1621               const UV uv = SvUV_nomg(sv);
1622               if (uv > IV_MAX)
1623                    count = IV_MAX; /* The best we can do? */
1624               else
1625                    count = uv;
1626          } else {
1627               const IV iv = SvIV_nomg(sv);
1628               if (iv < 0)
1629                    count = 0;
1630               else
1631                    count = iv;
1632          }
1633     }
1634     else if (SvNOKp(sv)) {
1635          const NV nv = SvNV_nomg(sv);
1636          if (nv < 0.0)
1637               count = 0;
1638          else
1639               count = (IV)nv;
1640     }
1641     else
1642          count = SvIV_nomg(sv);
1643
1644     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1645         dMARK;
1646         static const char oom_list_extend[] = "Out of memory during list extend";
1647         const I32 items = SP - MARK;
1648         const I32 max = items * count;
1649
1650         MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1651         /* Did the max computation overflow? */
1652         if (items > 0 && max > 0 && (max < items || max < count))
1653            Perl_croak(aTHX_ oom_list_extend);
1654         MEXTEND(MARK, max);
1655         if (count > 1) {
1656             while (SP > MARK) {
1657 #if 0
1658               /* This code was intended to fix 20010809.028:
1659
1660                  $x = 'abcd';
1661                  for (($x =~ /./g) x 2) {
1662                      print chop; # "abcdabcd" expected as output.
1663                  }
1664
1665                * but that change (#11635) broke this code:
1666
1667                $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1668
1669                * I can't think of a better fix that doesn't introduce
1670                * an efficiency hit by copying the SVs. The stack isn't
1671                * refcounted, and mortalisation obviously doesn't
1672                * Do The Right Thing when the stack has more than
1673                * one pointer to the same mortal value.
1674                * .robin.
1675                */
1676                 if (*SP) {
1677                     *SP = sv_2mortal(newSVsv(*SP));
1678                     SvREADONLY_on(*SP);
1679                 }
1680 #else
1681                if (*SP)
1682                    SvTEMP_off((*SP));
1683 #endif
1684                 SP--;
1685             }
1686             MARK++;
1687             repeatcpy((char*)(MARK + items), (char*)MARK,
1688                 items * sizeof(const SV *), count - 1);
1689             SP += max;
1690         }
1691         else if (count <= 0)
1692             SP -= items;
1693     }
1694     else {      /* Note: mark already snarfed by pp_list */
1695         SV * const tmpstr = POPs;
1696         STRLEN len;
1697         bool isutf;
1698         static const char oom_string_extend[] =
1699           "Out of memory during string extend";
1700
1701         if (TARG != tmpstr)
1702             sv_setsv_nomg(TARG, tmpstr);
1703         SvPV_force_nomg(TARG, len);
1704         isutf = DO_UTF8(TARG);
1705         if (count != 1) {
1706             if (count < 1)
1707                 SvCUR_set(TARG, 0);
1708             else {
1709                 const STRLEN max = (UV)count * len;
1710                 if (len > MEM_SIZE_MAX / count)
1711                      Perl_croak(aTHX_ oom_string_extend);
1712                 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1713                 SvGROW(TARG, max + 1);
1714                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1715                 SvCUR_set(TARG, SvCUR(TARG) * count);
1716             }
1717             *SvEND(TARG) = '\0';
1718         }
1719         if (isutf)
1720             (void)SvPOK_only_UTF8(TARG);
1721         else
1722             (void)SvPOK_only(TARG);
1723
1724         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1725             /* The parser saw this as a list repeat, and there
1726                are probably several items on the stack. But we're
1727                in scalar context, and there's no pp_list to save us
1728                now. So drop the rest of the items -- robin@kitsite.com
1729              */
1730             dMARK;
1731             SP = MARK;
1732         }
1733         PUSHTARG;
1734     }
1735     RETURN;
1736 }
1737
1738 PP(pp_subtract)
1739 {
1740     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1741     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1742     svr = TOPs;
1743     svl = TOPm1s;
1744     useleft = USE_LEFT(svl);
1745 #ifdef PERL_PRESERVE_IVUV
1746     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1747        "bad things" happen if you rely on signed integers wrapping.  */
1748     if (SvIV_please_nomg(svr)) {
1749         /* Unless the left argument is integer in range we are going to have to
1750            use NV maths. Hence only attempt to coerce the right argument if
1751            we know the left is integer.  */
1752         UV auv = 0;
1753         bool auvok = FALSE;
1754         bool a_valid = 0;
1755
1756         if (!useleft) {
1757             auv = 0;
1758             a_valid = auvok = 1;
1759             /* left operand is undef, treat as zero.  */
1760         } else {
1761             /* Left operand is defined, so is it IV? */
1762             if (SvIV_please_nomg(svl)) {
1763                 if ((auvok = SvUOK(svl)))
1764                     auv = SvUVX(svl);
1765                 else {
1766                     const IV aiv = SvIVX(svl);
1767                     if (aiv >= 0) {
1768                         auv = aiv;
1769                         auvok = 1;      /* Now acting as a sign flag.  */
1770                     } else { /* 2s complement assumption for IV_MIN */
1771                         auv = (UV)-aiv;
1772                     }
1773                 }
1774                 a_valid = 1;
1775             }
1776         }
1777         if (a_valid) {
1778             bool result_good = 0;
1779             UV result;
1780             UV buv;
1781             bool buvok = SvUOK(svr);
1782         
1783             if (buvok)
1784                 buv = SvUVX(svr);
1785             else {
1786                 const IV biv = SvIVX(svr);
1787                 if (biv >= 0) {
1788                     buv = biv;
1789                     buvok = 1;
1790                 } else
1791                     buv = (UV)-biv;
1792             }
1793             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1794                else "IV" now, independent of how it came in.
1795                if a, b represents positive, A, B negative, a maps to -A etc
1796                a - b =>  (a - b)
1797                A - b => -(a + b)
1798                a - B =>  (a + b)
1799                A - B => -(a - b)
1800                all UV maths. negate result if A negative.
1801                subtract if signs same, add if signs differ. */
1802
1803             if (auvok ^ buvok) {
1804                 /* Signs differ.  */
1805                 result = auv + buv;
1806                 if (result >= auv)
1807                     result_good = 1;
1808             } else {
1809                 /* Signs same */
1810                 if (auv >= buv) {
1811                     result = auv - buv;
1812                     /* Must get smaller */
1813                     if (result <= auv)
1814                         result_good = 1;
1815                 } else {
1816                     result = buv - auv;
1817                     if (result <= buv) {
1818                         /* result really should be -(auv-buv). as its negation
1819                            of true value, need to swap our result flag  */
1820                         auvok = !auvok;
1821                         result_good = 1;
1822                     }
1823                 }
1824             }
1825             if (result_good) {
1826                 SP--;
1827                 if (auvok)
1828                     SETu( result );
1829                 else {
1830                     /* Negate result */
1831                     if (result <= (UV)IV_MIN)
1832                         SETi( -(IV)result );
1833                     else {
1834                         /* result valid, but out of range for IV.  */
1835                         SETn( -(NV)result );
1836                     }
1837                 }
1838                 RETURN;
1839             } /* Overflow, drop through to NVs.  */
1840         }
1841     }
1842 #endif
1843     {
1844         NV value = SvNV_nomg(svr);
1845         (void)POPs;
1846
1847         if (!useleft) {
1848             /* left operand is undef, treat as zero - value */
1849             SETn(-value);
1850             RETURN;
1851         }
1852         SETn( SvNV_nomg(svl) - value );
1853         RETURN;
1854     }
1855 }
1856
1857 PP(pp_left_shift)
1858 {
1859     dVAR; dSP; dATARGET; SV *svl, *svr;
1860     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1861     svr = POPs;
1862     svl = TOPs;
1863     {
1864       const IV shift = SvIV_nomg(svr);
1865       if (PL_op->op_private & HINT_INTEGER) {
1866         const IV i = SvIV_nomg(svl);
1867         SETi(i << shift);
1868       }
1869       else {
1870         const UV u = SvUV_nomg(svl);
1871         SETu(u << shift);
1872       }
1873       RETURN;
1874     }
1875 }
1876
1877 PP(pp_right_shift)
1878 {
1879     dVAR; dSP; dATARGET; SV *svl, *svr;
1880     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1881     svr = POPs;
1882     svl = TOPs;
1883     {
1884       const IV shift = SvIV_nomg(svr);
1885       if (PL_op->op_private & HINT_INTEGER) {
1886         const IV i = SvIV_nomg(svl);
1887         SETi(i >> shift);
1888       }
1889       else {
1890         const UV u = SvUV_nomg(svl);
1891         SETu(u >> shift);
1892       }
1893       RETURN;
1894     }
1895 }
1896
1897 PP(pp_lt)
1898 {
1899     dVAR; dSP;
1900     SV *left, *right;
1901
1902     tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1903     right = POPs;
1904     left  = TOPs;
1905     SETs(boolSV(
1906         (SvIOK_notUV(left) && SvIOK_notUV(right))
1907         ? (SvIVX(left) < SvIVX(right))
1908         : (do_ncmp(left, right) == -1)
1909     ));
1910     RETURN;
1911 }
1912
1913 PP(pp_gt)
1914 {
1915     dVAR; dSP;
1916     SV *left, *right;
1917
1918     tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1919     right = POPs;
1920     left  = TOPs;
1921     SETs(boolSV(
1922         (SvIOK_notUV(left) && SvIOK_notUV(right))
1923         ? (SvIVX(left) > SvIVX(right))
1924         : (do_ncmp(left, right) == 1)
1925     ));
1926     RETURN;
1927 }
1928
1929 PP(pp_le)
1930 {
1931     dVAR; dSP;
1932     SV *left, *right;
1933
1934     tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1935     right = POPs;
1936     left  = TOPs;
1937     SETs(boolSV(
1938         (SvIOK_notUV(left) && SvIOK_notUV(right))
1939         ? (SvIVX(left) <= SvIVX(right))
1940         : (do_ncmp(left, right) <= 0)
1941     ));
1942     RETURN;
1943 }
1944
1945 PP(pp_ge)
1946 {
1947     dVAR; dSP;
1948     SV *left, *right;
1949
1950     tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1951     right = POPs;
1952     left  = TOPs;
1953     SETs(boolSV(
1954         (SvIOK_notUV(left) && SvIOK_notUV(right))
1955         ? (SvIVX(left) >= SvIVX(right))
1956         : ( (do_ncmp(left, right) & 2) == 0)
1957     ));
1958     RETURN;
1959 }
1960
1961 PP(pp_ne)
1962 {
1963     dVAR; dSP;
1964     SV *left, *right;
1965
1966     tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1967     right = POPs;
1968     left  = TOPs;
1969     SETs(boolSV(
1970         (SvIOK_notUV(left) && SvIOK_notUV(right))
1971         ? (SvIVX(left) != SvIVX(right))
1972         : (do_ncmp(left, right) != 0)
1973     ));
1974     RETURN;
1975 }
1976
1977 /* compare left and right SVs. Returns:
1978  * -1: <
1979  *  0: ==
1980  *  1: >
1981  *  2: left or right was a NaN
1982  */
1983 I32
1984 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
1985 {
1986     dVAR;
1987
1988     PERL_ARGS_ASSERT_DO_NCMP;
1989 #ifdef PERL_PRESERVE_IVUV
1990     /* Fortunately it seems NaN isn't IOK */
1991     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
1992             if (!SvUOK(left)) {
1993                 const IV leftiv = SvIVX(left);
1994                 if (!SvUOK(right)) {
1995                     /* ## IV <=> IV ## */
1996                     const IV rightiv = SvIVX(right);
1997                     return (leftiv > rightiv) - (leftiv < rightiv);
1998                 }
1999                 /* ## IV <=> UV ## */
2000                 if (leftiv < 0)
2001                     /* As (b) is a UV, it's >=0, so it must be < */
2002                     return -1;
2003                 {
2004                     const UV rightuv = SvUVX(right);
2005                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2006                 }
2007             }
2008
2009             if (SvUOK(right)) {
2010                 /* ## UV <=> UV ## */
2011                 const UV leftuv = SvUVX(left);
2012                 const UV rightuv = SvUVX(right);
2013                 return (leftuv > rightuv) - (leftuv < rightuv);
2014             }
2015             /* ## UV <=> IV ## */
2016             {
2017                 const IV rightiv = SvIVX(right);
2018                 if (rightiv < 0)
2019                     /* As (a) is a UV, it's >=0, so it cannot be < */
2020                     return 1;
2021                 {
2022                     const UV leftuv = SvUVX(left);
2023                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2024                 }
2025             }
2026             assert(0); /* NOTREACHED */
2027     }
2028 #endif
2029     {
2030       NV const rnv = SvNV_nomg(right);
2031       NV const lnv = SvNV_nomg(left);
2032
2033 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2034       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2035           return 2;
2036        }
2037       return (lnv > rnv) - (lnv < rnv);
2038 #else
2039       if (lnv < rnv)
2040         return -1;
2041       if (lnv > rnv)
2042         return 1;
2043       if (lnv == rnv)
2044         return 0;
2045       return 2;
2046 #endif
2047     }
2048 }
2049
2050
2051 PP(pp_ncmp)
2052 {
2053     dVAR; dSP;
2054     SV *left, *right;
2055     I32 value;
2056     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2057     right = POPs;
2058     left  = TOPs;
2059     value = do_ncmp(left, right);
2060     if (value == 2) {
2061         SETs(&PL_sv_undef);
2062     }
2063     else {
2064         dTARGET;
2065         SETi(value);
2066     }
2067     RETURN;
2068 }
2069
2070 PP(pp_sle)
2071 {
2072     dVAR; dSP;
2073
2074     int amg_type = sle_amg;
2075     int multiplier = 1;
2076     int rhs = 1;
2077
2078     switch (PL_op->op_type) {
2079     case OP_SLT:
2080         amg_type = slt_amg;
2081         /* cmp < 0 */
2082         rhs = 0;
2083         break;
2084     case OP_SGT:
2085         amg_type = sgt_amg;
2086         /* cmp > 0 */
2087         multiplier = -1;
2088         rhs = 0;
2089         break;
2090     case OP_SGE:
2091         amg_type = sge_amg;
2092         /* cmp >= 0 */
2093         multiplier = -1;
2094         break;
2095     }
2096
2097     tryAMAGICbin_MG(amg_type, AMGf_set);
2098     {
2099       dPOPTOPssrl;
2100       const int cmp = (IN_LOCALE_RUNTIME
2101                  ? sv_cmp_locale_flags(left, right, 0)
2102                  : sv_cmp_flags(left, right, 0));
2103       SETs(boolSV(cmp * multiplier < rhs));
2104       RETURN;
2105     }
2106 }
2107
2108 PP(pp_seq)
2109 {
2110     dVAR; dSP;
2111     tryAMAGICbin_MG(seq_amg, AMGf_set);
2112     {
2113       dPOPTOPssrl;
2114       SETs(boolSV(sv_eq_flags(left, right, 0)));
2115       RETURN;
2116     }
2117 }
2118
2119 PP(pp_sne)
2120 {
2121     dVAR; dSP;
2122     tryAMAGICbin_MG(sne_amg, AMGf_set);
2123     {
2124       dPOPTOPssrl;
2125       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2126       RETURN;
2127     }
2128 }
2129
2130 PP(pp_scmp)
2131 {
2132     dVAR; dSP; dTARGET;
2133     tryAMAGICbin_MG(scmp_amg, 0);
2134     {
2135       dPOPTOPssrl;
2136       const int cmp = (IN_LOCALE_RUNTIME
2137                  ? sv_cmp_locale_flags(left, right, 0)
2138                  : sv_cmp_flags(left, right, 0));
2139       SETi( cmp );
2140       RETURN;
2141     }
2142 }
2143
2144 PP(pp_bit_and)
2145 {
2146     dVAR; dSP; dATARGET;
2147     tryAMAGICbin_MG(band_amg, AMGf_assign);
2148     {
2149       dPOPTOPssrl;
2150       if (SvNIOKp(left) || SvNIOKp(right)) {
2151         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2152         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2153         if (PL_op->op_private & HINT_INTEGER) {
2154           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2155           SETi(i);
2156         }
2157         else {
2158           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2159           SETu(u);
2160         }
2161         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2162         if (right_ro_nonnum) SvNIOK_off(right);
2163       }
2164       else {
2165         do_vop(PL_op->op_type, TARG, left, right);
2166         SETTARG;
2167       }
2168       RETURN;
2169     }
2170 }
2171
2172 PP(pp_bit_or)
2173 {
2174     dVAR; dSP; dATARGET;
2175     const int op_type = PL_op->op_type;
2176
2177     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2178     {
2179       dPOPTOPssrl;
2180       if (SvNIOKp(left) || SvNIOKp(right)) {
2181         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2182         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2183         if (PL_op->op_private & HINT_INTEGER) {
2184           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2185           const IV r = SvIV_nomg(right);
2186           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2187           SETi(result);
2188         }
2189         else {
2190           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2191           const UV r = SvUV_nomg(right);
2192           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2193           SETu(result);
2194         }
2195         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2196         if (right_ro_nonnum) SvNIOK_off(right);
2197       }
2198       else {
2199         do_vop(op_type, TARG, left, right);
2200         SETTARG;
2201       }
2202       RETURN;
2203     }
2204 }
2205
2206 PERL_STATIC_INLINE bool
2207 S_negate_string(pTHX)
2208 {
2209     dTARGET; dSP;
2210     STRLEN len;
2211     const char *s;
2212     SV * const sv = TOPs;
2213     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2214         return FALSE;
2215     s = SvPV_nomg_const(sv, len);
2216     if (isIDFIRST(*s)) {
2217         sv_setpvs(TARG, "-");
2218         sv_catsv(TARG, sv);
2219     }
2220     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2221         sv_setsv_nomg(TARG, sv);
2222         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2223     }
2224     else return FALSE;
2225     SETTARG; PUTBACK;
2226     return TRUE;
2227 }
2228
2229 PP(pp_negate)
2230 {
2231     dVAR; dSP; dTARGET;
2232     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2233     if (S_negate_string(aTHX)) return NORMAL;
2234     {
2235         SV * const sv = TOPs;
2236
2237         if (SvIOK(sv)) {
2238             /* It's publicly an integer */
2239         oops_its_an_int:
2240             if (SvIsUV(sv)) {
2241                 if (SvIVX(sv) == IV_MIN) {
2242                     /* 2s complement assumption. */
2243                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2244                     RETURN;
2245                 }
2246                 else if (SvUVX(sv) <= IV_MAX) {
2247                     SETi(-SvIVX(sv));
2248                     RETURN;
2249                 }
2250             }
2251             else if (SvIVX(sv) != IV_MIN) {
2252                 SETi(-SvIVX(sv));
2253                 RETURN;
2254             }
2255 #ifdef PERL_PRESERVE_IVUV
2256             else {
2257                 SETu((UV)IV_MIN);
2258                 RETURN;
2259             }
2260 #endif
2261         }
2262         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2263             SETn(-SvNV_nomg(sv));
2264         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2265                   goto oops_its_an_int;
2266         else
2267             SETn(-SvNV_nomg(sv));
2268     }
2269     RETURN;
2270 }
2271
2272 PP(pp_not)
2273 {
2274     dVAR; dSP;
2275     tryAMAGICun_MG(not_amg, AMGf_set);
2276     *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2277     return NORMAL;
2278 }
2279
2280 PP(pp_complement)
2281 {
2282     dVAR; dSP; dTARGET;
2283     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2284     {
2285       dTOPss;
2286       if (SvNIOKp(sv)) {
2287         if (PL_op->op_private & HINT_INTEGER) {
2288           const IV i = ~SvIV_nomg(sv);
2289           SETi(i);
2290         }
2291         else {
2292           const UV u = ~SvUV_nomg(sv);
2293           SETu(u);
2294         }
2295       }
2296       else {
2297         U8 *tmps;
2298         I32 anum;
2299         STRLEN len;
2300
2301         (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2302         sv_setsv_nomg(TARG, sv);
2303         tmps = (U8*)SvPV_force_nomg(TARG, len);
2304         anum = len;
2305         if (SvUTF8(TARG)) {
2306           /* Calculate exact length, let's not estimate. */
2307           STRLEN targlen = 0;
2308           STRLEN l;
2309           UV nchar = 0;
2310           UV nwide = 0;
2311           U8 * const send = tmps + len;
2312           U8 * const origtmps = tmps;
2313           const UV utf8flags = UTF8_ALLOW_ANYUV;
2314
2315           while (tmps < send) {
2316             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2317             tmps += l;
2318             targlen += UNISKIP(~c);
2319             nchar++;
2320             if (c > 0xff)
2321                 nwide++;
2322           }
2323
2324           /* Now rewind strings and write them. */
2325           tmps = origtmps;
2326
2327           if (nwide) {
2328               U8 *result;
2329               U8 *p;
2330
2331               Newx(result, targlen + 1, U8);
2332               p = result;
2333               while (tmps < send) {
2334                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2335                   tmps += l;
2336                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2337               }
2338               *p = '\0';
2339               sv_usepvn_flags(TARG, (char*)result, targlen,
2340                               SV_HAS_TRAILING_NUL);
2341               SvUTF8_on(TARG);
2342           }
2343           else {
2344               U8 *result;
2345               U8 *p;
2346
2347               Newx(result, nchar + 1, U8);
2348               p = result;
2349               while (tmps < send) {
2350                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2351                   tmps += l;
2352                   *p++ = ~c;
2353               }
2354               *p = '\0';
2355               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2356               SvUTF8_off(TARG);
2357           }
2358           SETTARG;
2359           RETURN;
2360         }
2361 #ifdef LIBERAL
2362         {
2363             long *tmpl;
2364             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2365                 *tmps = ~*tmps;
2366             tmpl = (long*)tmps;
2367             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2368                 *tmpl = ~*tmpl;
2369             tmps = (U8*)tmpl;
2370         }
2371 #endif
2372         for ( ; anum > 0; anum--, tmps++)
2373             *tmps = ~*tmps;
2374         SETTARG;
2375       }
2376       RETURN;
2377     }
2378 }
2379
2380 /* integer versions of some of the above */
2381
2382 PP(pp_i_multiply)
2383 {
2384     dVAR; dSP; dATARGET;
2385     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2386     {
2387       dPOPTOPiirl_nomg;
2388       SETi( left * right );
2389       RETURN;
2390     }
2391 }
2392
2393 PP(pp_i_divide)
2394 {
2395     IV num;
2396     dVAR; dSP; dATARGET;
2397     tryAMAGICbin_MG(div_amg, AMGf_assign);
2398     {
2399       dPOPTOPssrl;
2400       IV value = SvIV_nomg(right);
2401       if (value == 0)
2402           DIE(aTHX_ "Illegal division by zero");
2403       num = SvIV_nomg(left);
2404
2405       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2406       if (value == -1)
2407           value = - num;
2408       else
2409           value = num / value;
2410       SETi(value);
2411       RETURN;
2412     }
2413 }
2414
2415 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2416 STATIC
2417 PP(pp_i_modulo_0)
2418 #else
2419 PP(pp_i_modulo)
2420 #endif
2421 {
2422      /* This is the vanilla old i_modulo. */
2423      dVAR; dSP; dATARGET;
2424      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2425      {
2426           dPOPTOPiirl_nomg;
2427           if (!right)
2428                DIE(aTHX_ "Illegal modulus zero");
2429           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2430           if (right == -1)
2431               SETi( 0 );
2432           else
2433               SETi( left % right );
2434           RETURN;
2435      }
2436 }
2437
2438 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2439 STATIC
2440 PP(pp_i_modulo_1)
2441
2442 {
2443      /* This is the i_modulo with the workaround for the _moddi3 bug
2444       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2445       * See below for pp_i_modulo. */
2446      dVAR; dSP; dATARGET;
2447      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2448      {
2449           dPOPTOPiirl_nomg;
2450           if (!right)
2451                DIE(aTHX_ "Illegal modulus zero");
2452           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2453           if (right == -1)
2454               SETi( 0 );
2455           else
2456               SETi( left % PERL_ABS(right) );
2457           RETURN;
2458      }
2459 }
2460
2461 PP(pp_i_modulo)
2462 {
2463      dVAR; dSP; dATARGET;
2464      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2465      {
2466           dPOPTOPiirl_nomg;
2467           if (!right)
2468                DIE(aTHX_ "Illegal modulus zero");
2469           /* The assumption is to use hereafter the old vanilla version... */
2470           PL_op->op_ppaddr =
2471                PL_ppaddr[OP_I_MODULO] =
2472                    Perl_pp_i_modulo_0;
2473           /* .. but if we have glibc, we might have a buggy _moddi3
2474            * (at least glicb 2.2.5 is known to have this bug), in other
2475            * words our integer modulus with negative quad as the second
2476            * argument might be broken.  Test for this and re-patch the
2477            * opcode dispatch table if that is the case, remembering to
2478            * also apply the workaround so that this first round works
2479            * right, too.  See [perl #9402] for more information. */
2480           {
2481                IV l =   3;
2482                IV r = -10;
2483                /* Cannot do this check with inlined IV constants since
2484                 * that seems to work correctly even with the buggy glibc. */
2485                if (l % r == -3) {
2486                     /* Yikes, we have the bug.
2487                      * Patch in the workaround version. */
2488                     PL_op->op_ppaddr =
2489                          PL_ppaddr[OP_I_MODULO] =
2490                              &Perl_pp_i_modulo_1;
2491                     /* Make certain we work right this time, too. */
2492                     right = PERL_ABS(right);
2493                }
2494           }
2495           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2496           if (right == -1)
2497               SETi( 0 );
2498           else
2499               SETi( left % right );
2500           RETURN;
2501      }
2502 }
2503 #endif
2504
2505 PP(pp_i_add)
2506 {
2507     dVAR; dSP; dATARGET;
2508     tryAMAGICbin_MG(add_amg, AMGf_assign);
2509     {
2510       dPOPTOPiirl_ul_nomg;
2511       SETi( left + right );
2512       RETURN;
2513     }
2514 }
2515
2516 PP(pp_i_subtract)
2517 {
2518     dVAR; dSP; dATARGET;
2519     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2520     {
2521       dPOPTOPiirl_ul_nomg;
2522       SETi( left - right );
2523       RETURN;
2524     }
2525 }
2526
2527 PP(pp_i_lt)
2528 {
2529     dVAR; dSP;
2530     tryAMAGICbin_MG(lt_amg, AMGf_set);
2531     {
2532       dPOPTOPiirl_nomg;
2533       SETs(boolSV(left < right));
2534       RETURN;
2535     }
2536 }
2537
2538 PP(pp_i_gt)
2539 {
2540     dVAR; dSP;
2541     tryAMAGICbin_MG(gt_amg, AMGf_set);
2542     {
2543       dPOPTOPiirl_nomg;
2544       SETs(boolSV(left > right));
2545       RETURN;
2546     }
2547 }
2548
2549 PP(pp_i_le)
2550 {
2551     dVAR; dSP;
2552     tryAMAGICbin_MG(le_amg, AMGf_set);
2553     {
2554       dPOPTOPiirl_nomg;
2555       SETs(boolSV(left <= right));
2556       RETURN;
2557     }
2558 }
2559
2560 PP(pp_i_ge)
2561 {
2562     dVAR; dSP;
2563     tryAMAGICbin_MG(ge_amg, AMGf_set);
2564     {
2565       dPOPTOPiirl_nomg;
2566       SETs(boolSV(left >= right));
2567       RETURN;
2568     }
2569 }
2570
2571 PP(pp_i_eq)
2572 {
2573     dVAR; dSP;
2574     tryAMAGICbin_MG(eq_amg, AMGf_set);
2575     {
2576       dPOPTOPiirl_nomg;
2577       SETs(boolSV(left == right));
2578       RETURN;
2579     }
2580 }
2581
2582 PP(pp_i_ne)
2583 {
2584     dVAR; dSP;
2585     tryAMAGICbin_MG(ne_amg, AMGf_set);
2586     {
2587       dPOPTOPiirl_nomg;
2588       SETs(boolSV(left != right));
2589       RETURN;
2590     }
2591 }
2592
2593 PP(pp_i_ncmp)
2594 {
2595     dVAR; dSP; dTARGET;
2596     tryAMAGICbin_MG(ncmp_amg, 0);
2597     {
2598       dPOPTOPiirl_nomg;
2599       I32 value;
2600
2601       if (left > right)
2602         value = 1;
2603       else if (left < right)
2604         value = -1;
2605       else
2606         value = 0;
2607       SETi(value);
2608       RETURN;
2609     }
2610 }
2611
2612 PP(pp_i_negate)
2613 {
2614     dVAR; dSP; dTARGET;
2615     tryAMAGICun_MG(neg_amg, 0);
2616     if (S_negate_string(aTHX)) return NORMAL;
2617     {
2618         SV * const sv = TOPs;
2619         IV const i = SvIV_nomg(sv);
2620         SETi(-i);
2621         RETURN;
2622     }
2623 }
2624
2625 /* High falutin' math. */
2626
2627 PP(pp_atan2)
2628 {
2629     dVAR; dSP; dTARGET;
2630     tryAMAGICbin_MG(atan2_amg, 0);
2631     {
2632       dPOPTOPnnrl_nomg;
2633       SETn(Perl_atan2(left, right));
2634       RETURN;
2635     }
2636 }
2637
2638 PP(pp_sin)
2639 {
2640     dVAR; dSP; dTARGET;
2641     int amg_type = sin_amg;
2642     const char *neg_report = NULL;
2643     NV (*func)(NV) = Perl_sin;
2644     const int op_type = PL_op->op_type;
2645
2646     switch (op_type) {
2647     case OP_COS:
2648         amg_type = cos_amg;
2649         func = Perl_cos;
2650         break;
2651     case OP_EXP:
2652         amg_type = exp_amg;
2653         func = Perl_exp;
2654         break;
2655     case OP_LOG:
2656         amg_type = log_amg;
2657         func = Perl_log;
2658         neg_report = "log";
2659         break;
2660     case OP_SQRT:
2661         amg_type = sqrt_amg;
2662         func = Perl_sqrt;
2663         neg_report = "sqrt";
2664         break;
2665     }
2666
2667
2668     tryAMAGICun_MG(amg_type, 0);
2669     {
2670       SV * const arg = POPs;
2671       const NV value = SvNV_nomg(arg);
2672       if (neg_report) {
2673           if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2674               SET_NUMERIC_STANDARD();
2675               /* diag_listed_as: Can't take log of %g */
2676               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2677           }
2678       }
2679       XPUSHn(func(value));
2680       RETURN;
2681     }
2682 }
2683
2684 /* Support Configure command-line overrides for rand() functions.
2685    After 5.005, perhaps we should replace this by Configure support
2686    for drand48(), random(), or rand().  For 5.005, though, maintain
2687    compatibility by calling rand() but allow the user to override it.
2688    See INSTALL for details.  --Andy Dougherty  15 July 1998
2689 */
2690 /* Now it's after 5.005, and Configure supports drand48() and random(),
2691    in addition to rand().  So the overrides should not be needed any more.
2692    --Jarkko Hietaniemi  27 September 1998
2693  */
2694
2695 #ifndef HAS_DRAND48_PROTO
2696 extern double drand48 (void);
2697 #endif
2698
2699 PP(pp_rand)
2700 {
2701     dVAR; dSP; dTARGET;
2702     NV value;
2703     if (MAXARG < 1)
2704         value = 1.0;
2705     else if (!TOPs) {
2706         value = 1.0; (void)POPs;
2707     }
2708     else
2709         value = POPn;
2710     if (value == 0.0)
2711         value = 1.0;
2712     if (!PL_srand_called) {
2713         (void)seedDrand01((Rand_seed_t)seed());
2714         PL_srand_called = TRUE;
2715     }
2716     value *= Drand01();
2717     XPUSHn(value);
2718     RETURN;
2719 }
2720
2721 PP(pp_srand)
2722 {
2723     dVAR; dSP; dTARGET;
2724     UV anum;
2725
2726     if (MAXARG >= 1 && (TOPs || POPs)) {
2727         SV *top;
2728         char *pv;
2729         STRLEN len;
2730         int flags;
2731
2732         top = POPs;
2733         pv = SvPV(top, len);
2734         flags = grok_number(pv, len, &anum);
2735
2736         if (!(flags & IS_NUMBER_IN_UV)) {
2737             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2738                              "Integer overflow in srand");
2739             anum = UV_MAX;
2740         }
2741     }
2742     else {
2743         anum = seed();
2744     }
2745
2746     (void)seedDrand01((Rand_seed_t)anum);
2747     PL_srand_called = TRUE;
2748     if (anum)
2749         XPUSHu(anum);
2750     else {
2751         /* Historically srand always returned true. We can avoid breaking
2752            that like this:  */
2753         sv_setpvs(TARG, "0 but true");
2754         XPUSHTARG;
2755     }
2756     RETURN;
2757 }
2758
2759 PP(pp_int)
2760 {
2761     dVAR; dSP; dTARGET;
2762     tryAMAGICun_MG(int_amg, AMGf_numeric);
2763     {
2764       SV * const sv = TOPs;
2765       const IV iv = SvIV_nomg(sv);
2766       /* XXX it's arguable that compiler casting to IV might be subtly
2767          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2768          else preferring IV has introduced a subtle behaviour change bug. OTOH
2769          relying on floating point to be accurate is a bug.  */
2770
2771       if (!SvOK(sv)) {
2772         SETu(0);
2773       }
2774       else if (SvIOK(sv)) {
2775         if (SvIsUV(sv))
2776             SETu(SvUV_nomg(sv));
2777         else
2778             SETi(iv);
2779       }
2780       else {
2781           const NV value = SvNV_nomg(sv);
2782           if (value >= 0.0) {
2783               if (value < (NV)UV_MAX + 0.5) {
2784                   SETu(U_V(value));
2785               } else {
2786                   SETn(Perl_floor(value));
2787               }
2788           }
2789           else {
2790               if (value > (NV)IV_MIN - 0.5) {
2791                   SETi(I_V(value));
2792               } else {
2793                   SETn(Perl_ceil(value));
2794               }
2795           }
2796       }
2797     }
2798     RETURN;
2799 }
2800
2801 PP(pp_abs)
2802 {
2803     dVAR; dSP; dTARGET;
2804     tryAMAGICun_MG(abs_amg, AMGf_numeric);
2805     {
2806       SV * const sv = TOPs;
2807       /* This will cache the NV value if string isn't actually integer  */
2808       const IV iv = SvIV_nomg(sv);
2809
2810       if (!SvOK(sv)) {
2811         SETu(0);
2812       }
2813       else if (SvIOK(sv)) {
2814         /* IVX is precise  */
2815         if (SvIsUV(sv)) {
2816           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
2817         } else {
2818           if (iv >= 0) {
2819             SETi(iv);
2820           } else {
2821             if (iv != IV_MIN) {
2822               SETi(-iv);
2823             } else {
2824               /* 2s complement assumption. Also, not really needed as
2825                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2826               SETu(IV_MIN);
2827             }
2828           }
2829         }
2830       } else{
2831         const NV value = SvNV_nomg(sv);
2832         if (value < 0.0)
2833           SETn(-value);
2834         else
2835           SETn(value);
2836       }
2837     }
2838     RETURN;
2839 }
2840
2841 PP(pp_oct)
2842 {
2843     dVAR; dSP; dTARGET;
2844     const char *tmps;
2845     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2846     STRLEN len;
2847     NV result_nv;
2848     UV result_uv;
2849     SV* const sv = POPs;
2850
2851     tmps = (SvPV_const(sv, len));
2852     if (DO_UTF8(sv)) {
2853          /* If Unicode, try to downgrade
2854           * If not possible, croak. */
2855          SV* const tsv = sv_2mortal(newSVsv(sv));
2856         
2857          SvUTF8_on(tsv);
2858          sv_utf8_downgrade(tsv, FALSE);
2859          tmps = SvPV_const(tsv, len);
2860     }
2861     if (PL_op->op_type == OP_HEX)
2862         goto hex;
2863
2864     while (*tmps && len && isSPACE(*tmps))
2865         tmps++, len--;
2866     if (*tmps == '0')
2867         tmps++, len--;
2868     if (*tmps == 'x' || *tmps == 'X') {
2869     hex:
2870         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2871     }
2872     else if (*tmps == 'b' || *tmps == 'B')
2873         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2874     else
2875         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2876
2877     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2878         XPUSHn(result_nv);
2879     }
2880     else {
2881         XPUSHu(result_uv);
2882     }
2883     RETURN;
2884 }
2885
2886 /* String stuff. */
2887
2888 PP(pp_length)
2889 {
2890     dVAR; dSP; dTARGET;
2891     SV * const sv = TOPs;
2892
2893     if (SvGAMAGIC(sv)) {
2894         /* For an overloaded or magic scalar, we can't know in advance if
2895            it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
2896            it likes to cache the length. Maybe that should be a documented
2897            feature of it.
2898         */
2899         STRLEN len;
2900         const char *const p
2901             = sv_2pv_flags(sv, &len,
2902                            SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
2903
2904         if (!p) {
2905             if (!SvPADTMP(TARG)) {
2906                 sv_setsv(TARG, &PL_sv_undef);
2907                 SETTARG;
2908             }
2909             SETs(&PL_sv_undef);
2910         }
2911         else if (DO_UTF8(sv)) {
2912             SETi(utf8_length((U8*)p, (U8*)p + len));
2913         }
2914         else
2915             SETi(len);
2916     } else if (SvOK(sv)) {
2917         /* Neither magic nor overloaded.  */
2918         if (DO_UTF8(sv))
2919             SETi(sv_len_utf8(sv));
2920         else
2921             SETi(sv_len(sv));
2922     } else {
2923         if (!SvPADTMP(TARG)) {
2924             sv_setsv_nomg(TARG, &PL_sv_undef);
2925             SETTARG;
2926         }
2927         SETs(&PL_sv_undef);
2928     }
2929     RETURN;
2930 }
2931
2932 /* Returns false if substring is completely outside original string.
2933    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
2934    always be true for an explicit 0.
2935 */
2936 bool
2937 Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2938                                     bool pos1_is_uv, IV len_iv,
2939                                     bool len_is_uv, STRLEN *posp,
2940                                     STRLEN *lenp)
2941 {
2942     IV pos2_iv;
2943     int    pos2_is_uv;
2944
2945     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2946
2947     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2948         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2949         pos1_iv += curlen;
2950     }
2951     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2952         return FALSE;
2953
2954     if (len_iv || len_is_uv) {
2955         if (!len_is_uv && len_iv < 0) {
2956             pos2_iv = curlen + len_iv;
2957             if (curlen)
2958                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2959             else
2960                 pos2_is_uv = 0;
2961         } else {  /* len_iv >= 0 */
2962             if (!pos1_is_uv && pos1_iv < 0) {
2963                 pos2_iv = pos1_iv + len_iv;
2964                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2965             } else {
2966                 if ((UV)len_iv > curlen-(UV)pos1_iv)
2967                     pos2_iv = curlen;
2968                 else
2969                     pos2_iv = pos1_iv+len_iv;
2970                 pos2_is_uv = 1;
2971             }
2972         }
2973     }
2974     else {
2975         pos2_iv = curlen;
2976         pos2_is_uv = 1;
2977     }
2978
2979     if (!pos2_is_uv && pos2_iv < 0) {
2980         if (!pos1_is_uv && pos1_iv < 0)
2981             return FALSE;
2982         pos2_iv = 0;
2983     }
2984     else if (!pos1_is_uv && pos1_iv < 0)
2985         pos1_iv = 0;
2986
2987     if ((UV)pos2_iv < (UV)pos1_iv)
2988         pos2_iv = pos1_iv;
2989     if ((UV)pos2_iv > curlen)
2990         pos2_iv = curlen;
2991
2992     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
2993     *posp = (STRLEN)( (UV)pos1_iv );
2994     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
2995
2996     return TRUE;
2997 }
2998
2999 PP(pp_substr)
3000 {
3001     dVAR; dSP; dTARGET;
3002     SV *sv;
3003     STRLEN curlen;
3004     STRLEN utf8_curlen;
3005     SV *   pos_sv;
3006     IV     pos1_iv;
3007     int    pos1_is_uv;
3008     SV *   len_sv;
3009     IV     len_iv = 0;
3010     int    len_is_uv = 0;
3011     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3012     const bool rvalue = (GIMME_V != G_VOID);
3013     const char *tmps;
3014     SV *repl_sv = NULL;
3015     const char *repl = NULL;
3016     STRLEN repl_len;
3017     int num_args = PL_op->op_private & 7;
3018     bool repl_need_utf8_upgrade = FALSE;
3019     bool repl_is_utf8 = 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 (repl_sv) {
3041         repl = SvPV_const(repl_sv, repl_len);
3042         repl_is_utf8 = DO_UTF8(repl_sv) && repl_len;
3043         if (repl_is_utf8) {
3044             if (!DO_UTF8(sv))
3045                 sv_utf8_upgrade(sv);
3046         }
3047         else if (DO_UTF8(sv))
3048             repl_need_utf8_upgrade = TRUE;
3049     }
3050     else if (lvalue) {
3051         SV * ret;
3052         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3053         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3054         LvTYPE(ret) = 'x';
3055         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3056         LvTARGOFF(ret) =
3057             pos1_is_uv || pos1_iv >= 0
3058                 ? (STRLEN)(UV)pos1_iv
3059                 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3060         LvTARGLEN(ret) =
3061             len_is_uv || len_iv > 0
3062                 ? (STRLEN)(UV)len_iv
3063                 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3064
3065         SPAGAIN;
3066         PUSHs(ret);    /* avoid SvSETMAGIC here */
3067         RETURN;
3068     }
3069     tmps = SvPV_const(sv, curlen);
3070     if (DO_UTF8(sv)) {
3071         utf8_curlen = sv_len_utf8_nomg(sv);
3072         if (utf8_curlen == curlen)
3073             utf8_curlen = 0;
3074         else
3075             curlen = utf8_curlen;
3076     }
3077     else
3078         utf8_curlen = 0;
3079
3080     {
3081         STRLEN pos, len, byte_len, byte_pos;
3082
3083         if (!translate_substr_offsets(
3084                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3085         )) goto bound_fail;
3086
3087         byte_len = len;
3088         byte_pos = utf8_curlen
3089             ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3090
3091         tmps += byte_pos;
3092
3093         if (rvalue) {
3094             SvTAINTED_off(TARG);                        /* decontaminate */
3095             SvUTF8_off(TARG);                   /* decontaminate */
3096             sv_setpvn(TARG, tmps, byte_len);
3097 #ifdef USE_LOCALE_COLLATE
3098             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3099 #endif
3100             if (utf8_curlen)
3101                 SvUTF8_on(TARG);
3102         }
3103
3104         if (repl) {
3105             SV* repl_sv_copy = NULL;
3106
3107             if (repl_need_utf8_upgrade) {
3108                 repl_sv_copy = newSVsv(repl_sv);
3109                 sv_utf8_upgrade(repl_sv_copy);
3110                 repl = SvPV_const(repl_sv_copy, repl_len);
3111                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && repl_len;
3112             }
3113             if (SvROK(sv))
3114                 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3115                             "Attempt to use reference as lvalue in substr"
3116                 );
3117             if (!SvOK(sv))
3118                 sv_setpvs(sv, "");
3119             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3120             if (repl_is_utf8)
3121                 SvUTF8_on(sv);
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&n