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