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