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