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