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