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