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