perldelta: update module versions
[perl.git] / pp.c
1 /*    pp.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * 'It's a big house this, and very peculiar.  Always a bit more
13  *  to discover, and no knowing what you'll find round a corner.
14  *  And Elves, sir!'                            --Samwise Gamgee
15  *
16  *     [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
17  */
18
19 /* This file contains general pp ("push/pop") functions that execute the
20  * opcodes that make up a perl program. A typical pp function expects to
21  * find its arguments on the stack, and usually pushes its results onto
22  * the stack, hence the 'pp' terminology. Each OP structure contains
23  * a pointer to the relevant pp_foo() function.
24  */
25
26 #include "EXTERN.h"
27 #define PERL_IN_PP_C
28 #include "perl.h"
29 #include "keywords.h"
30
31 #include "reentr.h"
32 #include "regcharclass.h"
33
34 /* XXX I can't imagine anyone who doesn't have this actually _needs_
35    it, since pid_t is an integral type.
36    --AD  2/20/1998
37 */
38 #ifdef NEED_GETPID_PROTO
39 extern Pid_t getpid (void);
40 #endif
41
42 /*
43  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44  * This switches them over to IEEE.
45  */
46 #if defined(LIBM_LIB_VERSION)
47     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
48 #endif
49
50 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
52
53 /* variations on pp_null */
54
55 PP(pp_stub)
56 {
57     dSP;
58     if (GIMME_V == G_SCALAR)
59         XPUSHs(&PL_sv_undef);
60     RETURN;
61 }
62
63 /* Pushy stuff. */
64
65 /* This is also called directly by pp_lvavref.  */
66 PP(pp_padav)
67 {
68     dSP; dTARGET;
69     U8 gimme;
70     assert(SvTYPE(TARG) == SVt_PVAV);
71     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
72         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
73             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
74     EXTEND(SP, 1);
75
76     if (PL_op->op_flags & OPf_REF) {
77         PUSHs(TARG);
78         RETURN;
79     }
80     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
81         const I32 flags = is_lvalue_sub();
82         if (flags && !(flags & OPpENTERSUB_INARGS)) {
83             if (GIMME_V == G_SCALAR)
84                 /* diag_listed_as: Can't return %s to lvalue scalar context */
85                 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
86             PUSHs(TARG);
87             RETURN;
88        }
89     }
90
91     gimme = GIMME_V;
92     if (gimme == G_ARRAY) {
93         /* XXX see also S_pushav in pp_hot.c */
94         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
95         EXTEND(SP, maxarg);
96         if (SvMAGICAL(TARG)) {
97             SSize_t i;
98             for (i=0; i < maxarg; i++) {
99                 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
100                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
101             }
102         }
103         else {
104             SSize_t i;
105             for (i=0; i < maxarg; i++) {
106                 SV * const sv = AvARRAY((const AV *)TARG)[i];
107                 SP[i+1] = sv ? sv : &PL_sv_undef;
108             }
109         }
110         SP += maxarg;
111     }
112     else if (gimme == G_SCALAR) {
113         SV* const sv = sv_newmortal();
114         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
115         sv_setiv(sv, maxarg);
116         PUSHs(sv);
117     }
118     RETURN;
119 }
120
121 PP(pp_padhv)
122 {
123     dSP; dTARGET;
124     U8 gimme;
125
126     assert(SvTYPE(TARG) == SVt_PVHV);
127     XPUSHs(TARG);
128     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
129         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
130             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
131
132     if (PL_op->op_flags & OPf_REF)
133         RETURN;
134     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
135         const I32 flags = is_lvalue_sub();
136         if (flags && !(flags & OPpENTERSUB_INARGS)) {
137             if (GIMME_V == G_SCALAR)
138                 /* diag_listed_as: Can't return %s to lvalue scalar context */
139                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
140             RETURN;
141         }
142     }
143
144     gimme = GIMME_V;
145     if (gimme == G_ARRAY) {
146         RETURNOP(Perl_do_kv(aTHX));
147     }
148     else if ((PL_op->op_private & OPpTRUEBOOL
149           || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
150              && block_gimme() == G_VOID  ))
151           && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied))
152     )
153         SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
154     else if (gimme == G_SCALAR) {
155         SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
156         SETs(sv);
157     }
158     RETURN;
159 }
160
161 PP(pp_padcv)
162 {
163     dSP; dTARGET;
164     assert(SvTYPE(TARG) == SVt_PVCV);
165     XPUSHs(TARG);
166     RETURN;
167 }
168
169 PP(pp_introcv)
170 {
171     dTARGET;
172     SvPADSTALE_off(TARG);
173     return NORMAL;
174 }
175
176 PP(pp_clonecv)
177 {
178     dTARGET;
179     CV * const protocv = PadnamePROTOCV(
180         PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
181     );
182     assert(SvTYPE(TARG) == SVt_PVCV);
183     assert(protocv);
184     if (CvISXSUB(protocv)) { /* constant */
185         /* XXX Should we clone it here? */
186         /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
187            to introcv and remove the SvPADSTALE_off. */
188         SAVEPADSVANDMORTALIZE(ARGTARG);
189         PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
190     }
191     else {
192         if (CvROOT(protocv)) {
193             assert(CvCLONE(protocv));
194             assert(!CvCLONED(protocv));
195         }
196         cv_clone_into(protocv,(CV *)TARG);
197         SAVECLEARSV(PAD_SVl(ARGTARG));
198     }
199     return NORMAL;
200 }
201
202 /* Translations. */
203
204 /* In some cases this function inspects PL_op.  If this function is called
205    for new op types, more bool parameters may need to be added in place of
206    the checks.
207
208    When noinit is true, the absence of a gv will cause a retval of undef.
209    This is unrelated to the cv-to-gv assignment case.
210 */
211
212 static SV *
213 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
214               const bool noinit)
215 {
216     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
217     if (SvROK(sv)) {
218         if (SvAMAGIC(sv)) {
219             sv = amagic_deref_call(sv, to_gv_amg);
220         }
221       wasref:
222         sv = SvRV(sv);
223         if (SvTYPE(sv) == SVt_PVIO) {
224             GV * const gv = MUTABLE_GV(sv_newmortal());
225             gv_init(gv, 0, "__ANONIO__", 10, 0);
226             GvIOp(gv) = MUTABLE_IO(sv);
227             SvREFCNT_inc_void_NN(sv);
228             sv = MUTABLE_SV(gv);
229         }
230         else if (!isGV_with_GP(sv)) {
231             Perl_die(aTHX_ "Not a GLOB reference");
232         }
233     }
234     else {
235         if (!isGV_with_GP(sv)) {
236             if (!SvOK(sv)) {
237                 /* If this is a 'my' scalar and flag is set then vivify
238                  * NI-S 1999/05/07
239                  */
240                 if (vivify_sv && sv != &PL_sv_undef) {
241                     GV *gv;
242                     if (SvREADONLY(sv))
243                         Perl_croak_no_modify();
244                     if (cUNOP->op_targ) {
245                         SV * const namesv = PAD_SV(cUNOP->op_targ);
246                         HV *stash = CopSTASH(PL_curcop);
247                         if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
248                         gv = MUTABLE_GV(newSV(0));
249                         gv_init_sv(gv, stash, namesv, 0);
250                     }
251                     else {
252                         const char * const name = CopSTASHPV(PL_curcop);
253                         gv = newGVgen_flags(name,
254                                 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
255                         SvREFCNT_inc_simple_void_NN(gv);
256                     }
257                     prepare_SV_for_RV(sv);
258                     SvRV_set(sv, MUTABLE_SV(gv));
259                     SvROK_on(sv);
260                     SvSETMAGIC(sv);
261                     goto wasref;
262                 }
263                 if (PL_op->op_flags & OPf_REF || strict) {
264                     Perl_die(aTHX_ PL_no_usym, "a symbol");
265                 }
266                 if (ckWARN(WARN_UNINITIALIZED))
267                     report_uninit(sv);
268                 return &PL_sv_undef;
269             }
270             if (noinit)
271             {
272                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
273                            sv, GV_ADDMG, SVt_PVGV
274                    ))))
275                     return &PL_sv_undef;
276             }
277             else {
278                 if (strict) {
279                     Perl_die(aTHX_
280                              PL_no_symref_sv,
281                              sv,
282                              (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
283                              "a symbol"
284                              );
285                 }
286                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
287                     == OPpDONT_INIT_GV) {
288                     /* We are the target of a coderef assignment.  Return
289                        the scalar unchanged, and let pp_sasssign deal with
290                        things.  */
291                     return sv;
292                 }
293                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
294             }
295             /* FAKE globs in the symbol table cause weird bugs (#77810) */
296             SvFAKE_off(sv);
297         }
298     }
299     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
300         SV *newsv = sv_newmortal();
301         sv_setsv_flags(newsv, sv, 0);
302         SvFAKE_off(newsv);
303         sv = newsv;
304     }
305     return sv;
306 }
307
308 PP(pp_rv2gv)
309 {
310     dSP; dTOPss;
311
312     sv = S_rv2gv(aTHX_
313           sv, PL_op->op_private & OPpDEREF,
314           PL_op->op_private & HINT_STRICT_REFS,
315           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
316              || PL_op->op_type == OP_READLINE
317          );
318     if (PL_op->op_private & OPpLVAL_INTRO)
319         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
320     SETs(sv);
321     RETURN;
322 }
323
324 /* Helper function for pp_rv2sv and pp_rv2av  */
325 GV *
326 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
327                 const svtype type, SV ***spp)
328 {
329     GV *gv;
330
331     PERL_ARGS_ASSERT_SOFTREF2XV;
332
333     if (PL_op->op_private & HINT_STRICT_REFS) {
334         if (SvOK(sv))
335             Perl_die(aTHX_ PL_no_symref_sv, sv,
336                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
337         else
338             Perl_die(aTHX_ PL_no_usym, what);
339     }
340     if (!SvOK(sv)) {
341         if (
342           PL_op->op_flags & OPf_REF
343         )
344             Perl_die(aTHX_ PL_no_usym, what);
345         if (ckWARN(WARN_UNINITIALIZED))
346             report_uninit(sv);
347         if (type != SVt_PV && GIMME_V == G_ARRAY) {
348             (*spp)--;
349             return NULL;
350         }
351         **spp = &PL_sv_undef;
352         return NULL;
353     }
354     if ((PL_op->op_flags & OPf_SPECIAL) &&
355         !(PL_op->op_flags & OPf_MOD))
356         {
357             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
358                 {
359                     **spp = &PL_sv_undef;
360                     return NULL;
361                 }
362         }
363     else {
364         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
365     }
366     return gv;
367 }
368
369 PP(pp_rv2sv)
370 {
371     dSP; dTOPss;
372     GV *gv = NULL;
373
374     SvGETMAGIC(sv);
375     if (SvROK(sv)) {
376         if (SvAMAGIC(sv)) {
377             sv = amagic_deref_call(sv, to_sv_amg);
378         }
379
380         sv = SvRV(sv);
381         if (SvTYPE(sv) >= SVt_PVAV)
382             DIE(aTHX_ "Not a SCALAR reference");
383     }
384     else {
385         gv = MUTABLE_GV(sv);
386
387         if (!isGV_with_GP(gv)) {
388             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
389             if (!gv)
390                 RETURN;
391         }
392         sv = GvSVn(gv);
393     }
394     if (PL_op->op_flags & OPf_MOD) {
395         if (PL_op->op_private & OPpLVAL_INTRO) {
396             if (cUNOP->op_first->op_type == OP_NULL)
397                 sv = save_scalar(MUTABLE_GV(TOPs));
398             else if (gv)
399                 sv = save_scalar(gv);
400             else
401                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
402         }
403         else if (PL_op->op_private & OPpDEREF)
404             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
405     }
406     SETs(sv);
407     RETURN;
408 }
409
410 PP(pp_av2arylen)
411 {
412     dSP;
413     AV * const av = MUTABLE_AV(TOPs);
414     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
415     if (lvalue) {
416         SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
417         if (!*svp) {
418             *svp = newSV_type(SVt_PVMG);
419             sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
420         }
421         SETs(*svp);
422     } else {
423         SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
424     }
425     RETURN;
426 }
427
428 PP(pp_pos)
429 {
430     dSP; dTOPss;
431
432     if (PL_op->op_flags & OPf_MOD || LVRET) {
433         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
434         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
435         LvTYPE(ret) = '.';
436         LvTARG(ret) = SvREFCNT_inc_simple(sv);
437         SETs(ret);    /* no SvSETMAGIC */
438     }
439     else {
440             const MAGIC * const mg = mg_find_mglob(sv);
441             if (mg && mg->mg_len != -1) {
442                 dTARGET;
443                 STRLEN i = mg->mg_len;
444                 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
445                     i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
446                 SETu(i);
447                 return NORMAL;
448             }
449             SETs(&PL_sv_undef);
450     }
451     return NORMAL;
452 }
453
454 PP(pp_rv2cv)
455 {
456     dSP;
457     GV *gv;
458     HV *stash_unused;
459     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
460         ? GV_ADDMG
461         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
462                                                     == OPpMAY_RETURN_CONSTANT)
463             ? GV_ADD|GV_NOEXPAND
464             : GV_ADD;
465     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
466     /* (But not in defined().) */
467
468     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
469     if (cv) NOOP;
470     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
471         cv = SvTYPE(SvRV(gv)) == SVt_PVCV
472             ? MUTABLE_CV(SvRV(gv))
473             : MUTABLE_CV(gv);
474     }    
475     else
476         cv = MUTABLE_CV(&PL_sv_undef);
477     SETs(MUTABLE_SV(cv));
478     return NORMAL;
479 }
480
481 PP(pp_prototype)
482 {
483     dSP;
484     CV *cv;
485     HV *stash;
486     GV *gv;
487     SV *ret = &PL_sv_undef;
488
489     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
490     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
491         const char * s = SvPVX_const(TOPs);
492         if (strnEQ(s, "CORE::", 6)) {
493             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
494             if (!code)
495                 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
496                    UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
497             {
498                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
499                 if (sv) ret = sv;
500             }
501             goto set;
502         }
503     }
504     cv = sv_2cv(TOPs, &stash, &gv, 0);
505     if (cv && SvPOK(cv))
506         ret = newSVpvn_flags(
507             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
508         );
509   set:
510     SETs(ret);
511     RETURN;
512 }
513
514 PP(pp_anoncode)
515 {
516     dSP;
517     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
518     if (CvCLONE(cv))
519         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
520     EXTEND(SP,1);
521     PUSHs(MUTABLE_SV(cv));
522     RETURN;
523 }
524
525 PP(pp_srefgen)
526 {
527     dSP;
528     *SP = refto(*SP);
529     return NORMAL;
530 }
531
532 PP(pp_refgen)
533 {
534     dSP; dMARK;
535     if (GIMME_V != G_ARRAY) {
536         if (++MARK <= SP)
537             *MARK = *SP;
538         else
539         {
540             MEXTEND(SP, 1);
541             *MARK = &PL_sv_undef;
542         }
543         *MARK = refto(*MARK);
544         SP = MARK;
545         RETURN;
546     }
547     EXTEND_MORTAL(SP - MARK);
548     while (++MARK <= SP)
549         *MARK = refto(*MARK);
550     RETURN;
551 }
552
553 STATIC SV*
554 S_refto(pTHX_ SV *sv)
555 {
556     SV* rv;
557
558     PERL_ARGS_ASSERT_REFTO;
559
560     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
561         if (LvTARGLEN(sv))
562             vivify_defelem(sv);
563         if (!(sv = LvTARG(sv)))
564             sv = &PL_sv_undef;
565         else
566             SvREFCNT_inc_void_NN(sv);
567     }
568     else if (SvTYPE(sv) == SVt_PVAV) {
569         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
570             av_reify(MUTABLE_AV(sv));
571         SvTEMP_off(sv);
572         SvREFCNT_inc_void_NN(sv);
573     }
574     else if (SvPADTMP(sv)) {
575         sv = newSVsv(sv);
576     }
577     else {
578         SvTEMP_off(sv);
579         SvREFCNT_inc_void_NN(sv);
580     }
581     rv = sv_newmortal();
582     sv_upgrade(rv, SVt_IV);
583     SvRV_set(rv, sv);
584     SvROK_on(rv);
585     return rv;
586 }
587
588 PP(pp_ref)
589 {
590     dSP;
591     SV * const sv = TOPs;
592
593     SvGETMAGIC(sv);
594     if (!SvROK(sv))
595         SETs(&PL_sv_no);
596     else {
597         dTARGET;
598         SETs(TARG);
599         /* use the return value that is in a register, its the same as TARG */
600         TARG = sv_ref(TARG,SvRV(sv),TRUE);
601         SvSETMAGIC(TARG);
602     }
603
604     return NORMAL;
605 }
606
607 PP(pp_bless)
608 {
609     dSP;
610     HV *stash;
611
612     if (MAXARG == 1)
613     {
614       curstash:
615         stash = CopSTASH(PL_curcop);
616         if (SvTYPE(stash) != SVt_PVHV)
617             Perl_croak(aTHX_ "Attempt to bless into a freed package");
618     }
619     else {
620         SV * const ssv = POPs;
621         STRLEN len;
622         const char *ptr;
623
624         if (!ssv) goto curstash;
625         SvGETMAGIC(ssv);
626         if (SvROK(ssv)) {
627           if (!SvAMAGIC(ssv)) {
628            frog:
629             Perl_croak(aTHX_ "Attempt to bless into a reference");
630           }
631           /* SvAMAGIC is on here, but it only means potentially overloaded,
632              so after stringification: */
633           ptr = SvPV_nomg_const(ssv,len);
634           /* We need to check the flag again: */
635           if (!SvAMAGIC(ssv)) goto frog;
636         }
637         else ptr = SvPV_nomg_const(ssv,len);
638         if (len == 0)
639             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
640                            "Explicit blessing to '' (assuming package main)");
641         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
642     }
643
644     (void)sv_bless(TOPs, stash);
645     RETURN;
646 }
647
648 PP(pp_gelem)
649 {
650     dSP;
651
652     SV *sv = POPs;
653     STRLEN len;
654     const char * const elem = SvPV_const(sv, len);
655     GV * const gv = MUTABLE_GV(TOPs);
656     SV * tmpRef = NULL;
657
658     sv = NULL;
659     if (elem) {
660         /* elem will always be NUL terminated.  */
661         const char * const second_letter = elem + 1;
662         switch (*elem) {
663         case 'A':
664             if (len == 5 && strEQ(second_letter, "RRAY"))
665             {
666                 tmpRef = MUTABLE_SV(GvAV(gv));
667                 if (tmpRef && !AvREAL((const AV *)tmpRef)
668                  && AvREIFY((const AV *)tmpRef))
669                     av_reify(MUTABLE_AV(tmpRef));
670             }
671             break;
672         case 'C':
673             if (len == 4 && strEQ(second_letter, "ODE"))
674                 tmpRef = MUTABLE_SV(GvCVu(gv));
675             break;
676         case 'F':
677             if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
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     SETs(sv);
720     RETURN;
721 }
722
723 /* Pattern matching */
724
725 PP(pp_study)
726 {
727     dSP; dTOPss;
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         SETs(&PL_sv_no);
734         return NORMAL;
735     }
736
737     /* Make study a no-op. It's no longer useful and its existence
738        complicates matters elsewhere. */
739     SETs(&PL_sv_yes);
740     return NORMAL;
741 }
742
743
744 /* also used for: pp_transr() */
745
746 PP(pp_trans)
747 {
748     dSP; 
749     SV *sv;
750
751     if (PL_op->op_flags & OPf_STACKED)
752         sv = POPs;
753     else {
754         EXTEND(SP,1);
755         if (ARGTARG)
756             sv = PAD_SV(ARGTARG);
757         else {
758             sv = DEFSV;
759         }
760     }
761     if(PL_op->op_type == OP_TRANSR) {
762         STRLEN len;
763         const char * const pv = SvPV(sv,len);
764         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
765         do_trans(newsv);
766         PUSHs(newsv);
767     }
768     else {
769         I32 i = do_trans(sv);
770         mPUSHi(i);
771     }
772     RETURN;
773 }
774
775 /* Lvalue operators. */
776
777 static size_t
778 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
779 {
780     STRLEN len;
781     char *s;
782     size_t count = 0;
783
784     PERL_ARGS_ASSERT_DO_CHOMP;
785
786     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
787         return 0;
788     if (SvTYPE(sv) == SVt_PVAV) {
789         I32 i;
790         AV *const av = MUTABLE_AV(sv);
791         const I32 max = AvFILL(av);
792
793         for (i = 0; i <= max; i++) {
794             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
795             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
796                 count += do_chomp(retval, sv, chomping);
797         }
798         return count;
799     }
800     else if (SvTYPE(sv) == SVt_PVHV) {
801         HV* const hv = MUTABLE_HV(sv);
802         HE* entry;
803         (void)hv_iterinit(hv);
804         while ((entry = hv_iternext(hv)))
805             count += do_chomp(retval, hv_iterval(hv,entry), chomping);
806         return count;
807     }
808     else if (SvREADONLY(sv)) {
809             Perl_croak_no_modify();
810     }
811
812     if (IN_ENCODING) {
813         if (!SvUTF8(sv)) {
814             /* XXX, here sv is utf8-ized as a side-effect!
815                If encoding.pm is used properly, almost string-generating
816                operations, including literal strings, chr(), input data, etc.
817                should have been utf8-ized already, right?
818             */
819             sv_recode_to_utf8(sv, _get_encoding());
820         }
821     }
822
823     s = SvPV(sv, len);
824     if (chomping) {
825         if (s && len) {
826             char *temp_buffer = NULL;
827             SV *svrecode = NULL;
828             s += --len;
829             if (RsPARA(PL_rs)) {
830                 if (*s != '\n')
831                     goto nope_free_nothing;
832                 ++count;
833                 while (len && s[-1] == '\n') {
834                     --len;
835                     --s;
836                     ++count;
837                 }
838             }
839             else {
840                 STRLEN rslen, rs_charlen;
841                 const char *rsptr = SvPV_const(PL_rs, rslen);
842
843                 rs_charlen = SvUTF8(PL_rs)
844                     ? sv_len_utf8(PL_rs)
845                     : rslen;
846
847                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
848                     /* Assumption is that rs is shorter than the scalar.  */
849                     if (SvUTF8(PL_rs)) {
850                         /* RS is utf8, scalar is 8 bit.  */
851                         bool is_utf8 = TRUE;
852                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
853                                                              &rslen, &is_utf8);
854                         if (is_utf8) {
855                             /* Cannot downgrade, therefore cannot possibly match.
856                                At this point, temp_buffer is not alloced, and
857                                is the buffer inside PL_rs, so dont free it.
858                              */
859                             assert (temp_buffer == rsptr);
860                             goto nope_free_sv;
861                         }
862                         rsptr = temp_buffer;
863                     }
864                     else if (IN_ENCODING) {
865                         /* RS is 8 bit, encoding.pm is used.
866                          * Do not recode PL_rs as a side-effect. */
867                         svrecode = newSVpvn(rsptr, rslen);
868                         sv_recode_to_utf8(svrecode, _get_encoding());
869                         rsptr = SvPV_const(svrecode, rslen);
870                         rs_charlen = sv_len_utf8(svrecode);
871                     }
872                     else {
873                         /* RS is 8 bit, scalar is utf8.  */
874                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
875                         rsptr = temp_buffer;
876                     }
877                 }
878                 if (rslen == 1) {
879                     if (*s != *rsptr)
880                         goto nope_free_all;
881                     ++count;
882                 }
883                 else {
884                     if (len < rslen - 1)
885                         goto nope_free_all;
886                     len -= rslen - 1;
887                     s -= rslen - 1;
888                     if (memNE(s, rsptr, rslen))
889                         goto nope_free_all;
890                     count += rs_charlen;
891                 }
892             }
893             SvPV_force_nomg_nolen(sv);
894             SvCUR_set(sv, len);
895             *SvEND(sv) = '\0';
896             SvNIOK_off(sv);
897             SvSETMAGIC(sv);
898
899             nope_free_all:
900             Safefree(temp_buffer);
901             nope_free_sv:
902             SvREFCNT_dec(svrecode);
903             nope_free_nothing: ;
904         }
905     } else {
906         if (len && (!SvPOK(sv) || SvIsCOW(sv)))
907             s = SvPV_force_nomg(sv, len);
908         if (DO_UTF8(sv)) {
909             if (s && len) {
910                 char * const send = s + len;
911                 char * const start = s;
912                 s = send - 1;
913                 while (s > start && UTF8_IS_CONTINUATION(*s))
914                     s--;
915                 if (is_utf8_string((U8*)s, send - s)) {
916                     sv_setpvn(retval, s, send - s);
917                     *s = '\0';
918                     SvCUR_set(sv, s - start);
919                     SvNIOK_off(sv);
920                     SvUTF8_on(retval);
921                 }
922             }
923             else
924                 sv_setpvs(retval, "");
925         }
926         else if (s && len) {
927             s += --len;
928             sv_setpvn(retval, s, 1);
929             *s = '\0';
930             SvCUR_set(sv, len);
931             SvUTF8_off(sv);
932             SvNIOK_off(sv);
933         }
934         else
935             sv_setpvs(retval, "");
936         SvSETMAGIC(sv);
937     }
938     return count;
939 }
940
941
942 /* also used for: pp_schomp() */
943
944 PP(pp_schop)
945 {
946     dSP; dTARGET;
947     const bool chomping = PL_op->op_type == OP_SCHOMP;
948
949     const size_t count = do_chomp(TARG, TOPs, chomping);
950     if (chomping)
951         sv_setiv(TARG, count);
952     SETTARG;
953     return NORMAL;
954 }
955
956
957 /* also used for: pp_chomp() */
958
959 PP(pp_chop)
960 {
961     dSP; dMARK; dTARGET; dORIGMARK;
962     const bool chomping = PL_op->op_type == OP_CHOMP;
963     size_t count = 0;
964
965     while (MARK < SP)
966         count += do_chomp(TARG, *++MARK, chomping);
967     if (chomping)
968         sv_setiv(TARG, count);
969     SP = ORIGMARK;
970     XPUSHTARG;
971     RETURN;
972 }
973
974 PP(pp_undef)
975 {
976     dSP;
977     SV *sv;
978
979     if (!PL_op->op_private) {
980         EXTEND(SP, 1);
981         RETPUSHUNDEF;
982     }
983
984     sv = TOPs;
985     if (!sv)
986     {
987         SETs(&PL_sv_undef);
988         return NORMAL;
989     }
990
991     if (SvTHINKFIRST(sv))
992         sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
993
994     switch (SvTYPE(sv)) {
995     case SVt_NULL:
996         break;
997     case SVt_PVAV:
998         av_undef(MUTABLE_AV(sv));
999         break;
1000     case SVt_PVHV:
1001         hv_undef(MUTABLE_HV(sv));
1002         break;
1003     case SVt_PVCV:
1004         if (cv_const_sv((const CV *)sv))
1005             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1006                           "Constant subroutine %"SVf" undefined",
1007                            SVfARG(CvANON((const CV *)sv)
1008                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
1009                              : sv_2mortal(newSVhek(
1010                                 CvNAMED(sv)
1011                                  ? CvNAME_HEK((CV *)sv)
1012                                  : GvENAME_HEK(CvGV((const CV *)sv))
1013                                ))
1014                            ));
1015         /* FALLTHROUGH */
1016     case SVt_PVFM:
1017             /* let user-undef'd sub keep its identity */
1018         cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
1019         break;
1020     case SVt_PVGV:
1021         assert(isGV_with_GP(sv));
1022         assert(!SvFAKE(sv));
1023         {
1024             GP *gp;
1025             HV *stash;
1026
1027             /* undef *Pkg::meth_name ... */
1028             bool method_changed
1029              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1030               && HvENAME_get(stash);
1031             /* undef *Foo:: */
1032             if((stash = GvHV((const GV *)sv))) {
1033                 if(HvENAME_get(stash))
1034                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1035                 else stash = NULL;
1036             }
1037
1038             SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1039             gp_free(MUTABLE_GV(sv));
1040             Newxz(gp, 1, GP);
1041             GvGP_set(sv, gp_ref(gp));
1042 #ifndef PERL_DONT_CREATE_GVSV
1043             GvSV(sv) = newSV(0);
1044 #endif
1045             GvLINE(sv) = CopLINE(PL_curcop);
1046             GvEGV(sv) = MUTABLE_GV(sv);
1047             GvMULTI_on(sv);
1048
1049             if(stash)
1050                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1051             stash = NULL;
1052             /* undef *Foo::ISA */
1053             if( strEQ(GvNAME((const GV *)sv), "ISA")
1054              && (stash = GvSTASH((const GV *)sv))
1055              && (method_changed || HvENAME(stash)) )
1056                 mro_isa_changed_in(stash);
1057             else if(method_changed)
1058                 mro_method_changed_in(
1059                  GvSTASH((const GV *)sv)
1060                 );
1061
1062             break;
1063         }
1064     default:
1065         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1066             SvPV_free(sv);
1067             SvPV_set(sv, NULL);
1068             SvLEN_set(sv, 0);
1069         }
1070         SvOK_off(sv);
1071         SvSETMAGIC(sv);
1072     }
1073
1074     SETs(&PL_sv_undef);
1075     return NORMAL;
1076 }
1077
1078
1079 /* common "slow" code for pp_postinc and pp_postdec */
1080
1081 static OP *
1082 S_postincdec_common(pTHX_ SV *sv, SV *targ)
1083 {
1084     dSP;
1085     const bool inc =
1086         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1087
1088     if (SvROK(sv))
1089         TARG = sv_newmortal();
1090     sv_setsv(TARG, sv);
1091     if (inc)
1092         sv_inc_nomg(sv);
1093     else
1094         sv_dec_nomg(sv);
1095     SvSETMAGIC(sv);
1096     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1097     if (inc && !SvOK(TARG))
1098         sv_setiv(TARG, 0);
1099     SETTARG;
1100     return NORMAL;
1101 }
1102
1103
1104 /* also used for: pp_i_postinc() */
1105
1106 PP(pp_postinc)
1107 {
1108     dSP; dTARGET;
1109     SV *sv = TOPs;
1110
1111     /* special-case sv being a simple integer */
1112     if (LIKELY(((sv->sv_flags &
1113                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1114                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1115                 == SVf_IOK))
1116         && SvIVX(sv) != IV_MAX)
1117     {
1118         IV iv = SvIVX(sv);
1119         SvIV_set(sv,  iv + 1);
1120         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1121         SETs(TARG);
1122         return NORMAL;
1123     }
1124
1125     return S_postincdec_common(aTHX_ sv, TARG);
1126 }
1127
1128
1129 /* also used for: pp_i_postdec() */
1130
1131 PP(pp_postdec)
1132 {
1133     dSP; dTARGET;
1134     SV *sv = TOPs;
1135
1136     /* special-case sv being a simple integer */
1137     if (LIKELY(((sv->sv_flags &
1138                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1139                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1140                 == SVf_IOK))
1141         && SvIVX(sv) != IV_MIN)
1142     {
1143         IV iv = SvIVX(sv);
1144         SvIV_set(sv,  iv - 1);
1145         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1146         SETs(TARG);
1147         return NORMAL;
1148     }
1149
1150     return S_postincdec_common(aTHX_ sv, TARG);
1151 }
1152
1153
1154 /* Ordinary operators. */
1155
1156 PP(pp_pow)
1157 {
1158     dSP; dATARGET; SV *svl, *svr;
1159 #ifdef PERL_PRESERVE_IVUV
1160     bool is_int = 0;
1161 #endif
1162     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1163     svr = TOPs;
1164     svl = TOPm1s;
1165 #ifdef PERL_PRESERVE_IVUV
1166     /* For integer to integer power, we do the calculation by hand wherever
1167        we're sure it is safe; otherwise we call pow() and try to convert to
1168        integer afterwards. */
1169     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1170                 UV power;
1171                 bool baseuok;
1172                 UV baseuv;
1173
1174                 if (SvUOK(svr)) {
1175                     power = SvUVX(svr);
1176                 } else {
1177                     const IV iv = SvIVX(svr);
1178                     if (iv >= 0) {
1179                         power = iv;
1180                     } else {
1181                         goto float_it; /* Can't do negative powers this way.  */
1182                     }
1183                 }
1184
1185                 baseuok = SvUOK(svl);
1186                 if (baseuok) {
1187                     baseuv = SvUVX(svl);
1188                 } else {
1189                     const IV iv = SvIVX(svl);
1190                     if (iv >= 0) {
1191                         baseuv = iv;
1192                         baseuok = TRUE; /* effectively it's a UV now */
1193                     } else {
1194                         baseuv = -iv; /* abs, baseuok == false records sign */
1195                     }
1196                 }
1197                 /* now we have integer ** positive integer. */
1198                 is_int = 1;
1199
1200                 /* foo & (foo - 1) is zero only for a power of 2.  */
1201                 if (!(baseuv & (baseuv - 1))) {
1202                     /* We are raising power-of-2 to a positive integer.
1203                        The logic here will work for any base (even non-integer
1204                        bases) but it can be less accurate than
1205                        pow (base,power) or exp (power * log (base)) when the
1206                        intermediate values start to spill out of the mantissa.
1207                        With powers of 2 we know this can't happen.
1208                        And powers of 2 are the favourite thing for perl
1209                        programmers to notice ** not doing what they mean. */
1210                     NV result = 1.0;
1211                     NV base = baseuok ? baseuv : -(NV)baseuv;
1212
1213                     if (power & 1) {
1214                         result *= base;
1215                     }
1216                     while (power >>= 1) {
1217                         base *= base;
1218                         if (power & 1) {
1219                             result *= base;
1220                         }
1221                     }
1222                     SP--;
1223                     SETn( result );
1224                     SvIV_please_nomg(svr);
1225                     RETURN;
1226                 } else {
1227                     unsigned int highbit = 8 * sizeof(UV);
1228                     unsigned int diff = 8 * sizeof(UV);
1229                     while (diff >>= 1) {
1230                         highbit -= diff;
1231                         if (baseuv >> highbit) {
1232                             highbit += diff;
1233                         }
1234                     }
1235                     /* we now have baseuv < 2 ** highbit */
1236                     if (power * highbit <= 8 * sizeof(UV)) {
1237                         /* result will definitely fit in UV, so use UV math
1238                            on same algorithm as above */
1239                         UV result = 1;
1240                         UV base = baseuv;
1241                         const bool odd_power = cBOOL(power & 1);
1242                         if (odd_power) {
1243                             result *= base;
1244                         }
1245                         while (power >>= 1) {
1246                             base *= base;
1247                             if (power & 1) {
1248                                 result *= base;
1249                             }
1250                         }
1251                         SP--;
1252                         if (baseuok || !odd_power)
1253                             /* answer is positive */
1254                             SETu( result );
1255                         else if (result <= (UV)IV_MAX)
1256                             /* answer negative, fits in IV */
1257                             SETi( -(IV)result );
1258                         else if (result == (UV)IV_MIN) 
1259                             /* 2's complement assumption: special case IV_MIN */
1260                             SETi( IV_MIN );
1261                         else
1262                             /* answer negative, doesn't fit */
1263                             SETn( -(NV)result );
1264                         RETURN;
1265                     } 
1266                 }
1267     }
1268   float_it:
1269 #endif    
1270     {
1271         NV right = SvNV_nomg(svr);
1272         NV left  = SvNV_nomg(svl);
1273         (void)POPs;
1274
1275 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1276     /*
1277     We are building perl with long double support and are on an AIX OS
1278     afflicted with a powl() function that wrongly returns NaNQ for any
1279     negative base.  This was reported to IBM as PMR #23047-379 on
1280     03/06/2006.  The problem exists in at least the following versions
1281     of AIX and the libm fileset, and no doubt others as well:
1282
1283         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1284         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1285         AIX 5.2.0           bos.adt.libm 5.2.0.85
1286
1287     So, until IBM fixes powl(), we provide the following workaround to
1288     handle the problem ourselves.  Our logic is as follows: for
1289     negative bases (left), we use fmod(right, 2) to check if the
1290     exponent is an odd or even integer:
1291
1292         - if odd,  powl(left, right) == -powl(-left, right)
1293         - if even, powl(left, right) ==  powl(-left, right)
1294
1295     If the exponent is not an integer, the result is rightly NaNQ, so
1296     we just return that (as NV_NAN).
1297     */
1298
1299         if (left < 0.0) {
1300             NV mod2 = Perl_fmod( right, 2.0 );
1301             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1302                 SETn( -Perl_pow( -left, right) );
1303             } else if (mod2 == 0.0) {           /* even integer */
1304                 SETn( Perl_pow( -left, right) );
1305             } else {                            /* fractional power */
1306                 SETn( NV_NAN );
1307             }
1308         } else {
1309             SETn( Perl_pow( left, right) );
1310         }
1311 #else
1312         SETn( Perl_pow( left, right) );
1313 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1314
1315 #ifdef PERL_PRESERVE_IVUV
1316         if (is_int)
1317             SvIV_please_nomg(svr);
1318 #endif
1319         RETURN;
1320     }
1321 }
1322
1323 PP(pp_multiply)
1324 {
1325     dSP; dATARGET; SV *svl, *svr;
1326     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1327     svr = TOPs;
1328     svl = TOPm1s;
1329
1330 #ifdef PERL_PRESERVE_IVUV
1331
1332     /* special-case some simple common cases */
1333     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1334         IV il, ir;
1335         U32 flags = (svl->sv_flags & svr->sv_flags);
1336         if (flags & SVf_IOK) {
1337             /* both args are simple IVs */
1338             UV topl, topr;
1339             il = SvIVX(svl);
1340             ir = SvIVX(svr);
1341           do_iv:
1342             topl = ((UV)il) >> (UVSIZE * 4 - 1);
1343             topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1344
1345             /* if both are in a range that can't under/overflow, do a
1346              * simple integer multiply: if the top halves(*) of both numbers
1347              * are 00...00  or 11...11, then it's safe.
1348              * (*) for 32-bits, the "top half" is the top 17 bits,
1349              *     for 64-bits, its 33 bits */
1350             if (!(
1351                       ((topl+1) | (topr+1))
1352                     & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1353             )) {
1354                 SP--;
1355                 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1356                 SETs(TARG);
1357                 RETURN;
1358             }
1359             goto generic;
1360         }
1361         else if (flags & SVf_NOK) {
1362             /* both args are NVs */
1363             NV nl = SvNVX(svl);
1364             NV nr = SvNVX(svr);
1365             NV result;
1366
1367             if (
1368 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1369                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1370                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1371 #else
1372                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1373 #endif
1374                 )
1375                 /* nothing was lost by converting to IVs */
1376                 goto do_iv;
1377             SP--;
1378             result = nl * nr;
1379 #  if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1380             if (Perl_isinf(result)) {
1381                 Zero((U8*)&result + 8, 8, U8);
1382             }
1383 #  endif
1384             TARGn(result, 0); /* args not GMG, so can't be tainted */
1385             SETs(TARG);
1386             RETURN;
1387         }
1388     }
1389
1390   generic:
1391
1392     if (SvIV_please_nomg(svr)) {
1393         /* Unless the left argument is integer in range we are going to have to
1394            use NV maths. Hence only attempt to coerce the right argument if
1395            we know the left is integer.  */
1396         /* Left operand is defined, so is it IV? */
1397         if (SvIV_please_nomg(svl)) {
1398             bool auvok = SvUOK(svl);
1399             bool buvok = SvUOK(svr);
1400             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1401             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1402             UV alow;
1403             UV ahigh;
1404             UV blow;
1405             UV bhigh;
1406
1407             if (auvok) {
1408                 alow = SvUVX(svl);
1409             } else {
1410                 const IV aiv = SvIVX(svl);
1411                 if (aiv >= 0) {
1412                     alow = aiv;
1413                     auvok = TRUE; /* effectively it's a UV now */
1414                 } else {
1415                     /* abs, auvok == false records sign */
1416                     alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1417                 }
1418             }
1419             if (buvok) {
1420                 blow = SvUVX(svr);
1421             } else {
1422                 const IV biv = SvIVX(svr);
1423                 if (biv >= 0) {
1424                     blow = biv;
1425                     buvok = TRUE; /* effectively it's a UV now */
1426                 } else {
1427                     /* abs, buvok == false records sign */
1428                     blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1429                 }
1430             }
1431
1432             /* If this does sign extension on unsigned it's time for plan B  */
1433             ahigh = alow >> (4 * sizeof (UV));
1434             alow &= botmask;
1435             bhigh = blow >> (4 * sizeof (UV));
1436             blow &= botmask;
1437             if (ahigh && bhigh) {
1438                 NOOP;
1439                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1440                    which is overflow. Drop to NVs below.  */
1441             } else if (!ahigh && !bhigh) {
1442                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1443                    so the unsigned multiply cannot overflow.  */
1444                 const UV product = alow * blow;
1445                 if (auvok == buvok) {
1446                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1447                     SP--;
1448                     SETu( product );
1449                     RETURN;
1450                 } else if (product <= (UV)IV_MIN) {
1451                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1452                     /* -ve result, which could overflow an IV  */
1453                     SP--;
1454                     /* can't negate IV_MIN, but there are aren't two
1455                      * integers such that !ahigh && !bhigh, where the
1456                      * product equals 0x800....000 */
1457                     assert(product != (UV)IV_MIN);
1458                     SETi( -(IV)product );
1459                     RETURN;
1460                 } /* else drop to NVs below. */
1461             } else {
1462                 /* One operand is large, 1 small */
1463                 UV product_middle;
1464                 if (bhigh) {
1465                     /* swap the operands */
1466                     ahigh = bhigh;
1467                     bhigh = blow; /* bhigh now the temp var for the swap */
1468                     blow = alow;
1469                     alow = bhigh;
1470                 }
1471                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1472                    multiplies can't overflow. shift can, add can, -ve can.  */
1473                 product_middle = ahigh * blow;
1474                 if (!(product_middle & topmask)) {
1475                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1476                     UV product_low;
1477                     product_middle <<= (4 * sizeof (UV));
1478                     product_low = alow * blow;
1479
1480                     /* as for pp_add, UV + something mustn't get smaller.
1481                        IIRC ANSI mandates this wrapping *behaviour* for
1482                        unsigned whatever the actual representation*/
1483                     product_low += product_middle;
1484                     if (product_low >= product_middle) {
1485                         /* didn't overflow */
1486                         if (auvok == buvok) {
1487                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1488                             SP--;
1489                             SETu( product_low );
1490                             RETURN;
1491                         } else if (product_low <= (UV)IV_MIN) {
1492                             /* 2s complement assumption again  */
1493                             /* -ve result, which could overflow an IV  */
1494                             SP--;
1495                             SETi(product_low == (UV)IV_MIN
1496                                     ? IV_MIN : -(IV)product_low);
1497                             RETURN;
1498                         } /* else drop to NVs below. */
1499                     }
1500                 } /* product_middle too large */
1501             } /* ahigh && bhigh */
1502         } /* SvIOK(svl) */
1503     } /* SvIOK(svr) */
1504 #endif
1505     {
1506       NV right = SvNV_nomg(svr);
1507       NV left  = SvNV_nomg(svl);
1508       NV result = left * right;
1509
1510       (void)POPs;
1511 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1512       if (Perl_isinf(result)) {
1513           Zero((U8*)&result + 8, 8, U8);
1514       }
1515 #endif
1516       SETn(result);
1517       RETURN;
1518     }
1519 }
1520
1521 PP(pp_divide)
1522 {
1523     dSP; dATARGET; SV *svl, *svr;
1524     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1525     svr = TOPs;
1526     svl = TOPm1s;
1527     /* Only try to do UV divide first
1528        if ((SLOPPYDIVIDE is true) or
1529            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1530             to preserve))
1531        The assumption is that it is better to use floating point divide
1532        whenever possible, only doing integer divide first if we can't be sure.
1533        If NV_PRESERVES_UV is true then we know at compile time that no UV
1534        can be too large to preserve, so don't need to compile the code to
1535        test the size of UVs.  */
1536
1537 #ifdef SLOPPYDIVIDE
1538 #  define PERL_TRY_UV_DIVIDE
1539     /* ensure that 20./5. == 4. */
1540 #else
1541 #  ifdef PERL_PRESERVE_IVUV
1542 #    ifndef NV_PRESERVES_UV
1543 #      define PERL_TRY_UV_DIVIDE
1544 #    endif
1545 #  endif
1546 #endif
1547
1548 #ifdef PERL_TRY_UV_DIVIDE
1549     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1550             bool left_non_neg = SvUOK(svl);
1551             bool right_non_neg = SvUOK(svr);
1552             UV left;
1553             UV right;
1554
1555             if (right_non_neg) {
1556                 right = SvUVX(svr);
1557             }
1558             else {
1559                 const IV biv = SvIVX(svr);
1560                 if (biv >= 0) {
1561                     right = biv;
1562                     right_non_neg = TRUE; /* effectively it's a UV now */
1563                 }
1564                 else {
1565                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1566                 }
1567             }
1568             /* historically undef()/0 gives a "Use of uninitialized value"
1569                warning before dieing, hence this test goes here.
1570                If it were immediately before the second SvIV_please, then
1571                DIE() would be invoked before left was even inspected, so
1572                no inspection would give no warning.  */
1573             if (right == 0)
1574                 DIE(aTHX_ "Illegal division by zero");
1575
1576             if (left_non_neg) {
1577                 left = SvUVX(svl);
1578             }
1579             else {
1580                 const IV aiv = SvIVX(svl);
1581                 if (aiv >= 0) {
1582                     left = aiv;
1583                     left_non_neg = TRUE; /* effectively it's a UV now */
1584                 }
1585                 else {
1586                     left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1587                 }
1588             }
1589
1590             if (left >= right
1591 #ifdef SLOPPYDIVIDE
1592                 /* For sloppy divide we always attempt integer division.  */
1593 #else
1594                 /* Otherwise we only attempt it if either or both operands
1595                    would not be preserved by an NV.  If both fit in NVs
1596                    we fall through to the NV divide code below.  However,
1597                    as left >= right to ensure integer result here, we know that
1598                    we can skip the test on the right operand - right big
1599                    enough not to be preserved can't get here unless left is
1600                    also too big.  */
1601
1602                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1603 #endif
1604                 ) {
1605                 /* Integer division can't overflow, but it can be imprecise.  */
1606                 const UV result = left / right;
1607                 if (result * right == left) {
1608                     SP--; /* result is valid */
1609                     if (left_non_neg == right_non_neg) {
1610                         /* signs identical, result is positive.  */
1611                         SETu( result );
1612                         RETURN;
1613                     }
1614                     /* 2s complement assumption */
1615                     if (result <= (UV)IV_MIN)
1616                         SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1617                     else {
1618                         /* It's exact but too negative for IV. */
1619                         SETn( -(NV)result );
1620                     }
1621                     RETURN;
1622                 } /* tried integer divide but it was not an integer result */
1623             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1624     } /* one operand wasn't SvIOK */
1625 #endif /* PERL_TRY_UV_DIVIDE */
1626     {
1627         NV right = SvNV_nomg(svr);
1628         NV left  = SvNV_nomg(svl);
1629         (void)POPs;(void)POPs;
1630 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1631         if (! Perl_isnan(right) && right == 0.0)
1632 #else
1633         if (right == 0.0)
1634 #endif
1635             DIE(aTHX_ "Illegal division by zero");
1636         PUSHn( left / right );
1637         RETURN;
1638     }
1639 }
1640
1641 PP(pp_modulo)
1642 {
1643     dSP; dATARGET;
1644     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1645     {
1646         UV left  = 0;
1647         UV right = 0;
1648         bool left_neg = FALSE;
1649         bool right_neg = FALSE;
1650         bool use_double = FALSE;
1651         bool dright_valid = FALSE;
1652         NV dright = 0.0;
1653         NV dleft  = 0.0;
1654         SV * const svr = TOPs;
1655         SV * const svl = TOPm1s;
1656         if (SvIV_please_nomg(svr)) {
1657             right_neg = !SvUOK(svr);
1658             if (!right_neg) {
1659                 right = SvUVX(svr);
1660             } else {
1661                 const IV biv = SvIVX(svr);
1662                 if (biv >= 0) {
1663                     right = biv;
1664                     right_neg = FALSE; /* effectively it's a UV now */
1665                 } else {
1666                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1667                 }
1668             }
1669         }
1670         else {
1671             dright = SvNV_nomg(svr);
1672             right_neg = dright < 0;
1673             if (right_neg)
1674                 dright = -dright;
1675             if (dright < UV_MAX_P1) {
1676                 right = U_V(dright);
1677                 dright_valid = TRUE; /* In case we need to use double below.  */
1678             } else {
1679                 use_double = TRUE;
1680             }
1681         }
1682
1683         /* At this point use_double is only true if right is out of range for
1684            a UV.  In range NV has been rounded down to nearest UV and
1685            use_double false.  */
1686         if (!use_double && SvIV_please_nomg(svl)) {
1687                 left_neg = !SvUOK(svl);
1688                 if (!left_neg) {
1689                     left = SvUVX(svl);
1690                 } else {
1691                     const IV aiv = SvIVX(svl);
1692                     if (aiv >= 0) {
1693                         left = aiv;
1694                         left_neg = FALSE; /* effectively it's a UV now */
1695                     } else {
1696                         left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1697                     }
1698                 }
1699         }
1700         else {
1701             dleft = SvNV_nomg(svl);
1702             left_neg = dleft < 0;
1703             if (left_neg)
1704                 dleft = -dleft;
1705
1706             /* This should be exactly the 5.6 behaviour - if left and right are
1707                both in range for UV then use U_V() rather than floor.  */
1708             if (!use_double) {
1709                 if (dleft < UV_MAX_P1) {
1710                     /* right was in range, so is dleft, so use UVs not double.
1711                      */
1712                     left = U_V(dleft);
1713                 }
1714                 /* left is out of range for UV, right was in range, so promote
1715                    right (back) to double.  */
1716                 else {
1717                     /* The +0.5 is used in 5.6 even though it is not strictly
1718                        consistent with the implicit +0 floor in the U_V()
1719                        inside the #if 1. */
1720                     dleft = Perl_floor(dleft + 0.5);
1721                     use_double = TRUE;
1722                     if (dright_valid)
1723                         dright = Perl_floor(dright + 0.5);
1724                     else
1725                         dright = right;
1726                 }
1727             }
1728         }
1729         sp -= 2;
1730         if (use_double) {
1731             NV dans;
1732
1733             if (!dright)
1734                 DIE(aTHX_ "Illegal modulus zero");
1735
1736             dans = Perl_fmod(dleft, dright);
1737             if ((left_neg != right_neg) && dans)
1738                 dans = dright - dans;
1739             if (right_neg)
1740                 dans = -dans;
1741             sv_setnv(TARG, dans);
1742         }
1743         else {
1744             UV ans;
1745
1746             if (!right)
1747                 DIE(aTHX_ "Illegal modulus zero");
1748
1749             ans = left % right;
1750             if ((left_neg != right_neg) && ans)
1751                 ans = right - ans;
1752             if (right_neg) {
1753                 /* XXX may warn: unary minus operator applied to unsigned type */
1754                 /* could change -foo to be (~foo)+1 instead     */
1755                 if (ans <= ~((UV)IV_MAX)+1)
1756                     sv_setiv(TARG, ~ans+1);
1757                 else
1758                     sv_setnv(TARG, -(NV)ans);
1759             }
1760             else
1761                 sv_setuv(TARG, ans);
1762         }
1763         PUSHTARG;
1764         RETURN;
1765     }
1766 }
1767
1768 PP(pp_repeat)
1769 {
1770     dSP; dATARGET;
1771     IV count;
1772     SV *sv;
1773     bool infnan = FALSE;
1774
1775     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1776         /* TODO: think of some way of doing list-repeat overloading ??? */
1777         sv = POPs;
1778         SvGETMAGIC(sv);
1779     }
1780     else {
1781         if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1782             /* The parser saw this as a list repeat, and there
1783                are probably several items on the stack. But we're
1784                in scalar/void context, and there's no pp_list to save us
1785                now. So drop the rest of the items -- robin@kitsite.com
1786              */
1787             dMARK;
1788             if (MARK + 1 < SP) {
1789                 MARK[1] = TOPm1s;
1790                 MARK[2] = TOPs;
1791             }
1792             else {
1793                 dTOPss;
1794                 ASSUME(MARK + 1 == SP);
1795                 XPUSHs(sv);
1796                 MARK[1] = &PL_sv_undef;
1797             }
1798             SP = MARK + 2;
1799         }
1800         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1801         sv = POPs;
1802     }
1803
1804     if (SvIOKp(sv)) {
1805          if (SvUOK(sv)) {
1806               const UV uv = SvUV_nomg(sv);
1807               if (uv > IV_MAX)
1808                    count = IV_MAX; /* The best we can do? */
1809               else
1810                    count = uv;
1811          } else {
1812               count = SvIV_nomg(sv);
1813          }
1814     }
1815     else if (SvNOKp(sv)) {
1816         const NV nv = SvNV_nomg(sv);
1817         infnan = Perl_isinfnan(nv);
1818         if (UNLIKELY(infnan)) {
1819             count = 0;
1820         } else {
1821             if (nv < 0.0)
1822                 count = -1;   /* An arbitrary negative integer */
1823             else
1824                 count = (IV)nv;
1825         }
1826     }
1827     else
1828         count = SvIV_nomg(sv);
1829
1830     if (infnan) {
1831         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1832                        "Non-finite repeat count does nothing");
1833     } else if (count < 0) {
1834         count = 0;
1835         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1836                        "Negative repeat count does nothing");
1837     }
1838
1839     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1840         dMARK;
1841         const SSize_t items = SP - MARK;
1842         const U8 mod = PL_op->op_flags & OPf_MOD;
1843
1844         if (count > 1) {
1845             SSize_t max;
1846
1847             if (  items > SSize_t_MAX / count   /* max would overflow */
1848                                                 /* repeatcpy would overflow */
1849                || items > I32_MAX / (I32)sizeof(SV *)
1850             )
1851                Perl_croak(aTHX_ "%s","Out of memory during list extend");
1852             max = items * count;
1853             MEXTEND(MARK, max);
1854
1855             while (SP > MARK) {
1856                 if (*SP) {
1857                    if (mod && SvPADTMP(*SP)) {
1858                        *SP = sv_mortalcopy(*SP);
1859                    }
1860                    SvTEMP_off((*SP));
1861                 }
1862                 SP--;
1863             }
1864             MARK++;
1865             repeatcpy((char*)(MARK + items), (char*)MARK,
1866                 items * sizeof(const SV *), count - 1);
1867             SP += max;
1868         }
1869         else if (count <= 0)
1870             SP = MARK;
1871     }
1872     else {      /* Note: mark already snarfed by pp_list */
1873         SV * const tmpstr = POPs;
1874         STRLEN len;
1875         bool isutf;
1876
1877         if (TARG != tmpstr)
1878             sv_setsv_nomg(TARG, tmpstr);
1879         SvPV_force_nomg(TARG, len);
1880         isutf = DO_UTF8(TARG);
1881         if (count != 1) {
1882             if (count < 1)
1883                 SvCUR_set(TARG, 0);
1884             else {
1885                 STRLEN max;
1886
1887                 if (   len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1888                     || len > (U32)I32_MAX  /* repeatcpy would overflow */
1889                 )
1890                      Perl_croak(aTHX_ "%s",
1891                                         "Out of memory during string extend");
1892                 max = (UV)count * len + 1;
1893                 SvGROW(TARG, max);
1894
1895                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1896                 SvCUR_set(TARG, SvCUR(TARG) * count);
1897             }
1898             *SvEND(TARG) = '\0';
1899         }
1900         if (isutf)
1901             (void)SvPOK_only_UTF8(TARG);
1902         else
1903             (void)SvPOK_only(TARG);
1904
1905         PUSHTARG;
1906     }
1907     RETURN;
1908 }
1909
1910 PP(pp_subtract)
1911 {
1912     dSP; dATARGET; bool useleft; SV *svl, *svr;
1913     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1914     svr = TOPs;
1915     svl = TOPm1s;
1916
1917 #ifdef PERL_PRESERVE_IVUV
1918
1919     /* special-case some simple common cases */
1920     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1921         IV il, ir;
1922         U32 flags = (svl->sv_flags & svr->sv_flags);
1923         if (flags & SVf_IOK) {
1924             /* both args are simple IVs */
1925             UV topl, topr;
1926             il = SvIVX(svl);
1927             ir = SvIVX(svr);
1928           do_iv:
1929             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1930             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1931
1932             /* if both are in a range that can't under/overflow, do a
1933              * simple integer subtract: if the top of both numbers
1934              * are 00  or 11, then it's safe */
1935             if (!( ((topl+1) | (topr+1)) & 2)) {
1936                 SP--;
1937                 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1938                 SETs(TARG);
1939                 RETURN;
1940             }
1941             goto generic;
1942         }
1943         else if (flags & SVf_NOK) {
1944             /* both args are NVs */
1945             NV nl = SvNVX(svl);
1946             NV nr = SvNVX(svr);
1947
1948             if (
1949 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1950                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1951                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1952 #else
1953                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1954 #endif
1955                 )
1956                 /* nothing was lost by converting to IVs */
1957                 goto do_iv;
1958             SP--;
1959             TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1960             SETs(TARG);
1961             RETURN;
1962         }
1963     }
1964
1965   generic:
1966
1967     useleft = USE_LEFT(svl);
1968     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1969        "bad things" happen if you rely on signed integers wrapping.  */
1970     if (SvIV_please_nomg(svr)) {
1971         /* Unless the left argument is integer in range we are going to have to
1972            use NV maths. Hence only attempt to coerce the right argument if
1973            we know the left is integer.  */
1974         UV auv = 0;
1975         bool auvok = FALSE;
1976         bool a_valid = 0;
1977
1978         if (!useleft) {
1979             auv = 0;
1980             a_valid = auvok = 1;
1981             /* left operand is undef, treat as zero.  */
1982         } else {
1983             /* Left operand is defined, so is it IV? */
1984             if (SvIV_please_nomg(svl)) {
1985                 if ((auvok = SvUOK(svl)))
1986                     auv = SvUVX(svl);
1987                 else {
1988                     const IV aiv = SvIVX(svl);
1989                     if (aiv >= 0) {
1990                         auv = aiv;
1991                         auvok = 1;      /* Now acting as a sign flag.  */
1992                     } else { /* 2s complement assumption for IV_MIN */
1993                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
1994                     }
1995                 }
1996                 a_valid = 1;
1997             }
1998         }
1999         if (a_valid) {
2000             bool result_good = 0;
2001             UV result;
2002             UV buv;
2003             bool buvok = SvUOK(svr);
2004         
2005             if (buvok)
2006                 buv = SvUVX(svr);
2007             else {
2008                 const IV biv = SvIVX(svr);
2009                 if (biv >= 0) {
2010                     buv = biv;
2011                     buvok = 1;
2012                 } else
2013                     buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
2014             }
2015             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
2016                else "IV" now, independent of how it came in.
2017                if a, b represents positive, A, B negative, a maps to -A etc
2018                a - b =>  (a - b)
2019                A - b => -(a + b)
2020                a - B =>  (a + b)
2021                A - B => -(a - b)
2022                all UV maths. negate result if A negative.
2023                subtract if signs same, add if signs differ. */
2024
2025             if (auvok ^ buvok) {
2026                 /* Signs differ.  */
2027                 result = auv + buv;
2028                 if (result >= auv)
2029                     result_good = 1;
2030             } else {
2031                 /* Signs same */
2032                 if (auv >= buv) {
2033                     result = auv - buv;
2034                     /* Must get smaller */
2035                     if (result <= auv)
2036                         result_good = 1;
2037                 } else {
2038                     result = buv - auv;
2039                     if (result <= buv) {
2040                         /* result really should be -(auv-buv). as its negation
2041                            of true value, need to swap our result flag  */
2042                         auvok = !auvok;
2043                         result_good = 1;
2044                     }
2045                 }
2046             }
2047             if (result_good) {
2048                 SP--;
2049                 if (auvok)
2050                     SETu( result );
2051                 else {
2052                     /* Negate result */
2053                     if (result <= (UV)IV_MIN)
2054                         SETi(result == (UV)IV_MIN
2055                                 ? IV_MIN : -(IV)result);
2056                     else {
2057                         /* result valid, but out of range for IV.  */
2058                         SETn( -(NV)result );
2059                     }
2060                 }
2061                 RETURN;
2062             } /* Overflow, drop through to NVs.  */
2063         }
2064     }
2065 #else
2066     useleft = USE_LEFT(svl);
2067 #endif
2068     {
2069         NV value = SvNV_nomg(svr);
2070         (void)POPs;
2071
2072         if (!useleft) {
2073             /* left operand is undef, treat as zero - value */
2074             SETn(-value);
2075             RETURN;
2076         }
2077         SETn( SvNV_nomg(svl) - value );
2078         RETURN;
2079     }
2080 }
2081
2082 #define IV_BITS (IVSIZE * 8)
2083
2084 static UV S_uv_shift(UV uv, int shift, bool left)
2085 {
2086    if (shift < 0) {
2087        shift = -shift;
2088        left = !left;
2089    }
2090    if (shift >= IV_BITS) {
2091        return 0;
2092    }
2093    return left ? uv << shift : uv >> shift;
2094 }
2095
2096 static IV S_iv_shift(IV iv, int shift, bool left)
2097 {
2098    if (shift < 0) {
2099        shift = -shift;
2100        left = !left;
2101    }
2102    if (shift >= IV_BITS) {
2103        return iv < 0 && !left ? -1 : 0;
2104    }
2105    return left ? iv << shift : iv >> shift;
2106 }
2107
2108 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2109 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2110 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2111 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2112
2113 PP(pp_left_shift)
2114 {
2115     dSP; dATARGET; SV *svl, *svr;
2116     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2117     svr = POPs;
2118     svl = TOPs;
2119     {
2120       const IV shift = SvIV_nomg(svr);
2121       if (PL_op->op_private & HINT_INTEGER) {
2122           SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2123       }
2124       else {
2125           SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2126       }
2127       RETURN;
2128     }
2129 }
2130
2131 PP(pp_right_shift)
2132 {
2133     dSP; dATARGET; SV *svl, *svr;
2134     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2135     svr = POPs;
2136     svl = TOPs;
2137     {
2138       const IV shift = SvIV_nomg(svr);
2139       if (PL_op->op_private & HINT_INTEGER) {
2140           SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2141       }
2142       else {
2143           SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2144       }
2145       RETURN;
2146     }
2147 }
2148
2149 PP(pp_lt)
2150 {
2151     dSP;
2152     SV *left, *right;
2153
2154     tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2155     right = POPs;
2156     left  = TOPs;
2157     SETs(boolSV(
2158         (SvIOK_notUV(left) && SvIOK_notUV(right))
2159         ? (SvIVX(left) < SvIVX(right))
2160         : (do_ncmp(left, right) == -1)
2161     ));
2162     RETURN;
2163 }
2164
2165 PP(pp_gt)
2166 {
2167     dSP;
2168     SV *left, *right;
2169
2170     tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2171     right = POPs;
2172     left  = TOPs;
2173     SETs(boolSV(
2174         (SvIOK_notUV(left) && SvIOK_notUV(right))
2175         ? (SvIVX(left) > SvIVX(right))
2176         : (do_ncmp(left, right) == 1)
2177     ));
2178     RETURN;
2179 }
2180
2181 PP(pp_le)
2182 {
2183     dSP;
2184     SV *left, *right;
2185
2186     tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2187     right = POPs;
2188     left  = TOPs;
2189     SETs(boolSV(
2190         (SvIOK_notUV(left) && SvIOK_notUV(right))
2191         ? (SvIVX(left) <= SvIVX(right))
2192         : (do_ncmp(left, right) <= 0)
2193     ));
2194     RETURN;
2195 }
2196
2197 PP(pp_ge)
2198 {
2199     dSP;
2200     SV *left, *right;
2201
2202     tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2203     right = POPs;
2204     left  = TOPs;
2205     SETs(boolSV(
2206         (SvIOK_notUV(left) && SvIOK_notUV(right))
2207         ? (SvIVX(left) >= SvIVX(right))
2208         : ( (do_ncmp(left, right) & 2) == 0)
2209     ));
2210     RETURN;
2211 }
2212
2213 PP(pp_ne)
2214 {
2215     dSP;
2216     SV *left, *right;
2217
2218     tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2219     right = POPs;
2220     left  = TOPs;
2221     SETs(boolSV(
2222         (SvIOK_notUV(left) && SvIOK_notUV(right))
2223         ? (SvIVX(left) != SvIVX(right))
2224         : (do_ncmp(left, right) != 0)
2225     ));
2226     RETURN;
2227 }
2228
2229 /* compare left and right SVs. Returns:
2230  * -1: <
2231  *  0: ==
2232  *  1: >
2233  *  2: left or right was a NaN
2234  */
2235 I32
2236 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2237 {
2238     PERL_ARGS_ASSERT_DO_NCMP;
2239 #ifdef PERL_PRESERVE_IVUV
2240     /* Fortunately it seems NaN isn't IOK */
2241     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2242             if (!SvUOK(left)) {
2243                 const IV leftiv = SvIVX(left);
2244                 if (!SvUOK(right)) {
2245                     /* ## IV <=> IV ## */
2246                     const IV rightiv = SvIVX(right);
2247                     return (leftiv > rightiv) - (leftiv < rightiv);
2248                 }
2249                 /* ## IV <=> UV ## */
2250                 if (leftiv < 0)
2251                     /* As (b) is a UV, it's >=0, so it must be < */
2252                     return -1;
2253                 {
2254                     const UV rightuv = SvUVX(right);
2255                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2256                 }
2257             }
2258
2259             if (SvUOK(right)) {
2260                 /* ## UV <=> UV ## */
2261                 const UV leftuv = SvUVX(left);
2262                 const UV rightuv = SvUVX(right);
2263                 return (leftuv > rightuv) - (leftuv < rightuv);
2264             }
2265             /* ## UV <=> IV ## */
2266             {
2267                 const IV rightiv = SvIVX(right);
2268                 if (rightiv < 0)
2269                     /* As (a) is a UV, it's >=0, so it cannot be < */
2270                     return 1;
2271                 {
2272                     const UV leftuv = SvUVX(left);
2273                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2274                 }
2275             }
2276             NOT_REACHED; /* NOTREACHED */
2277     }
2278 #endif
2279     {
2280       NV const rnv = SvNV_nomg(right);
2281       NV const lnv = SvNV_nomg(left);
2282
2283 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2284       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2285           return 2;
2286        }
2287       return (lnv > rnv) - (lnv < rnv);
2288 #else
2289       if (lnv < rnv)
2290         return -1;
2291       if (lnv > rnv)
2292         return 1;
2293       if (lnv == rnv)
2294         return 0;
2295       return 2;
2296 #endif
2297     }
2298 }
2299
2300
2301 PP(pp_ncmp)
2302 {
2303     dSP;
2304     SV *left, *right;
2305     I32 value;
2306     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2307     right = POPs;
2308     left  = TOPs;
2309     value = do_ncmp(left, right);
2310     if (value == 2) {
2311         SETs(&PL_sv_undef);
2312     }
2313     else {
2314         dTARGET;
2315         SETi(value);
2316     }
2317     RETURN;
2318 }
2319
2320
2321 /* also used for: pp_sge() pp_sgt() pp_slt() */
2322
2323 PP(pp_sle)
2324 {
2325     dSP;
2326
2327     int amg_type = sle_amg;
2328     int multiplier = 1;
2329     int rhs = 1;
2330
2331     switch (PL_op->op_type) {
2332     case OP_SLT:
2333         amg_type = slt_amg;
2334         /* cmp < 0 */
2335         rhs = 0;
2336         break;
2337     case OP_SGT:
2338         amg_type = sgt_amg;
2339         /* cmp > 0 */
2340         multiplier = -1;
2341         rhs = 0;
2342         break;
2343     case OP_SGE:
2344         amg_type = sge_amg;
2345         /* cmp >= 0 */
2346         multiplier = -1;
2347         break;
2348     }
2349
2350     tryAMAGICbin_MG(amg_type, AMGf_set);
2351     {
2352       dPOPTOPssrl;
2353       const int cmp =
2354 #ifdef USE_LOCALE_COLLATE
2355                       (IN_LC_RUNTIME(LC_COLLATE))
2356                       ? sv_cmp_locale_flags(left, right, 0)
2357                       :
2358 #endif
2359                         sv_cmp_flags(left, right, 0);
2360       SETs(boolSV(cmp * multiplier < rhs));
2361       RETURN;
2362     }
2363 }
2364
2365 PP(pp_seq)
2366 {
2367     dSP;
2368     tryAMAGICbin_MG(seq_amg, AMGf_set);
2369     {
2370       dPOPTOPssrl;
2371       SETs(boolSV(sv_eq_flags(left, right, 0)));
2372       RETURN;
2373     }
2374 }
2375
2376 PP(pp_sne)
2377 {
2378     dSP;
2379     tryAMAGICbin_MG(sne_amg, AMGf_set);
2380     {
2381       dPOPTOPssrl;
2382       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2383       RETURN;
2384     }
2385 }
2386
2387 PP(pp_scmp)
2388 {
2389     dSP; dTARGET;
2390     tryAMAGICbin_MG(scmp_amg, 0);
2391     {
2392       dPOPTOPssrl;
2393       const int cmp =
2394 #ifdef USE_LOCALE_COLLATE
2395                       (IN_LC_RUNTIME(LC_COLLATE))
2396                       ? sv_cmp_locale_flags(left, right, 0)
2397                       :
2398 #endif
2399                         sv_cmp_flags(left, right, 0);
2400       SETi( cmp );
2401       RETURN;
2402     }
2403 }
2404
2405 PP(pp_bit_and)
2406 {
2407     dSP; dATARGET;
2408     tryAMAGICbin_MG(band_amg, AMGf_assign);
2409     {
2410       dPOPTOPssrl;
2411       if (SvNIOKp(left) || SvNIOKp(right)) {
2412         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2413         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2414         if (PL_op->op_private & HINT_INTEGER) {
2415           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2416           SETi(i);
2417         }
2418         else {
2419           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2420           SETu(u);
2421         }
2422         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2423         if (right_ro_nonnum) SvNIOK_off(right);
2424       }
2425       else {
2426         do_vop(PL_op->op_type, TARG, left, right);
2427         SETTARG;
2428       }
2429       RETURN;
2430     }
2431 }
2432
2433 PP(pp_nbit_and)
2434 {
2435     dSP;
2436     tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2437     {
2438         dATARGET; dPOPTOPssrl;
2439         if (PL_op->op_private & HINT_INTEGER) {
2440           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2441           SETi(i);
2442         }
2443         else {
2444           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2445           SETu(u);
2446         }
2447     }
2448     RETURN;
2449 }
2450
2451 PP(pp_sbit_and)
2452 {
2453     dSP;
2454     tryAMAGICbin_MG(sband_amg, AMGf_assign);
2455     {
2456         dATARGET; dPOPTOPssrl;
2457         do_vop(OP_BIT_AND, TARG, left, right);
2458         RETSETTARG;
2459     }
2460 }
2461
2462 /* also used for: pp_bit_xor() */
2463
2464 PP(pp_bit_or)
2465 {
2466     dSP; dATARGET;
2467     const int op_type = PL_op->op_type;
2468
2469     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2470     {
2471       dPOPTOPssrl;
2472       if (SvNIOKp(left) || SvNIOKp(right)) {
2473         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2474         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2475         if (PL_op->op_private & HINT_INTEGER) {
2476           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2477           const IV r = SvIV_nomg(right);
2478           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2479           SETi(result);
2480         }
2481         else {
2482           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2483           const UV r = SvUV_nomg(right);
2484           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2485           SETu(result);
2486         }
2487         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2488         if (right_ro_nonnum) SvNIOK_off(right);
2489       }
2490       else {
2491         do_vop(op_type, TARG, left, right);
2492         SETTARG;
2493       }
2494       RETURN;
2495     }
2496 }
2497
2498 /* also used for: pp_nbit_xor() */
2499
2500 PP(pp_nbit_or)
2501 {
2502     dSP;
2503     const int op_type = PL_op->op_type;
2504
2505     tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2506                     AMGf_assign|AMGf_numarg);
2507     {
2508         dATARGET; dPOPTOPssrl;
2509         if (PL_op->op_private & HINT_INTEGER) {
2510           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2511           const IV r = SvIV_nomg(right);
2512           const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2513           SETi(result);
2514         }
2515         else {
2516           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2517           const UV r = SvUV_nomg(right);
2518           const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2519           SETu(result);
2520         }
2521     }
2522     RETURN;
2523 }
2524
2525 /* also used for: pp_sbit_xor() */
2526
2527 PP(pp_sbit_or)
2528 {
2529     dSP;
2530     const int op_type = PL_op->op_type;
2531
2532     tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2533                     AMGf_assign);
2534     {
2535         dATARGET; dPOPTOPssrl;
2536         do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2537                right);
2538         RETSETTARG;
2539     }
2540 }
2541
2542 PERL_STATIC_INLINE bool
2543 S_negate_string(pTHX)
2544 {
2545     dTARGET; dSP;
2546     STRLEN len;
2547     const char *s;
2548     SV * const sv = TOPs;
2549     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2550         return FALSE;
2551     s = SvPV_nomg_const(sv, len);
2552     if (isIDFIRST(*s)) {
2553         sv_setpvs(TARG, "-");
2554         sv_catsv(TARG, sv);
2555     }
2556     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2557         sv_setsv_nomg(TARG, sv);
2558         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2559     }
2560     else return FALSE;
2561     SETTARG;
2562     return TRUE;
2563 }
2564
2565 PP(pp_negate)
2566 {
2567     dSP; dTARGET;
2568     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2569     if (S_negate_string(aTHX)) return NORMAL;
2570     {
2571         SV * const sv = TOPs;
2572
2573         if (SvIOK(sv)) {
2574             /* It's publicly an integer */
2575         oops_its_an_int:
2576             if (SvIsUV(sv)) {
2577                 if (SvIVX(sv) == IV_MIN) {
2578                     /* 2s complement assumption. */
2579                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2580                                            IV_MIN */
2581                     return NORMAL;
2582                 }
2583                 else if (SvUVX(sv) <= IV_MAX) {
2584                     SETi(-SvIVX(sv));
2585                     return NORMAL;
2586                 }
2587             }
2588             else if (SvIVX(sv) != IV_MIN) {
2589                 SETi(-SvIVX(sv));
2590                 return NORMAL;
2591             }
2592 #ifdef PERL_PRESERVE_IVUV
2593             else {
2594                 SETu((UV)IV_MIN);
2595                 return NORMAL;
2596             }
2597 #endif
2598         }
2599         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2600             SETn(-SvNV_nomg(sv));
2601         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2602                   goto oops_its_an_int;
2603         else
2604             SETn(-SvNV_nomg(sv));
2605     }
2606     return NORMAL;
2607 }
2608
2609 PP(pp_not)
2610 {
2611     dSP;
2612     tryAMAGICun_MG(not_amg, AMGf_set);
2613     *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2614     return NORMAL;
2615 }
2616
2617 static void
2618 S_scomplement(pTHX_ SV *targ, SV *sv)
2619 {
2620         U8 *tmps;
2621         I32 anum;
2622         STRLEN len;
2623
2624         sv_copypv_nomg(TARG, sv);
2625         tmps = (U8*)SvPV_nomg(TARG, len);
2626         anum = len;
2627         if (SvUTF8(TARG)) {
2628           /* Calculate exact length, let's not estimate. */
2629           STRLEN targlen = 0;
2630           STRLEN l;
2631           UV nchar = 0;
2632           UV nwide = 0;
2633           U8 * const send = tmps + len;
2634           U8 * const origtmps = tmps;
2635           const UV utf8flags = UTF8_ALLOW_ANYUV;
2636
2637           while (tmps < send) {
2638             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2639             tmps += l;
2640             targlen += UVCHR_SKIP(~c);
2641             nchar++;
2642             if (c > 0xff)
2643                 nwide++;
2644           }
2645
2646           /* Now rewind strings and write them. */
2647           tmps = origtmps;
2648
2649           if (nwide) {
2650               U8 *result;
2651               U8 *p;
2652
2653               Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2654                         deprecated_above_ff_msg, PL_op_desc[PL_op->op_type]);
2655               Newx(result, targlen + 1, U8);
2656               p = result;
2657               while (tmps < send) {
2658                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2659                   tmps += l;
2660                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2661               }
2662               *p = '\0';
2663               sv_usepvn_flags(TARG, (char*)result, targlen,
2664                               SV_HAS_TRAILING_NUL);
2665               SvUTF8_on(TARG);
2666           }
2667           else {
2668               U8 *result;
2669               U8 *p;
2670
2671               Newx(result, nchar + 1, U8);
2672               p = result;
2673               while (tmps < send) {
2674                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2675                   tmps += l;
2676                   *p++ = ~c;
2677               }
2678               *p = '\0';
2679               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2680               SvUTF8_off(TARG);
2681           }
2682           return;
2683         }
2684 #ifdef LIBERAL
2685         {
2686             long *tmpl;
2687             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2688                 *tmps = ~*tmps;
2689             tmpl = (long*)tmps;
2690             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2691                 *tmpl = ~*tmpl;
2692             tmps = (U8*)tmpl;
2693         }
2694 #endif
2695         for ( ; anum > 0; anum--, tmps++)
2696             *tmps = ~*tmps;
2697 }
2698
2699 PP(pp_complement)
2700 {
2701     dSP; dTARGET;
2702     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2703     {
2704       dTOPss;
2705       if (SvNIOKp(sv)) {
2706         if (PL_op->op_private & HINT_INTEGER) {
2707           const IV i = ~SvIV_nomg(sv);
2708           SETi(i);
2709         }
2710         else {
2711           const UV u = ~SvUV_nomg(sv);
2712           SETu(u);
2713         }
2714       }
2715       else {
2716         S_scomplement(aTHX_ TARG, sv);
2717         SETTARG;
2718       }
2719       return NORMAL;
2720     }
2721 }
2722
2723 PP(pp_ncomplement)
2724 {
2725     dSP;
2726     tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2727     {
2728         dTARGET; dTOPss;
2729         if (PL_op->op_private & HINT_INTEGER) {
2730           const IV i = ~SvIV_nomg(sv);
2731           SETi(i);
2732         }
2733         else {
2734           const UV u = ~SvUV_nomg(sv);
2735           SETu(u);
2736         }
2737     }
2738     return NORMAL;
2739 }
2740
2741 PP(pp_scomplement)
2742 {
2743     dSP;
2744     tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2745     {
2746         dTARGET; dTOPss;
2747         S_scomplement(aTHX_ TARG, sv);
2748         SETTARG;
2749         return NORMAL;
2750     }
2751 }
2752
2753 /* integer versions of some of the above */
2754
2755 PP(pp_i_multiply)
2756 {
2757     dSP; dATARGET;
2758     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2759     {
2760       dPOPTOPiirl_nomg;
2761       SETi( left * right );
2762       RETURN;
2763     }
2764 }
2765
2766 PP(pp_i_divide)
2767 {
2768     IV num;
2769     dSP; dATARGET;
2770     tryAMAGICbin_MG(div_amg, AMGf_assign);
2771     {
2772       dPOPTOPssrl;
2773       IV value = SvIV_nomg(right);
2774       if (value == 0)
2775           DIE(aTHX_ "Illegal division by zero");
2776       num = SvIV_nomg(left);
2777
2778       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2779       if (value == -1)
2780           value = - num;
2781       else
2782           value = num / value;
2783       SETi(value);
2784       RETURN;
2785     }
2786 }
2787
2788 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2789     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2790 STATIC
2791 PP(pp_i_modulo_0)
2792 #else
2793 PP(pp_i_modulo)
2794 #endif
2795 {
2796      /* This is the vanilla old i_modulo. */
2797      dSP; dATARGET;
2798      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2799      {
2800           dPOPTOPiirl_nomg;
2801           if (!right)
2802                DIE(aTHX_ "Illegal modulus zero");
2803           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2804           if (right == -1)
2805               SETi( 0 );
2806           else
2807               SETi( left % right );
2808           RETURN;
2809      }
2810 }
2811
2812 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2813     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2814 STATIC
2815 PP(pp_i_modulo_1)
2816
2817 {
2818      /* This is the i_modulo with the workaround for the _moddi3 bug
2819       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2820       * See below for pp_i_modulo. */
2821      dSP; dATARGET;
2822      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2823      {
2824           dPOPTOPiirl_nomg;
2825           if (!right)
2826                DIE(aTHX_ "Illegal modulus zero");
2827           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2828           if (right == -1)
2829               SETi( 0 );
2830           else
2831               SETi( left % PERL_ABS(right) );
2832           RETURN;
2833      }
2834 }
2835
2836 PP(pp_i_modulo)
2837 {
2838      dVAR; dSP; dATARGET;
2839      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2840      {
2841           dPOPTOPiirl_nomg;
2842           if (!right)
2843                DIE(aTHX_ "Illegal modulus zero");
2844           /* The assumption is to use hereafter the old vanilla version... */
2845           PL_op->op_ppaddr =
2846                PL_ppaddr[OP_I_MODULO] =
2847                    Perl_pp_i_modulo_0;
2848           /* .. but if we have glibc, we might have a buggy _moddi3
2849            * (at least glibc 2.2.5 is known to have this bug), in other
2850            * words our integer modulus with negative quad as the second
2851            * argument might be broken.  Test for this and re-patch the
2852            * opcode dispatch table if that is the case, remembering to
2853            * also apply the workaround so that this first round works
2854            * right, too.  See [perl #9402] for more information. */
2855           {
2856                IV l =   3;
2857                IV r = -10;
2858                /* Cannot do this check with inlined IV constants since
2859                 * that seems to work correctly even with the buggy glibc. */
2860                if (l % r == -3) {
2861                     /* Yikes, we have the bug.
2862                      * Patch in the workaround version. */
2863                     PL_op->op_ppaddr =
2864                          PL_ppaddr[OP_I_MODULO] =
2865                              &Perl_pp_i_modulo_1;
2866                     /* Make certain we work right this time, too. */
2867                     right = PERL_ABS(right);
2868                }
2869           }
2870           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2871           if (right == -1)
2872               SETi( 0 );
2873           else
2874               SETi( left % right );
2875           RETURN;
2876      }
2877 }
2878 #endif
2879
2880 PP(pp_i_add)
2881 {
2882     dSP; dATARGET;
2883     tryAMAGICbin_MG(add_amg, AMGf_assign);
2884     {
2885       dPOPTOPiirl_ul_nomg;
2886       SETi( left + right );
2887       RETURN;
2888     }
2889 }
2890
2891 PP(pp_i_subtract)
2892 {
2893     dSP; dATARGET;
2894     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2895     {
2896       dPOPTOPiirl_ul_nomg;
2897       SETi( left - right );
2898       RETURN;
2899     }
2900 }
2901
2902 PP(pp_i_lt)
2903 {
2904     dSP;
2905     tryAMAGICbin_MG(lt_amg, AMGf_set);
2906     {
2907       dPOPTOPiirl_nomg;
2908       SETs(boolSV(left < right));
2909       RETURN;
2910     }
2911 }
2912
2913 PP(pp_i_gt)
2914 {
2915     dSP;
2916     tryAMAGICbin_MG(gt_amg, AMGf_set);
2917     {
2918       dPOPTOPiirl_nomg;
2919       SETs(boolSV(left > right));
2920       RETURN;
2921     }
2922 }
2923
2924 PP(pp_i_le)
2925 {
2926     dSP;
2927     tryAMAGICbin_MG(le_amg, AMGf_set);
2928     {
2929       dPOPTOPiirl_nomg;
2930       SETs(boolSV(left <= right));
2931       RETURN;
2932     }
2933 }
2934
2935 PP(pp_i_ge)
2936 {
2937     dSP;
2938     tryAMAGICbin_MG(ge_amg, AMGf_set);
2939     {
2940       dPOPTOPiirl_nomg;
2941       SETs(boolSV(left >= right));
2942       RETURN;
2943     }
2944 }
2945
2946 PP(pp_i_eq)
2947 {
2948     dSP;
2949     tryAMAGICbin_MG(eq_amg, AMGf_set);
2950     {
2951       dPOPTOPiirl_nomg;
2952       SETs(boolSV(left == right));
2953       RETURN;
2954     }
2955 }
2956
2957 PP(pp_i_ne)
2958 {
2959     dSP;
2960     tryAMAGICbin_MG(ne_amg, AMGf_set);
2961     {
2962       dPOPTOPiirl_nomg;
2963       SETs(boolSV(left != right));
2964       RETURN;
2965     }
2966 }
2967
2968 PP(pp_i_ncmp)
2969 {
2970     dSP; dTARGET;
2971     tryAMAGICbin_MG(ncmp_amg, 0);
2972     {
2973       dPOPTOPiirl_nomg;
2974       I32 value;
2975
2976       if (left > right)
2977         value = 1;
2978       else if (left < right)
2979         value = -1;
2980       else
2981         value = 0;
2982       SETi(value);
2983       RETURN;
2984     }
2985 }
2986
2987 PP(pp_i_negate)
2988 {
2989     dSP; dTARGET;
2990     tryAMAGICun_MG(neg_amg, 0);
2991     if (S_negate_string(aTHX)) return NORMAL;
2992     {
2993         SV * const sv = TOPs;
2994         IV const i = SvIV_nomg(sv);
2995         SETi(-i);
2996         return NORMAL;
2997     }
2998 }
2999
3000 /* High falutin' math. */
3001
3002 PP(pp_atan2)
3003 {
3004     dSP; dTARGET;
3005     tryAMAGICbin_MG(atan2_amg, 0);
3006     {
3007       dPOPTOPnnrl_nomg;
3008       SETn(Perl_atan2(left, right));
3009       RETURN;
3010     }
3011 }
3012
3013
3014 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
3015
3016 PP(pp_sin)
3017 {
3018     dSP; dTARGET;
3019     int amg_type = fallback_amg;
3020     const char *neg_report = NULL;
3021     const int op_type = PL_op->op_type;
3022
3023     switch (op_type) {
3024     case OP_SIN:  amg_type = sin_amg; break;
3025     case OP_COS:  amg_type = cos_amg; break;
3026     case OP_EXP:  amg_type = exp_amg; break;
3027     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
3028     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
3029     }
3030
3031     assert(amg_type != fallback_amg);
3032
3033     tryAMAGICun_MG(amg_type, 0);
3034     {
3035       SV * const arg = TOPs;
3036       const NV value = SvNV_nomg(arg);
3037       NV result = NV_NAN;
3038       if (neg_report) { /* log or sqrt */
3039           if (
3040 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3041               ! Perl_isnan(value) &&
3042 #endif
3043               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
3044               SET_NUMERIC_STANDARD();
3045               /* diag_listed_as: Can't take log of %g */
3046               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
3047           }
3048       }
3049       switch (op_type) {
3050       default:
3051       case OP_SIN:  result = Perl_sin(value);  break;
3052       case OP_COS:  result = Perl_cos(value);  break;
3053       case OP_EXP:  result = Perl_exp(value);  break;
3054       case OP_LOG:  result = Perl_log(value);  break;
3055       case OP_SQRT: result = Perl_sqrt(value); break;
3056       }
3057       SETn(result);
3058       return NORMAL;
3059     }
3060 }
3061
3062 /* Support Configure command-line overrides for rand() functions.
3063    After 5.005, perhaps we should replace this by Configure support
3064    for drand48(), random(), or rand().  For 5.005, though, maintain
3065    compatibility by calling rand() but allow the user to override it.
3066    See INSTALL for details.  --Andy Dougherty  15 July 1998
3067 */
3068 /* Now it's after 5.005, and Configure supports drand48() and random(),
3069    in addition to rand().  So the overrides should not be needed any more.
3070    --Jarkko Hietaniemi  27 September 1998
3071  */
3072
3073 PP(pp_rand)
3074 {
3075     if (!PL_srand_called) {
3076         (void)seedDrand01((Rand_seed_t)seed());
3077         PL_srand_called = TRUE;
3078     }
3079     {
3080         dSP;
3081         NV value;
3082     
3083         if (MAXARG < 1)
3084         {
3085             EXTEND(SP, 1);
3086             value = 1.0;
3087         }
3088         else {
3089             SV * const sv = POPs;
3090             if(!sv)
3091                 value = 1.0;
3092             else
3093                 value = SvNV(sv);
3094         }
3095     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
3096 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3097         if (! Perl_isnan(value) && value == 0.0)
3098 #else
3099         if (value == 0.0)
3100 #endif
3101             value = 1.0;
3102         {
3103             dTARGET;
3104             PUSHs(TARG);
3105             PUTBACK;
3106             value *= Drand01();
3107             sv_setnv_mg(TARG, value);
3108         }
3109     }
3110     return NORMAL;
3111 }
3112
3113 PP(pp_srand)
3114 {
3115     dSP; dTARGET;
3116     UV anum;
3117
3118     if (MAXARG >= 1 && (TOPs || POPs)) {
3119         SV *top;
3120         char *pv;
3121         STRLEN len;
3122         int flags;
3123
3124         top = POPs;
3125         pv = SvPV(top, len);
3126         flags = grok_number(pv, len, &anum);
3127
3128         if (!(flags & IS_NUMBER_IN_UV)) {
3129             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3130                              "Integer overflow in srand");
3131             anum = UV_MAX;
3132         }
3133     }
3134     else {
3135         anum = seed();
3136     }
3137
3138     (void)seedDrand01((Rand_seed_t)anum);
3139     PL_srand_called = TRUE;
3140     if (anum)
3141         XPUSHu(anum);
3142     else {
3143         /* Historically srand always returned true. We can avoid breaking
3144            that like this:  */
3145         sv_setpvs(TARG, "0 but true");
3146         XPUSHTARG;
3147     }
3148     RETURN;
3149 }
3150
3151 PP(pp_int)
3152 {
3153     dSP; dTARGET;
3154     tryAMAGICun_MG(int_amg, AMGf_numeric);
3155     {
3156       SV * const sv = TOPs;
3157       const IV iv = SvIV_nomg(sv);
3158       /* XXX it's arguable that compiler casting to IV might be subtly
3159          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3160          else preferring IV has introduced a subtle behaviour change bug. OTOH
3161          relying on floating point to be accurate is a bug.  */
3162
3163       if (!SvOK(sv)) {
3164         SETu(0);
3165       }
3166       else if (SvIOK(sv)) {
3167         if (SvIsUV(sv))
3168             SETu(SvUV_nomg(sv));
3169         else
3170             SETi(iv);
3171       }
3172       else {
3173           const NV value = SvNV_nomg(sv);
3174           if (UNLIKELY(Perl_isinfnan(value)))
3175               SETn(value);
3176           else if (value >= 0.0) {
3177               if (value < (NV)UV_MAX + 0.5) {
3178                   SETu(U_V(value));
3179               } else {
3180                   SETn(Perl_floor(value));
3181               }
3182           }
3183           else {
3184               if (value > (NV)IV_MIN - 0.5) {
3185                   SETi(I_V(value));
3186               } else {
3187                   SETn(Perl_ceil(value));
3188               }
3189           }
3190       }
3191     }
3192     return NORMAL;
3193 }
3194
3195 PP(pp_abs)
3196 {
3197     dSP; dTARGET;
3198     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3199     {
3200       SV * const sv = TOPs;
3201       /* This will cache the NV value if string isn't actually integer  */
3202       const IV iv = SvIV_nomg(sv);
3203
3204       if (!SvOK(sv)) {
3205         SETu(0);
3206       }
3207       else if (SvIOK(sv)) {
3208         /* IVX is precise  */
3209         if (SvIsUV(sv)) {
3210           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3211         } else {
3212           if (iv >= 0) {
3213             SETi(iv);
3214           } else {
3215             if (iv != IV_MIN) {
3216               SETi(-iv);
3217             } else {
3218               /* 2s complement assumption. Also, not really needed as
3219                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3220               SETu((UV)IV_MIN);
3221             }
3222           }
3223         }
3224       } else{
3225         const NV value = SvNV_nomg(sv);
3226         if (value < 0.0)
3227           SETn(-value);
3228         else
3229           SETn(value);
3230       }
3231     }
3232     return NORMAL;
3233 }
3234
3235
3236 /* also used for: pp_hex() */
3237
3238 PP(pp_oct)
3239 {
3240     dSP; dTARGET;
3241     const char *tmps;
3242     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3243     STRLEN len;
3244     NV result_nv;
3245     UV result_uv;
3246     SV* const sv = TOPs;
3247
3248     tmps = (SvPV_const(sv, len));
3249     if (DO_UTF8(sv)) {
3250          /* If Unicode, try to downgrade
3251           * If not possible, croak. */
3252          SV* const tsv = sv_2mortal(newSVsv(sv));
3253         
3254          SvUTF8_on(tsv);
3255          sv_utf8_downgrade(tsv, FALSE);
3256          tmps = SvPV_const(tsv, len);
3257     }
3258     if (PL_op->op_type == OP_HEX)
3259         goto hex;
3260
3261     while (*tmps && len && isSPACE(*tmps))
3262         tmps++, len--;
3263     if (*tmps == '0')
3264         tmps++, len--;
3265     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3266     hex:
3267         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3268     }
3269     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3270         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3271     else
3272         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3273
3274     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3275         SETn(result_nv);
3276     }
3277     else {
3278         SETu(result_uv);
3279     }
3280     return NORMAL;
3281 }
3282
3283 /* String stuff. */
3284
3285 PP(pp_length)
3286 {
3287     dSP; dTARGET;
3288     SV * const sv = TOPs;
3289
3290     U32 in_bytes = IN_BYTES;
3291     /* simplest case shortcut */
3292     /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3293     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3294     STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3295     SETs(TARG);
3296
3297     if(LIKELY(svflags == SVf_POK))
3298         goto simple_pv;
3299     if(svflags & SVs_GMG)
3300         mg_get(sv);
3301     if (SvOK(sv)) {
3302         if (!IN_BYTES) /* reread to avoid using an C auto/register */
3303             sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3304         else
3305         {
3306             STRLEN len;
3307             /* unrolled SvPV_nomg_const(sv,len) */
3308             if(SvPOK_nog(sv)){
3309                 simple_pv:
3310                 len = SvCUR(sv);
3311             } else  {
3312                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3313             }
3314             sv_setiv(TARG, (IV)(len));
3315         }
3316     } else {
3317         if (!SvPADTMP(TARG)) {
3318             sv_setsv_nomg(TARG, &PL_sv_undef);
3319         } else { /* TARG is on stack at this point and is overwriten by SETs.
3320                    This branch is the odd one out, so put TARG by default on
3321                    stack earlier to let local SP go out of liveness sooner */
3322             SETs(&PL_sv_undef);
3323             goto no_set_magic;
3324         }
3325     }
3326     SvSETMAGIC(TARG);
3327     no_set_magic:
3328     return NORMAL; /* no putback, SP didn't move in this opcode */
3329 }
3330
3331 /* Returns false if substring is completely outside original string.
3332    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3333    always be true for an explicit 0.
3334 */
3335 bool
3336 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3337                                 bool pos1_is_uv, IV len_iv,
3338                                 bool len_is_uv, STRLEN *posp,
3339                                 STRLEN *lenp)
3340 {
3341     IV pos2_iv;
3342     int    pos2_is_uv;
3343
3344     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3345
3346     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3347         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3348         pos1_iv += curlen;
3349     }
3350     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3351         return FALSE;
3352
3353     if (len_iv || len_is_uv) {
3354         if (!len_is_uv && len_iv < 0) {
3355             pos2_iv = curlen + len_iv;
3356             if (curlen)
3357                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3358             else
3359                 pos2_is_uv = 0;
3360         } else {  /* len_iv >= 0 */
3361             if (!pos1_is_uv && pos1_iv < 0) {
3362                 pos2_iv = pos1_iv + len_iv;
3363                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3364             } else {
3365                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3366                     pos2_iv = curlen;
3367                 else
3368                     pos2_iv = pos1_iv+len_iv;
3369                 pos2_is_uv = 1;
3370             }
3371         }
3372     }
3373     else {
3374         pos2_iv = curlen;
3375         pos2_is_uv = 1;
3376     }
3377
3378     if (!pos2_is_uv && pos2_iv < 0) {
3379         if (!pos1_is_uv && pos1_iv < 0)
3380             return FALSE;
3381         pos2_iv = 0;
3382     }
3383     else if (!pos1_is_uv && pos1_iv < 0)
3384         pos1_iv = 0;
3385
3386     if ((UV)pos2_iv < (UV)pos1_iv)
3387         pos2_iv = pos1_iv;
3388     if ((UV)pos2_iv > curlen)
3389         pos2_iv = curlen;
3390
3391     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3392     *posp = (STRLEN)( (UV)pos1_iv );
3393     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3394
3395     return TRUE;
3396 }
3397
3398 PP(pp_substr)
3399 {
3400     dSP; dTARGET;
3401     SV *sv;
3402     STRLEN curlen;
3403     STRLEN utf8_curlen;
3404     SV *   pos_sv;
3405     IV     pos1_iv;
3406     int    pos1_is_uv;
3407     SV *   len_sv;
3408     IV     len_iv = 0;
3409     int    len_is_uv = 0;
3410     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3411     const bool rvalue = (GIMME_V != G_VOID);
3412     const char *tmps;
3413     SV *repl_sv = NULL;
3414     const char *repl = NULL;
3415     STRLEN repl_len;
3416     int num_args = PL_op->op_private & 7;
3417     bool repl_need_utf8_upgrade = FALSE;
3418
3419     if (num_args > 2) {
3420         if (num_args > 3) {
3421           if(!(repl_sv = POPs)) num_args--;
3422         }
3423         if ((len_sv = POPs)) {
3424             len_iv    = SvIV(len_sv);
3425             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3426         }
3427         else num_args--;
3428     }
3429     pos_sv     = POPs;
3430     pos1_iv    = SvIV(pos_sv);
3431     pos1_is_uv = SvIOK_UV(pos_sv);
3432     sv = POPs;
3433     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3434         assert(!repl_sv);
3435         repl_sv = POPs;
3436     }
3437     if (lvalue && !repl_sv) {
3438         SV * ret;
3439         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3440         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3441         LvTYPE(ret) = 'x';
3442         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3443         LvTARGOFF(ret) =
3444             pos1_is_uv || pos1_iv >= 0
3445                 ? (STRLEN)(UV)pos1_iv
3446                 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3447         LvTARGLEN(ret) =
3448             len_is_uv || len_iv > 0
3449                 ? (STRLEN)(UV)len_iv
3450                 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3451
3452         PUSHs(ret);    /* avoid SvSETMAGIC here */
3453         RETURN;
3454     }
3455     if (repl_sv) {
3456         repl = SvPV_const(repl_sv, repl_len);
3457         SvGETMAGIC(sv);
3458         if (SvROK(sv))
3459             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3460                             "Attempt to use reference as lvalue in substr"
3461             );
3462         tmps = SvPV_force_nomg(sv, curlen);
3463         if (DO_UTF8(repl_sv) && repl_len) {
3464             if (!DO_UTF8(sv)) {
3465                 sv_utf8_upgrade_nomg(sv);
3466                 curlen = SvCUR(sv);
3467             }
3468         }
3469         else if (DO_UTF8(sv))
3470             repl_need_utf8_upgrade = TRUE;
3471     }
3472     else tmps = SvPV_const(sv, curlen);
3473     if (DO_UTF8(sv)) {
3474         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3475         if (utf8_curlen == curlen)
3476             utf8_curlen = 0;
3477         else
3478             curlen = utf8_curlen;
3479     }
3480     else
3481         utf8_curlen = 0;
3482
3483     {
3484         STRLEN pos, len, byte_len, byte_pos;
3485
3486         if (!translate_substr_offsets(
3487                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3488         )) goto bound_fail;
3489
3490         byte_len = len;
3491         byte_pos = utf8_curlen
3492             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3493
3494         tmps += byte_pos;
3495
3496         if (rvalue) {
3497             SvTAINTED_off(TARG);                        /* decontaminate */
3498             SvUTF8_off(TARG);                   /* decontaminate */
3499             sv_setpvn(TARG, tmps, byte_len);
3500 #ifdef USE_LOCALE_COLLATE
3501             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3502 #endif
3503             if (utf8_curlen)
3504                 SvUTF8_on(TARG);
3505         }
3506
3507         if (repl) {
3508             SV* repl_sv_copy = NULL;
3509
3510             if (repl_need_utf8_upgrade) {
3511                 repl_sv_copy = newSVsv(repl_sv);
3512                 sv_utf8_upgrade(repl_sv_copy);
3513                 repl = SvPV_const(repl_sv_copy, repl_len);
3514             }
3515             if (!SvOK(sv))
3516                 sv_setpvs(sv, "");
3517             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3518             SvREFCNT_dec(repl_sv_copy);
3519         }
3520     }
3521     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3522         SP++;
3523     else if (rvalue) {
3524         SvSETMAGIC(TARG);
3525         PUSHs(TARG);
3526     }
3527     RETURN;
3528
3529   bound_fail:
3530     if (repl)
3531         Perl_croak(aTHX_ "substr outside of string");
3532     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3533     RETPUSHUNDEF;
3534 }
3535
3536 PP(pp_vec)
3537 {
3538     dSP;
3539     const IV size   = POPi;
3540     const IV offset = POPi;
3541     SV * const src = POPs;
3542     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3543     SV * ret;
3544
3545     if (lvalue) {                       /* it's an lvalue! */
3546         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3547         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3548         LvTYPE(ret) = 'v';
3549         LvTARG(ret) = SvREFCNT_inc_simple(src);
3550         LvTARGOFF(ret) = offset;
3551         LvTARGLEN(ret) = size;
3552     }
3553     else {
3554         dTARGET;
3555         SvTAINTED_off(TARG);            /* decontaminate */
3556         ret = TARG;
3557     }
3558
3559     sv_setuv(ret, do_vecget(src, offset, size));
3560     if (!lvalue)
3561         SvSETMAGIC(ret);
3562     PUSHs(ret);
3563     RETURN;
3564 }
3565
3566
3567 /* also used for: pp_rindex() */
3568
3569 PP(pp_index)
3570 {
3571     dSP; dTARGET;
3572     SV *big;
3573     SV *little;
3574     SV *temp = NULL;
3575     STRLEN biglen;
3576     STRLEN llen = 0;
3577     SSize_t offset = 0;
3578     SSize_t retval;
3579     const char *big_p;
3580     const char *little_p;
3581     bool big_utf8;
3582     bool little_utf8;
3583     const bool is_index = PL_op->op_type == OP_INDEX;
3584     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3585
3586     if (threeargs)
3587         offset = POPi;
3588     little = POPs;
3589     big = POPs;
3590     big_p = SvPV_const(big, biglen);
3591     little_p = SvPV_const(little, llen);
3592
3593     big_utf8 = DO_UTF8(big);
3594     little_utf8 = DO_UTF8(little);
3595     if (big_utf8 ^ little_utf8) {
3596         /* One needs to be upgraded.  */
3597         if (little_utf8 && !IN_ENCODING) {
3598             /* Well, maybe instead we might be able to downgrade the small
3599                string?  */
3600             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3601                                                      &little_utf8);
3602             if (little_utf8) {
3603                 /* If the large string is ISO-8859-1, and it's not possible to
3604                    convert the small string to ISO-8859-1, then there is no
3605                    way that it could be found anywhere by index.  */
3606                 retval = -1;
3607                 goto fail;
3608             }
3609
3610             /* At this point, pv is a malloc()ed string. So donate it to temp
3611                to ensure it will get free()d  */
3612             little = temp = newSV(0);
3613             sv_usepvn(temp, pv, llen);
3614             little_p = SvPVX(little);
3615         } else {
3616             temp = little_utf8
3617                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3618
3619             if (IN_ENCODING) {
3620                 sv_recode_to_utf8(temp, _get_encoding());
3621             } else {
3622                 sv_utf8_upgrade(temp);
3623             }
3624             if (little_utf8) {
3625                 big = temp;
3626                 big_utf8 = TRUE;
3627                 big_p = SvPV_const(big, biglen);
3628             } else {
3629                 little = temp;
3630                 little_p = SvPV_const(little, llen);
3631             }
3632         }
3633     }
3634     if (SvGAMAGIC(big)) {
3635         /* Life just becomes a lot easier if I use a temporary here.
3636            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3637            will trigger magic and overloading again, as will fbm_instr()
3638         */
3639         big = newSVpvn_flags(big_p, biglen,
3640                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3641         big_p = SvPVX(big);
3642     }
3643     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3644         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3645            warn on undef, and we've already triggered a warning with the
3646            SvPV_const some lines above. We can't remove that, as we need to
3647            call some SvPV to trigger overloading early and find out if the
3648            string is UTF-8.
3649            This is all getting too messy. The API isn't quite clean enough,
3650            because data access has side effects.
3651         */
3652         little = newSVpvn_flags(little_p, llen,
3653                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3654         little_p = SvPVX(little);
3655     }
3656
3657     if (!threeargs)
3658         offset = is_index ? 0 : biglen;
3659     else {
3660         if (big_utf8 && offset > 0)
3661             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3662         if (!is_index)
3663             offset += llen;
3664     }
3665     if (offset < 0)
3666         offset = 0;
3667     else if (offset > (SSize_t)biglen)
3668         offset = biglen;
3669     if (!(little_p = is_index
3670           ? fbm_instr((unsigned char*)big_p + offset,
3671                       (unsigned char*)big_p + biglen, little, 0)
3672           : rninstr(big_p,  big_p  + offset,
3673                     little_p, little_p + llen)))
3674         retval = -1;
3675     else {
3676         retval = little_p - big_p;
3677         if (retval > 1 && big_utf8)
3678             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3679     }
3680     SvREFCNT_dec(temp);
3681  fail:
3682     PUSHi(retval);
3683     RETURN;
3684 }
3685
3686 PP(pp_sprintf)
3687 {
3688     dSP; dMARK; dORIGMARK; dTARGET;
3689     SvTAINTED_off(TARG);
3690     do_sprintf(TARG, SP-MARK, MARK+1);
3691     TAINT_IF(SvTAINTED(TARG));
3692     SP = ORIGMARK;
3693     PUSHTARG;
3694     RETURN;
3695 }
3696
3697 PP(pp_ord)
3698 {
3699     dSP; dTARGET;
3700
3701     SV *argsv = TOPs;
3702     STRLEN len;
3703     const U8 *s = (U8*)SvPV_const(argsv, len);
3704
3705     if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
3706         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3707         s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
3708         len = UTF8SKIP(s);  /* Should be well-formed; so this is its length */
3709         argsv = tmpsv;
3710     }
3711
3712     SETu(DO_UTF8(argsv)
3713            ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3714            : (UV)(*s));
3715
3716     return NORMAL;
3717 }
3718
3719 PP(pp_chr)
3720 {
3721     dSP; dTARGET;
3722     char *tmps;
3723     UV value;
3724     SV *top = TOPs;
3725
3726     SvGETMAGIC(top);
3727     if (UNLIKELY(SvAMAGIC(top)))
3728         top = sv_2num(top);
3729     if (UNLIKELY(isinfnansv(top)))
3730         Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3731     else {
3732         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3733             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3734                 ||
3735                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3736                  && SvNV_nomg(top) < 0.0)))
3737         {
3738             if (ckWARN(WARN_UTF8)) {
3739                 if (SvGMAGICAL(top)) {
3740                     SV *top2 = sv_newmortal();
3741                     sv_setsv_nomg(top2, top);
3742                     top = top2;
3743                 }
3744                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3745                             "Invalid negative number (%"SVf") in chr", SVfARG(top));
3746             }
3747             value = UNICODE_REPLACEMENT;
3748         } else {
3749             value = SvUV_nomg(top);
3750         }
3751     }
3752
3753     SvUPGRADE(TARG,SVt_PV);
3754
3755     if (value > 255 && !IN_BYTES) {
3756         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3757         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3758         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3759         *tmps = '\0';
3760         (void)SvPOK_only(TARG);
3761         SvUTF8_on(TARG);
3762         SETTARG;
3763         return NORMAL;
3764     }
3765
3766     SvGROW(TARG,2);
3767     SvCUR_set(TARG, 1);
3768     tmps = SvPVX(TARG);
3769     *tmps++ = (char)value;
3770     *tmps = '\0';
3771     (void)SvPOK_only(TARG);
3772
3773     if (IN_ENCODING && !IN_BYTES) {
3774         sv_recode_to_utf8(TARG, _get_encoding());
3775         tmps = SvPVX(TARG);
3776         if (SvCUR(TARG) == 0
3777             || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3778             || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3779         {
3780             SvGROW(TARG, 2);
3781             tmps = SvPVX(TARG);
3782             SvCUR_set(TARG, 1);
3783             *tmps++ = (char)value;
3784             *tmps = '\0';
3785             SvUTF8_off(TARG);
3786         }
3787     }
3788
3789     SETTARG;
3790     return NORMAL;
3791 }
3792
3793 PP(pp_crypt)
3794 {
3795 #ifdef HAS_CRYPT
3796     dSP; dTARGET;
3797     dPOPTOPssrl;
3798     STRLEN len;
3799     const char *tmps = SvPV_const(left, len);
3800
3801     if (DO_UTF8(left)) {
3802          /* If Unicode, try to downgrade.
3803           * If not possible, croak.
3804           * Yes, we made this up.  */
3805          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3806
3807          sv_utf8_downgrade(tsv, FALSE);
3808          tmps = SvPV_const(tsv, len);
3809     }
3810 #   ifdef USE_ITHREADS
3811 #     ifdef HAS_CRYPT_R
3812     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3813       /* This should be threadsafe because in ithreads there is only
3814        * one thread per interpreter.  If this would not be true,
3815        * we would need a mutex to protect this malloc. */
3816         PL_reentrant_buffer->_crypt_struct_buffer =
3817           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3818 #if defined(__GLIBC__) || defined(__EMX__)
3819         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3820             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3821             /* work around glibc-2.2.5 bug */
3822             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3823         }
3824 #endif
3825     }
3826 #     endif /* HAS_CRYPT_R */
3827 #   endif /* USE_ITHREADS */
3828 #   ifdef FCRYPT
3829     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3830 #   else
3831     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3832 #   endif
3833     SvUTF8_off(TARG);
3834     SETTARG;
3835     RETURN;
3836 #else
3837     DIE(aTHX_
3838       "The crypt() function is unimplemented due to excessive paranoia.");
3839 #endif
3840 }
3841
3842 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So 
3843  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3844
3845
3846 /* also used for: pp_lcfirst() */
3847
3848 PP(pp_ucfirst)
3849 {
3850     /* Actually is both lcfirst() and ucfirst().  Only the first character
3851      * changes.  This means that possibly we can change in-place, ie., just
3852      * take the source and change that one character and store it back, but not
3853      * if read-only etc, or if the length changes */
3854
3855     dSP;
3856     SV *source = TOPs;
3857     STRLEN slen; /* slen is the byte length of the whole SV. */
3858     STRLEN need;
3859     SV *dest;
3860     bool inplace;   /* ? Convert first char only, in-place */
3861     bool doing_utf8 = FALSE;               /* ? using utf8 */
3862     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3863     const int op_type = PL_op->op_type;
3864     const U8 *s;
3865     U8 *d;
3866     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3867     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3868                      * stored as UTF-8 at s. */
3869     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3870                      * lowercased) character stored in tmpbuf.  May be either
3871                      * UTF-8 or not, but in either case is the number of bytes */
3872
3873     s = (const U8*)SvPV_const(source, slen);
3874
3875     /* We may be able to get away with changing only the first character, in
3876      * place, but not if read-only, etc.  Later we may discover more reasons to
3877      * not convert in-place. */
3878     inplace = !SvREADONLY(source) && SvPADTMP(source);
3879
3880     /* First calculate what the changed first character should be.  This affects
3881      * whether we can just swap it out, leaving the rest of the string unchanged,
3882      * or even if have to convert the dest to UTF-8 when the source isn't */
3883
3884     if (! slen) {   /* If empty */
3885         need = 1; /* still need a trailing NUL */
3886         ulen = 0;
3887     }
3888     else if (DO_UTF8(source)) { /* Is the source utf8? */
3889         doing_utf8 = TRUE;
3890         ulen = UTF8SKIP(s);
3891         if (op_type == OP_UCFIRST) {
3892 #ifdef USE_LOCALE_CTYPE
3893             _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3894 #else
3895             _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3896 #endif
3897         }
3898         else {
3899 #ifdef USE_LOCALE_CTYPE
3900             _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3901 #else
3902             _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3903 #endif
3904         }
3905
3906         /* we can't do in-place if the length changes.  */
3907         if (ulen != tculen) inplace = FALSE;
3908         need = slen + 1 - ulen + tculen;
3909     }
3910     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3911             * latin1 is treated as caseless.  Note that a locale takes
3912             * precedence */ 
3913         ulen = 1;       /* Original character is 1 byte */
3914         tculen = 1;     /* Most characters will require one byte, but this will
3915                          * need to be overridden for the tricky ones */
3916         need = slen + 1;
3917
3918         if (op_type == OP_LCFIRST) {
3919
3920             /* lower case the first letter: no trickiness for any character */
3921 #ifdef USE_LOCALE_CTYPE
3922             if (IN_LC_RUNTIME(LC_CTYPE)) {
3923                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3924                 *tmpbuf = toLOWER_LC(*s);
3925             }
3926             else
3927 #endif
3928             {
3929                 *tmpbuf = (IN_UNI_8_BIT)
3930                           ? toLOWER_LATIN1(*s)
3931                           : toLOWER(*s);
3932             }
3933         }
3934 #ifdef USE_LOCALE_CTYPE
3935         /* is ucfirst() */
3936         else if (IN_LC_RUNTIME(LC_CTYPE)) {
3937             if (IN_UTF8_CTYPE_LOCALE) {
3938                 goto do_uni_rules;
3939             }
3940
3941             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3942             *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3943                                               locales have upper and title case
3944                                               different */
3945         }
3946 #endif
3947         else if (! IN_UNI_8_BIT) {
3948             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3949                                          * on EBCDIC machines whatever the
3950                                          * native function does */
3951         }
3952         else {
3953             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3954              * UTF-8, which we treat as not in locale), and cased latin1 */
3955             UV title_ord;
3956 #ifdef USE_LOCALE_CTYPE
3957       do_uni_rules:
3958 #endif
3959
3960             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3961             if (tculen > 1) {
3962                 assert(tculen == 2);
3963
3964                 /* If the result is an upper Latin1-range character, it can
3965                  * still be represented in one byte, which is its ordinal */
3966                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3967                     *tmpbuf = (U8) title_ord;
3968                     tculen = 1;
3969                 }
3970                 else {
3971                     /* Otherwise it became more than one ASCII character (in
3972                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3973                      * beyond Latin1, so the number of bytes changed, so can't
3974                      * replace just the first character in place. */
3975                     inplace = FALSE;
3976
3977                     /* If the result won't fit in a byte, the entire result
3978                      * will have to be in UTF-8.  Assume worst case sizing in
3979                      * conversion. (all latin1 characters occupy at most two
3980                      * bytes in utf8) */
3981                     if (title_ord > 255) {
3982                         doing_utf8 = TRUE;
3983                         convert_source_to_utf8 = TRUE;
3984                         need = slen * 2 + 1;
3985
3986                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3987                          * (both) characters whose title case is above 255 is
3988                          * 2. */
3989                         ulen = 2;
3990                     }
3991                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3992                         need = slen + 1 + 1;
3993                     }
3994                 }
3995             }
3996         } /* End of use Unicode (Latin1) semantics */
3997     } /* End of changing the case of the first character */
3998
3999     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
4000      * generate the result */
4001     if (inplace) {
4002
4003         /* We can convert in place.  This means we change just the first
4004          * character without disturbing the rest; no need to grow */
4005         dest = source;
4006         s = d = (U8*)SvPV_force_nomg(source, slen);
4007     } else {
4008         dTARGET;
4009
4010         dest = TARG;
4011
4012         /* Here, we can't convert in place; we earlier calculated how much
4013          * space we will need, so grow to accommodate that */
4014         SvUPGRADE(dest, SVt_PV);
4015         d = (U8*)SvGROW(dest, need);
4016         (void)SvPOK_only(dest);
4017
4018         SETs(dest);
4019     }
4020
4021     if (doing_utf8) {
4022         if (! inplace) {
4023             if (! convert_source_to_utf8) {
4024
4025                 /* Here  both source and dest are in UTF-8, but have to create
4026                  * the entire output.  We initialize the result to be the
4027                  * title/lower cased first character, and then append the rest
4028                  * of the string. */
4029                 sv_setpvn(dest, (char*)tmpbuf, tculen);
4030                 if (slen > ulen) {
4031                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
4032                 }
4033             }
4034             else {
4035                 const U8 *const send = s + slen;
4036
4037                 /* Here the dest needs to be in UTF-8, but the source isn't,
4038                  * except we earlier UTF-8'd the first character of the source
4039                  * into tmpbuf.  First put that into dest, and then append the
4040                  * rest of the source, converting it to UTF-8 as we go. */
4041
4042                 /* Assert tculen is 2 here because the only two characters that
4043                  * get to this part of the code have 2-byte UTF-8 equivalents */
4044                 *d++ = *tmpbuf;
4045                 *d++ = *(tmpbuf + 1);
4046                 s++;    /* We have just processed the 1st char */
4047
4048                 for (; s < send; s++) {
4049                     d = uvchr_to_utf8(d, *s);
4050                 }
4051                 *d = '\0';
4052                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4053             }
4054             SvUTF8_on(dest);
4055         }
4056         else {   /* in-place UTF-8.  Just overwrite the first character */
4057             Copy(tmpbuf, d, tculen, U8);
4058             SvCUR_set(dest, need - 1);
4059         }
4060
4061     }
4062     else {  /* Neither source nor dest are in or need to be UTF-8 */
4063         if (slen) {
4064             if (inplace) {  /* in-place, only need to change the 1st char */
4065                 *d = *tmpbuf;
4066             }
4067             else {      /* Not in-place */
4068
4069                 /* Copy the case-changed character(s) from tmpbuf */
4070                 Copy(tmpbuf, d, tculen, U8);
4071                 d += tculen - 1; /* Code below expects d to point to final
4072                                   * character stored */
4073             }
4074         }
4075         else {  /* empty source */
4076             /* See bug #39028: Don't taint if empty  */
4077             *d = *s;
4078         }
4079
4080         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4081          * the destination to retain that flag */
4082         if (SvUTF8(source) && ! IN_BYTES)
4083             SvUTF8_on(dest);
4084
4085         if (!inplace) { /* Finish the rest of the string, unchanged */
4086             /* This will copy the trailing NUL  */
4087             Copy(s + 1, d + 1, slen, U8);
4088             SvCUR_set(dest, need - 1);
4089         }
4090     }
4091 #ifdef USE_LOCALE_CTYPE
4092     if (IN_LC_RUNTIME(LC_CTYPE)) {
4093         TAINT;
4094         SvTAINTED_on(dest);
4095     }
4096 #endif
4097     if (dest != source && SvTAINTED(source))
4098         SvTAINT(dest);
4099     SvSETMAGIC(dest);
4100     return NORMAL;
4101 }
4102
4103 /* There's so much setup/teardown code common between uc and lc, I wonder if
4104    it would be worth merging the two, and just having a switch outside each
4105    of the three tight loops.  There is less and less commonality though */
4106 PP(pp_uc)
4107 {
4108     dSP;
4109     SV *source = TOPs;
4110     STRLEN len;
4111     STRLEN min;
4112     SV *dest;
4113     const U8 *s;
4114     U8 *d;
4115
4116     SvGETMAGIC(source);
4117
4118     if (   SvPADTMP(source)
4119         && !SvREADONLY(source) && SvPOK(source)
4120         && !DO_UTF8(source)
4121         && (
4122 #ifdef USE_LOCALE_CTYPE
4123             (IN_LC_RUNTIME(LC_CTYPE))
4124             ? ! IN_UTF8_CTYPE_LOCALE
4125             :
4126 #endif
4127               ! IN_UNI_8_BIT))
4128     {
4129
4130         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4131          * make the loop tight, so we overwrite the source with the dest before
4132          * looking at it, and we need to look at the original source
4133          * afterwards.  There would also need to be code added to handle
4134          * switching to not in-place in midstream if we run into characters
4135          * that change the length.  Since being in locale overrides UNI_8_BIT,
4136          * that latter becomes irrelevant in the above test; instead for
4137          * locale, the size can't normally change, except if the locale is a
4138          * UTF-8 one */
4139         dest = source;
4140         s = d = (U8*)SvPV_force_nomg(source, len);
4141         min = len + 1;
4142     } else {
4143         dTARGET;
4144
4145         dest = TARG;
4146
4147         s = (const U8*)SvPV_nomg_const(source, len);
4148         min = len + 1;
4149
4150         SvUPGRADE(dest, SVt_PV);
4151         d = (U8*)SvGROW(dest, min);
4152         (void)SvPOK_only(dest);
4153
4154         SETs(dest);
4155     }
4156
4157     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4158        to check DO_UTF8 again here.  */
4159
4160     if (DO_UTF8(source)) {
4161         const U8 *const send = s + len;
4162         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4163
4164         /* All occurrences of these are to be moved to follow any other marks.
4165          * This is context-dependent.  We may not be passed enough context to
4166          * move the iota subscript beyond all of them, but we do the best we can
4167          * with what we're given.  The result is always better than if we
4168          * hadn't done this.  And, the problem would only arise if we are
4169          * passed a character without all its combining marks, which would be
4170          * the caller's mistake.  The information this is based on comes from a
4171          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4172          * itself) and so can't be checked properly to see if it ever gets
4173          * revised.  But the likelihood of it changing is remote */
4174         bool in_iota_subscript = FALSE;
4175
4176         while (s < send) {
4177             STRLEN u;
4178             STRLEN ulen;
4179             UV uv;
4180             if (in_iota_subscript && ! _is_utf8_mark(s)) {
4181
4182                 /* A non-mark.  Time to output the iota subscript */
4183                 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4184                 d += capital_iota_len;
4185                 in_iota_subscript = FALSE;
4186             }
4187
4188             /* Then handle the current character.  Get the changed case value
4189              * and copy it to the output buffer */
4190
4191             u = UTF8SKIP(s);
4192 #ifdef USE_LOCALE_CTYPE
4193             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4194 #else
4195             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
4196 #endif
4197 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4198 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4199             if (uv == GREEK_CAPITAL_LETTER_IOTA
4200                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4201             {
4202                 in_iota_subscript = TRUE;
4203             }
4204             else {
4205                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4206                     /* If the eventually required minimum size outgrows the
4207                      * available space, we need to grow. */
4208                     const UV o = d - (U8*)SvPVX_const(dest);
4209
4210                     /* If someone uppercases one million U+03B0s we SvGROW()
4211                      * one million times.  Or we could try guessing how much to
4212                      * allocate without allocating too much.  Such is life.
4213                      * See corresponding comment in lc code for another option
4214                      * */
4215                     SvGROW(dest, min);
4216                     d = (U8*)SvPVX(dest) + o;
4217                 }
4218                 Copy(tmpbuf, d, ulen, U8);
4219                 d += ulen;
4220             }
4221             s += u;
4222         }
4223         if (in_iota_subscript) {
4224             Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4225             d += capital_iota_len;
4226         }
4227         SvUTF8_on(dest);
4228         *d = '\0';
4229
4230         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4231     }
4232     else {      /* Not UTF-8 */
4233         if (len) {
4234             const U8 *const send = s + len;
4235
4236             /* Use locale casing if in locale; regular style if not treating
4237              * latin1 as having case; otherwise the latin1 casing.  Do the
4238              * whole thing in a tight loop, for speed, */
4239 #ifdef USE_LOCALE_CTYPE
4240             if (IN_LC_RUNTIME(LC_CTYPE)) {
4241                 if (IN_UTF8_CTYPE_LOCALE) {
4242                     goto do_uni_rules;
4243                 }
4244                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4245                 for (; s < send; d++, s++)
4246                     *d = (U8) toUPPER_LC(*s);
4247             }
4248             else
4249 #endif
4250                  if (! IN_UNI_8_BIT) {
4251                 for (; s < send; d++, s++) {
4252                     *d = toUPPER(*s);
4253                 }
4254             }
4255             else {
4256 #ifdef USE_LOCALE_CTYPE
4257           do_uni_rules:
4258 #endif
4259                 for (; s < send; d++, s++) {
4260                     *d = toUPPER_LATIN1_MOD(*s);
4261                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4262                         continue;
4263                     }
4264
4265                     /* The mainstream case is the tight loop above.  To avoid
4266                      * extra tests in that, all three characters that require
4267                      * special handling are mapped by the MOD to the one tested
4268                      * just above.  
4269                      * Use the source to distinguish between the three cases */
4270
4271 #if    UNICODE_MAJOR_VERSION > 2                                        \
4272    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4273                                   && UNICODE_DOT_DOT_VERSION >= 8)
4274                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4275
4276                         /* uc() of this requires 2 characters, but they are
4277                          * ASCII.  If not enough room, grow the string */
4278                         if (SvLEN(dest) < ++min) {      
4279                             const UV o = d - (U8*)SvPVX_const(dest);
4280                             SvGROW(dest, min);
4281                             d = (U8*)SvPVX(dest) + o;
4282                         }
4283                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4284                         continue;   /* Back to the tight loop; still in ASCII */
4285                     }
4286 #endif
4287
4288                     /* The other two special handling characters have their
4289                      * upper cases outside the latin1 range, hence need to be
4290                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4291                      * here we are somewhere in the middle of processing a
4292                      * non-UTF-8 string, and realize that we will have to convert
4293                      * the whole thing to UTF-8.  What to do?  There are
4294                      * several possibilities.  The simplest to code is to
4295                      * convert what we have so far, set a flag, and continue on
4296                      * in the loop.  The flag would be tested each time through
4297                      * the loop, and if set, the next character would be
4298                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4299                      * to slow down the mainstream case at all for this fairly
4300                      * rare case, so I didn't want to add a test that didn't
4301                      * absolutely have to be there in the loop, besides the
4302                      * possibility that it would get too complicated for
4303                      * optimizers to deal with.  Another possibility is to just
4304                      * give up, convert the source to UTF-8, and restart the
4305                      * function that way.  Another possibility is to convert
4306                      * both what has already been processed and what is yet to
4307                      * come separately to UTF-8, then jump into the loop that
4308                      * handles UTF-8.  But the most efficient time-wise of the
4309                      * ones I could think of is what follows, and turned out to
4310                      * not require much extra code.  */
4311
4312                     /* Convert what we have so far into UTF-8, telling the
4313                      * function that we know it should be converted, and to
4314                      * allow extra space for what we haven't processed yet.
4315                      * Assume the worst case space requirements for converting
4316                      * what we haven't processed so far: that it will require
4317                      * two bytes for each remaining source character, plus the
4318                      * NUL at the end.  This may cause the string pointer to
4319                      * move, so re-find it. */
4320
4321                     len = d - (U8*)SvPVX_const(dest);
4322                     SvCUR_set(dest, len);
4323                     len = sv_utf8_upgrade_flags_grow(dest,
4324                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4325                                                 (send -s) * 2 + 1);
4326                     d = (U8*)SvPVX(dest) + len;
4327
4328                     /* Now process the remainder of the source, converting to
4329                      * upper and UTF-8.  If a resulting byte is invariant in
4330                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4331                      * append it to the output. */
4332                     for (; s < send; s++) {
4333                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
4334                         d += len;
4335                     }
4336
4337                     /* Here have processed the whole source; no need to continue
4338                      * with the outer loop.  Each character has been converted
4339                      * to upper case and converted to UTF-8 */
4340
4341                     break;
4342                 } /* End of processing all latin1-style chars */
4343             } /* End of processing all chars */
4344         } /* End of source is not empty */
4345
4346         if (source != dest) {
4347             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4348             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4349         }
4350     } /* End of isn't utf8 */
4351 #ifdef USE_LOCALE_CTYPE
4352     if (IN_LC_RUNTIME(LC_CTYPE)) {
4353         TAINT;
4354         SvTAINTED_on(dest);
4355     }
4356 #endif
4357     if (dest != source && SvTAINTED(source))
4358         SvTAINT(dest);
4359     SvSETMAGIC(dest);
4360     return NORMAL;
4361 }
4362
4363 PP(pp_lc)
4364 {
4365     dSP;
4366     SV *source = TOPs;
4367     STRLEN len;
4368     STRLEN min;
4369     SV *dest;
4370     const U8 *s;
4371     U8 *d;
4372
4373     SvGETMAGIC(source);
4374
4375     if (   SvPADTMP(source)
4376         && !SvREADONLY(source) && SvPOK(source)
4377         && !DO_UTF8(source)) {
4378
4379         /* We can convert in place, as lowercasing anything in the latin1 range
4380          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4381         dest = source;
4382         s = d = (U8*)SvPV_force_nomg(source, len);
4383         min = len + 1;
4384     } else {
4385         dTARGET;
4386
4387         dest = TARG;
4388
4389         s = (const U8*)SvPV_nomg_const(source, len);
4390         min = len + 1;
4391
4392         SvUPGRADE(dest, SVt_PV);
4393         d = (U8*)SvGROW(dest, min);
4394         (void)SvPOK_only(dest);
4395
4396         SETs(dest);
4397     }
4398
4399     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4400        to check DO_UTF8 again here.  */
4401
4402     if (DO_UTF8(source)) {
4403         const U8 *const send = s + len;
4404         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4405
4406         while (s < send) {
4407             const STRLEN u = UTF8SKIP(s);
4408             STRLEN ulen;
4409
4410 #ifdef USE_LOCALE_CTYPE
4411             _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4412 #else
4413             _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4414 #endif
4415
4416             /* Here is where we would do context-sensitive actions.  See the
4417              * commit message for 86510fb15 for why there isn't any */
4418
4419             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4420
4421                 /* If the eventually required minimum size outgrows the
4422                  * available space, we need to grow. */
4423                 const UV o = d - (U8*)SvPVX_const(dest);
4424
4425                 /* If someone lowercases one million U+0130s we SvGROW() one
4426                  * million times.  Or we could try guessing how much to
4427                  * allocate without allocating too much.  Such is life.
4428                  * Another option would be to grow an extra byte or two more
4429                  * each time we need to grow, which would cut down the million
4430                  * to 500K, with little waste */
4431                 SvGROW(dest, min);
4432                 d = (U8*)SvPVX(dest) + o;
4433             }
4434
4435             /* Copy the newly lowercased letter to the output buffer we're
4436              * building */
4437             Copy(tmpbuf, d, ulen, U8);
4438             d += ulen;
4439             s += u;
4440         }   /* End of looping through the source string */
4441         SvUTF8_on(dest);
4442         *d = '\0';
4443         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4444     } else {    /* Not utf8 */
4445         if (len) {
4446             const U8 *const send = s + len;
4447
4448             /* Use locale casing if in locale; regular style if not treating
4449              * latin1 as having case; otherwise the latin1 casing.  Do the
4450              * whole thing in a tight loop, for speed, */
4451 #ifdef USE_LOCALE_CTYPE
4452             if (IN_LC_RUNTIME(LC_CTYPE)) {
4453                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4454                 for (; s < send; d++, s++)
4455                     *d = toLOWER_LC(*s);
4456             }
4457             else
4458 #endif
4459             if (! IN_UNI_8_BIT) {
4460                 for (; s < send; d++, s++) {
4461                     *d = toLOWER(*s);
4462                 }
4463             }
4464             else {
4465                 for (; s < send; d++, s++) {
4466                     *d = toLOWER_LATIN1(*s);
4467                 }
4468             }
4469         }
4470         if (source != dest) {
4471             *d = '\0';
4472             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4473         }
4474     }
4475 #ifdef USE_LOCALE_CTYPE
4476     if (IN_LC_RUNTIME(LC_CTYPE)) {
4477         TAINT;
4478         SvTAINTED_on(dest);
4479     }
4480 #endif
4481     if (dest != source && SvTAINTED(source))
4482         SvTAINT(dest);
4483     SvSETMAGIC(dest);
4484     return NORMAL;
4485 }
4486
4487 PP(pp_quotemeta)
4488 {
4489     dSP; dTARGET;
4490     SV * const sv = TOPs;
4491     STRLEN len;
4492     const char *s = SvPV_const(sv,len);
4493
4494     SvUTF8_off(TARG);                           /* decontaminate */
4495     if (len) {
4496         char *d;
4497         SvUPGRADE(TARG, SVt_PV);
4498         SvGROW(TARG, (len * 2) + 1);
4499         d = SvPVX(TARG);
4500         if (DO_UTF8(sv)) {
4501             while (len) {
4502                 STRLEN ulen = UTF8SKIP(s);
4503                 bool to_quote = FALSE;
4504
4505                 if (UTF8_IS_INVARIANT(*s)) {
4506                     if (_isQUOTEMETA(*s)) {
4507                         to_quote = TRUE;
4508                     }
4509                 }
4510                 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4511                     if (
4512 #ifdef USE_LOCALE_CTYPE
4513                     /* In locale, we quote all non-ASCII Latin1 chars.
4514                      * Otherwise use the quoting rules */
4515                     
4516                     IN_LC_RUNTIME(LC_CTYPE)
4517                         ||
4518 #endif
4519                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4520                     {
4521                         to_quote = TRUE;
4522                     }
4523                 }
4524                 else if (is_QUOTEMETA_high(s)) {
4525                     to_quote = TRUE;
4526                 }
4527
4528                 if (to_quote) {
4529                     *d++ = '\\';
4530                 }
4531                 if (ulen > len)
4532                     ulen = len;
4533                 len -= ulen;
4534                 while (ulen--)
4535                     *d++ = *s++;
4536             }
4537             SvUTF8_on(TARG);
4538         }
4539         else if (IN_UNI_8_BIT) {
4540             while (len--) {
4541                 if (_isQUOTEMETA(*s))
4542                     *d++ = '\\';
4543                 *d++ = *s++;
4544             }
4545         }
4546         else {
4547             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4548              * including everything above ASCII */
4549             while (len--) {
4550                 if (!isWORDCHAR_A(*s))
4551                     *d++ = '\\';
4552                 *d++ = *s++;
4553             }
4554         }
4555         *d = '\0';
4556         SvCUR_set(TARG, d - SvPVX_const(TARG));
4557         (void)SvPOK_only_UTF8(TARG);
4558     }
4559     else
4560         sv_setpvn(TARG, s, len);
4561     SETTARG;
4562     return NORMAL;
4563 }
4564
4565 PP(pp_fc)
4566 {
4567     dTARGET;
4568     dSP;
4569     SV *source = TOPs;
4570     STRLEN len;
4571     STRLEN min;
4572     SV *dest;
4573     const U8 *s;
4574     const U8 *send;
4575     U8 *d;
4576     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4577 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4578    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4579                                       || UNICODE_DOT_DOT_VERSION > 0)
4580     const bool full_folding = TRUE; /* This variable is here so we can easily
4581                                        move to more generality later */
4582 #else
4583     const bool full_folding = FALSE;
4584 #endif
4585     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4586 #ifdef USE_LOCALE_CTYPE
4587                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4588 #endif
4589     ;
4590
4591     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4592      * You are welcome(?) -Hugmeir
4593      */
4594
4595     SvGETMAGIC(source);
4596
4597     dest = TARG;
4598
4599     if (SvOK(source)) {
4600         s = (const U8*)SvPV_nomg_const(source, len);
4601     } else {
4602         if (ckWARN(WARN_UNINITIALIZED))
4603             report_uninit(source);
4604         s = (const U8*)"";
4605         len = 0;
4606     }
4607
4608     min = len + 1;
4609
4610     SvUPGRADE(dest, SVt_PV);
4611     d = (U8*)SvGROW(dest, min);
4612     (void)SvPOK_only(dest);
4613
4614     SETs(dest);
4615
4616     send = s + len;
4617     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4618         while (s < send) {
4619             const STRLEN u = UTF8SKIP(s);
4620             STRLEN ulen;
4621
4622             _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4623
4624             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4625                 const UV o = d - (U8*)SvPVX_const(dest);
4626                 SvGROW(dest, min);
4627                 d = (U8*)SvPVX(dest) + o;
4628             }
4629
4630             Copy(tmpbuf, d, ulen, U8);
4631             d += ulen;
4632             s += u;
4633         }
4634         SvUTF8_on(dest);
4635     } /* Unflagged string */
4636     else if (len) {
4637 #ifdef USE_LOCALE_CTYPE
4638         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4639             if (IN_UTF8_CTYPE_LOCALE) {
4640                 goto do_uni_folding;
4641             }
4642             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4643             for (; s < send; d++, s++)
4644                 *d = (U8) toFOLD_LC(*s);
4645         }
4646         else
4647 #endif
4648         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4649             for (; s < send; d++, s++)
4650                 *d = toFOLD(*s);
4651         }
4652         else {
4653 #ifdef USE_LOCALE_CTYPE
4654       do_uni_folding:
4655 #endif
4656             /* For ASCII and the Latin-1 range, there's only two troublesome
4657              * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4658              * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4659              * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4660              * For the rest, the casefold is their lowercase.  */
4661             for (; s < send; d++, s++) {
4662                 if (*s == MICRO_SIGN) {
4663                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4664                      * which is outside of the latin-1 range. There's a couple
4665                      * of ways to deal with this -- khw discusses them in
4666                      * pp_lc/uc, so go there :) What we do here is upgrade what
4667                      * we had already casefolded, then enter an inner loop that
4668                      * appends the rest of the characters as UTF-8. */
4669                     len = d - (U8*)SvPVX_const(dest);
4670                     SvCUR_set(dest, len);
4671                     len = sv_utf8_upgrade_flags_grow(dest,
4672                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4673                                                 /* The max expansion for latin1
4674                                                  * chars is 1 byte becomes 2 */
4675                                                 (send -s) * 2 + 1);
4676                     d = (U8*)SvPVX(dest) + len;
4677
4678                     Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4679                     d += small_mu_len;
4680                     s++;
4681                     for (; s < send; s++) {
4682                         STRLEN ulen;
4683                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4684                         if UVCHR_IS_INVARIANT(fc) {
4685                             if (full_folding
4686                                 && *s == LATIN_SMALL_LETTER_SHARP_S)
4687                             {
4688                                 *d++ = 's';
4689                                 *d++ = 's';
4690                             }
4691                             else
4692                                 *d++ = (U8)fc;
4693                         }
4694                         else {
4695                             Copy(tmpbuf, d, ulen, U8);
4696                             d += ulen;
4697                         }
4698                     }
4699                     break;
4700                 }
4701                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4702                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4703                      * becomes "ss", which may require growing the SV. */
4704                     if (SvLEN(dest) < ++min) {
4705                         const UV o = d - (U8*)SvPVX_const(dest);
4706                         SvGROW(dest, min);
4707                         d = (U8*)SvPVX(dest) + o;
4708                      }
4709                     *(d)++ = 's';
4710                     *d = 's';
4711                 }
4712                 else { /* If it's not one of those two, the fold is their lower
4713                           case */
4714                     *d = toLOWER_LATIN1(*s);
4715                 }
4716              }
4717         }
4718     }
4719     *d = '\0';
4720     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4721
4722 #ifdef USE_LOCALE_CTYPE
4723     if (IN_LC_RUNTIME(LC_CTYPE)) {
4724         TAINT;
4725         SvTAINTED_on(dest);
4726     }
4727 #endif
4728     if (SvTAINTED(source))
4729         SvTAINT(dest);
4730     SvSETMAGIC(dest);
4731     RETURN;
4732 }
4733
4734 /* Arrays. */
4735
4736 PP(pp_aslice)
4737 {
4738     dSP; dMARK; dORIGMARK;
4739     AV *const av = MUTABLE_AV(POPs);
4740     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4741
4742     if (SvTYPE(av) == SVt_PVAV) {
4743         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4744         bool can_preserve = FALSE;
4745
4746         if (localizing) {
4747             MAGIC *mg;
4748             HV *stash;
4749
4750             can_preserve = SvCANEXISTDELETE(av);
4751         }
4752
4753         if (lval && localizing) {
4754             SV **svp;
4755             SSize_t max = -1;
4756             for (svp = MARK + 1; svp <= SP; svp++) {
4757                 const SSize_t elem = SvIV(*svp);
4758                 if (elem > max)
4759                     max = elem;
4760             }
4761             if (max > AvMAX(av))
4762                 av_extend(av, max);
4763         }
4764
4765         while (++MARK <= SP) {
4766             SV **svp;
4767             SSize_t elem = SvIV(*MARK);
4768             bool preeminent = TRUE;
4769
4770             if (localizing && can_preserve) {
4771                 /* If we can determine whether the element exist,
4772                  * Try to preserve the existenceness of a tied array
4773                  * element by using EXISTS and DELETE if possible.
4774                  * Fallback to FETCH and STORE otherwise. */
4775                 preeminent = av_exists(av, elem);
4776             }
4777
4778             svp = av_fetch(av, elem, lval);
4779             if (lval) {
4780                 if (!svp || !*svp)
4781                     DIE(aTHX_ PL_no_aelem, elem);
4782                 if (localizing) {
4783                     if (preeminent)
4784                         save_aelem(av, elem, svp);
4785                     else
4786                         SAVEADELETE(av, elem);
4787                 }
4788             }
4789             *MARK = svp ? *svp : &PL_sv_undef;
4790         }
4791     }
4792     if (GIMME_V != G_ARRAY) {
4793         MARK = ORIGMARK;
4794         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4795         SP = MARK;
4796     }
4797     RETURN;
4798 }
4799
4800 PP(pp_kvaslice)
4801 {
4802     dSP; dMARK;
4803     AV *const av = MUTABLE_AV(POPs);
4804     I32 lval = (PL_op->op_flags & OPf_MOD);
4805     SSize_t items = SP - MARK;
4806
4807     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4808        const I32 flags = is_lvalue_sub();
4809        if (flags) {
4810            if (!(flags & OPpENTERSUB_INARGS))
4811                /* diag_listed_as: Can't modify %s in %s */
4812                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4813            lval = flags;
4814        }
4815     }
4816
4817     MEXTEND(SP,items);
4818     while (items > 1) {
4819         *(MARK+items*2-1) = *(MARK+items);
4820         items--;
4821     }
4822     items = SP-MARK;
4823     SP += items;
4824
4825     while (++MARK <= SP) {
4826         SV **svp;
4827
4828         svp = av_fetch(av, SvIV(*MARK), lval);
4829         if (lval) {
4830             if (!svp || !*svp || *svp == &PL_sv_undef) {
4831                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4832             }
4833             *MARK = sv_mortalcopy(*MARK);
4834         }
4835         *++MARK = svp ? *svp : &PL_sv_undef;
4836     }
4837     if (GIMME_V != G_ARRAY) {
4838         MARK = SP - items*2;
4839         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4840         SP = MARK;
4841     }
4842     RETURN;
4843 }
4844
4845
4846 PP(pp_aeach)
4847 {
4848     dSP;
4849     AV *array = MUTABLE_AV(POPs);
4850     const U8 gimme = GIMME_V;
4851     IV *iterp = Perl_av_iter_p(aTHX_ array);
4852     const IV current = (*iterp)++;
4853
4854     if (current > av_tindex(array)) {
4855         *iterp = 0;
4856         if (gimme == G_SCALAR)
4857             RETPUSHUNDEF;
4858         else
4859             RETURN;
4860     }
4861
4862     EXTEND(SP, 2);
4863     mPUSHi(current);
4864     if (gimme == G_ARRAY) {
4865         SV **const element = av_fetch(array, current, 0);
4866         PUSHs(element ? *element : &PL_sv_undef);
4867     }
4868     RETURN;
4869 }
4870
4871 /* also used for: pp_avalues()*/
4872 PP(pp_akeys)
4873 {
4874     dSP;
4875     AV *array = MUTABLE_AV(POPs);
4876     const U8 gimme = GIMME_V;
4877
4878     *Perl_av_iter_p(aTHX_ array) = 0;
4879
4880     if (gimme == G_SCALAR) {
4881         dTARGET;
4882         PUSHi(av_tindex(array) + 1);
4883     }
4884     else if (gimme == G_ARRAY) {
4885         IV n = Perl_av_len(aTHX_ array);
4886         IV i;
4887
4888         EXTEND(SP, n + 1);
4889
4890         if (PL_op->op_type == OP_AKEYS) {
4891             for (i = 0;  i <= n;  i++) {
4892                 mPUSHi(i);
4893             }
4894         }
4895         else {
4896             for (i = 0;  i <= n;  i++) {
4897                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4898                 PUSHs(elem ? *elem : &PL_sv_undef);
4899             }
4900         }
4901     }
4902     RETURN;
4903 }
4904
4905 /* Associative arrays. */
4906
4907 PP(pp_each)
4908 {
4909     dSP;
4910     HV * hash = MUTABLE_HV(POPs);
4911     HE *entry;
4912     const U8 gimme = GIMME_V;
4913
4914     entry = hv_iternext(hash);
4915
4916     EXTEND(SP, 2);
4917     if (entry) {
4918         SV* const sv = hv_iterkeysv(entry);
4919         PUSHs(sv);
4920         if (gimme == G_ARRAY) {
4921             SV *val;
4922             val = hv_iterval(hash, entry);
4923             PUSHs(val);
4924         }
4925     }
4926     else if (gimme == G_SCALAR)
4927         RETPUSHUNDEF;
4928
4929     RETURN;
4930 }
4931
4932 STATIC OP *
4933 S_do_delete_local(pTHX)
4934 {
4935     dSP;
4936     const U8 gimme = GIMME_V;
4937     const MAGIC *mg;
4938     HV *stash;
4939     const bool sliced = !!(PL_op->op_private & OPpSLICE);
4940     SV **unsliced_keysv = sliced ? NULL : sp--;
4941     SV * const osv = POPs;
4942     SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4943     dORIGMARK;
4944     const bool tied = SvRMAGICAL(osv)
4945                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4946     const bool can_preserve = SvCANEXISTDELETE(osv);
4947     const U32 type = SvTYPE(osv);
4948     SV ** const end = sliced ? SP : unsliced_keysv;
4949
4950     if (type == SVt_PVHV) {                     /* hash element */
4951             HV * const hv = MUTABLE_HV(osv);
4952             while (++MARK <= end) {
4953                 SV * const keysv = *MARK;
4954                 SV *sv = NULL;
4955                 bool preeminent = TRUE;
4956                 if (can_preserve)
4957                     preeminent = hv_exists_ent(hv, keysv, 0);
4958                 if (tied) {
4959                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4960                     if (he)
4961                         sv = HeVAL(he);
4962                     else
4963                         preeminent = FALSE;
4964                 }
4965                 else {
4966                     sv = hv_delete_ent(hv, keysv, 0, 0);
4967                     if (preeminent)
4968                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4969                 }
4970                 if (preeminent) {
4971                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4972                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4973                     if (tied) {
4974                         *MARK = sv_mortalcopy(sv);
4975                         mg_clear(sv);
4976                     } else
4977                         *MARK = sv;
4978                 }
4979                 else {
4980                     SAVEHDELETE(hv, keysv);
4981                     *MARK = &PL_sv_undef;
4982                 }
4983             }
4984     }
4985     else if (type == SVt_PVAV) {                  /* array element */
4986             if (PL_op->op_flags & OPf_SPECIAL) {
4987                 AV * const av = MUTABLE_AV(osv);
4988                 while (++MARK <= end) {
4989                     SSize_t idx = SvIV(*MARK);
4990                     SV *sv = NULL;
4991                     bool preeminent = TRUE;
4992                     if (can_preserve)
4993                         preeminent = av_exists(av, idx);
4994                     if (tied) {
4995                         SV **svp = av_fetch(av, idx, 1);
4996                         if (svp)
4997                             sv = *svp;
4998                         else
4999                             preeminent = FALSE;
5000                     }
5001                     else {
5002                         sv = av_delete(av, idx, 0);
5003                         if (preeminent)
5004                            SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5005                     }
5006                     if (preeminent) {
5007                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5008                         if (tied) {
5009                             *MARK = sv_mortalcopy(sv);
5010                             mg_clear(sv);
5011                         } else
5012                             *MARK = sv;
5013                     }
5014                     else {
5015                         SAVEADELETE(av, idx);
5016                         *MARK = &PL_sv_undef;
5017                     }
5018                 }
5019             }
5020             else
5021                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5022     }
5023     else
5024             DIE(aTHX_ "Not a HASH reference");
5025     if (sliced) {
5026         if (gimme == G_VOID)
5027             SP = ORIGMARK;
5028         else if (gimme == G_SCALAR) {
5029             MARK = ORIGMARK;
5030             if (SP > MARK)
5031                 *++MARK = *SP;
5032             else
5033                 *++MARK = &PL_sv_undef;
5034             SP = MARK;
5035         }
5036     }
5037     else if (gimme != G_VOID)
5038         PUSHs(*unsliced_keysv);
5039
5040     RETURN;
5041 }
5042
5043 PP(pp_delete)
5044 {
5045     dSP;
5046     U8 gimme;
5047     I32 discard;
5048
5049     if (PL_op->op_private & OPpLVAL_INTRO)
5050         return do_delete_local();
5051
5052     gimme = GIMME_V;
5053     discard = (gimme == G_VOID) ? G_DISCARD : 0;
5054
5055     if (PL_op->op_private & OPpSLICE) {
5056         dMARK; dORIGMARK;
5057         HV * const hv = MUTABLE_HV(POPs);
5058         const U32 hvtype = SvTYPE(hv);
5059         if (hvtype == SVt_PVHV) {                       /* hash element */
5060             while (++MARK <= SP) {
5061                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
5062                 *MARK = sv ? sv : &PL_sv_undef;
5063             }
5064         }
5065         else if (hvtype == SVt_PVAV) {                  /* array element */
5066             if (PL_op->op_flags & OPf_SPECIAL) {
5067                 while (++MARK <= SP) {
5068                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
5069                     *MARK = sv ? sv : &PL_sv_undef;
5070                 }
5071             }
5072         }
5073         else
5074             DIE(aTHX_ "Not a HASH reference");
5075         if (discard)
5076             SP = ORIGMARK;
5077         else if (gimme == G_SCALAR) {
5078             MARK = ORIGMARK;
5079             if (SP > MARK)
5080                 *++MARK = *SP;
5081             else
5082                 *++MARK = &PL_sv_undef;
5083             SP = MARK;
5084         }
5085     }
5086     else {
5087         SV *keysv = POPs;
5088         HV * const hv = MUTABLE_HV(POPs);
5089         SV *sv = NULL;
5090         if (SvTYPE(hv) == SVt_PVHV)
5091             sv = hv_delete_ent(hv, keysv, discard, 0);
5092         else if (SvTYPE(hv) == SVt_PVAV) {
5093             if (PL_op->op_flags & OPf_SPECIAL)
5094                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5095             else
5096                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5097         }
5098         else
5099             DIE(aTHX_ "Not a HASH reference");
5100         if (!sv)
5101             sv = &PL_sv_undef;
5102         if (!discard)
5103             PUSHs(sv);
5104     }
5105     RETURN;
5106 }
5107
5108 PP(pp_exists)
5109 {
5110     dSP;
5111     SV *tmpsv;
5112     HV *hv;
5113
5114     if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5115         GV *gv;
5116         SV * const sv = POPs;
5117         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5118         if (cv)
5119             RETPUSHYES;
5120         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5121             RETPUSHYES;
5122         RETPUSHNO;
5123     }
5124     tmpsv = POPs;
5125     hv = MUTABLE_HV(POPs);
5126     if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5127         if (hv_exists_ent(hv, tmpsv, 0))
5128             RETPUSHYES;
5129     }
5130     else if (SvTYPE(hv) == SVt_PVAV) {
5131         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
5132             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5133                 RETPUSHYES;
5134         }
5135     }
5136     else {
5137         DIE(aTHX_ "Not a HASH reference");
5138     }
5139     RETPUSHNO;
5140 }
5141
5142 PP(pp_hslice)
5143 {
5144     dSP; dMARK; dORIGMARK;
5145     HV * const hv = MUTABLE_HV(POPs);
5146     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5147     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5148     bool can_preserve = FALSE;
5149
5150     if (localizing) {
5151         MAGIC *mg;
5152         HV *stash;
5153
5154         if (SvCANEXISTDELETE(hv))
5155             can_preserve = TRUE;
5156     }
5157
5158     while (++MARK <= SP) {
5159         SV * const keysv = *MARK;
5160         SV **svp;
5161         HE *he;
5162         bool preeminent = TRUE;
5163
5164         if (localizing && can_preserve) {
5165             /* If we can determine whether the element exist,
5166              * try to preserve the existenceness of a tied hash
5167              * element by using EXISTS and DELETE if possible.
5168              * Fallback to FETCH and STORE otherwise. */
5169             preeminent = hv_exists_ent(hv, keysv, 0);
5170         }
5171
5172         he = hv_fetch_ent(hv, keysv, lval, 0);
5173         svp = he ? &HeVAL(he) : NULL;
5174
5175         if (lval) {
5176             if (!svp || !*svp || *svp == &PL_sv_undef) {
5177                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5178             }
5179             if (localizing) {
5180                 if (HvNAME_get(hv) && isGV(*svp))
5181                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5182                 else if (preeminent)
5183                     save_helem_flags(hv, keysv, svp,
5184                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5185                 else
5186                     SAVEHDELETE(hv, keysv);
5187             }
5188         }
5189         *MARK = svp && *svp ? *svp : &PL_sv_undef;
5190     }
5191     if (GIMME_V != G_ARRAY) {
5192         MARK = ORIGMARK;
5193         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5194         SP = MARK;
5195     }
5196     RETURN;
5197 }
5198
5199 PP(pp_kvhslice)
5200 {
5201     dSP; dMARK;
5202     HV * const hv = MUTABLE_HV(POPs);
5203     I32 lval = (PL_op->op_flags & OPf_MOD);
5204     SSize_t items = SP - MARK;
5205
5206     if (PL_op->op_private & OPpMAYBE_LVSUB) {
5207        const I32 flags = is_lvalue_sub();
5208        if (flags) {
5209            if (!(flags & OPpENTERSUB_INARGS))
5210                /* diag_listed_as: Can't modify %s in %s */
5211                Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
5212            lval = flags;
5213        }
5214     }
5215
5216     MEXTEND(SP,items);
5217     while (items > 1) {
5218         *(MARK+items*2-1) = *(MARK+items);
5219         items--;
5220     }
5221     items = SP-MARK;
5222     SP += items;
5223
5224     while (++MARK <= SP) {
5225         SV * const keysv = *MARK;
5226         SV **svp;
5227         HE *he;
5228
5229         he = hv_fetch_ent(hv, keysv, lval, 0);
5230         svp = he ? &HeVAL(he) : NULL;
5231
5232         if (lval) {
5233             if (!svp || !*svp || *svp == &PL_sv_undef) {
5234                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5235             }
5236             *MARK = sv_mortalcopy(*MARK);
5237         }
5238         *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5239     }
5240     if (GIMME_V != G_ARRAY) {
5241         MARK = SP - items*2;
5242         *++MARK = items > 0 ? *SP : &PL_sv_undef;
5243         SP = MARK;
5244     }
5245     RETURN;
5246 }
5247
5248 /* List operators. */
5249
5250 PP(pp_list)
5251 {
5252     I32 markidx = POPMARK;
5253     if (GIMME_V != G_ARRAY) {
5254         SV **mark = PL_stack_base + markidx;
5255         dSP;
5256         if (++MARK <= SP)
5257             *MARK = *SP;                /* unwanted list, return last item */
5258         else
5259             *MARK = &PL_sv_undef;
5260         SP = MARK;
5261         PUTBACK;
5262     }
5263     return NORMAL;
5264 }
5265
5266 PP(pp_lslice)
5267 {
5268     dSP;
5269     SV ** const lastrelem = PL_stack_sp;
5270     SV ** const lastlelem = PL_stack_base + POPMARK;
5271     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5272     SV ** const firstrelem = lastlelem + 1;
5273     const U8 mod = PL_op->op_flags & OPf_MOD;
5274
5275     const I32 max = lastrelem - lastlelem;
5276     SV **lelem;
5277
5278     if (GIMME_V != G_ARRAY) {
5279         if (lastlelem < firstlelem) {
5280             *firstlelem = &PL_sv_undef;
5281         }
5282         else {
5283             I32 ix = SvIV(*lastlelem);
5284             if (ix < 0)
5285                 ix += max;
5286             if (ix < 0 || ix >= max)
5287                 *firstlelem = &PL_sv_undef;
5288             else
5289                 *firstlelem = firstrelem[ix];
5290         }
5291         SP = firstlelem;
5292         RETURN;
5293     }
5294
5295     if (max == 0) {
5296         SP = firstlelem - 1;
5297         RETURN;
5298     }
5299
5300     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5301         I32 ix = SvIV(*lelem);
5302         if (ix < 0)
5303             ix += max;
5304         if (ix < 0 || ix >= max)
5305             *lelem = &PL_sv_undef;
5306         else {
5307             if (!(*lelem = firstrelem[ix]))
5308                 *lelem = &PL_sv_undef;
5309             else if (mod && SvPADTMP(*lelem)) {
5310                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5311             }
5312         }
5313     }
5314     SP = lastlelem;
5315     RETURN;
5316 }
5317
5318 PP(pp_anonlist)
5319 {
5320     dSP; dMARK;
5321     const I32 items = SP - MARK;
5322     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5323     SP = MARK;
5324     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5325             ? newRV_noinc(av) : av);
5326     RETURN;
5327 }
5328
5329 PP(pp_anonhash)
5330 {
5331     dSP; dMARK; dORIGMARK;
5332     HV* const hv = newHV();
5333     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5334                                     ? newRV_noinc(MUTABLE_SV(hv))
5335                                     : MUTABLE_SV(hv) );
5336
5337     while (MARK < SP) {
5338         SV * const key =
5339             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5340         SV *val;
5341         if (MARK < SP)
5342         {
5343             MARK++;
5344             SvGETMAGIC(*MARK);
5345             val = newSV(0);
5346             sv_setsv_nomg(val, *MARK);
5347         }
5348         else
5349         {
5350             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5351             val = newSV(0);
5352         }
5353         (void)hv_store_ent(hv,key,val,0);
5354     }
5355     SP = ORIGMARK;
5356     XPUSHs(retval);
5357     RETURN;
5358 }
5359
5360 static AV *
5361 S_deref_plain_array(pTHX_ AV *ary)
5362 {
5363     if (SvTYPE(ary) == SVt_PVAV) return ary;
5364     SvGETMAGIC((SV *)ary);
5365     if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5366         Perl_die(aTHX_ "Not an ARRAY reference");
5367     else if (SvOBJECT(SvRV(ary)))
5368         Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5369     return (AV *)SvRV(ary);
5370 }
5371
5372 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5373 # define DEREF_PLAIN_ARRAY(ary)       \
5374    ({                                  \
5375      AV *aRrRay = ary;                  \
5376      SvTYPE(aRrRay) == SVt_PVAV          \
5377       ? aRrRay                            \
5378       : S_deref_plain_array(aTHX_ aRrRay); \
5379    })
5380 #else
5381 # define DEREF_PLAIN_ARRAY(ary)            \
5382    (                                        \
5383      PL_Sv = (SV *)(ary),                    \
5384      SvTYPE(PL_Sv) == SVt_PVAV                \
5385       ? (AV *)PL_Sv                            \
5386       : S_deref_plain_array(aTHX_ (AV *)PL_Sv)  \
5387    )
5388 #endif
5389
5390 PP(pp_splice)
5391 {
5392     dSP; dMARK; dORIGMARK;
5393     int num_args = (SP - MARK);
5394     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5395     SV **src;
5396     SV **dst;
5397     SSize_t i;
5398     SSize_t offset;
5399     SSize_t length;
5400     SSize_t newlen;
5401     SSize_t after;
5402     SSize_t diff;
5403     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5404
5405     if (mg) {
5406         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5407                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5408                                     sp - mark);
5409     }
5410
5411     SP++;
5412
5413     if (++MARK < SP) {
5414         offset = i = SvIV(*MARK);
5415         if (offset < 0)
5416             offset += AvFILLp(ary) + 1;
5417         if (offset < 0)
5418             DIE(aTHX_ PL_no_aelem, i);
5419         if (++MARK < SP) {
5420             length = SvIVx(*MARK++);
5421             if (length < 0) {
5422                 length += AvFILLp(ary) - offset + 1;
5423                 if (length < 0)
5424                     length = 0;
5425             }
5426         }
5427         else
5428             length = AvMAX(ary) + 1;            /* close enough to infinity */
5429     }
5430     else {
5431         offset = 0;
5432         length = AvMAX(ary) + 1;
5433     }
5434     if (offset > AvFILLp(ary) + 1) {
5435         if (num_args > 2)
5436             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5437         offset = AvFILLp(ary) + 1;
5438     }
5439     after = AvFILLp(ary) + 1 - (offset + length);
5440     if (after < 0) {                            /* not that much array */
5441         length += after;                        /* offset+length now in array */
5442         after = 0;
5443         if (!AvALLOC(ary))
5444             av_extend(ary, 0);
5445     }
5446
5447     /* At this point, MARK .. SP-1 is our new LIST */
5448
5449     newlen = SP - MARK;
5450     diff = newlen - length;
5451     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5452         av_reify(ary);
5453
5454     /* make new elements SVs now: avoid problems if they're from the array */
5455     for (dst = MARK, i = newlen; i; i--) {
5456         SV * const h = *dst;
5457         *dst++ = newSVsv(h);
5458     }
5459
5460     if (diff < 0) {                             /* shrinking the area */
5461         SV **tmparyval = NULL;
5462         if (newlen) {
5463             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5464             Copy(MARK, tmparyval, newlen, SV*);
5465         }
5466
5467         MARK = ORIGMARK + 1;
5468         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5469             const bool real = cBOOL(AvREAL(ary));
5470             MEXTEND(MARK, length);
5471             if (real)
5472                 EXTEND_MORTAL(length);
5473             for (i = 0, dst = MARK; i < length; i++) {
5474                 if ((*dst = AvARRAY(ary)[i+offset])) {
5475                   if (real)
5476                     sv_2mortal(*dst);   /* free them eventually */
5477                 }
5478                 else
5479                     *dst = &PL_sv_undef;
5480                 dst++;
5481             }
5482             MARK += length - 1;
5483         }
5484         else {
5485             *MARK = AvARRAY(ary)[offset+length-1];
5486             if (AvREAL(ary)) {
5487                 sv_2mortal(*MARK);
5488                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5489                     SvREFCNT_dec(*dst++);       /* free them now */
5490             }
5491         }
5492         AvFILLp(ary) += diff;
5493
5494         /* pull up or down? */
5495
5496         if (offset < after) {                   /* easier to pull up */
5497             if (offset) {                       /* esp. if nothing to pull */
5498                 src = &AvARRAY(ary)[offset-1];
5499                 dst = src - diff;               /* diff is negative */
5500                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5501                     *dst-- = *src--;
5502             }
5503             dst = AvARRAY(ary);
5504             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5505             AvMAX(ary) += diff;
5506         }
5507         else {
5508             if (after) {                        /* anything to pull down? */
5509                 src = AvARRAY(ary) + offset + length;
5510                 dst = src + diff;               /* diff is negative */
5511                 Move(src, dst, after, SV*);
5512             }
5513             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5514                                                 /* avoid later double free */
5515         }
5516         i = -diff;
5517         while (i)
5518             dst[--i] = NULL;
5519         
5520         if (newlen) {
5521             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5522             Safefree(tmparyval);
5523         }
5524     }
5525     else {                                      /* no, expanding (or same) */
5526         SV** tmparyval = NULL;
5527         if (length) {
5528             Newx(tmparyval, length, SV*);       /* so remember deletion */
5529             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5530         }
5531
5532         if (diff > 0) {                         /* expanding */
5533             /* push up or down? */
5534             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5535                 if (offset) {
5536                     src = AvARRAY(ary);
5537                     dst = src - diff;
5538                     Move(src, dst, offset, SV*);
5539                 }
5540                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5541                 AvMAX(ary) += diff;
5542                 AvFILLp(ary) += diff;
5543             }
5544             else {
5545                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5546                     av_extend(ary, AvFILLp(ary) + diff);
5547                 AvFILLp(ary) += diff;
5548
5549                 if (after) {
5550                     dst = AvARRAY(ary) + AvFILLp(ary);
5551                     src = dst - diff;
5552                     for (i = after; i; i--) {
5553                         *dst-- = *src--;
5554                     }
5555                 }
5556             }
5557         }
5558
5559         if (newlen) {
5560             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5561         }
5562
5563         MARK = ORIGMARK + 1;
5564         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5565             if (length) {
5566                 const bool real = cBOOL(AvREAL(ary));
5567                 if (real)
5568                     EXTEND_MORTAL(length);
5569                 for (i = 0, dst = MARK; i < length; i++) {
5570                     if ((*dst = tmparyval[i])) {
5571                       if (real)
5572                         sv_2mortal(*dst);       /* free them eventually */
5573                     }
5574                     else *dst = &PL_sv_undef;
5575                     dst++;
5576                 }
5577             }
5578             MARK += length - 1;
5579         }
5580         else if (length--) {
5581             *MARK = tmparyval[length];
5582             if (AvREAL(ary)) {
5583                 sv_2mortal(*MARK);
5584                 while (length-- > 0)
5585                     SvREFCNT_dec(tmparyval[length]);
5586             }
5587         }
5588         else
5589             *MARK = &PL_sv_undef;
5590         Safefree(tmparyval);
5591     }
5592
5593     if (SvMAGICAL(ary))
5594         mg_set(MUTABLE_SV(ary));
5595
5596     SP = MARK;
5597     RETURN;
5598 }
5599
5600 PP(pp_push)
5601 {
5602     dSP; dMARK; dORIGMARK; dTARGET;
5603     AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5604     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5605
5606     if (mg) {
5607         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5608         PUSHMARK(MARK);
5609         PUTBACK;
5610         ENTER_with_name("call_PUSH");
5611         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5612         LEAVE_with_name("call_PUSH");
5613         /* SPAGAIN; not needed: SP is assigned to immediately below */
5614     }
5615     else {
5616         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5617          * only need to save locally, not on the save stack */
5618         U16 old_delaymagic = PL_delaymagic;
5619
5620         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5621         PL_delaymagic = DM_DELAY;
5622         for (++MARK; MARK <= SP; MARK++) {
5623             SV *sv;
5624             if (*MARK) SvGETMAGIC(*MARK);
5625             sv = newSV(0);
5626             if (*MARK)
5627                 sv_setsv_nomg(sv, *MARK);
5628             av_store(ary, AvFILLp(ary)+1, sv);
5629         }
5630         if (PL_delaymagic & DM_ARRAY_ISA)
5631             mg_set(MUTABLE_SV(ary));
5632         PL_delaymagic = old_delaymagic;
5633     }
5634     SP = ORIGMARK;
5635     if (OP_GIMME(PL_op, 0) != G_VOID) {
5636         PUSHi( AvFILL(ary) + 1 );
5637     }
5638     RETURN;
5639 }
5640
5641 /* also used for: pp_pop()*/
5642 PP(pp_shift)
5643 {
5644     dSP;
5645     AV * const av = PL_op->op_flags & OPf_SPECIAL
5646         ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5647     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5648     EXTEND(SP, 1);
5649     assert (sv);
5650     if (AvREAL(av))
5651         (void)sv_2mortal(sv);
5652     PUSHs(sv);
5653     RETURN;
5654 }
5655
5656 PP(pp_unshift)
5657 {
5658     dSP; dMARK; dORIGMARK; dTARGET;
5659     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5660     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5661
5662     if (mg) {
5663         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5664         PUSHMARK(MARK);
5665         PUTBACK;
5666         ENTER_with_name("call_UNSHIFT");
5667         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5668         LEAVE_with_name("call_UNSHIFT");
5669         /* SPAGAIN; not needed: SP is assigned to immediately below */
5670     }
5671     else {
5672         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5673          * only need to save locally, not on the save stack */
5674         U16 old_delaymagic = PL_delaymagic;
5675         SSize_t i = 0;
5676
5677         av_unshift(ary, SP - MARK);
5678         PL_delaymagic = DM_DELAY;
5679         while (MARK < SP) {
5680             SV * const sv = newSVsv(*++MARK);
5681             (void)av_store(ary, i++, sv);
5682         }
5683         if (PL_delaymagic & DM_ARRAY_ISA)
5684             mg_set(MUTABLE_SV(ary));
5685         PL_delaymagic = old_delaymagic;
5686     }
5687     SP = ORIGMARK;
5688     if (OP_GIMME(PL_op, 0) != G_VOID) {
5689         PUSHi( AvFILL(ary) + 1 );
5690     }
5691     RETURN;
5692 }
5693
5694 PP(pp_reverse)
5695 {
5696     dSP; dMARK;
5697
5698     if (GIMME_V == G_ARRAY) {
5699         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5700             AV *av;
5701
5702             /* See pp_sort() */
5703             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5704             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5705             av = MUTABLE_AV((*SP));
5706             /* In-place reversing only happens in void context for the array
5707              * assignment. We don't need to push anything on the stack. */
5708             SP = MARK;
5709
5710             if (SvMAGICAL(av)) {
5711                 SSize_t i, j;
5712                 SV *tmp = sv_newmortal();
5713                 /* For SvCANEXISTDELETE */
5714                 HV *stash;
5715                 const MAGIC *mg;
5716                 bool can_preserve = SvCANEXISTDELETE(av);
5717
5718                 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5719                     SV *begin, *end;
5720
5721                     if (can_preserve) {
5722                         if (!av_exists(av, i)) {
5723                             if (av_exists(av, j)) {
5724                                 SV *sv = av_delete(av, j, 0);
5725                                 begin = *av_fetch(av, i, TRUE);
5726                                 sv_setsv_mg(begin, sv);
5727                             }
5728                             continue;
5729                         }
5730                         else if (!av_exists(av, j)) {
5731                             SV *sv = av_delete(av, i, 0);
5732                             end = *av_fetch(av, j, TRUE);
5733                             sv_setsv_mg(end, sv);
5734                             continue;
5735                         }
5736                     }
5737
5738                     begin = *av_fetch(av, i, TRUE);
5739                     end   = *av_fetch(av, j, TRUE);
5740                     sv_setsv(tmp,      begin);
5741                     sv_setsv_mg(begin, end);
5742                     sv_setsv_mg(end,   tmp);
5743                 }
5744             }
5745             else {
5746                 SV **begin = AvARRAY(av);
5747
5748                 if (begin) {
5749                     SV **end   = begin + AvFILLp(av);
5750
5751                     while (begin < end) {
5752                         SV * const tmp = *begin;
5753                         *begin++ = *end;
5754                         *end--   = tmp;
5755                     }
5756                 }
5757             }
5758         }
5759         else {
5760             SV **oldsp = SP;
5761             MARK++;
5762             while (MARK < SP) {
5763                 SV * const tmp = *MARK;
5764                 *MARK++ = *SP;
5765                 *SP--   = tmp;
5766             }
5767             /* safe as long as stack cannot get extended in the above */
5768             SP = oldsp;
5769         }
5770     }
5771     else {
5772         char *up;
5773         char *down;
5774         I32 tmp;
5775         dTARGET;
5776         STRLEN len;
5777
5778         SvUTF8_off(TARG);                               /* decontaminate */
5779         if (SP - MARK > 1)
5780             do_join(TARG, &PL_sv_no, MARK, SP);
5781         else {
5782             sv_setsv(TARG, SP > MARK ? *SP : DEFSV);
5783         }
5784
5785         up = SvPV_force(TARG, len);
5786         if (len > 1) {
5787             if (DO_UTF8(TARG)) {        /* first reverse each character */
5788                 U8* s = (U8*)SvPVX(TARG);
5789                 const U8* send = (U8*)(s + len);
5790                 while (s < send) {
5791                     if (UTF8_IS_INVARIANT(*s)) {
5792                         s++;
5793                         continue;
5794                     }
5795                     else {
5796                         if (!utf8_to_uvchr_buf(s, send, 0))
5797                             break;
5798                         up = (char*)s;
5799                         s += UTF8SKIP(s);
5800                         down = (char*)(s - 1);
5801                         /* reverse this character */
5802                         while (down > up) {
5803                             tmp = *up;
5804                             *up++ = *down;
5805                             *down-- = (char)tmp;
5806                         }
5807                     }
5808                 }
5809                 up = SvPVX(TARG);
5810             }
5811             down = SvPVX(TARG) + len - 1;
5812             while (down > up) {
5813                 tmp = *up;
5814                 *up++ = *down;
5815                 *down-- = (char)tmp;
5816             }
5817             (void)SvPOK_only_UTF8(TARG);
5818         }
5819         SP = MARK + 1;
5820         SETTARG;
5821     }
5822     RETURN;
5823 }
5824
5825 PP(pp_split)
5826 {
5827     dSP; dTARG;
5828     AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
5829     IV limit = POPi;                    /* note, negative is forever */
5830     SV * const sv = POPs;
5831     STRLEN len;
5832     const char *s = SvPV_const(sv, len);
5833     const bool do_utf8 = DO_UTF8(sv);
5834     const char *strend = s + len;
5835     PMOP *pm;
5836     REGEXP *rx;
5837     SV *dstr;
5838     const char *m;
5839     SSize_t iters = 0;
5840     const STRLEN slen = do_utf8
5841                         ? utf8_length((U8*)s, (U8*)strend)
5842                         : (STRLEN)(strend - s);
5843     SSize_t maxiters = slen + 10;
5844     I32 trailing_empty = 0;
5845     const char *orig;
5846     const IV origlimit = limit;
5847     I32 realarray = 0;
5848     I32 base;
5849     const U8 gimme = GIMME_V;
5850     bool gimme_scalar;
5851     const I32 oldsave = PL_savestack_ix;
5852     U32 make_mortal = SVs_TEMP;
5853     bool multiline = 0;
5854     MAGIC *mg = NULL;
5855
5856 #ifdef DEBUGGING
5857     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5858 #else
5859     pm = (PMOP*)POPs;
5860 #endif
5861     if (!pm)
5862         DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5863     rx = PM_GETRE(pm);
5864
5865     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5866              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5867
5868 #ifdef USE_ITHREADS
5869     if (pm->op_pmreplrootu.op_pmtargetoff) {
5870         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5871         goto have_av;
5872     }
5873 #else
5874     if (pm->op_pmreplrootu.op_pmtargetgv) {
5875         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5876         goto have_av;
5877     }
5878 #endif
5879     else if (pm->op_targ)
5880         ary = (AV *)PAD_SVl(pm->op_targ);
5881     if (ary) {
5882         have_av:
5883         realarray = 1;
5884         PUTBACK;
5885         av_extend(ary,0);
5886         (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5887         av_clear(ary);
5888         SPAGAIN;
5889         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5890             PUSHMARK(SP);
5891             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5892         }
5893         else {
5894             if (!AvREAL(ary)) {
5895                 I32 i;
5896                 AvREAL_on(ary);
5897                 AvREIFY_off(ary);
5898                 for (i = AvFILLp(ary); i >= 0; i--)
5899                     AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5900             }
5901             /* temporarily switch stacks */
5902             SAVESWITCHSTACK(PL_curstack, ary);
5903             make_mortal = 0;
5904         }
5905     }
5906     base = SP - PL_stack_base;
5907     orig = s;
5908     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5909         if (do_utf8) {
5910             while (isSPACE_utf8(s))
5911                 s += UTF8SKIP(s);
5912         }
5913         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5914             while (isSPACE_LC(*s))
5915                 s++;
5916         }
5917         else {
5918             while (isSPACE(*s))
5919                 s++;
5920         }
5921     }
5922     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5923         multiline = 1;
5924     }
5925
5926     gimme_scalar = gimme == G_SCALAR && !ary;
5927
5928     if (!limit)
5929         limit = maxiters + 2;
5930     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5931         while (--limit) {
5932             m = s;
5933             /* this one uses 'm' and is a negative test */
5934             if (do_utf8) {
5935                 while (m < strend && ! isSPACE_utf8(m) ) {
5936                     const int t = UTF8SKIP(m);
5937                     /* isSPACE_utf8 returns FALSE for malform utf8 */
5938                     if (strend - m < t)
5939                         m = strend;
5940                     else
5941                         m += t;
5942                 }
5943             }
5944             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5945             {
5946                 while (m < strend && !isSPACE_LC(*m))
5947                     ++m;
5948             } else {
5949                 while (m < strend && !isSPACE(*m))
5950                     ++m;
5951             }  
5952             if (m >= strend)
5953                 break;
5954
5955             if (gimme_scalar) {
5956                 iters++;
5957                 if (m-s == 0)
5958                     trailing_empty++;
5959                 else
5960                     trailing_empty = 0;
5961             } else {
5962                 dstr = newSVpvn_flags(s, m-s,
5963                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5964                 XPUSHs(dstr);
5965             }
5966
5967             /* skip the whitespace found last */
5968             if (do_utf8)
5969                 s = m + UTF8SKIP(m);
5970             else
5971                 s = m + 1;
5972
5973             /* this one uses 's' and is a positive test */
5974             if (do_utf8) {
5975                 while (s < strend && isSPACE_utf8(s) )
5976                     s +=  UTF8SKIP(s);
5977             }
5978             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5979             {
5980                 while (s < strend && isSPACE_LC(*s))
5981                     ++s;
5982             } else {
5983                 while (s < strend && isSPACE(*s))
5984                     ++s;
5985             }       
5986         }
5987     }
5988     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5989         while (--limit) {
5990             for (m = s; m < strend && *m != '\n'; m++)
5991                 ;
5992             m++;
5993             if (m >= strend)
5994                 break;
5995
5996             if (gimme_scalar) {
5997                 iters++;
5998                 if (m-s == 0)
5999                     trailing_empty++;
6000                 else
6001                     trailing_empty = 0;
6002             } else {
6003                 dstr = newSVpvn_flags(s, m-s,
6004                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6005                 XPUSHs(dstr);
6006             }
6007             s = m;
6008         }
6009     }
6010     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6011         /*
6012           Pre-extend the stack, either the number of bytes or
6013           characters in the string or a limited amount, triggered by:
6014
6015           my ($x, $y) = split //, $str;
6016             or
6017           split //, $str, $i;
6018         */
6019         if (!gimme_scalar) {
6020             const IV items = limit - 1;
6021             /* setting it to -1 will trigger a panic in EXTEND() */
6022             const SSize_t sslen = slen > SSize_t_MAX ?  -1 : (SSize_t)slen;
6023             if (items >=0 && items < sslen)
6024                 EXTEND(SP, items);
6025             else
6026                 EXTEND(SP, sslen);
6027         }
6028
6029         if (do_utf8) {
6030             while (--limit) {
6031                 /* keep track of how many bytes we skip over */
6032                 m = s;
6033                 s += UTF8SKIP(s);
6034                 if (gimme_scalar) {
6035                     iters++;
6036                     if (s-m == 0)
6037                         trailing_empty++;
6038                     else
6039                         trailing_empty = 0;
6040                 } else {
6041                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
6042
6043                     PUSHs(dstr);
6044                 }
6045
6046                 if (s >= strend)
6047                     break;
6048             }
6049         } else {
6050             while (--limit) {
6051                 if (gimme_scalar) {
6052                     iters++;
6053                 } else {
6054                     dstr = newSVpvn(s, 1);
6055
6056
6057                     if (make_mortal)
6058                         sv_2mortal(dstr);
6059
6060                     PUSHs(dstr);
6061                 }
6062
6063                 s++;
6064
6065                 if (s >= strend)
6066                     break;
6067             }
6068         }
6069     }
6070     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6071              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6072              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6073              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6074         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6075         SV * const csv = CALLREG_INTUIT_STRING(rx);
6076
6077         len = RX_MINLENRET(rx);
6078         if (len == 1 && !RX_UTF8(rx) && !tail) {
6079             const char c = *SvPV_nolen_const(csv);
6080             while (--limit) {
6081                 for (m = s; m < strend && *m != c; m++)
6082                     ;
6083                 if (m >= strend)
6084                     break;
6085                 if (gimme_scalar) {
6086                     iters++;
6087                     if (m-s == 0)
6088                         trailing_empty++;
6089                     else
6090                         trailing_empty = 0;
6091                 } else {
6092                     dstr = newSVpvn_flags(s, m-s,
6093                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6094                     XPUSHs(dstr);
6095                 }
6096                 /* The rx->minlen is in characters but we want to step
6097                  * s ahead by bytes. */
6098                 if (do_utf8)
6099                     s = (char*)utf8_hop((U8*)m, len);
6100                 else
6101                     s = m + len; /* Fake \n at the end */
6102             }
6103         }
6104         else {
6105             while (s < strend && --limit &&
6106               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6107                              csv, multiline ? FBMrf_MULTILINE : 0)) )
6108             {
6109                 if (gimme_scalar) {
6110                     iters++;
6111                     if (m-s == 0)
6112                         trailing_empty++;
6113                     else
6114                         trailing_empty = 0;
6115                 } else {
6116                     dstr = newSVpvn_flags(s, m-s,
6117                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6118                     XPUSHs(dstr);
6119                 }
6120                 /* The rx->minlen is in characters but we want to step
6121                  * s ahead by bytes. */
6122                 if (do_utf8)
6123                     s = (char*)utf8_hop((U8*)m, len);
6124                 else
6125                     s = m + len; /* Fake \n at the end */
6126             }
6127         }
6128     }
6129     else {
6130         maxiters += slen * RX_NPARENS(rx);
6131         while (s < strend && --limit)
6132         {
6133             I32 rex_return;
6134             PUTBACK;
6135             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6136                                      sv, NULL, 0);
6137             SPAGAIN;
6138             if (rex_return == 0)
6139                 break;
6140             TAINT_IF(RX_MATCH_TAINTED(rx));
6141             /* we never pass the REXEC_COPY_STR flag, so it should
6142              * never get copied */
6143             assert(!RX_MATCH_COPIED(rx));
6144             m = RX_OFFS(rx)[0].start + orig;
6145
6146             if (gimme_scalar) {
6147                 iters++;
6148                 if (m-s == 0)
6149                     trailing_empty++;
6150                 else
6151                     trailing_empty = 0;
6152             } else {
6153                 dstr = newSVpvn_flags(s, m-s,
6154                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6155                 XPUSHs(dstr);
6156             }
6157             if (RX_NPARENS(rx)) {
6158                 I32 i;
6159                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6160                     s = RX_OFFS(rx)[i].start + orig;
6161                     m = RX_OFFS(rx)[i].end + orig;
6162
6163                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
6164                        parens that didn't match -- they should be set to
6165                        undef, not the empty string */
6166                     if (gimme_scalar) {
6167                         iters++;
6168                         if (m-s == 0)
6169                             trailing_empty++;
6170                         else
6171                             trailing_empty = 0;
6172                     } else {
6173                         if (m >= orig && s >= orig) {
6174                             dstr = newSVpvn_flags(s, m-s,
6175                                                  (do_utf8 ? SVf_UTF8 : 0)
6176                                                   | make_mortal);
6177                         }
6178                         else
6179                             dstr = &PL_sv_undef;  /* undef, not "" */
6180                         XPUSHs(dstr);
6181                     }
6182
6183                 }
6184             }
6185             s = RX_OFFS(rx)[0].end + orig;
6186         }
6187     }
6188
6189     if (!gimme_scalar) {
6190         iters = (SP - PL_stack_base) - base;
6191     }
6192     if (iters > maxiters)
6193         DIE(aTHX_ "Split loop");
6194
6195     /* keep field after final delim? */
6196     if (s < strend || (iters && origlimit)) {
6197         if (!gimme_scalar) {
6198             const STRLEN l = strend - s;
6199             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6200             XPUSHs(dstr);
6201         }
6202         iters++;
6203     }
6204     else if (!origlimit) {
6205         if (gimme_scalar) {
6206             iters -= trailing_empty;
6207         } else {
6208             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6209                 if (TOPs && !make_mortal)
6210                     sv_2mortal(TOPs);
6211                 *SP-- = &PL_sv_undef;
6212                 iters--;
6213             }
6214         }
6215     }
6216
6217     PUTBACK;
6218     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6219     SPAGAIN;
6220     if (realarray) {
6221         if (!mg) {
6222             if (SvSMAGICAL(ary)) {
6223                 PUTBACK;
6224                 mg_set(MUTABLE_SV(ary));
6225                 SPAGAIN;
6226             }
6227             if (gimme == G_ARRAY) {
6228                 EXTEND(SP, iters);
6229                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6230                 SP += iters;
6231                 RETURN;
6232             }
6233         }
6234         else {
6235             PUTBACK;
6236             ENTER_with_name("call_PUSH");
6237             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6238             LEAVE_with_name("call_PUSH");
6239             SPAGAIN;
6240             if (gimme == G_ARRAY) {
6241                 SSize_t i;
6242                 /* EXTEND should not be needed - we just popped them */
6243                 EXTEND(SP, iters);
6244                 for (i=0; i < iters; i++) {
6245                     SV **svp = av_fetch(ary, i, FALSE);
6246                     PUSHs((svp) ? *svp : &PL_sv_undef);
6247                 }
6248                 RETURN;
6249             }
6250         }
6251     }
6252     else {
6253         if (gimme == G_ARRAY)
6254             RETURN;
6255     }
6256
6257     GETTARGET;
6258     PUSHi(iters);
6259     RETURN;
6260 }
6261
6262 PP(pp_once)
6263 {
6264     dSP;
6265     SV *const sv = PAD_SVl(PL_op->op_targ);
6266
6267     if (SvPADSTALE(sv)) {
6268         /* First time. */
6269         SvPADSTALE_off(sv);
6270         RETURNOP(cLOGOP->op_other);
6271     }
6272     RETURNOP(cLOGOP->op_next);
6273 }
6274
6275 PP(pp_lock)
6276 {
6277     dSP;
6278     dTOPss;
6279     SV *retsv = sv;
6280     SvLOCK(sv);
6281     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6282      || SvTYPE(retsv) == SVt_PVCV) {
6283         retsv = refto(retsv);
6284     }
6285     SETs(retsv);
6286     RETURN;
6287 }
6288
6289
6290 /* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
6291  * that aren't implemented on a particular platform */
6292
6293 PP(unimplemented_op)
6294 {
6295     const Optype op_type = PL_op->op_type;
6296     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6297        with out of range op numbers - it only "special" cases op_custom.
6298        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6299        if we get here for a custom op then that means that the custom op didn't
6300        have an implementation. Given that OP_NAME() looks up the custom op
6301        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6302        registers &PL_unimplemented_op as the address of their custom op.
6303        NULL doesn't generate a useful error message. "custom" does. */
6304     const char *const name = op_type >= OP_max
6305         ? "[out of range]" : PL_op_name[PL_op->op_type];
6306     if(OP_IS_SOCKET(op_type))
6307         DIE(aTHX_ PL_no_sock_func, name);
6308     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
6309 }
6310
6311 /* For sorting out arguments passed to a &CORE:: subroutine */
6312 PP(pp_coreargs)
6313 {
6314     dSP;
6315     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6316     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6317     AV * const at_ = GvAV(PL_defgv);
6318     SV **svp = at_ ? AvARRAY(at_) : NULL;
6319     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6320     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6321     bool seen_question = 0;
6322     const char *err = NULL;
6323     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6324
6325     /* Count how many args there are first, to get some idea how far to
6326        extend the stack. */
6327     while (oa) {
6328         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6329         maxargs++;
6330         if (oa & OA_OPTIONAL) seen_question = 1;
6331         if (!seen_question) minargs++;
6332         oa >>= 4;
6333     }
6334
6335     if(numargs < minargs) err = "Not enough";
6336     else if(numargs > maxargs) err = "Too many";
6337     if (err)
6338         /* diag_listed_as: Too many arguments for %s */
6339         Perl_croak(aTHX_
6340           "%s arguments for %s", err,
6341            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6342         );
6343
6344     /* Reset the stack pointer.  Without this, we end up returning our own
6345        arguments in list context, in addition to the values we are supposed
6346        to return.  nextstate usually does this on sub entry, but we need
6347        to run the next op with the caller's hints, so we cannot have a
6348        nextstate. */
6349     SP = PL_stack_base + CX_CUR()->blk_oldsp;
6