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