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