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