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