This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
expunge gratuitous Unicode punctuation in comments
[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 PP(pp_ucfirst)
3443 {
3444     /* Actually is both lcfirst() and ucfirst().  Only the first character
3445      * changes.  This means that possibly we can change in-place, ie., just
3446      * take the source and change that one character and store it back, but not
3447      * if read-only etc, or if the length changes */
3448
3449     dVAR;
3450     dSP;
3451     SV *source = TOPs;
3452     STRLEN slen; /* slen is the byte length of the whole SV. */
3453     STRLEN need;
3454     SV *dest;
3455     bool inplace;   /* ? Convert first char only, in-place */
3456     bool doing_utf8 = FALSE;               /* ? using utf8 */
3457     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3458     const int op_type = PL_op->op_type;
3459     const U8 *s;
3460     U8 *d;
3461     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3462     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3463                      * stored as UTF-8 at s. */
3464     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3465                      * lowercased) character stored in tmpbuf.  May be either
3466                      * UTF-8 or not, but in either case is the number of bytes */
3467
3468     SvGETMAGIC(source);
3469     if (SvOK(source)) {
3470         s = (const U8*)SvPV_nomg_const(source, slen);
3471     } else {
3472         if (ckWARN(WARN_UNINITIALIZED))
3473             report_uninit(source);
3474         s = (const U8*)"";
3475         slen = 0;
3476     }
3477
3478     /* We may be able to get away with changing only the first character, in
3479      * place, but not if read-only, etc.  Later we may discover more reasons to
3480      * not convert in-place. */
3481     inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3482
3483     /* First calculate what the changed first character should be.  This affects
3484      * whether we can just swap it out, leaving the rest of the string unchanged,
3485      * or even if have to convert the dest to UTF-8 when the source isn't */
3486
3487     if (! slen) {   /* If empty */
3488         need = 1; /* still need a trailing NUL */
3489         ulen = 0;
3490     }
3491     else if (DO_UTF8(source)) { /* Is the source utf8? */
3492         doing_utf8 = TRUE;
3493         ulen = UTF8SKIP(s);
3494         if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3495         else toLOWER_utf8(s, tmpbuf, &tculen);
3496
3497         /* we can't do in-place if the length changes.  */
3498         if (ulen != tculen) inplace = FALSE;
3499         need = slen + 1 - ulen + tculen;
3500     }
3501     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3502             * latin1 is treated as caseless.  Note that a locale takes
3503             * precedence */ 
3504         ulen = 1;       /* Original character is 1 byte */
3505         tculen = 1;     /* Most characters will require one byte, but this will
3506                          * need to be overridden for the tricky ones */
3507         need = slen + 1;
3508
3509         if (op_type == OP_LCFIRST) {
3510
3511             /* lower case the first letter: no trickiness for any character */
3512             *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3513                         ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3514         }
3515         /* is ucfirst() */
3516         else if (IN_LOCALE_RUNTIME) {
3517             *tmpbuf = toUPPER_LC(*s);   /* This would be a bug if any locales
3518                                          * have upper and title case different
3519                                          */
3520         }
3521         else if (! IN_UNI_8_BIT) {
3522             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3523                                          * on EBCDIC machines whatever the
3524                                          * native function does */
3525         }
3526         else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3527             UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3528             if (tculen > 1) {
3529                 assert(tculen == 2);
3530
3531                 /* If the result is an upper Latin1-range character, it can
3532                  * still be represented in one byte, which is its ordinal */
3533                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3534                     *tmpbuf = (U8) title_ord;
3535                     tculen = 1;
3536                 }
3537                 else {
3538                     /* Otherwise it became more than one ASCII character (in
3539                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3540                      * beyond Latin1, so the number of bytes changed, so can't
3541                      * replace just the first character in place. */
3542                     inplace = FALSE;
3543
3544                     /* If the result won't fit in a byte, the entire result will
3545                      * have to be in UTF-8.  Assume worst case sizing in
3546                      * conversion. (all latin1 characters occupy at most two bytes
3547                      * in utf8) */
3548                     if (title_ord > 255) {
3549                         doing_utf8 = TRUE;
3550                         convert_source_to_utf8 = TRUE;
3551                         need = slen * 2 + 1;
3552
3553                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3554                          * (both) characters whose title case is above 255 is
3555                          * 2. */
3556                         ulen = 2;
3557                     }
3558                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3559                         need = slen + 1 + 1;
3560                     }
3561                 }
3562             }
3563         } /* End of use Unicode (Latin1) semantics */
3564     } /* End of changing the case of the first character */
3565
3566     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3567      * generate the result */
3568     if (inplace) {
3569
3570         /* We can convert in place.  This means we change just the first
3571          * character without disturbing the rest; no need to grow */
3572         dest = source;
3573         s = d = (U8*)SvPV_force_nomg(source, slen);
3574     } else {
3575         dTARGET;
3576
3577         dest = TARG;
3578
3579         /* Here, we can't convert in place; we earlier calculated how much
3580          * space we will need, so grow to accommodate that */
3581         SvUPGRADE(dest, SVt_PV);
3582         d = (U8*)SvGROW(dest, need);
3583         (void)SvPOK_only(dest);
3584
3585         SETs(dest);
3586     }
3587
3588     if (doing_utf8) {
3589         if (! inplace) {
3590             if (! convert_source_to_utf8) {
3591
3592                 /* Here  both source and dest are in UTF-8, but have to create
3593                  * the entire output.  We initialize the result to be the
3594                  * title/lower cased first character, and then append the rest
3595                  * of the string. */
3596                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3597                 if (slen > ulen) {
3598                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3599                 }
3600             }
3601             else {
3602                 const U8 *const send = s + slen;
3603
3604                 /* Here the dest needs to be in UTF-8, but the source isn't,
3605                  * except we earlier UTF-8'd the first character of the source
3606                  * into tmpbuf.  First put that into dest, and then append the
3607                  * rest of the source, converting it to UTF-8 as we go. */
3608
3609                 /* Assert tculen is 2 here because the only two characters that
3610                  * get to this part of the code have 2-byte UTF-8 equivalents */
3611                 *d++ = *tmpbuf;
3612                 *d++ = *(tmpbuf + 1);
3613                 s++;    /* We have just processed the 1st char */
3614
3615                 for (; s < send; s++) {
3616                     d = uvchr_to_utf8(d, *s);
3617                 }
3618                 *d = '\0';
3619                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3620             }
3621             SvUTF8_on(dest);
3622         }
3623         else {   /* in-place UTF-8.  Just overwrite the first character */
3624             Copy(tmpbuf, d, tculen, U8);
3625             SvCUR_set(dest, need - 1);
3626         }
3627     }
3628     else {  /* Neither source nor dest are in or need to be UTF-8 */
3629         if (slen) {
3630             if (IN_LOCALE_RUNTIME) {
3631                 TAINT;
3632                 SvTAINTED_on(dest);
3633             }
3634             if (inplace) {  /* in-place, only need to change the 1st char */
3635                 *d = *tmpbuf;
3636             }
3637             else {      /* Not in-place */
3638
3639                 /* Copy the case-changed character(s) from tmpbuf */
3640                 Copy(tmpbuf, d, tculen, U8);
3641                 d += tculen - 1; /* Code below expects d to point to final
3642                                   * character stored */
3643             }
3644         }
3645         else {  /* empty source */
3646             /* See bug #39028: Don't taint if empty  */
3647             *d = *s;
3648         }
3649
3650         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3651          * the destination to retain that flag */
3652         if (SvUTF8(source))
3653             SvUTF8_on(dest);
3654
3655         if (!inplace) { /* Finish the rest of the string, unchanged */
3656             /* This will copy the trailing NUL  */
3657             Copy(s + 1, d + 1, slen, U8);
3658             SvCUR_set(dest, need - 1);
3659         }
3660     }
3661     if (dest != source && SvTAINTED(source))
3662         SvTAINT(dest);
3663     SvSETMAGIC(dest);
3664     RETURN;
3665 }
3666
3667 /* There's so much setup/teardown code common between uc and lc, I wonder if
3668    it would be worth merging the two, and just having a switch outside each
3669    of the three tight loops.  There is less and less commonality though */
3670 PP(pp_uc)
3671 {
3672     dVAR;
3673     dSP;
3674     SV *source = TOPs;
3675     STRLEN len;
3676     STRLEN min;
3677     SV *dest;
3678     const U8 *s;
3679     U8 *d;
3680
3681     SvGETMAGIC(source);
3682
3683     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3684         && SvTEMP(source) && !DO_UTF8(source)
3685         && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3686
3687         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
3688          * make the loop tight, so we overwrite the source with the dest before
3689          * looking at it, and we need to look at the original source
3690          * afterwards.  There would also need to be code added to handle
3691          * switching to not in-place in midstream if we run into characters
3692          * that change the length.
3693          */
3694         dest = source;
3695         s = d = (U8*)SvPV_force_nomg(source, len);
3696         min = len + 1;
3697     } else {
3698         dTARGET;
3699
3700         dest = TARG;
3701
3702         /* The old implementation would copy source into TARG at this point.
3703            This had the side effect that if source was undef, TARG was now
3704            an undefined SV with PADTMP set, and they don't warn inside
3705            sv_2pv_flags(). However, we're now getting the PV direct from
3706            source, which doesn't have PADTMP set, so it would warn. Hence the
3707            little games.  */
3708
3709         if (SvOK(source)) {
3710             s = (const U8*)SvPV_nomg_const(source, len);
3711         } else {
3712             if (ckWARN(WARN_UNINITIALIZED))
3713                 report_uninit(source);
3714             s = (const U8*)"";
3715             len = 0;
3716         }
3717         min = len + 1;
3718
3719         SvUPGRADE(dest, SVt_PV);
3720         d = (U8*)SvGROW(dest, min);
3721         (void)SvPOK_only(dest);
3722
3723         SETs(dest);
3724     }
3725
3726     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3727        to check DO_UTF8 again here.  */
3728
3729     if (DO_UTF8(source)) {
3730         const U8 *const send = s + len;
3731         U8 tmpbuf[UTF8_MAXBYTES+1];
3732
3733         /* All occurrences of these are to be moved to follow any other marks.
3734          * This is context-dependent.  We may not be passed enough context to
3735          * move the iota subscript beyond all of them, but we do the best we can
3736          * with what we're given.  The result is always better than if we
3737          * hadn't done this.  And, the problem would only arise if we are
3738          * passed a character without all its combining marks, which would be
3739          * the caller's mistake.  The information this is based on comes from a
3740          * comment in Unicode SpecialCasing.txt, (and the Standard's text
3741          * itself) and so can't be checked properly to see if it ever gets
3742          * revised.  But the likelihood of it changing is remote */
3743         bool in_iota_subscript = FALSE;
3744
3745         while (s < send) {
3746             STRLEN u;
3747             STRLEN ulen;
3748             UV uv;
3749             if (in_iota_subscript && ! is_utf8_mark(s)) {
3750
3751                 /* A non-mark.  Time to output the iota subscript */
3752 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3753 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3754
3755                 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3756                 in_iota_subscript = FALSE;
3757             }
3758
3759             /* Then handle the current character.  Get the changed case value
3760              * and copy it to the output buffer */
3761
3762             u = UTF8SKIP(s);
3763             uv = toUPPER_utf8(s, tmpbuf, &ulen);
3764             if (uv == GREEK_CAPITAL_LETTER_IOTA
3765                 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3766             {
3767                 in_iota_subscript = TRUE;
3768             }
3769             else {
3770                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3771                     /* If the eventually required minimum size outgrows the
3772                      * available space, we need to grow. */
3773                     const UV o = d - (U8*)SvPVX_const(dest);
3774
3775                     /* If someone uppercases one million U+03B0s we SvGROW()
3776                      * one million times.  Or we could try guessing how much to
3777                      * allocate without allocating too much.  Such is life.
3778                      * See corresponding comment in lc code for another option
3779                      * */
3780                     SvGROW(dest, min);
3781                     d = (U8*)SvPVX(dest) + o;
3782                 }
3783                 Copy(tmpbuf, d, ulen, U8);
3784                 d += ulen;
3785             }
3786             s += u;
3787         }
3788         if (in_iota_subscript) {
3789             CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3790         }
3791         SvUTF8_on(dest);
3792         *d = '\0';
3793         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3794     }
3795     else {      /* Not UTF-8 */
3796         if (len) {
3797             const U8 *const send = s + len;
3798
3799             /* Use locale casing if in locale; regular style if not treating
3800              * latin1 as having case; otherwise the latin1 casing.  Do the
3801              * whole thing in a tight loop, for speed, */
3802             if (IN_LOCALE_RUNTIME) {
3803                 TAINT;
3804                 SvTAINTED_on(dest);
3805                 for (; s < send; d++, s++)
3806                     *d = toUPPER_LC(*s);
3807             }
3808             else if (! IN_UNI_8_BIT) {
3809                 for (; s < send; d++, s++) {
3810                     *d = toUPPER(*s);
3811                 }
3812             }
3813             else {
3814                 for (; s < send; d++, s++) {
3815                     *d = toUPPER_LATIN1_MOD(*s);
3816                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) continue;
3817
3818                     /* The mainstream case is the tight loop above.  To avoid
3819                      * extra tests in that, all three characters that require
3820                      * special handling are mapped by the MOD to the one tested
3821                      * just above.  
3822                      * Use the source to distinguish between the three cases */
3823
3824                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3825
3826                         /* uc() of this requires 2 characters, but they are
3827                          * ASCII.  If not enough room, grow the string */
3828                         if (SvLEN(dest) < ++min) {      
3829                             const UV o = d - (U8*)SvPVX_const(dest);
3830                             SvGROW(dest, min);
3831                             d = (U8*)SvPVX(dest) + o;
3832                         }
3833                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3834                         continue;   /* Back to the tight loop; still in ASCII */
3835                     }
3836
3837                     /* The other two special handling characters have their
3838                      * upper cases outside the latin1 range, hence need to be
3839                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
3840                      * here we are somewhere in the middle of processing a
3841                      * non-UTF-8 string, and realize that we will have to convert
3842                      * the whole thing to UTF-8.  What to do?  There are
3843                      * several possibilities.  The simplest to code is to
3844                      * convert what we have so far, set a flag, and continue on
3845                      * in the loop.  The flag would be tested each time through
3846                      * the loop, and if set, the next character would be
3847                      * converted to UTF-8 and stored.  But, I (khw) didn't want
3848                      * to slow down the mainstream case at all for this fairly
3849                      * rare case, so I didn't want to add a test that didn't
3850                      * absolutely have to be there in the loop, besides the
3851                      * possibility that it would get too complicated for
3852                      * optimizers to deal with.  Another possibility is to just
3853                      * give up, convert the source to UTF-8, and restart the
3854                      * function that way.  Another possibility is to convert
3855                      * both what has already been processed and what is yet to
3856                      * come separately to UTF-8, then jump into the loop that
3857                      * handles UTF-8.  But the most efficient time-wise of the
3858                      * ones I could think of is what follows, and turned out to
3859                      * not require much extra code.  */
3860
3861                     /* Convert what we have so far into UTF-8, telling the
3862                      * function that we know it should be converted, and to
3863                      * allow extra space for what we haven't processed yet.
3864                      * Assume the worst case space requirements for converting
3865                      * what we haven't processed so far: that it will require
3866                      * two bytes for each remaining source character, plus the
3867                      * NUL at the end.  This may cause the string pointer to
3868                      * move, so re-find it. */
3869
3870                     len = d - (U8*)SvPVX_const(dest);
3871                     SvCUR_set(dest, len);
3872                     len = sv_utf8_upgrade_flags_grow(dest,
3873                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3874                                                 (send -s) * 2 + 1);
3875                     d = (U8*)SvPVX(dest) + len;
3876
3877                     /* Now process the remainder of the source, converting to
3878                      * upper and UTF-8.  If a resulting byte is invariant in
3879                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
3880                      * append it to the output. */
3881                     for (; s < send; s++) {
3882                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
3883                         d += len;
3884                     }
3885
3886                     /* Here have processed the whole source; no need to continue
3887                      * with the outer loop.  Each character has been converted
3888                      * to upper case and converted to UTF-8 */
3889
3890                     break;
3891                 } /* End of processing all latin1-style chars */
3892             } /* End of processing all chars */
3893         } /* End of source is not empty */
3894
3895         if (source != dest) {
3896             *d = '\0';  /* Here d points to 1 after last char, add NUL */
3897             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3898         }
3899     } /* End of isn't utf8 */
3900     if (dest != source && SvTAINTED(source))
3901         SvTAINT(dest);
3902     SvSETMAGIC(dest);
3903     RETURN;
3904 }
3905
3906 PP(pp_lc)
3907 {
3908     dVAR;
3909     dSP;
3910     SV *source = TOPs;
3911     STRLEN len;
3912     STRLEN min;
3913     SV *dest;
3914     const U8 *s;
3915     U8 *d;
3916
3917     SvGETMAGIC(source);
3918
3919     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3920         && SvTEMP(source) && !DO_UTF8(source)) {
3921
3922         /* We can convert in place, as lowercasing anything in the latin1 range
3923          * (or else DO_UTF8 would have been on) doesn't lengthen it */
3924         dest = source;
3925         s = d = (U8*)SvPV_force_nomg(source, len);
3926         min = len + 1;
3927     } else {
3928         dTARGET;
3929
3930         dest = TARG;
3931
3932         /* The old implementation would copy source into TARG at this point.
3933            This had the side effect that if source was undef, TARG was now
3934            an undefined SV with PADTMP set, and they don't warn inside
3935            sv_2pv_flags(). However, we're now getting the PV direct from
3936            source, which doesn't have PADTMP set, so it would warn. Hence the
3937            little games.  */
3938
3939         if (SvOK(source)) {
3940             s = (const U8*)SvPV_nomg_const(source, len);
3941         } else {
3942             if (ckWARN(WARN_UNINITIALIZED))
3943                 report_uninit(source);
3944             s = (const U8*)"";
3945             len = 0;
3946         }
3947         min = len + 1;
3948
3949         SvUPGRADE(dest, SVt_PV);
3950         d = (U8*)SvGROW(dest, min);
3951         (void)SvPOK_only(dest);
3952
3953         SETs(dest);
3954     }
3955
3956     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3957        to check DO_UTF8 again here.  */
3958
3959     if (DO_UTF8(source)) {
3960         const U8 *const send = s + len;
3961         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3962
3963         while (s < send) {
3964             const STRLEN u = UTF8SKIP(s);
3965             STRLEN ulen;
3966
3967             toLOWER_utf8(s, tmpbuf, &ulen);
3968
3969             /* Here is where we would do context-sensitive actions.  See the
3970              * commit message for this comment for why there isn't any */
3971
3972             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3973
3974                 /* If the eventually required minimum size outgrows the
3975                  * available space, we need to grow. */
3976                 const UV o = d - (U8*)SvPVX_const(dest);
3977
3978                 /* If someone lowercases one million U+0130s we SvGROW() one
3979                  * million times.  Or we could try guessing how much to
3980                  * allocate without allocating too much.  Such is life.
3981                  * Another option would be to grow an extra byte or two more
3982                  * each time we need to grow, which would cut down the million
3983                  * to 500K, with little waste */
3984                 SvGROW(dest, min);
3985                 d = (U8*)SvPVX(dest) + o;
3986             }
3987
3988             /* Copy the newly lowercased letter to the output buffer we're
3989              * building */
3990             Copy(tmpbuf, d, ulen, U8);
3991             d += ulen;
3992             s += u;
3993         }   /* End of looping through the source string */
3994         SvUTF8_on(dest);
3995         *d = '\0';
3996         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3997     } else {    /* Not utf8 */
3998         if (len) {
3999             const U8 *const send = s + len;
4000
4001             /* Use locale casing if in locale; regular style if not treating
4002              * latin1 as having case; otherwise the latin1 casing.  Do the
4003              * whole thing in a tight loop, for speed, */
4004             if (IN_LOCALE_RUNTIME) {
4005                 TAINT;
4006                 SvTAINTED_on(dest);
4007                 for (; s < send; d++, s++)
4008                     *d = toLOWER_LC(*s);
4009             }
4010             else if (! IN_UNI_8_BIT) {
4011                 for (; s < send; d++, s++) {
4012                     *d = toLOWER(*s);
4013                 }
4014             }
4015             else {
4016                 for (; s < send; d++, s++) {
4017                     *d = toLOWER_LATIN1(*s);
4018                 }
4019             }
4020         }
4021         if (source != dest) {
4022             *d = '\0';
4023             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4024         }
4025     }
4026     if (dest != source && SvTAINTED(source))
4027         SvTAINT(dest);
4028     SvSETMAGIC(dest);
4029     RETURN;
4030 }
4031
4032 PP(pp_quotemeta)
4033 {
4034     dVAR; dSP; dTARGET;
4035     SV * const sv = TOPs;
4036     STRLEN len;
4037     register const char *s = SvPV_const(sv,len);
4038
4039     SvUTF8_off(TARG);                           /* decontaminate */
4040     if (len) {
4041         register char *d;
4042         SvUPGRADE(TARG, SVt_PV);
4043         SvGROW(TARG, (len * 2) + 1);
4044         d = SvPVX(TARG);
4045         if (DO_UTF8(sv)) {
4046             while (len) {
4047                 if (UTF8_IS_CONTINUED(*s)) {
4048                     STRLEN ulen = UTF8SKIP(s);
4049                     if (ulen > len)
4050                         ulen = len;
4051                     len -= ulen;
4052                     while (ulen--)
4053                         *d++ = *s++;
4054                 }
4055                 else {
4056                     if (!isALNUM(*s))
4057                         *d++ = '\\';
4058                     *d++ = *s++;
4059                     len--;
4060                 }
4061             }
4062             SvUTF8_on(TARG);
4063         }
4064         else {
4065             while (len--) {
4066                 if (!isALNUM(*s))
4067                     *d++ = '\\';
4068                 *d++ = *s++;
4069             }
4070         }
4071         *d = '\0';
4072         SvCUR_set(TARG, d - SvPVX_const(TARG));
4073         (void)SvPOK_only_UTF8(TARG);
4074     }
4075     else
4076         sv_setpvn(TARG, s, len);
4077     SETTARG;
4078     RETURN;
4079 }
4080
4081 /* Arrays. */
4082
4083 PP(pp_aslice)
4084 {
4085     dVAR; dSP; dMARK; dORIGMARK;
4086     register AV *const av = MUTABLE_AV(POPs);
4087     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4088
4089     if (SvTYPE(av) == SVt_PVAV) {
4090         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4091         bool can_preserve = FALSE;
4092
4093         if (localizing) {
4094             MAGIC *mg;
4095             HV *stash;
4096
4097             can_preserve = SvCANEXISTDELETE(av);
4098         }
4099
4100         if (lval && localizing) {
4101             register SV **svp;
4102             I32 max = -1;
4103             for (svp = MARK + 1; svp <= SP; svp++) {
4104                 const I32 elem = SvIV(*svp);
4105                 if (elem > max)
4106                     max = elem;
4107             }
4108             if (max > AvMAX(av))
4109                 av_extend(av, max);
4110         }
4111
4112         while (++MARK <= SP) {
4113             register SV **svp;
4114             I32 elem = SvIV(*MARK);
4115             bool preeminent = TRUE;
4116
4117             if (localizing && can_preserve) {
4118                 /* If we can determine whether the element exist,
4119                  * Try to preserve the existenceness of a tied array
4120                  * element by using EXISTS and DELETE if possible.
4121                  * Fallback to FETCH and STORE otherwise. */
4122                 preeminent = av_exists(av, elem);
4123             }
4124
4125             svp = av_fetch(av, elem, lval);
4126             if (lval) {
4127                 if (!svp || *svp == &PL_sv_undef)
4128                     DIE(aTHX_ PL_no_aelem, elem);
4129                 if (localizing) {
4130                     if (preeminent)
4131                         save_aelem(av, elem, svp);
4132                     else
4133                         SAVEADELETE(av, elem);
4134                 }
4135             }
4136             *MARK = svp ? *svp : &PL_sv_undef;
4137         }
4138     }
4139     if (GIMME != G_ARRAY) {
4140         MARK = ORIGMARK;
4141         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4142         SP = MARK;
4143     }
4144     RETURN;
4145 }
4146
4147 /* Smart dereferencing for keys, values and each */
4148 PP(pp_rkeys)
4149 {
4150     dVAR;
4151     dSP;
4152     dPOPss;
4153
4154     SvGETMAGIC(sv);
4155
4156     if (
4157          !SvROK(sv)
4158       || (sv = SvRV(sv),
4159             (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4160           || SvOBJECT(sv)
4161          )
4162     ) {
4163         DIE(aTHX_
4164            "Type of argument to %s must be unblessed hashref or arrayref",
4165             PL_op_desc[PL_op->op_type] );
4166     }
4167
4168     if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4169         DIE(aTHX_
4170            "Can't modify %s in %s",
4171             PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4172         );
4173
4174     /* Delegate to correct function for op type */
4175     PUSHs(sv);
4176     if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4177         return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4178     }
4179     else {
4180         return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4181     }
4182 }
4183
4184 PP(pp_aeach)
4185 {
4186     dVAR;
4187     dSP;
4188     AV *array = MUTABLE_AV(POPs);
4189     const I32 gimme = GIMME_V;
4190     IV *iterp = Perl_av_iter_p(aTHX_ array);
4191     const IV current = (*iterp)++;
4192
4193     if (current > av_len(array)) {
4194         *iterp = 0;
4195         if (gimme == G_SCALAR)
4196             RETPUSHUNDEF;
4197         else
4198             RETURN;
4199     }
4200
4201     EXTEND(SP, 2);
4202     mPUSHi(current);
4203     if (gimme == G_ARRAY) {
4204         SV **const element = av_fetch(array, current, 0);
4205         PUSHs(element ? *element : &PL_sv_undef);
4206     }
4207     RETURN;
4208 }
4209
4210 PP(pp_akeys)
4211 {
4212     dVAR;
4213     dSP;
4214     AV *array = MUTABLE_AV(POPs);
4215     const I32 gimme = GIMME_V;
4216
4217     *Perl_av_iter_p(aTHX_ array) = 0;
4218
4219     if (gimme == G_SCALAR) {
4220         dTARGET;
4221         PUSHi(av_len(array) + 1);
4222     }
4223     else if (gimme == G_ARRAY) {
4224         IV n = Perl_av_len(aTHX_ array);
4225         IV i;
4226
4227         EXTEND(SP, n + 1);
4228
4229         if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4230             for (i = 0;  i <= n;  i++) {
4231                 mPUSHi(i);
4232             }
4233         }
4234         else {
4235             for (i = 0;  i <= n;  i++) {
4236                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4237                 PUSHs(elem ? *elem : &PL_sv_undef);
4238             }
4239         }
4240     }
4241     RETURN;
4242 }
4243
4244 /* Associative arrays. */
4245
4246 PP(pp_each)
4247 {
4248     dVAR;
4249     dSP;
4250     HV * hash = MUTABLE_HV(POPs);
4251     HE *entry;
4252     const I32 gimme = GIMME_V;
4253
4254     PUTBACK;
4255     /* might clobber stack_sp */
4256     entry = hv_iternext(hash);
4257     SPAGAIN;
4258
4259     EXTEND(SP, 2);
4260     if (entry) {
4261         SV* const sv = hv_iterkeysv(entry);
4262         PUSHs(sv);      /* won't clobber stack_sp */
4263         if (gimme == G_ARRAY) {
4264             SV *val;
4265             PUTBACK;
4266             /* might clobber stack_sp */
4267             val = hv_iterval(hash, entry);
4268             SPAGAIN;
4269             PUSHs(val);
4270         }
4271     }
4272     else if (gimme == G_SCALAR)
4273         RETPUSHUNDEF;
4274
4275     RETURN;
4276 }
4277
4278 STATIC OP *
4279 S_do_delete_local(pTHX)
4280 {
4281     dVAR;
4282     dSP;
4283     const I32 gimme = GIMME_V;
4284     const MAGIC *mg;
4285     HV *stash;
4286
4287     if (PL_op->op_private & OPpSLICE) {
4288         dMARK; dORIGMARK;
4289         SV * const osv = POPs;
4290         const bool tied = SvRMAGICAL(osv)
4291                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4292         const bool can_preserve = SvCANEXISTDELETE(osv)
4293                                     || mg_find((const SV *)osv, PERL_MAGIC_env);
4294         const U32 type = SvTYPE(osv);
4295         if (type == SVt_PVHV) {                 /* hash element */
4296             HV * const hv = MUTABLE_HV(osv);
4297             while (++MARK <= SP) {
4298                 SV * const keysv = *MARK;
4299                 SV *sv = NULL;
4300                 bool preeminent = TRUE;
4301                 if (can_preserve)
4302                     preeminent = hv_exists_ent(hv, keysv, 0);
4303                 if (tied) {
4304                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4305                     if (he)
4306                         sv = HeVAL(he);
4307                     else
4308                         preeminent = FALSE;
4309                 }
4310                 else {
4311                     sv = hv_delete_ent(hv, keysv, 0, 0);
4312                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4313                 }
4314                 if (preeminent) {
4315                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4316                     if (tied) {
4317                         *MARK = sv_mortalcopy(sv);
4318                         mg_clear(sv);
4319                     } else
4320                         *MARK = sv;
4321                 }
4322                 else {
4323                     SAVEHDELETE(hv, keysv);
4324                     *MARK = &PL_sv_undef;
4325                 }
4326             }
4327         }
4328         else if (type == SVt_PVAV) {                  /* array element */
4329             if (PL_op->op_flags & OPf_SPECIAL) {
4330                 AV * const av = MUTABLE_AV(osv);
4331                 while (++MARK <= SP) {
4332                     I32 idx = SvIV(*MARK);
4333                     SV *sv = NULL;
4334                     bool preeminent = TRUE;
4335                     if (can_preserve)
4336                         preeminent = av_exists(av, idx);
4337                     if (tied) {
4338                         SV **svp = av_fetch(av, idx, 1);
4339                         if (svp)
4340                             sv = *svp;
4341                         else
4342                             preeminent = FALSE;
4343                     }
4344                     else {
4345                         sv = av_delete(av, idx, 0);
4346                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4347                     }
4348                     if (preeminent) {
4349                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4350                         if (tied) {
4351                             *MARK = sv_mortalcopy(sv);
4352                             mg_clear(sv);
4353                         } else
4354                             *MARK = sv;
4355                     }
4356                     else {
4357                         SAVEADELETE(av, idx);
4358                         *MARK = &PL_sv_undef;
4359                     }
4360                 }
4361             }
4362         }
4363         else
4364             DIE(aTHX_ "Not a HASH reference");
4365         if (gimme == G_VOID)
4366             SP = ORIGMARK;
4367         else if (gimme == G_SCALAR) {
4368             MARK = ORIGMARK;
4369             if (SP > MARK)
4370                 *++MARK = *SP;
4371             else
4372                 *++MARK = &PL_sv_undef;
4373             SP = MARK;
4374         }
4375     }
4376     else {
4377         SV * const keysv = POPs;
4378         SV * const osv   = POPs;
4379         const bool tied = SvRMAGICAL(osv)
4380                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4381         const bool can_preserve = SvCANEXISTDELETE(osv)
4382                                     || mg_find((const SV *)osv, PERL_MAGIC_env);
4383         const U32 type = SvTYPE(osv);
4384         SV *sv = NULL;
4385         if (type == SVt_PVHV) {
4386             HV * const hv = MUTABLE_HV(osv);
4387             bool preeminent = TRUE;
4388             if (can_preserve)
4389                 preeminent = hv_exists_ent(hv, keysv, 0);
4390             if (tied) {
4391                 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4392                 if (he)
4393                     sv = HeVAL(he);
4394                 else
4395                     preeminent = FALSE;
4396             }
4397             else {
4398                 sv = hv_delete_ent(hv, keysv, 0, 0);
4399                 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4400             }
4401             if (preeminent) {
4402                 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4403                 if (tied) {
4404                     SV *nsv = sv_mortalcopy(sv);
4405                     mg_clear(sv);
4406                     sv = nsv;
4407                 }
4408             }
4409             else
4410                 SAVEHDELETE(hv, keysv);
4411         }
4412         else if (type == SVt_PVAV) {
4413             if (PL_op->op_flags & OPf_SPECIAL) {
4414                 AV * const av = MUTABLE_AV(osv);
4415                 I32 idx = SvIV(keysv);
4416                 bool preeminent = TRUE;
4417                 if (can_preserve)
4418                     preeminent = av_exists(av, idx);
4419                 if (tied) {
4420                     SV **svp = av_fetch(av, idx, 1);
4421                     if (svp)
4422                         sv = *svp;
4423                     else
4424                         preeminent = FALSE;
4425                 }
4426                 else {
4427                     sv = av_delete(av, idx, 0);
4428                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4429                 }
4430                 if (preeminent) {
4431                     save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4432                     if (tied) {
4433                         SV *nsv = sv_mortalcopy(sv);
4434                         mg_clear(sv);
4435                         sv = nsv;
4436                     }
4437                 }
4438                 else
4439                     SAVEADELETE(av, idx);
4440             }
4441             else
4442                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4443         }
4444         else
4445             DIE(aTHX_ "Not a HASH reference");
4446         if (!sv)
4447             sv = &PL_sv_undef;
4448         if (gimme != G_VOID)
4449             PUSHs(sv);
4450     }
4451
4452     RETURN;
4453 }
4454
4455 PP(pp_delete)
4456 {
4457     dVAR;
4458     dSP;
4459     I32 gimme;
4460     I32 discard;
4461
4462     if (PL_op->op_private & OPpLVAL_INTRO)
4463         return do_delete_local();
4464
4465     gimme = GIMME_V;
4466     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4467
4468     if (PL_op->op_private & OPpSLICE) {
4469         dMARK; dORIGMARK;
4470         HV * const hv = MUTABLE_HV(POPs);
4471         const U32 hvtype = SvTYPE(hv);
4472         if (hvtype == SVt_PVHV) {                       /* hash element */
4473             while (++MARK <= SP) {
4474                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4475                 *MARK = sv ? sv : &PL_sv_undef;
4476             }
4477         }
4478         else if (hvtype == SVt_PVAV) {                  /* array element */
4479             if (PL_op->op_flags & OPf_SPECIAL) {
4480                 while (++MARK <= SP) {
4481                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4482                     *MARK = sv ? sv : &PL_sv_undef;
4483                 }
4484             }
4485         }
4486         else
4487             DIE(aTHX_ "Not a HASH reference");
4488         if (discard)
4489             SP = ORIGMARK;
4490         else if (gimme == G_SCALAR) {
4491             MARK = ORIGMARK;
4492             if (SP > MARK)
4493                 *++MARK = *SP;
4494             else
4495                 *++MARK = &PL_sv_undef;
4496             SP = MARK;
4497         }
4498     }
4499     else {
4500         SV *keysv = POPs;
4501         HV * const hv = MUTABLE_HV(POPs);
4502         SV *sv = NULL;
4503         if (SvTYPE(hv) == SVt_PVHV)
4504             sv = hv_delete_ent(hv, keysv, discard, 0);
4505         else if (SvTYPE(hv) == SVt_PVAV) {
4506             if (PL_op->op_flags & OPf_SPECIAL)
4507                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4508             else
4509                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4510         }
4511         else
4512             DIE(aTHX_ "Not a HASH reference");
4513         if (!sv)
4514             sv = &PL_sv_undef;
4515         if (!discard)
4516             PUSHs(sv);
4517     }
4518     RETURN;
4519 }
4520
4521 PP(pp_exists)
4522 {
4523     dVAR;
4524     dSP;
4525     SV *tmpsv;
4526     HV *hv;
4527
4528     if (PL_op->op_private & OPpEXISTS_SUB) {
4529         GV *gv;
4530         SV * const sv = POPs;
4531         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4532         if (cv)
4533             RETPUSHYES;
4534         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4535             RETPUSHYES;
4536         RETPUSHNO;
4537     }
4538     tmpsv = POPs;
4539     hv = MUTABLE_HV(POPs);
4540     if (SvTYPE(hv) == SVt_PVHV) {
4541         if (hv_exists_ent(hv, tmpsv, 0))
4542             RETPUSHYES;
4543     }
4544     else if (SvTYPE(hv) == SVt_PVAV) {
4545         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4546             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4547                 RETPUSHYES;
4548         }
4549     }
4550     else {
4551         DIE(aTHX_ "Not a HASH reference");
4552     }
4553     RETPUSHNO;
4554 }
4555
4556 PP(pp_hslice)
4557 {
4558     dVAR; dSP; dMARK; dORIGMARK;
4559     register HV * const hv = MUTABLE_HV(POPs);
4560     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4561     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4562     bool can_preserve = FALSE;
4563
4564     if (localizing) {
4565         MAGIC *mg;
4566         HV *stash;
4567
4568         if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4569             can_preserve = TRUE;
4570     }
4571
4572     while (++MARK <= SP) {
4573         SV * const keysv = *MARK;
4574         SV **svp;
4575         HE *he;
4576         bool preeminent = TRUE;
4577
4578         if (localizing && can_preserve) {
4579             /* If we can determine whether the element exist,
4580              * try to preserve the existenceness of a tied hash
4581              * element by using EXISTS and DELETE if possible.
4582              * Fallback to FETCH and STORE otherwise. */
4583             preeminent = hv_exists_ent(hv, keysv, 0);
4584         }
4585
4586         he = hv_fetch_ent(hv, keysv, lval, 0);
4587         svp = he ? &HeVAL(he) : NULL;
4588
4589         if (lval) {
4590             if (!svp || *svp == &PL_sv_undef) {
4591                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4592             }
4593             if (localizing) {
4594                 if (HvNAME_get(hv) && isGV(*svp))
4595                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4596                 else if (preeminent)
4597                     save_helem_flags(hv, keysv, svp,
4598                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4599                 else
4600                     SAVEHDELETE(hv, keysv);
4601             }
4602         }
4603         *MARK = svp ? *svp : &PL_sv_undef;
4604     }
4605     if (GIMME != G_ARRAY) {
4606         MARK = ORIGMARK;
4607         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4608         SP = MARK;
4609     }
4610     RETURN;
4611 }
4612
4613 /* List operators. */
4614
4615 PP(pp_list)
4616 {
4617     dVAR; dSP; dMARK;
4618     if (GIMME != G_ARRAY) {
4619         if (++MARK <= SP)
4620             *MARK = *SP;                /* unwanted list, return last item */
4621         else
4622             *MARK = &PL_sv_undef;
4623         SP = MARK;
4624     }
4625     RETURN;
4626 }
4627
4628 PP(pp_lslice)
4629 {
4630     dVAR;
4631     dSP;
4632     SV ** const lastrelem = PL_stack_sp;
4633     SV ** const lastlelem = PL_stack_base + POPMARK;
4634     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4635     register SV ** const firstrelem = lastlelem + 1;
4636     I32 is_something_there = FALSE;
4637
4638     register const I32 max = lastrelem - lastlelem;
4639     register SV **lelem;