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