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