&CORE::srand()
[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 if (!TOPs) {
2817         value = 1.0; (void)POPs;
2818     }
2819     else
2820         value = POPn;
2821     if (value == 0.0)
2822         value = 1.0;
2823     if (!PL_srand_called) {
2824         (void)seedDrand01((Rand_seed_t)seed());
2825         PL_srand_called = TRUE;
2826     }
2827     value *= Drand01();
2828     XPUSHn(value);
2829     RETURN;
2830 }
2831
2832 PP(pp_srand)
2833 {
2834     dVAR; dSP; dTARGET;
2835     const UV anum = (MAXARG < 1 || (!TOPs && !POPs)) ? seed() : POPu;
2836     (void)seedDrand01((Rand_seed_t)anum);
2837     PL_srand_called = TRUE;
2838     if (anum)
2839         XPUSHu(anum);
2840     else {
2841         /* Historically srand always returned true. We can avoid breaking
2842            that like this:  */
2843         sv_setpvs(TARG, "0 but true");
2844         XPUSHTARG;
2845     }
2846     RETURN;
2847 }
2848
2849 PP(pp_int)
2850 {
2851     dVAR; dSP; dTARGET;
2852     tryAMAGICun_MG(int_amg, AMGf_numeric);
2853     {
2854       SV * const sv = TOPs;
2855       const IV iv = SvIV_nomg(sv);
2856       /* XXX it's arguable that compiler casting to IV might be subtly
2857          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2858          else preferring IV has introduced a subtle behaviour change bug. OTOH
2859          relying on floating point to be accurate is a bug.  */
2860
2861       if (!SvOK(sv)) {
2862         SETu(0);
2863       }
2864       else if (SvIOK(sv)) {
2865         if (SvIsUV(sv))
2866             SETu(SvUV_nomg(sv));
2867         else
2868             SETi(iv);
2869       }
2870       else {
2871           const NV value = SvNV_nomg(sv);
2872           if (value >= 0.0) {
2873               if (value < (NV)UV_MAX + 0.5) {
2874                   SETu(U_V(value));
2875               } else {
2876                   SETn(Perl_floor(value));
2877               }
2878           }
2879           else {
2880               if (value > (NV)IV_MIN - 0.5) {
2881                   SETi(I_V(value));
2882               } else {
2883                   SETn(Perl_ceil(value));
2884               }
2885           }
2886       }
2887     }
2888     RETURN;
2889 }
2890
2891 PP(pp_abs)
2892 {
2893     dVAR; dSP; dTARGET;
2894     tryAMAGICun_MG(abs_amg, AMGf_numeric);
2895     {
2896       SV * const sv = TOPs;
2897       /* This will cache the NV value if string isn't actually integer  */
2898       const IV iv = SvIV_nomg(sv);
2899
2900       if (!SvOK(sv)) {
2901         SETu(0);
2902       }
2903       else if (SvIOK(sv)) {
2904         /* IVX is precise  */
2905         if (SvIsUV(sv)) {
2906           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
2907         } else {
2908           if (iv >= 0) {
2909             SETi(iv);
2910           } else {
2911             if (iv != IV_MIN) {
2912               SETi(-iv);
2913             } else {
2914               /* 2s complement assumption. Also, not really needed as
2915                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2916               SETu(IV_MIN);
2917             }
2918           }
2919         }
2920       } else{
2921         const NV value = SvNV_nomg(sv);
2922         if (value < 0.0)
2923           SETn(-value);
2924         else
2925           SETn(value);
2926       }
2927     }
2928     RETURN;
2929 }
2930
2931 PP(pp_oct)
2932 {
2933     dVAR; dSP; dTARGET;
2934     const char *tmps;
2935     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2936     STRLEN len;
2937     NV result_nv;
2938     UV result_uv;
2939     SV* const sv = POPs;
2940
2941     tmps = (SvPV_const(sv, len));
2942     if (DO_UTF8(sv)) {
2943          /* If Unicode, try to downgrade
2944           * If not possible, croak. */
2945          SV* const tsv = sv_2mortal(newSVsv(sv));
2946         
2947          SvUTF8_on(tsv);
2948          sv_utf8_downgrade(tsv, FALSE);
2949          tmps = SvPV_const(tsv, len);
2950     }
2951     if (PL_op->op_type == OP_HEX)
2952         goto hex;
2953
2954     while (*tmps && len && isSPACE(*tmps))
2955         tmps++, len--;
2956     if (*tmps == '0')
2957         tmps++, len--;
2958     if (*tmps == 'x' || *tmps == 'X') {
2959     hex:
2960         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2961     }
2962     else if (*tmps == 'b' || *tmps == 'B')
2963         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2964     else
2965         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2966
2967     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2968         XPUSHn(result_nv);
2969     }
2970     else {
2971         XPUSHu(result_uv);
2972     }
2973     RETURN;
2974 }
2975
2976 /* String stuff. */
2977
2978 PP(pp_length)
2979 {
2980     dVAR; dSP; dTARGET;
2981     SV * const sv = TOPs;
2982
2983     if (SvGAMAGIC(sv)) {
2984         /* For an overloaded or magic scalar, we can't know in advance if
2985            it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
2986            it likes to cache the length. Maybe that should be a documented
2987            feature of it.
2988         */
2989         STRLEN len;
2990         const char *const p
2991             = sv_2pv_flags(sv, &len,
2992                            SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
2993
2994         if (!p) {
2995             if (!SvPADTMP(TARG)) {
2996                 sv_setsv(TARG, &PL_sv_undef);
2997                 SETTARG;
2998             }
2999             SETs(&PL_sv_undef);
3000         }
3001         else if (DO_UTF8(sv)) {
3002             SETi(utf8_length((U8*)p, (U8*)p + len));
3003         }
3004         else
3005             SETi(len);
3006     } else if (SvOK(sv)) {
3007         /* Neither magic nor overloaded.  */
3008         if (DO_UTF8(sv))
3009             SETi(sv_len_utf8(sv));
3010         else
3011             SETi(sv_len(sv));
3012     } else {
3013         if (!SvPADTMP(TARG)) {
3014             sv_setsv_nomg(TARG, &PL_sv_undef);
3015             SETTARG;
3016         }
3017         SETs(&PL_sv_undef);
3018     }
3019     RETURN;
3020 }
3021
3022 PP(pp_substr)
3023 {
3024     dVAR; dSP; dTARGET;
3025     SV *sv;
3026     STRLEN curlen;
3027     STRLEN utf8_curlen;
3028     SV *   pos_sv;
3029     IV     pos1_iv;
3030     int    pos1_is_uv;
3031     IV     pos2_iv;
3032     int    pos2_is_uv;
3033     SV *   len_sv;
3034     IV     len_iv = 0;
3035     int    len_is_uv = 1;
3036     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3037     const char *tmps;
3038     const IV arybase = CopARYBASE_get(PL_curcop);
3039     SV *repl_sv = NULL;
3040     const char *repl = NULL;
3041     STRLEN repl_len;
3042     const int num_args = PL_op->op_private & 7;
3043     bool repl_need_utf8_upgrade = FALSE;
3044     bool repl_is_utf8 = FALSE;
3045
3046     if (num_args > 2) {
3047         if (num_args > 3) {
3048             repl_sv = POPs;
3049             repl = SvPV_const(repl_sv, repl_len);
3050             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3051         }
3052         len_sv    = POPs;
3053         len_iv    = SvIV(len_sv);
3054         len_is_uv = SvIOK_UV(len_sv);
3055     }
3056     pos_sv     = POPs;
3057     pos1_iv    = SvIV(pos_sv);
3058     pos1_is_uv = SvIOK_UV(pos_sv);
3059     sv = POPs;
3060     PUTBACK;
3061     if (repl_sv) {
3062         if (repl_is_utf8) {
3063             if (!DO_UTF8(sv))
3064                 sv_utf8_upgrade(sv);
3065         }
3066         else if (DO_UTF8(sv))
3067             repl_need_utf8_upgrade = TRUE;
3068     }
3069     tmps = SvPV_const(sv, curlen);
3070     if (DO_UTF8(sv)) {
3071         utf8_curlen = sv_len_utf8(sv);
3072         if (utf8_curlen == curlen)
3073             utf8_curlen = 0;
3074         else
3075             curlen = utf8_curlen;
3076     }
3077     else
3078         utf8_curlen = 0;
3079
3080     if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3081         UV pos1_uv = pos1_iv-arybase;
3082         /* Overflow can occur when $[ < 0 */
3083         if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3084             goto bound_fail;
3085         pos1_iv = pos1_uv;
3086         pos1_is_uv = 1;
3087     }
3088     else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3089         goto bound_fail;  /* $[=3; substr($_,2,...) */
3090     }
3091     else { /* pos < $[ */
3092         if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3093             pos1_iv = curlen;
3094             pos1_is_uv = 1;
3095         } else {
3096             if (curlen) {
3097                 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3098                 pos1_iv += curlen;
3099            }
3100         }
3101     }
3102     if (pos1_is_uv || pos1_iv > 0) {
3103         if ((UV)pos1_iv > curlen)
3104             goto bound_fail;
3105     }
3106
3107     if (num_args > 2) {
3108         if (!len_is_uv && len_iv < 0) {
3109             pos2_iv = curlen + len_iv;
3110             if (curlen)
3111                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3112             else
3113                 pos2_is_uv = 0;
3114         } else {  /* len_iv >= 0 */
3115             if (!pos1_is_uv && pos1_iv < 0) {
3116                 pos2_iv = pos1_iv + len_iv;
3117                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3118             } else {
3119                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3120                     pos2_iv = curlen;
3121                 else
3122                     pos2_iv = pos1_iv+len_iv;
3123                 pos2_is_uv = 1;
3124             }
3125         }
3126     }
3127     else {
3128         pos2_iv = curlen;
3129         pos2_is_uv = 1;
3130     }
3131
3132     if (!pos2_is_uv && pos2_iv < 0) {
3133         if (!pos1_is_uv && pos1_iv < 0)
3134             goto bound_fail;
3135         pos2_iv = 0;
3136     }
3137     else if (!pos1_is_uv && pos1_iv < 0)
3138         pos1_iv = 0;
3139
3140     if ((UV)pos2_iv < (UV)pos1_iv)
3141         pos2_iv = pos1_iv;
3142     if ((UV)pos2_iv > curlen)
3143         pos2_iv = curlen;
3144
3145     {
3146         /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3147         const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3148         const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3149         STRLEN byte_len = len;
3150         STRLEN byte_pos = utf8_curlen
3151             ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3152
3153         if (lvalue && !repl) {
3154             SV * ret;
3155
3156             if (!SvGMAGICAL(sv)) {
3157                 if (SvROK(sv)) {
3158                     SvPV_force_nolen(sv);
3159                     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3160                                    "Attempt to use reference as lvalue in substr");
3161                 }
3162                 if (isGV_with_GP(sv))
3163                     SvPV_force_nolen(sv);
3164                 else if (SvOK(sv))      /* is it defined ? */
3165                     (void)SvPOK_only_UTF8(sv);
3166                 else
3167                     sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3168             }
3169
3170             ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3171             sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3172             LvTYPE(ret) = 'x';
3173             LvTARG(ret) = SvREFCNT_inc_simple(sv);
3174             LvTARGOFF(ret) = pos;
3175             LvTARGLEN(ret) = len;
3176
3177             SPAGAIN;
3178             PUSHs(ret);    /* avoid SvSETMAGIC here */
3179             RETURN;
3180         }
3181
3182         SvTAINTED_off(TARG);                    /* decontaminate */
3183         SvUTF8_off(TARG);                       /* decontaminate */
3184
3185         tmps += byte_pos;
3186         sv_setpvn(TARG, tmps, byte_len);
3187 #ifdef USE_LOCALE_COLLATE
3188         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3189 #endif
3190         if (utf8_curlen)
3191             SvUTF8_on(TARG);
3192
3193         if (repl) {
3194             SV* repl_sv_copy = NULL;
3195
3196             if (repl_need_utf8_upgrade) {
3197                 repl_sv_copy = newSVsv(repl_sv);
3198                 sv_utf8_upgrade(repl_sv_copy);
3199                 repl = SvPV_const(repl_sv_copy, repl_len);
3200                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3201             }
3202             if (!SvOK(sv))
3203                 sv_setpvs(sv, "");
3204             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3205             if (repl_is_utf8)
3206                 SvUTF8_on(sv);
3207             SvREFCNT_dec(repl_sv_copy);
3208         }
3209     }
3210     SPAGAIN;
3211     SvSETMAGIC(TARG);
3212     PUSHs(TARG);
3213     RETURN;
3214
3215 bound_fail:
3216     if (lvalue || repl)
3217         Perl_croak(aTHX_ "substr outside of string");
3218     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3219     RETPUSHUNDEF;
3220 }
3221
3222 PP(pp_vec)
3223 {
3224     dVAR; dSP;
3225     register const IV size   = POPi;
3226     register const IV offset = POPi;
3227     register SV * const src = POPs;
3228     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3229     SV * ret;
3230
3231     if (lvalue) {                       /* it's an lvalue! */
3232         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3233         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3234         LvTYPE(ret) = 'v';
3235         LvTARG(ret) = SvREFCNT_inc_simple(src);
3236         LvTARGOFF(ret) = offset;
3237         LvTARGLEN(ret) = size;
3238     }
3239     else {
3240         dTARGET;
3241         SvTAINTED_off(TARG);            /* decontaminate */
3242         ret = TARG;
3243     }
3244
3245     sv_setuv(ret, do_vecget(src, offset, size));
3246     PUSHs(ret);
3247     RETURN;
3248 }
3249
3250 PP(pp_index)
3251 {
3252     dVAR; dSP; dTARGET;
3253     SV *big;
3254     SV *little;
3255     SV *temp = NULL;
3256     STRLEN biglen;
3257     STRLEN llen = 0;
3258     I32 offset;
3259     I32 retval;
3260     const char *big_p;
3261     const char *little_p;
3262     const I32 arybase = CopARYBASE_get(PL_curcop);
3263     bool big_utf8;
3264     bool little_utf8;
3265     const bool is_index = PL_op->op_type == OP_INDEX;
3266     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3267
3268     if (threeargs) {
3269         /* arybase is in characters, like offset, so combine prior to the
3270            UTF-8 to bytes calculation.  */
3271         offset = POPi - arybase;
3272     }
3273     little = POPs;
3274     big = POPs;
3275     big_p = SvPV_const(big, biglen);
3276     little_p = SvPV_const(little, llen);
3277
3278     big_utf8 = DO_UTF8(big);
3279     little_utf8 = DO_UTF8(little);
3280     if (big_utf8 ^ little_utf8) {
3281         /* One needs to be upgraded.  */
3282         if (little_utf8 && !PL_encoding) {
3283             /* Well, maybe instead we might be able to downgrade the small
3284                string?  */
3285             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3286                                                      &little_utf8);
3287             if (little_utf8) {
3288                 /* If the large string is ISO-8859-1, and it's not possible to
3289                    convert the small string to ISO-8859-1, then there is no
3290                    way that it could be found anywhere by index.  */
3291                 retval = -1;
3292                 goto fail;
3293             }
3294
3295             /* At this point, pv is a malloc()ed string. So donate it to temp
3296                to ensure it will get free()d  */
3297             little = temp = newSV(0);
3298             sv_usepvn(temp, pv, llen);
3299             little_p = SvPVX(little);
3300         } else {
3301             temp = little_utf8
3302                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3303
3304             if (PL_encoding) {
3305                 sv_recode_to_utf8(temp, PL_encoding);
3306             } else {
3307                 sv_utf8_upgrade(temp);
3308             }
3309             if (little_utf8) {
3310                 big = temp;
3311                 big_utf8 = TRUE;
3312                 big_p = SvPV_const(big, biglen);
3313             } else {
3314                 little = temp;
3315                 little_p = SvPV_const(little, llen);
3316             }
3317         }
3318     }
3319     if (SvGAMAGIC(big)) {
3320         /* Life just becomes a lot easier if I use a temporary here.
3321            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3322            will trigger magic and overloading again, as will fbm_instr()
3323         */
3324         big = newSVpvn_flags(big_p, biglen,
3325                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3326         big_p = SvPVX(big);
3327     }
3328     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3329         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3330            warn on undef, and we've already triggered a warning with the
3331            SvPV_const some lines above. We can't remove that, as we need to
3332            call some SvPV to trigger overloading early and find out if the
3333            string is UTF-8.
3334            This is all getting to messy. The API isn't quite clean enough,
3335            because data access has side effects.
3336         */
3337         little = newSVpvn_flags(little_p, llen,
3338                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3339         little_p = SvPVX(little);
3340     }
3341
3342     if (!threeargs)
3343         offset = is_index ? 0 : biglen;
3344     else {
3345         if (big_utf8 && offset > 0)
3346             sv_pos_u2b(big, &offset, 0);
3347         if (!is_index)
3348             offset += llen;
3349     }
3350     if (offset < 0)
3351         offset = 0;
3352     else if (offset > (I32)biglen)
3353         offset = biglen;
3354     if (!(little_p = is_index
3355           ? fbm_instr((unsigned char*)big_p + offset,
3356                       (unsigned char*)big_p + biglen, little, 0)
3357           : rninstr(big_p,  big_p  + offset,
3358                     little_p, little_p + llen)))
3359         retval = -1;
3360     else {
3361         retval = little_p - big_p;
3362         if (retval > 0 && big_utf8)
3363             sv_pos_b2u(big, &retval);
3364     }
3365     SvREFCNT_dec(temp);
3366  fail:
3367     PUSHi(retval + arybase);
3368     RETURN;
3369 }
3370
3371 PP(pp_sprintf)
3372 {
3373     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3374     SvTAINTED_off(TARG);
3375     do_sprintf(TARG, SP-MARK, MARK+1);
3376     TAINT_IF(SvTAINTED(TARG));
3377     SP = ORIGMARK;
3378     PUSHTARG;
3379     RETURN;
3380 }
3381
3382 PP(pp_ord)
3383 {
3384     dVAR; dSP; dTARGET;
3385
3386     SV *argsv = POPs;
3387     STRLEN len;
3388     const U8 *s = (U8*)SvPV_const(argsv, len);
3389
3390     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3391         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3392         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3393         argsv = tmpsv;
3394     }
3395
3396     XPUSHu(DO_UTF8(argsv) ?
3397            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3398            (UV)(*s & 0xff));
3399
3400     RETURN;
3401 }
3402
3403 PP(pp_chr)
3404 {
3405     dVAR; dSP; dTARGET;
3406     char *tmps;
3407     UV value;
3408
3409     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3410          ||
3411          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3412         if (IN_BYTES) {
3413             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3414         } else {
3415             (void) POPs; /* Ignore the argument value. */
3416             value = UNICODE_REPLACEMENT;
3417         }
3418     } else {
3419         value = POPu;
3420     }
3421
3422     SvUPGRADE(TARG,SVt_PV);
3423
3424     if (value > 255 && !IN_BYTES) {
3425         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3426         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3427         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3428         *tmps = '\0';
3429         (void)SvPOK_only(TARG);
3430         SvUTF8_on(TARG);
3431         XPUSHs(TARG);
3432         RETURN;
3433     }
3434
3435     SvGROW(TARG,2);
3436     SvCUR_set(TARG, 1);
3437     tmps = SvPVX(TARG);
3438     *tmps++ = (char)value;
3439     *tmps = '\0';
3440     (void)SvPOK_only(TARG);
3441
3442     if (PL_encoding && !IN_BYTES) {
3443         sv_recode_to_utf8(TARG, PL_encoding);
3444         tmps = SvPVX(TARG);
3445         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3446             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3447             SvGROW(TARG, 2);
3448             tmps = SvPVX(TARG);
3449             SvCUR_set(TARG, 1);
3450             *tmps++ = (char)value;
3451             *tmps = '\0';
3452             SvUTF8_off(TARG);
3453         }
3454     }
3455
3456     XPUSHs(TARG);
3457     RETURN;
3458 }
3459
3460 PP(pp_crypt)
3461 {
3462 #ifdef HAS_CRYPT
3463     dVAR; dSP; dTARGET;
3464     dPOPTOPssrl;
3465     STRLEN len;
3466     const char *tmps = SvPV_const(left, len);
3467
3468     if (DO_UTF8(left)) {
3469          /* If Unicode, try to downgrade.
3470           * If not possible, croak.
3471           * Yes, we made this up.  */
3472          SV* const tsv = sv_2mortal(newSVsv(left));
3473
3474          SvUTF8_on(tsv);
3475          sv_utf8_downgrade(tsv, FALSE);
3476          tmps = SvPV_const(tsv, len);
3477     }
3478 #   ifdef USE_ITHREADS
3479 #     ifdef HAS_CRYPT_R
3480     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3481       /* This should be threadsafe because in ithreads there is only
3482        * one thread per interpreter.  If this would not be true,
3483        * we would need a mutex to protect this malloc. */
3484         PL_reentrant_buffer->_crypt_struct_buffer =
3485           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3486 #if defined(__GLIBC__) || defined(__EMX__)
3487         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3488             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3489             /* work around glibc-2.2.5 bug */
3490             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3491         }
3492 #endif
3493     }
3494 #     endif /* HAS_CRYPT_R */
3495 #   endif /* USE_ITHREADS */
3496 #   ifdef FCRYPT
3497     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3498 #   else
3499     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3500 #   endif
3501     SETTARG;
3502     RETURN;
3503 #else
3504     DIE(aTHX_
3505       "The crypt() function is unimplemented due to excessive paranoia.");
3506 #endif
3507 }
3508
3509 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So 
3510  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3511
3512 /* Below are several macros that generate code */
3513 /* Generates code to store a unicode codepoint c that is known to occupy
3514  * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3515 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c)                                    \
3516     STMT_START {                                                            \
3517         *(p) = UTF8_TWO_BYTE_HI(c);                                         \
3518         *((p)+1) = UTF8_TWO_BYTE_LO(c);                                     \
3519     } STMT_END
3520
3521 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3522  * available byte after the two bytes */
3523 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c)                                      \
3524     STMT_START {                                                            \
3525         *(p)++ = UTF8_TWO_BYTE_HI(c);                                       \
3526         *((p)++) = UTF8_TWO_BYTE_LO(c);                                     \
3527     } STMT_END
3528
3529 /* Generates code to store the upper case of latin1 character l which is known
3530  * to have its upper case be non-latin1 into the two bytes p and p+1.  There
3531  * are only two characters that fit this description, and this macro knows
3532  * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3533  * bytes */
3534 #define STORE_NON_LATIN1_UC(p, l)                                           \
3535 STMT_START {                                                                \
3536     if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {                       \
3537         STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);  \
3538     } else { /* Must be the following letter */                                                             \
3539         STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU);           \
3540     }                                                                       \
3541 } STMT_END
3542
3543 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3544  * after the character stored */
3545 #define CAT_NON_LATIN1_UC(p, l)                                             \
3546 STMT_START {                                                                \
3547     if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {                       \
3548         CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);    \
3549     } else {                                                                \
3550         CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU);             \
3551     }                                                                       \
3552 } STMT_END
3553
3554 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3555  * case of l into p and p+1.  u must be the result of toUPPER_LATIN1_MOD(l),
3556  * and must require two bytes to store it.  Advances p to point to the next
3557  * available position */
3558 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u)                                 \
3559 STMT_START {                                                                \
3560     if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {                       \
3561         CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3562     } else if (l == LATIN_SMALL_LETTER_SHARP_S) {                           \
3563         *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */                \
3564     } else {/* else is one of the other two special cases */                \
3565         CAT_NON_LATIN1_UC((p), (l));                                        \
3566     }                                                                       \
3567 } STMT_END
3568
3569 PP(pp_ucfirst)
3570 {
3571     /* Actually is both lcfirst() and ucfirst().  Only the first character
3572      * changes.  This means that possibly we can change in-place, ie., just
3573      * take the source and change that one character and store it back, but not
3574      * if read-only etc, or if the length changes */
3575
3576     dVAR;
3577     dSP;
3578     SV *source = TOPs;
3579     STRLEN slen; /* slen is the byte length of the whole SV. */
3580     STRLEN need;
3581     SV *dest;
3582     bool inplace;   /* ? Convert first char only, in-place */
3583     bool doing_utf8 = FALSE;               /* ? using utf8 */
3584     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3585     const int op_type = PL_op->op_type;
3586     const U8 *s;
3587     U8 *d;
3588     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3589     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3590                      * stored as UTF-8 at s. */
3591     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3592                      * lowercased) character stored in tmpbuf.  May be either
3593                      * UTF-8 or not, but in either case is the number of bytes */
3594
3595     SvGETMAGIC(source);
3596     if (SvOK(source)) {
3597         s = (const U8*)SvPV_nomg_const(source, slen);
3598     } else {
3599         if (ckWARN(WARN_UNINITIALIZED))
3600             report_uninit(source);
3601         s = (const U8*)"";
3602         slen = 0;
3603     }
3604
3605     /* We may be able to get away with changing only the first character, in
3606      * place, but not if read-only, etc.  Later we may discover more reasons to
3607      * not convert in-place. */
3608     inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3609
3610     /* First calculate what the changed first character should be.  This affects
3611      * whether we can just swap it out, leaving the rest of the string unchanged,
3612      * or even if have to convert the dest to UTF-8 when the source isn't */
3613
3614     if (! slen) {   /* If empty */
3615         need = 1; /* still need a trailing NUL */
3616     }
3617     else if (DO_UTF8(source)) { /* Is the source utf8? */
3618         doing_utf8 = TRUE;
3619
3620         if (UTF8_IS_INVARIANT(*s)) {
3621
3622             /* An invariant source character is either ASCII or, in EBCDIC, an
3623              * ASCII equivalent or a caseless C1 control.  In both these cases,
3624              * the lower and upper cases of any character are also invariants
3625              * (and title case is the same as upper case).  So it is safe to
3626              * use the simple case change macros which avoid the overhead of
3627              * the general functions.  Note that if perl were to be extended to
3628              * do locale handling in UTF-8 strings, this wouldn't be true in,
3629              * for example, Lithuanian or Turkic.  */
3630             *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3631             tculen = ulen = 1;
3632             need = slen + 1;
3633         }
3634         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3635             U8 chr;
3636
3637             /* Similarly, if the source character isn't invariant but is in the
3638              * latin1 range (or EBCDIC equivalent thereof), we have the case
3639              * changes compiled into perl, and can avoid the overhead of the
3640              * general functions.  In this range, the characters are stored as
3641              * two UTF-8 bytes, and it so happens that any changed-case version
3642              * is also two bytes (in both ASCIIish and EBCDIC machines). */
3643             tculen = ulen = 2;
3644             need = slen + 1;
3645
3646             /* Convert the two source bytes to a single Unicode code point
3647              * value, change case and save for below */
3648             chr = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
3649             if (op_type == OP_LCFIRST) {    /* lower casing is easy */
3650                 U8 lower = toLOWER_LATIN1(chr);
3651                 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3652             }
3653             else {      /* ucfirst */
3654                 U8 upper = toUPPER_LATIN1_MOD(chr);
3655
3656                 /* Most of the latin1 range characters are well-behaved.  Their
3657                  * title and upper cases are the same, and are also in the
3658                  * latin1 range.  The macro above returns their upper (hence
3659                  * title) case, and all that need be done is to save the result
3660                  * for below.  However, several characters are problematic, and
3661                  * have to be handled specially.  The MOD in the macro name
3662                  * above means that these tricky characters all get mapped to
3663                  * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3664                  * This mapping saves some tests for the majority of the
3665                  * characters */
3666
3667                 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3668
3669                     /* Not tricky.  Just save it. */
3670                     STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3671                 }
3672                 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3673
3674                     /* This one is tricky because it is two characters long,
3675                      * though the UTF-8 is still two bytes, so the stored
3676                      * length doesn't change */
3677                     *tmpbuf = 'S';  /* The UTF-8 is 'Ss' */
3678                     *(tmpbuf + 1) = 's';
3679                 }
3680                 else {
3681
3682                     /* The other two have their title and upper cases the same,
3683                      * but are tricky because the changed-case characters
3684                      * aren't in the latin1 range.  They, however, do fit into
3685                      * two UTF-8 bytes */
3686                     STORE_NON_LATIN1_UC(tmpbuf, chr);    
3687                 }
3688             }
3689         }
3690         else {
3691
3692             /* Here, can't short-cut the general case */
3693
3694             utf8_to_uvchr(s, &ulen);
3695             if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3696             else toLOWER_utf8(s, tmpbuf, &tculen);
3697
3698             /* we can't do in-place if the length changes.  */
3699             if (ulen != tculen) inplace = FALSE;
3700             need = slen + 1 - ulen + tculen;
3701         }
3702     }
3703     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3704             * latin1 is treated as caseless.  Note that a locale takes
3705             * precedence */ 
3706         tculen = 1;     /* Most characters will require one byte, but this will
3707                          * need to be overridden for the tricky ones */
3708         need = slen + 1;
3709
3710         if (op_type == OP_LCFIRST) {
3711
3712             /* lower case the first letter: no trickiness for any character */
3713             *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3714                         ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3715         }
3716         /* is ucfirst() */
3717         else if (IN_LOCALE_RUNTIME) {
3718             *tmpbuf = toUPPER_LC(*s);   /* This would be a bug if any locales
3719                                          * have upper and title case different
3720                                          */
3721         }
3722         else if (! IN_UNI_8_BIT) {
3723             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3724                                          * on EBCDIC machines whatever the
3725                                          * native function does */
3726         }
3727         else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3728             *tmpbuf = toUPPER_LATIN1_MOD(*s);
3729
3730             /* tmpbuf now has the correct title case for all latin1 characters
3731              * except for the several ones that have tricky handling.  All
3732              * of these are mapped by the MOD to the letter below. */
3733             if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3734
3735                 /* The length is going to change, with all three of these, so
3736                  * can't replace just the first character */
3737                 inplace = FALSE;
3738
3739                 /* We use the original to distinguish between these tricky
3740                  * cases */
3741                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3742                     /* Two character title case 'Ss', but can remain non-UTF-8 */
3743                     need = slen + 2;
3744                     *tmpbuf = 'S';
3745                     *(tmpbuf + 1) = 's';   /* Assert: length(tmpbuf) >= 2 */
3746                     tculen = 2;
3747                 }
3748                 else {
3749
3750                     /* The other two tricky ones have their title case outside
3751                      * latin1.  It is the same as their upper case. */
3752                     doing_utf8 = TRUE;
3753                     STORE_NON_LATIN1_UC(tmpbuf, *s);
3754
3755                     /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3756                      * and their upper cases is 2. */
3757                     tculen = ulen = 2;
3758
3759                     /* The entire result will have to be in UTF-8.  Assume worst
3760                      * case sizing in conversion. (all latin1 characters occupy
3761                      * at most two bytes in utf8) */
3762                     convert_source_to_utf8 = TRUE;
3763                     need = slen * 2 + 1;
3764                 }
3765             } /* End of is one of the three special chars */
3766         } /* End of use Unicode (Latin1) semantics */
3767     } /* End of changing the case of the first character */
3768
3769     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3770      * generate the result */
3771     if (inplace) {
3772
3773         /* We can convert in place.  This means we change just the first
3774          * character without disturbing the rest; no need to grow */
3775         dest = source;
3776         s = d = (U8*)SvPV_force_nomg(source, slen);
3777     } else {
3778         dTARGET;
3779
3780         dest = TARG;
3781
3782         /* Here, we can't convert in place; we earlier calculated how much
3783          * space we will need, so grow to accommodate that */
3784         SvUPGRADE(dest, SVt_PV);
3785         d = (U8*)SvGROW(dest, need);
3786         (void)SvPOK_only(dest);
3787
3788         SETs(dest);
3789     }
3790
3791     if (doing_utf8) {
3792         if (! inplace) {
3793             if (! convert_source_to_utf8) {
3794
3795                 /* Here  both source and dest are in UTF-8, but have to create
3796                  * the entire output.  We initialize the result to be the
3797                  * title/lower cased first character, and then append the rest
3798                  * of the string. */
3799                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3800                 if (slen > ulen) {
3801                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3802                 }
3803             }
3804             else {
3805                 const U8 *const send = s + slen;
3806
3807                 /* Here the dest needs to be in UTF-8, but the source isn't,
3808                  * except we earlier UTF-8'd the first character of the source
3809                  * into tmpbuf.  First put that into dest, and then append the
3810                  * rest of the source, converting it to UTF-8 as we go. */
3811
3812                 /* Assert tculen is 2 here because the only two characters that
3813                  * get to this part of the code have 2-byte UTF-8 equivalents */
3814                 *d++ = *tmpbuf;
3815                 *d++ = *(tmpbuf + 1);
3816                 s++;    /* We have just processed the 1st char */
3817
3818                 for (; s < send; s++) {
3819                     d = uvchr_to_utf8(d, *s);
3820                 }
3821                 *d = '\0';
3822                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3823             }
3824             SvUTF8_on(dest);
3825         }
3826         else {   /* in-place UTF-8.  Just overwrite the first character */
3827             Copy(tmpbuf, d, tculen, U8);
3828             SvCUR_set(dest, need - 1);
3829         }
3830     }
3831     else {  /* Neither source nor dest are in or need to be UTF-8 */
3832         if (slen) {
3833             if (IN_LOCALE_RUNTIME) {
3834                 TAINT;
3835                 SvTAINTED_on(dest);
3836             }
3837             if (inplace) {  /* in-place, only need to change the 1st char */
3838                 *d = *tmpbuf;
3839             }
3840             else {      /* Not in-place */
3841
3842                 /* Copy the case-changed character(s) from tmpbuf */
3843                 Copy(tmpbuf, d, tculen, U8);
3844                 d += tculen - 1; /* Code below expects d to point to final
3845                                   * character stored */
3846             }
3847         }
3848         else {  /* empty source */
3849             /* See bug #39028: Don't taint if empty  */
3850             *d = *s;
3851         }
3852
3853         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3854          * the destination to retain that flag */
3855         if (SvUTF8(source))
3856             SvUTF8_on(dest);
3857
3858         if (!inplace) { /* Finish the rest of the string, unchanged */
3859             /* This will copy the trailing NUL  */
3860             Copy(s + 1, d + 1, slen, U8);
3861             SvCUR_set(dest, need - 1);
3862         }
3863     }
3864     if (dest != source && SvTAINTED(source))
3865         SvTAINT(dest);
3866     SvSETMAGIC(dest);
3867     RETURN;
3868 }
3869
3870 /* There's so much setup/teardown code common between uc and lc, I wonder if
3871    it would be worth merging the two, and just having a switch outside each
3872    of the three tight loops.  There is less and less commonality though */
3873 PP(pp_uc)
3874 {
3875     dVAR;
3876     dSP;
3877     SV *source = TOPs;
3878     STRLEN len;
3879     STRLEN min;
3880     SV *dest;
3881     const U8 *s;
3882     U8 *d;
3883
3884     SvGETMAGIC(source);
3885
3886     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3887         && SvTEMP(source) && !DO_UTF8(source)
3888         && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3889
3890         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
3891          * make the loop tight, so we overwrite the source with the dest before
3892          * looking at it, and we need to look at the original source
3893          * afterwards.  There would also need to be code added to handle
3894          * switching to not in-place in midstream if we run into characters
3895          * that change the length.
3896          */
3897         dest = source;
3898         s = d = (U8*)SvPV_force_nomg(source, len);
3899         min = len + 1;
3900     } else {
3901         dTARGET;
3902
3903         dest = TARG;
3904
3905         /* The old implementation would copy source into TARG at this point.
3906            This had the side effect that if source was undef, TARG was now
3907            an undefined SV with PADTMP set, and they don't warn inside
3908            sv_2pv_flags(). However, we're now getting the PV direct from
3909            source, which doesn't have PADTMP set, so it would warn. Hence the
3910            little games.  */
3911
3912         if (SvOK(source)) {
3913             s = (const U8*)SvPV_nomg_const(source, len);
3914         } else {
3915             if (ckWARN(WARN_UNINITIALIZED))
3916                 report_uninit(source);
3917             s = (const U8*)"";
3918             len = 0;
3919         }
3920         min = len + 1;
3921
3922         SvUPGRADE(dest, SVt_PV);
3923         d = (U8*)SvGROW(dest, min);
3924         (void)SvPOK_only(dest);
3925
3926         SETs(dest);
3927     }
3928
3929     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3930        to check DO_UTF8 again here.  */
3931
3932     if (DO_UTF8(source)) {
3933         const U8 *const send = s + len;
3934         U8 tmpbuf[UTF8_MAXBYTES+1];
3935
3936         /* All occurrences of these are to be moved to follow any other marks.
3937          * This is context-dependent.  We may not be passed enough context to
3938          * move the iota subscript beyond all of them, but we do the best we can
3939          * with what we're given.  The result is always better than if we
3940          * hadn't done this.  And, the problem would only arise if we are
3941          * passed a character without all its combining marks, which would be
3942          * the caller's mistake.  The information this is based on comes from a
3943          * comment in Unicode SpecialCasing.txt, (and the Standard's text
3944          * itself) and so can't be checked properly to see if it ever gets
3945          * revised.  But the likelihood of it changing is remote */
3946         bool in_iota_subscript = FALSE;
3947
3948         while (s < send) {
3949             if (in_iota_subscript && ! is_utf8_mark(s)) {
3950                 /* A non-mark.  Time to output the iota subscript */
3951 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3952 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3953
3954                 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3955                 in_iota_subscript = FALSE;
3956             }
3957
3958             /* If the UTF-8 character is invariant, then it is in the range
3959              * known by the standard macro; result is only one byte long */
3960             if (UTF8_IS_INVARIANT(*s)) {
3961                 *d++ = toUPPER(*s);
3962                 s++;
3963             }
3964             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3965
3966                 /* Likewise, if it fits in a byte, its case change is in our
3967                  * table */
3968                 U8 orig = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
3969                 U8 upper = toUPPER_LATIN1_MOD(orig);
3970                 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
3971                 s += 2;
3972             }
3973             else {
3974
3975                 /* Otherwise, need the general UTF-8 case.  Get the changed
3976                  * case value and copy it to the output buffer */
3977
3978                 const STRLEN u = UTF8SKIP(s);
3979                 STRLEN ulen;
3980
3981                 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
3982                 if (uv == GREEK_CAPITAL_LETTER_IOTA
3983                     && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3984                 {
3985                     in_iota_subscript = TRUE;
3986                 }
3987                 else {
3988                     if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3989                         /* If the eventually required minimum size outgrows
3990                          * the available space, we need to grow. */
3991                         const UV o = d - (U8*)SvPVX_const(dest);
3992
3993                         /* If someone uppercases one million U+03B0s we
3994                          * SvGROW() one million times.  Or we could try
3995                          * guessing how much to allocate without allocating too
3996                          * much.  Such is life.  See corresponding comment in
3997                          * lc code for another option */
3998                         SvGROW(dest, min);
3999                         d = (U8*)SvPVX(dest) + o;
4000                     }
4001                     Copy(tmpbuf, d, ulen, U8);
4002                     d += ulen;
4003                 }
4004                 s += u;
4005             }
4006         }
4007         if (in_iota_subscript) {
4008             CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4009         }
4010         SvUTF8_on(dest);
4011         *d = '\0';
4012         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4013     }
4014     else {      /* Not UTF-8 */
4015         if (len) {
4016             const U8 *const send = s + len;
4017
4018             /* Use locale casing if in locale; regular style if not treating
4019              * latin1 as having case; otherwise the latin1 casing.  Do the
4020              * whole thing in a tight loop, for speed, */
4021             if (IN_LOCALE_RUNTIME) {
4022                 TAINT;
4023                 SvTAINTED_on(dest);
4024                 for (; s < send; d++, s++)
4025                     *d = toUPPER_LC(*s);
4026             }
4027             else if (! IN_UNI_8_BIT) {
4028                 for (; s < send; d++, s++) {
4029                     *d = toUPPER(*s);
4030                 }
4031             }
4032             else {
4033                 for (; s < send; d++, s++) {
4034                     *d = toUPPER_LATIN1_MOD(*s);
4035                     if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4036
4037                     /* The mainstream case is the tight loop above.  To avoid
4038                      * extra tests in that, all three characters that require
4039                      * special handling are mapped by the MOD to the one tested
4040                      * just above.  
4041                      * Use the source to distinguish between the three cases */
4042
4043                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4044
4045                         /* uc() of this requires 2 characters, but they are
4046                          * ASCII.  If not enough room, grow the string */
4047                         if (SvLEN(dest) < ++min) {      
4048                             const UV o = d - (U8*)SvPVX_const(dest);
4049                             SvGROW(dest, min);
4050                             d = (U8*)SvPVX(dest) + o;
4051                         }
4052                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4053                         continue;   /* Back to the tight loop; still in ASCII */
4054                     }
4055
4056                     /* The other two special handling characters have their
4057                      * upper cases outside the latin1 range, hence need to be
4058                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4059                      * here we are somewhere in the middle of processing a
4060                      * non-UTF-8 string, and realize that we will have to convert
4061                      * the whole thing to UTF-8.  What to do?  There are
4062                      * several possibilities.  The simplest to code is to
4063                      * convert what we have so far, set a flag, and continue on
4064                      * in the loop.  The flag would be tested each time through
4065                      * the loop, and if set, the next character would be
4066                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4067                      * to slow down the mainstream case at all for this fairly
4068                      * rare case, so I didn't want to add a test that didn't
4069                      * absolutely have to be there in the loop, besides the
4070                      * possibility that it would get too complicated for
4071                      * optimizers to deal with.  Another possibility is to just
4072                      * give up, convert the source to UTF-8, and restart the
4073                      * function that way.  Another possibility is to convert
4074                      * both what has already been processed and what is yet to
4075                      * come separately to UTF-8, then jump into the loop that
4076                      * handles UTF-8.  But the most efficient time-wise of the
4077                      * ones I could think of is what follows, and turned out to
4078                      * not require much extra code.  */
4079
4080                     /* Convert what we have so far into UTF-8, telling the
4081                      * function that we know it should be converted, and to
4082                      * allow extra space for what we haven't processed yet.
4083                      * Assume the worst case space requirements for converting
4084                      * what we haven't processed so far: that it will require
4085                      * two bytes for each remaining source character, plus the
4086                      * NUL at the end.  This may cause the string pointer to
4087                      * move, so re-find it. */
4088
4089                     len = d - (U8*)SvPVX_const(dest);
4090                     SvCUR_set(dest, len);
4091                     len = sv_utf8_upgrade_flags_grow(dest,
4092                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4093                                                 (send -s) * 2 + 1);
4094                     d = (U8*)SvPVX(dest) + len;
4095
4096                     /* And append the current character's upper case in UTF-8 */
4097                     CAT_NON_LATIN1_UC(d, *s);
4098
4099                     /* Now process the remainder of the source, converting to
4100                      * upper and UTF-8.  If a resulting byte is invariant in
4101                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4102                      * append it to the output. */
4103
4104                     s++;
4105                     for (; s < send; s++) {
4106                         U8 upper = toUPPER_LATIN1_MOD(*s);
4107                         if UTF8_IS_INVARIANT(upper) {
4108                             *d++ = upper;
4109                         }
4110                         else {
4111                             CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4112                         }
4113                     }
4114
4115                     /* Here have processed the whole source; no need to continue
4116                      * with the outer loop.  Each character has been converted
4117                      * to upper case and converted to UTF-8 */
4118
4119                     break;
4120                 } /* End of processing all latin1-style chars */
4121             } /* End of processing all chars */
4122         } /* End of source is not empty */
4123
4124         if (source != dest) {
4125             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4126             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4127         }
4128     } /* End of isn't utf8 */
4129     if (dest != source && SvTAINTED(source))
4130         SvTAINT(dest);
4131     SvSETMAGIC(dest);
4132     RETURN;
4133 }
4134
4135 PP(pp_lc)
4136 {
4137     dVAR;
4138     dSP;
4139     SV *source = TOPs;
4140     STRLEN len;
4141     STRLEN min;
4142     SV *dest;
4143     const U8 *s;
4144     U8 *d;
4145
4146     SvGETMAGIC(source);
4147
4148     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4149         && SvTEMP(source) && !DO_UTF8(source)) {
4150
4151         /* We can convert in place, as lowercasing anything in the latin1 range
4152          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4153         dest = source;
4154         s = d = (U8*)SvPV_force_nomg(source, len);
4155         min = len + 1;
4156     } else {
4157         dTARGET;
4158
4159         dest = TARG;
4160
4161         /* The old implementation would copy source into TARG at this point.
4162            This had the side effect that if source was undef, TARG was now
4163            an undefined SV with PADTMP set, and they don't warn inside
4164            sv_2pv_flags(). However, we're now getting the PV direct from
4165            source, which doesn't have PADTMP set, so it would warn. Hence the
4166            little games.  */
4167
4168         if (SvOK(source)) {
4169             s = (const U8*)SvPV_nomg_const(source, len);
4170         } else {
4171             if (ckWARN(WARN_UNINITIALIZED))
4172                 report_uninit(source);
4173             s = (const U8*)"";
4174             len = 0;
4175         }
4176         min = len + 1;
4177
4178         SvUPGRADE(dest, SVt_PV);
4179         d = (U8*)SvGROW(dest, min);
4180         (void)SvPOK_only(dest);
4181
4182         SETs(dest);
4183     }
4184
4185     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4186        to check DO_UTF8 again here.  */
4187
4188     if (DO_UTF8(source)) {
4189         const U8 *const send = s + len;
4190         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4191
4192         while (s < send) {
4193             if (UTF8_IS_INVARIANT(*s)) {
4194
4195                 /* Invariant characters use the standard mappings compiled in.
4196                  */
4197                 *d++ = toLOWER(*s);
4198                 s++;
4199             }
4200             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4201
4202                 /* As do the ones in the Latin1 range */
4203                 U8 lower = toLOWER_LATIN1(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1)));
4204                 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4205                 s += 2;
4206             }
4207             else {
4208                 /* Here, is utf8 not in Latin-1 range, have to go out and get
4209                  * the mappings from the tables. */
4210
4211                 const STRLEN u = UTF8SKIP(s);
4212                 STRLEN ulen;
4213
4214 #ifndef CONTEXT_DEPENDENT_CASING
4215                 toLOWER_utf8(s, tmpbuf, &ulen);
4216 #else
4217 /* This is ifdefd out because it probably is the wrong thing to do.  The right
4218  * thing is probably to have an I/O layer that converts final sigma to regular
4219  * on input and vice versa (under the correct circumstances) on output.  In
4220  * effect, the final sigma is just a glyph variation when the regular one
4221  * occurs at the end of a word.   And we don't really know what's going to be
4222  * the end of the word until it is finally output, as splitting and joining can
4223  * occur at any time and change what once was the word end to be in the middle,
4224  * and vice versa. */
4225
4226                 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4227
4228                 /* If the lower case is a small sigma, it may be that we need
4229                  * to change it to a final sigma.  This happens at the end of 
4230                  * a word that contains more than just this character, and only
4231                  * when we started with a capital sigma. */
4232                 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4233                     s > send - len &&   /* Makes sure not the first letter */
4234                     utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4235                 ) {
4236
4237                     /* We use the algorithm in:
4238                      * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4239                      * is a CAPITAL SIGMA): If C is preceded by a sequence
4240                      * consisting of a cased letter and a case-ignorable
4241                      * sequence, and C is not followed by a sequence consisting
4242                      * of a case ignorable sequence and then a cased letter,
4243                      * then when lowercasing C, C becomes a final sigma */
4244
4245                     /* To determine if this is the end of a word, need to peek
4246                      * ahead.  Look at the next character */
4247                     const U8 *peek = s + u;
4248
4249                     /* Skip any case ignorable characters */
4250                     while (peek < send && is_utf8_case_ignorable(peek)) {
4251                         peek += UTF8SKIP(peek);
4252                     }
4253
4254                     /* If we reached the end of the string without finding any
4255                      * non-case ignorable characters, or if the next such one
4256                      * is not-cased, then we have met the conditions for it
4257                      * being a final sigma with regards to peek ahead, and so
4258                      * must do peek behind for the remaining conditions. (We
4259                      * know there is stuff behind to look at since we tested
4260                      * above that this isn't the first letter) */
4261                     if (peek >= send || ! is_utf8_cased(peek)) {
4262                         peek = utf8_hop(s, -1);
4263
4264                         /* Here are at the beginning of the first character
4265                          * before the original upper case sigma.  Keep backing
4266                          * up, skipping any case ignorable characters */
4267                         while (is_utf8_case_ignorable(peek)) {
4268                             peek = utf8_hop(peek, -1);
4269                         }
4270
4271                         /* Here peek points to the first byte of the closest
4272                          * non-case-ignorable character before the capital
4273                          * sigma.  If it is cased, then by the Unicode
4274                          * algorithm, we should use a small final sigma instead
4275                          * of what we have */
4276                         if (is_utf8_cased(peek)) {
4277                             STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4278                                         UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4279                         }
4280                     }
4281                 }
4282                 else {  /* Not a context sensitive mapping */
4283 #endif  /* End of commented out context sensitive */
4284                     if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4285
4286                         /* If the eventually required minimum size outgrows
4287                          * the available space, we need to grow. */
4288                         const UV o = d - (U8*)SvPVX_const(dest);
4289
4290                         /* If someone lowercases one million U+0130s we
4291                          * SvGROW() one million times.  Or we could try
4292                          * guessing how much to allocate without allocating too
4293                          * much.  Such is life.  Another option would be to
4294                          * grow an extra byte or two more each time we need to
4295                          * grow, which would cut down the million to 500K, with
4296                          * little waste */
4297                         SvGROW(dest, min);
4298                         d = (U8*)SvPVX(dest) + o;
4299                     }
4300 #ifdef CONTEXT_DEPENDENT_CASING
4301                 }
4302 #endif
4303                 /* Copy the newly lowercased letter to the output buffer we're
4304                  * building */
4305                 Copy(tmpbuf, d, ulen, U8);
4306                 d += ulen;
4307                 s += u;
4308             }
4309         }   /* End of looping through the source string */
4310         SvUTF8_on(dest);
4311         *d = '\0';
4312         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4313     } else {    /* Not utf8 */
4314         if (len) {
4315             const U8 *const send = s + len;
4316
4317             /* Use locale casing if in locale; regular style if not treating
4318              * latin1 as having case; otherwise the latin1 casing.  Do the
4319              * whole thing in a tight loop, for speed, */
4320             if (IN_LOCALE_RUNTIME) {
4321                 TAINT;
4322                 SvTAINTED_on(dest);
4323                 for (; s < send; d++, s++)
4324                     *d = toLOWER_LC(*s);
4325             }
4326             else if (! IN_UNI_8_BIT) {
4327                 for (; s < send; d++, s++) {
4328                     *d = toLOWER(*s);
4329                 }
4330             }
4331             else {
4332                 for (; s < send; d++, s++) {
4333                     *d = toLOWER_LATIN1(*s);
4334                 }
4335             }
4336         }
4337         if (source != dest) {
4338             *d = '\0';
4339             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4340         }
4341     }
4342     if (dest != source && SvTAINTED(source))
4343         SvTAINT(dest);
4344     SvSETMAGIC(dest);
4345     RETURN;
4346 }
4347
4348 PP(pp_quotemeta)
4349 {
4350     dVAR; dSP; dTARGET;
4351     SV * const sv = TOPs;
4352     STRLEN len;
4353     register const char *s = SvPV_const(sv,len);
4354
4355     SvUTF8_off(TARG);                           /* decontaminate */
4356     if (len) {
4357         register char *d;
4358         SvUPGRADE(TARG, SVt_PV);
4359         SvGROW(TARG, (len * 2) + 1);
4360         d = SvPVX(TARG);
4361         if (DO_UTF8(sv)) {
4362             while (len) {
4363                 if (UTF8_IS_CONTINUED(*s)) {
4364                     STRLEN ulen = UTF8SKIP(s);
4365                     if (ulen > len)
4366                         ulen = len;
4367                     len -= ulen;
4368                     while (ulen--)
4369                         *d++ = *s++;
4370                 }
4371                 else {
4372                     if (!isALNUM(*s))
4373                         *d++ = '\\';
4374                     *d++ = *s++;
4375                     len--;
4376                 }
4377             }
4378             SvUTF8_on(TARG);
4379         }
4380         else {
4381             while (len--) {
4382                 if (!isALNUM(*s))
4383                     *d++ = '\\';
4384                 *d++ = *s++;
4385             }
4386         }
4387         *d = '\0';
4388         SvCUR_set(TARG, d - SvPVX_const(TARG));
4389         (void)SvPOK_only_UTF8(TARG);
4390     }
4391     else
4392         sv_setpvn(TARG, s, len);
4393     SETTARG;
4394     RETURN;
4395 }
4396
4397 /* Arrays. */
4398
4399 PP(pp_aslice)
4400 {
4401     dVAR; dSP; dMARK; dORIGMARK;
4402     register AV *const av = MUTABLE_AV(POPs);
4403     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4404
4405     if (SvTYPE(av) == SVt_PVAV) {
4406         const I32 arybase = CopARYBASE_get(PL_curcop);
4407         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4408         bool can_preserve = FALSE;
4409
4410         if (localizing) {
4411             MAGIC *mg;
4412             HV *stash;
4413
4414             can_preserve = SvCANEXISTDELETE(av);
4415         }
4416
4417         if (lval && localizing) {
4418             register SV **svp;
4419             I32 max = -1;
4420             for (svp = MARK + 1; svp <= SP; svp++) {
4421                 const I32 elem = SvIV(*svp);
4422                 if (elem > max)
4423                     max = elem;
4424             }
4425             if (max > AvMAX(av))
4426                 av_extend(av, max);
4427         }
4428
4429         while (++MARK <= SP) {
4430             register SV **svp;
4431             I32 elem = SvIV(*MARK);
4432             bool preeminent = TRUE;
4433
4434             if (elem > 0)
4435                 elem -= arybase;
4436             if (localizing && can_preserve) {
4437                 /* If we can determine whether the element exist,
4438                  * Try to preserve the existenceness of a tied array
4439                  * element by using EXISTS and DELETE if possible.
4440                  * Fallback to FETCH and STORE otherwise. */
4441                 preeminent = av_exists(av, elem);
4442             }
4443
4444             svp = av_fetch(av, elem, lval);
4445             if (lval) {
4446                 if (!svp || *svp == &PL_sv_undef)
4447                     DIE(aTHX_ PL_no_aelem, elem);
4448                 if (localizing) {
4449                     if (preeminent)
4450                         save_aelem(av, elem, svp);
4451                     else
4452                         SAVEADELETE(av, elem);
4453                 }
4454             }
4455             *MARK = svp ? *svp : &PL_sv_undef;
4456         }
4457     }
4458     if (GIMME != G_ARRAY) {
4459         MARK = ORIGMARK;
4460         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4461         SP = MARK;
4462     }
4463     RETURN;
4464 }
4465
4466 /* Smart dereferencing for keys, values and each */
4467 PP(pp_rkeys)
4468 {
4469     dVAR;
4470     dSP;
4471     dPOPss;
4472
4473     SvGETMAGIC(sv);
4474
4475     if (
4476          !SvROK(sv)
4477       || (sv = SvRV(sv),
4478             (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4479           || SvOBJECT(sv)
4480          )
4481     ) {
4482         DIE(aTHX_
4483            "Type of argument to %s must be unblessed hashref or arrayref",
4484             PL_op_desc[PL_op->op_type] );
4485     }
4486
4487     if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4488         DIE(aTHX_
4489            "Can't modify %s in %s",
4490             PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4491         );
4492
4493     /* Delegate to correct function for op type */
4494     PUSHs(sv);
4495     if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4496         return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4497     }
4498     else {
4499         return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4500     }
4501 }
4502
4503 PP(pp_aeach)
4504 {
4505     dVAR;
4506     dSP;
4507     AV *array = MUTABLE_AV(POPs);
4508     const I32 gimme = GIMME_V;
4509     IV *iterp = Perl_av_iter_p(aTHX_ array);
4510     const IV current = (*iterp)++;
4511
4512     if (current > av_len(array)) {
4513         *iterp = 0;
4514         if (gimme == G_SCALAR)
4515             RETPUSHUNDEF;
4516         else
4517             RETURN;
4518     }
4519
4520     EXTEND(SP, 2);
4521     mPUSHi(CopARYBASE_get(PL_curcop) + current);
4522     if (gimme == G_ARRAY) {
4523         SV **const element = av_fetch(array, current, 0);
4524         PUSHs(element ? *element : &PL_sv_undef);
4525     }
4526     RETURN;
4527 }
4528
4529 PP(pp_akeys)
4530 {
4531     dVAR;
4532     dSP;
4533     AV *array = MUTABLE_AV(POPs);
4534     const I32 gimme = GIMME_V;
4535
4536     *Perl_av_iter_p(aTHX_ array) = 0;
4537
4538     if (gimme == G_SCALAR) {
4539         dTARGET;
4540         PUSHi(av_len(array) + 1);
4541     }
4542     else if (gimme == G_ARRAY) {
4543         IV n = Perl_av_len(aTHX_ array);
4544         IV i = CopARYBASE_get(PL_curcop);
4545
4546         EXTEND(SP, n + 1);
4547
4548         if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4549             n += i;
4550             for (;  i <= n;  i++) {
4551                 mPUSHi(i);
4552             }
4553         }
4554         else {
4555             for (i = 0;  i <= n;  i++) {
4556                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4557                 PUSHs(elem ? *elem : &PL_sv_undef);
4558             }
4559         }
4560     }
4561     RETURN;
4562 }
4563
4564 /* Associative arrays. */
4565
4566 PP(pp_each)
4567 {
4568     dVAR;
4569     dSP;
4570     HV * hash = MUTABLE_HV(POPs);
4571     HE *entry;
4572     const I32 gimme = GIMME_V;
4573
4574     PUTBACK;
4575     /* might clobber stack_sp */
4576     entry = hv_iternext(hash);
4577     SPAGAIN;
4578
4579     EXTEND(SP, 2);
4580     if (entry) {
4581         SV* const sv = hv_iterkeysv(entry);
4582         PUSHs(sv);      /* won't clobber stack_sp */
4583         if (gimme == G_ARRAY) {
4584             SV *val;
4585             PUTBACK;
4586             /* might clobber stack_sp */
4587             val = hv_iterval(hash, entry);
4588             SPAGAIN;
4589             PUSHs(val);
4590         }
4591     }
4592     else if (gimme == G_SCALAR)
4593         RETPUSHUNDEF;
4594
4595     RETURN;
4596 }
4597
4598 STATIC OP *
4599 S_do_delete_local(pTHX)
4600 {
4601     dVAR;
4602     dSP;