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