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