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