regcomp.c: Add shortcuts to some inversion list ops
[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 PP(pp_i_modulo)
2789 {
2790      /* This is the vanilla old i_modulo. */
2791      dSP; dATARGET;
2792      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2793      {
2794           dPOPTOPiirl_nomg;
2795           if (!right)
2796                DIE(aTHX_ "Illegal modulus zero");
2797           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2798           if (right == -1)
2799               SETi( 0 );
2800           else
2801               SETi( left % right );
2802           RETURN;
2803      }
2804 }
2805
2806 #if defined(__GLIBC__) && IVSIZE == 8 \
2807     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2808
2809 PP(pp_i_modulo_glibc_bugfix)
2810 {
2811      /* This is the i_modulo with the workaround for the _moddi3 bug
2812       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2813       * See below for pp_i_modulo. */
2814      dSP; dATARGET;
2815      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2816      {
2817           dPOPTOPiirl_nomg;
2818           if (!right)
2819                DIE(aTHX_ "Illegal modulus zero");
2820           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2821           if (right == -1)
2822               SETi( 0 );
2823           else
2824               SETi( left % PERL_ABS(right) );
2825           RETURN;
2826      }
2827 }
2828 #endif
2829
2830 PP(pp_i_add)
2831 {
2832     dSP; dATARGET;
2833     tryAMAGICbin_MG(add_amg, AMGf_assign);
2834     {
2835       dPOPTOPiirl_ul_nomg;
2836       SETi( left + right );
2837       RETURN;
2838     }
2839 }
2840
2841 PP(pp_i_subtract)
2842 {
2843     dSP; dATARGET;
2844     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2845     {
2846       dPOPTOPiirl_ul_nomg;
2847       SETi( left - right );
2848       RETURN;
2849     }
2850 }
2851
2852 PP(pp_i_lt)
2853 {
2854     dSP;
2855     tryAMAGICbin_MG(lt_amg, AMGf_set);
2856     {
2857       dPOPTOPiirl_nomg;
2858       SETs(boolSV(left < right));
2859       RETURN;
2860     }
2861 }
2862
2863 PP(pp_i_gt)
2864 {
2865     dSP;
2866     tryAMAGICbin_MG(gt_amg, AMGf_set);
2867     {
2868       dPOPTOPiirl_nomg;
2869       SETs(boolSV(left > right));
2870       RETURN;
2871     }
2872 }
2873
2874 PP(pp_i_le)
2875 {
2876     dSP;
2877     tryAMAGICbin_MG(le_amg, AMGf_set);
2878     {
2879       dPOPTOPiirl_nomg;
2880       SETs(boolSV(left <= right));
2881       RETURN;
2882     }
2883 }
2884
2885 PP(pp_i_ge)
2886 {
2887     dSP;
2888     tryAMAGICbin_MG(ge_amg, AMGf_set);
2889     {
2890       dPOPTOPiirl_nomg;
2891       SETs(boolSV(left >= right));
2892       RETURN;
2893     }
2894 }
2895
2896 PP(pp_i_eq)
2897 {
2898     dSP;
2899     tryAMAGICbin_MG(eq_amg, AMGf_set);
2900     {
2901       dPOPTOPiirl_nomg;
2902       SETs(boolSV(left == right));
2903       RETURN;
2904     }
2905 }
2906
2907 PP(pp_i_ne)
2908 {
2909     dSP;
2910     tryAMAGICbin_MG(ne_amg, AMGf_set);
2911     {
2912       dPOPTOPiirl_nomg;
2913       SETs(boolSV(left != right));
2914       RETURN;
2915     }
2916 }
2917
2918 PP(pp_i_ncmp)
2919 {
2920     dSP; dTARGET;
2921     tryAMAGICbin_MG(ncmp_amg, 0);
2922     {
2923       dPOPTOPiirl_nomg;
2924       I32 value;
2925
2926       if (left > right)
2927         value = 1;
2928       else if (left < right)
2929         value = -1;
2930       else
2931         value = 0;
2932       SETi(value);
2933       RETURN;
2934     }
2935 }
2936
2937 PP(pp_i_negate)
2938 {
2939     dSP; dTARGET;
2940     tryAMAGICun_MG(neg_amg, 0);
2941     if (S_negate_string(aTHX)) return NORMAL;
2942     {
2943         SV * const sv = TOPs;
2944         IV const i = SvIV_nomg(sv);
2945         SETi(-i);
2946         return NORMAL;
2947     }
2948 }
2949
2950 /* High falutin' math. */
2951
2952 PP(pp_atan2)
2953 {
2954     dSP; dTARGET;
2955     tryAMAGICbin_MG(atan2_amg, 0);
2956     {
2957       dPOPTOPnnrl_nomg;
2958       SETn(Perl_atan2(left, right));
2959       RETURN;
2960     }
2961 }
2962
2963
2964 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2965
2966 PP(pp_sin)
2967 {
2968     dSP; dTARGET;
2969     int amg_type = fallback_amg;
2970     const char *neg_report = NULL;
2971     const int op_type = PL_op->op_type;
2972
2973     switch (op_type) {
2974     case OP_SIN:  amg_type = sin_amg; break;
2975     case OP_COS:  amg_type = cos_amg; break;
2976     case OP_EXP:  amg_type = exp_amg; break;
2977     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2978     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2979     }
2980
2981     assert(amg_type != fallback_amg);
2982
2983     tryAMAGICun_MG(amg_type, 0);
2984     {
2985       SV * const arg = TOPs;
2986       const NV value = SvNV_nomg(arg);
2987       NV result = NV_NAN;
2988       if (neg_report) { /* log or sqrt */
2989           if (
2990 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2991               ! Perl_isnan(value) &&
2992 #endif
2993               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2994               SET_NUMERIC_STANDARD();
2995               /* diag_listed_as: Can't take log of %g */
2996               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2997           }
2998       }
2999       switch (op_type) {
3000       default:
3001       case OP_SIN:  result = Perl_sin(value);  break;
3002       case OP_COS:  result = Perl_cos(value);  break;
3003       case OP_EXP:  result = Perl_exp(value);  break;
3004       case OP_LOG:  result = Perl_log(value);  break;
3005       case OP_SQRT: result = Perl_sqrt(value); break;
3006       }
3007       SETn(result);
3008       return NORMAL;
3009     }
3010 }
3011
3012 /* Support Configure command-line overrides for rand() functions.
3013    After 5.005, perhaps we should replace this by Configure support
3014    for drand48(), random(), or rand().  For 5.005, though, maintain
3015    compatibility by calling rand() but allow the user to override it.
3016    See INSTALL for details.  --Andy Dougherty  15 July 1998
3017 */
3018 /* Now it's after 5.005, and Configure supports drand48() and random(),
3019    in addition to rand().  So the overrides should not be needed any more.
3020    --Jarkko Hietaniemi  27 September 1998
3021  */
3022
3023 PP(pp_rand)
3024 {
3025     if (!PL_srand_called) {
3026         (void)seedDrand01((Rand_seed_t)seed());
3027         PL_srand_called = TRUE;
3028     }
3029     {
3030         dSP;
3031         NV value;
3032     
3033         if (MAXARG < 1)
3034         {
3035             EXTEND(SP, 1);
3036             value = 1.0;
3037         }
3038         else {
3039             SV * const sv = POPs;
3040             if(!sv)
3041                 value = 1.0;
3042             else
3043                 value = SvNV(sv);
3044         }
3045     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
3046 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3047         if (! Perl_isnan(value) && value == 0.0)
3048 #else
3049         if (value == 0.0)
3050 #endif
3051             value = 1.0;
3052         {
3053             dTARGET;
3054             PUSHs(TARG);
3055             PUTBACK;
3056             value *= Drand01();
3057             sv_setnv_mg(TARG, value);
3058         }
3059     }
3060     return NORMAL;
3061 }
3062
3063 PP(pp_srand)
3064 {
3065     dSP; dTARGET;
3066     UV anum;
3067
3068     if (MAXARG >= 1 && (TOPs || POPs)) {
3069         SV *top;
3070         char *pv;
3071         STRLEN len;
3072         int flags;
3073
3074         top = POPs;
3075         pv = SvPV(top, len);
3076         flags = grok_number(pv, len, &anum);
3077
3078         if (!(flags & IS_NUMBER_IN_UV)) {
3079             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3080                              "Integer overflow in srand");
3081             anum = UV_MAX;
3082         }
3083     }
3084     else {
3085         anum = seed();
3086     }
3087
3088     (void)seedDrand01((Rand_seed_t)anum);
3089     PL_srand_called = TRUE;
3090     if (anum)
3091         XPUSHu(anum);
3092     else {
3093         /* Historically srand always returned true. We can avoid breaking
3094            that like this:  */
3095         sv_setpvs(TARG, "0 but true");
3096         XPUSHTARG;
3097     }
3098     RETURN;
3099 }
3100
3101 PP(pp_int)
3102 {
3103     dSP; dTARGET;
3104     tryAMAGICun_MG(int_amg, AMGf_numeric);
3105     {
3106       SV * const sv = TOPs;
3107       const IV iv = SvIV_nomg(sv);
3108       /* XXX it's arguable that compiler casting to IV might be subtly
3109          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3110          else preferring IV has introduced a subtle behaviour change bug. OTOH
3111          relying on floating point to be accurate is a bug.  */
3112
3113       if (!SvOK(sv)) {
3114         SETu(0);
3115       }
3116       else if (SvIOK(sv)) {
3117         if (SvIsUV(sv))
3118             SETu(SvUV_nomg(sv));
3119         else
3120             SETi(iv);
3121       }
3122       else {
3123           const NV value = SvNV_nomg(sv);
3124           if (UNLIKELY(Perl_isinfnan(value)))
3125               SETn(value);
3126           else if (value >= 0.0) {
3127               if (value < (NV)UV_MAX + 0.5) {
3128                   SETu(U_V(value));
3129               } else {
3130                   SETn(Perl_floor(value));
3131               }
3132           }
3133           else {
3134               if (value > (NV)IV_MIN - 0.5) {
3135                   SETi(I_V(value));
3136               } else {
3137                   SETn(Perl_ceil(value));
3138               }
3139           }
3140       }
3141     }
3142     return NORMAL;
3143 }
3144
3145 PP(pp_abs)
3146 {
3147     dSP; dTARGET;
3148     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3149     {
3150       SV * const sv = TOPs;
3151       /* This will cache the NV value if string isn't actually integer  */
3152       const IV iv = SvIV_nomg(sv);
3153
3154       if (!SvOK(sv)) {
3155         SETu(0);
3156       }
3157       else if (SvIOK(sv)) {
3158         /* IVX is precise  */
3159         if (SvIsUV(sv)) {
3160           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3161         } else {
3162           if (iv >= 0) {
3163             SETi(iv);
3164           } else {
3165             if (iv != IV_MIN) {
3166               SETi(-iv);
3167             } else {
3168               /* 2s complement assumption. Also, not really needed as
3169                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3170               SETu((UV)IV_MIN);
3171             }
3172           }
3173         }
3174       } else{
3175         const NV value = SvNV_nomg(sv);
3176         if (value < 0.0)
3177           SETn(-value);
3178         else
3179           SETn(value);
3180       }
3181     }
3182     return NORMAL;
3183 }
3184
3185
3186 /* also used for: pp_hex() */
3187
3188 PP(pp_oct)
3189 {
3190     dSP; dTARGET;
3191     const char *tmps;
3192     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3193     STRLEN len;
3194     NV result_nv;
3195     UV result_uv;
3196     SV* const sv = TOPs;
3197
3198     tmps = (SvPV_const(sv, len));
3199     if (DO_UTF8(sv)) {
3200          /* If Unicode, try to downgrade
3201           * If not possible, croak. */
3202          SV* const tsv = sv_2mortal(newSVsv(sv));
3203         
3204          SvUTF8_on(tsv);
3205          sv_utf8_downgrade(tsv, FALSE);
3206          tmps = SvPV_const(tsv, len);
3207     }
3208     if (PL_op->op_type == OP_HEX)
3209         goto hex;
3210
3211     while (*tmps && len && isSPACE(*tmps))
3212         tmps++, len--;
3213     if (*tmps == '0')
3214         tmps++, len--;
3215     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3216     hex:
3217         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3218     }
3219     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3220         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3221     else
3222         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3223
3224     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3225         SETn(result_nv);
3226     }
3227     else {
3228         SETu(result_uv);
3229     }
3230     return NORMAL;
3231 }
3232
3233 /* String stuff. */
3234
3235 PP(pp_length)
3236 {
3237     dSP; dTARGET;
3238     SV * const sv = TOPs;
3239
3240     U32 in_bytes = IN_BYTES;
3241     /* simplest case shortcut */
3242     /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3243     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3244     STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3245     SETs(TARG);
3246
3247     if(LIKELY(svflags == SVf_POK))
3248         goto simple_pv;
3249     if(svflags & SVs_GMG)
3250         mg_get(sv);
3251     if (SvOK(sv)) {
3252         if (!IN_BYTES) /* reread to avoid using an C auto/register */
3253             sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3254         else
3255         {
3256             STRLEN len;
3257             /* unrolled SvPV_nomg_const(sv,len) */
3258             if(SvPOK_nog(sv)){
3259                 simple_pv:
3260                 len = SvCUR(sv);
3261             } else  {
3262                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3263             }
3264             sv_setiv(TARG, (IV)(len));
3265         }
3266     } else {
3267         if (!SvPADTMP(TARG)) {
3268             sv_setsv_nomg(TARG, &PL_sv_undef);
3269         } else { /* TARG is on stack at this point and is overwriten by SETs.
3270                    This branch is the odd one out, so put TARG by default on
3271                    stack earlier to let local SP go out of liveness sooner */
3272             SETs(&PL_sv_undef);
3273             goto no_set_magic;
3274         }
3275     }
3276     SvSETMAGIC(TARG);
3277     no_set_magic:
3278     return NORMAL; /* no putback, SP didn't move in this opcode */
3279 }
3280
3281 /* Returns false if substring is completely outside original string.
3282    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3283    always be true for an explicit 0.
3284 */
3285 bool
3286 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3287                                 bool pos1_is_uv, IV len_iv,
3288                                 bool len_is_uv, STRLEN *posp,
3289                                 STRLEN *lenp)
3290 {
3291     IV pos2_iv;
3292     int    pos2_is_uv;
3293
3294     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3295
3296     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3297         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3298         pos1_iv += curlen;
3299     }
3300     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3301         return FALSE;
3302
3303     if (len_iv || len_is_uv) {
3304         if (!len_is_uv && len_iv < 0) {
3305             pos2_iv = curlen + len_iv;
3306             if (curlen)
3307                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3308             else
3309                 pos2_is_uv = 0;
3310         } else {  /* len_iv >= 0 */
3311             if (!pos1_is_uv && pos1_iv < 0) {
3312                 pos2_iv = pos1_iv + len_iv;
3313                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3314             } else {
3315                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3316                     pos2_iv = curlen;
3317                 else
3318                     pos2_iv = pos1_iv+len_iv;
3319                 pos2_is_uv = 1;
3320             }
3321         }
3322     }
3323     else {
3324         pos2_iv = curlen;
3325         pos2_is_uv = 1;
3326     }
3327
3328     if (!pos2_is_uv && pos2_iv < 0) {
3329         if (!pos1_is_uv && pos1_iv < 0)
3330             return FALSE;
3331         pos2_iv = 0;
3332     }
3333     else if (!pos1_is_uv && pos1_iv < 0)
3334         pos1_iv = 0;
3335
3336     if ((UV)pos2_iv < (UV)pos1_iv)
3337         pos2_iv = pos1_iv;
3338     if ((UV)pos2_iv > curlen)
3339         pos2_iv = curlen;
3340
3341     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3342     *posp = (STRLEN)( (UV)pos1_iv );
3343     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3344
3345     return TRUE;
3346 }
3347
3348 PP(pp_substr)
3349 {
3350     dSP; dTARGET;
3351     SV *sv;
3352     STRLEN curlen;
3353     STRLEN utf8_curlen;
3354     SV *   pos_sv;
3355     IV     pos1_iv;
3356     int    pos1_is_uv;
3357     SV *   len_sv;
3358     IV     len_iv = 0;
3359     int    len_is_uv = 0;
3360     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3361     const bool rvalue = (GIMME_V != G_VOID);
3362     const char *tmps;
3363     SV *repl_sv = NULL;
3364     const char *repl = NULL;
3365     STRLEN repl_len;
3366     int num_args = PL_op->op_private & 7;
3367     bool repl_need_utf8_upgrade = FALSE;
3368
3369     if (num_args > 2) {
3370         if (num_args > 3) {
3371           if(!(repl_sv = POPs)) num_args--;
3372         }
3373         if ((len_sv = POPs)) {
3374             len_iv    = SvIV(len_sv);
3375             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3376         }
3377         else num_args--;
3378     }
3379     pos_sv     = POPs;
3380     pos1_iv    = SvIV(pos_sv);
3381     pos1_is_uv = SvIOK_UV(pos_sv);
3382     sv = POPs;
3383     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3384         assert(!repl_sv);
3385         repl_sv = POPs;
3386     }
3387     if (lvalue && !repl_sv) {
3388         SV * ret;
3389         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3390         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3391         LvTYPE(ret) = 'x';
3392         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3393         LvTARGOFF(ret) =
3394             pos1_is_uv || pos1_iv >= 0
3395                 ? (STRLEN)(UV)pos1_iv
3396                 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3397         LvTARGLEN(ret) =
3398             len_is_uv || len_iv > 0
3399                 ? (STRLEN)(UV)len_iv
3400                 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3401
3402         PUSHs(ret);    /* avoid SvSETMAGIC here */
3403         RETURN;
3404     }
3405     if (repl_sv) {
3406         repl = SvPV_const(repl_sv, repl_len);
3407         SvGETMAGIC(sv);
3408         if (SvROK(sv))
3409             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3410                             "Attempt to use reference as lvalue in substr"
3411             );
3412         tmps = SvPV_force_nomg(sv, curlen);
3413         if (DO_UTF8(repl_sv) && repl_len) {
3414             if (!DO_UTF8(sv)) {
3415                 sv_utf8_upgrade_nomg(sv);
3416                 curlen = SvCUR(sv);
3417             }
3418         }
3419         else if (DO_UTF8(sv))
3420             repl_need_utf8_upgrade = TRUE;
3421     }
3422     else tmps = SvPV_const(sv, curlen);
3423     if (DO_UTF8(sv)) {
3424         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3425         if (utf8_curlen == curlen)
3426             utf8_curlen = 0;
3427         else
3428             curlen = utf8_curlen;
3429     }
3430     else
3431         utf8_curlen = 0;
3432
3433     {
3434         STRLEN pos, len, byte_len, byte_pos;
3435
3436         if (!translate_substr_offsets(
3437                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3438         )) goto bound_fail;
3439
3440         byte_len = len;
3441         byte_pos = utf8_curlen
3442             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3443
3444         tmps += byte_pos;
3445
3446         if (rvalue) {
3447             SvTAINTED_off(TARG);                        /* decontaminate */
3448             SvUTF8_off(TARG);                   /* decontaminate */
3449             sv_setpvn(TARG, tmps, byte_len);
3450 #ifdef USE_LOCALE_COLLATE
3451             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3452 #endif
3453             if (utf8_curlen)
3454                 SvUTF8_on(TARG);
3455         }
3456
3457         if (repl) {
3458             SV* repl_sv_copy = NULL;
3459
3460             if (repl_need_utf8_upgrade) {
3461                 repl_sv_copy = newSVsv(repl_sv);
3462                 sv_utf8_upgrade(repl_sv_copy);
3463                 repl = SvPV_const(repl_sv_copy, repl_len);
3464             }
3465             if (!SvOK(sv))
3466                 sv_setpvs(sv, "");
3467             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3468             SvREFCNT_dec(repl_sv_copy);
3469         }
3470     }
3471     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3472         SP++;
3473     else if (rvalue) {
3474         SvSETMAGIC(TARG);
3475         PUSHs(TARG);
3476     }
3477     RETURN;
3478
3479   bound_fail:
3480     if (repl)
3481         Perl_croak(aTHX_ "substr outside of string");
3482     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3483     RETPUSHUNDEF;
3484 }
3485
3486 PP(pp_vec)
3487 {
3488     dSP;
3489     const IV size   = POPi;
3490     const IV offset = POPi;
3491     SV * const src = POPs;
3492     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3493     SV * ret;
3494
3495     if (lvalue) {                       /* it's an lvalue! */
3496         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3497         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3498         LvTYPE(ret) = 'v';
3499         LvTARG(ret) = SvREFCNT_inc_simple(src);
3500         LvTARGOFF(ret) = offset;
3501         LvTARGLEN(ret) = size;
3502     }
3503     else {
3504         dTARGET;
3505         SvTAINTED_off(TARG);            /* decontaminate */
3506         ret = TARG;
3507     }
3508
3509     sv_setuv(ret, do_vecget(src, offset, size));
3510     if (!lvalue)
3511         SvSETMAGIC(ret);
3512     PUSHs(ret);
3513     RETURN;
3514 }
3515
3516
3517 /* also used for: pp_rindex() */
3518
3519 PP(pp_index)
3520 {
3521     dSP; dTARGET;
3522     SV *big;
3523     SV *little;
3524     SV *temp = NULL;
3525     STRLEN biglen;
3526     STRLEN llen = 0;
3527     SSize_t offset = 0;
3528     SSize_t retval;
3529     const char *big_p;
3530     const char *little_p;
3531     bool big_utf8;
3532     bool little_utf8;
3533     const bool is_index = PL_op->op_type == OP_INDEX;
3534     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3535
3536     if (threeargs)
3537         offset = POPi;
3538     little = POPs;
3539     big = POPs;
3540     big_p = SvPV_const(big, biglen);
3541     little_p = SvPV_const(little, llen);
3542
3543     big_utf8 = DO_UTF8(big);
3544     little_utf8 = DO_UTF8(little);
3545     if (big_utf8 ^ little_utf8) {
3546         /* One needs to be upgraded.  */
3547         if (little_utf8 && !IN_ENCODING) {
3548             /* Well, maybe instead we might be able to downgrade the small
3549                string?  */
3550             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3551                                                      &little_utf8);
3552             if (little_utf8) {
3553                 /* If the large string is ISO-8859-1, and it's not possible to
3554                    convert the small string to ISO-8859-1, then there is no
3555                    way that it could be found anywhere by index.  */
3556                 retval = -1;
3557                 goto fail;
3558             }
3559
3560             /* At this point, pv is a malloc()ed string. So donate it to temp
3561                to ensure it will get free()d  */
3562             little = temp = newSV(0);
3563             sv_usepvn(temp, pv, llen);
3564             little_p = SvPVX(little);
3565         } else {
3566             temp = little_utf8
3567                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3568
3569             if (IN_ENCODING) {
3570                 sv_recode_to_utf8(temp, _get_encoding());
3571             } else {
3572                 sv_utf8_upgrade(temp);
3573             }
3574             if (little_utf8) {
3575                 big = temp;
3576                 big_utf8 = TRUE;
3577                 big_p = SvPV_const(big, biglen);
3578             } else {
3579                 little = temp;
3580                 little_p = SvPV_const(little, llen);
3581             }
3582         }
3583     }
3584     if (SvGAMAGIC(big)) {
3585         /* Life just becomes a lot easier if I use a temporary here.
3586            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3587            will trigger magic and overloading again, as will fbm_instr()
3588         */
3589         big = newSVpvn_flags(big_p, biglen,
3590                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3591         big_p = SvPVX(big);
3592     }
3593     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3594         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3595            warn on undef, and we've already triggered a warning with the
3596            SvPV_const some lines above. We can't remove that, as we need to
3597            call some SvPV to trigger overloading early and find out if the
3598            string is UTF-8.
3599            This is all getting too messy. The API isn't quite clean enough,
3600            because data access has side effects.
3601         */
3602         little = newSVpvn_flags(little_p, llen,
3603                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3604         little_p = SvPVX(little);
3605     }
3606
3607     if (!threeargs)
3608         offset = is_index ? 0 : biglen;
3609     else {
3610         if (big_utf8 && offset > 0)
3611             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3612         if (!is_index)
3613             offset += llen;
3614     }
3615     if (offset < 0)
3616         offset = 0;
3617     else if (offset > (SSize_t)biglen)
3618         offset = biglen;
3619     if (!(little_p = is_index
3620           ? fbm_instr((unsigned char*)big_p + offset,
3621                       (unsigned char*)big_p + biglen, little, 0)
3622           : rninstr(big_p,  big_p  + offset,
3623                     little_p, little_p + llen)))
3624         retval = -1;
3625     else {
3626         retval = little_p - big_p;
3627         if (retval > 1 && big_utf8)
3628             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3629     }
3630     SvREFCNT_dec(temp);
3631  fail:
3632     PUSHi(retval);
3633     RETURN;
3634 }
3635
3636 PP(pp_sprintf)
3637 {
3638     dSP; dMARK; dORIGMARK; dTARGET;
3639     SvTAINTED_off(TARG);
3640     do_sprintf(TARG, SP-MARK, MARK+1);
3641     TAINT_IF(SvTAINTED(TARG));
3642     SP = ORIGMARK;
3643     PUSHTARG;
3644     RETURN;
3645 }
3646
3647 PP(pp_ord)
3648 {
3649     dSP; dTARGET;
3650
3651     SV *argsv = TOPs;
3652     STRLEN len;
3653     const U8 *s = (U8*)SvPV_const(argsv, len);
3654
3655     if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
3656         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3657         s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
3658         len = UTF8SKIP(s);  /* Should be well-formed; so this is its length */
3659         argsv = tmpsv;
3660     }
3661
3662     SETu(DO_UTF8(argsv)
3663            ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3664            : (UV)(*s));
3665
3666     return NORMAL;
3667 }
3668
3669 PP(pp_chr)
3670 {
3671     dSP; dTARGET;
3672     char *tmps;
3673     UV value;
3674     SV *top = TOPs;
3675
3676     SvGETMAGIC(top);
3677     if (UNLIKELY(SvAMAGIC(top)))
3678         top = sv_2num(top);
3679     if (UNLIKELY(isinfnansv(top)))
3680         Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3681     else {
3682         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3683             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3684                 ||
3685                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3686                  && SvNV_nomg(top) < 0.0)))
3687         {
3688             if (ckWARN(WARN_UTF8)) {
3689                 if (SvGMAGICAL(top)) {
3690                     SV *top2 = sv_newmortal();
3691                     sv_setsv_nomg(top2, top);
3692                     top = top2;
3693                 }
3694                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3695                             "Invalid negative number (%"SVf") in chr", SVfARG(top));
3696             }
3697             value = UNICODE_REPLACEMENT;
3698         } else {
3699             value = SvUV_nomg(top);
3700         }
3701     }
3702
3703     SvUPGRADE(TARG,SVt_PV);
3704
3705     if (value > 255 && !IN_BYTES) {
3706         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3707         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3708         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3709         *tmps = '\0';
3710         (void)SvPOK_only(TARG);
3711         SvUTF8_on(TARG);
3712         SETTARG;
3713         return NORMAL;
3714     }
3715
3716     SvGROW(TARG,2);
3717     SvCUR_set(TARG, 1);
3718     tmps = SvPVX(TARG);
3719     *tmps++ = (char)value;
3720     *tmps = '\0';
3721     (void)SvPOK_only(TARG);
3722
3723     if (IN_ENCODING && !IN_BYTES) {
3724         sv_recode_to_utf8(TARG, _get_encoding());
3725         tmps = SvPVX(TARG);
3726         if (SvCUR(TARG) == 0
3727             || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3728             || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3729         {
3730             SvGROW(TARG, 2);
3731             tmps = SvPVX(TARG);
3732             SvCUR_set(TARG, 1);
3733             *tmps++ = (char)value;
3734             *tmps = '\0';
3735             SvUTF8_off(TARG);
3736         }
3737     }
3738
3739     SETTARG;
3740     return NORMAL;
3741 }
3742
3743 PP(pp_crypt)
3744 {
3745 #ifdef HAS_CRYPT
3746     dSP; dTARGET;
3747     dPOPTOPssrl;
3748     STRLEN len;
3749     const char *tmps = SvPV_const(left, len);
3750
3751     if (DO_UTF8(left)) {
3752          /* If Unicode, try to downgrade.
3753           * If not possible, croak.
3754           * Yes, we made this up.  */
3755          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3756
3757          sv_utf8_downgrade(tsv, FALSE);
3758          tmps = SvPV_const(tsv, len);
3759     }
3760 #   ifdef USE_ITHREADS
3761 #     ifdef HAS_CRYPT_R
3762     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3763       /* This should be threadsafe because in ithreads there is only
3764        * one thread per interpreter.  If this would not be true,
3765        * we would need a mutex to protect this malloc. */
3766         PL_reentrant_buffer->_crypt_struct_buffer =
3767           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3768 #if defined(__GLIBC__) || defined(__EMX__)
3769         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3770             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3771             /* work around glibc-2.2.5 bug */
3772             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3773         }
3774 #endif
3775     }
3776 #     endif /* HAS_CRYPT_R */
3777 #   endif /* USE_ITHREADS */
3778 #   ifdef FCRYPT
3779     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3780 #   else
3781     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3782 #   endif
3783     SvUTF8_off(TARG);
3784     SETTARG;
3785     RETURN;
3786 #else
3787     DIE(aTHX_
3788       "The crypt() function is unimplemented due to excessive paranoia.");
3789 #endif
3790 }
3791
3792 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So 
3793  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3794
3795
3796 /* also used for: pp_lcfirst() */
3797
3798 PP(pp_ucfirst)
3799 {
3800     /* Actually is both lcfirst() and ucfirst().  Only the first character
3801      * changes.  This means that possibly we can change in-place, ie., just
3802      * take the source and change that one character and store it back, but not
3803      * if read-only etc, or if the length changes */
3804
3805     dSP;
3806     SV *source = TOPs;
3807     STRLEN slen; /* slen is the byte length of the whole SV. */
3808     STRLEN need;
3809     SV *dest;
3810     bool inplace;   /* ? Convert first char only, in-place */
3811     bool doing_utf8 = FALSE;               /* ? using utf8 */
3812     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3813     const int op_type = PL_op->op_type;
3814     const U8 *s;
3815     U8 *d;
3816     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3817     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3818                      * stored as UTF-8 at s. */
3819     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3820                      * lowercased) character stored in tmpbuf.  May be either
3821                      * UTF-8 or not, but in either case is the number of bytes */
3822
3823     s = (const U8*)SvPV_const(source, slen);
3824
3825     /* We may be able to get away with changing only the first character, in
3826      * place, but not if read-only, etc.  Later we may discover more reasons to
3827      * not convert in-place. */
3828     inplace = !SvREADONLY(source) && SvPADTMP(source);
3829
3830     /* First calculate what the changed first character should be.  This affects
3831      * whether we can just swap it out, leaving the rest of the string unchanged,
3832      * or even if have to convert the dest to UTF-8 when the source isn't */
3833
3834     if (! slen) {   /* If empty */
3835         need = 1; /* still need a trailing NUL */
3836         ulen = 0;
3837     }
3838     else if (DO_UTF8(source)) { /* Is the source utf8? */
3839         doing_utf8 = TRUE;
3840         ulen = UTF8SKIP(s);
3841         if (op_type == OP_UCFIRST) {
3842 #ifdef USE_LOCALE_CTYPE
3843             _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3844 #else
3845             _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3846 #endif
3847         }
3848         else {
3849 #ifdef USE_LOCALE_CTYPE
3850             _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3851 #else
3852             _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3853 #endif
3854         }
3855
3856         /* we can't do in-place if the length changes.  */
3857         if (ulen != tculen) inplace = FALSE;
3858         need = slen + 1 - ulen + tculen;
3859     }
3860     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3861             * latin1 is treated as caseless.  Note that a locale takes
3862             * precedence */ 
3863         ulen = 1;       /* Original character is 1 byte */
3864         tculen = 1;     /* Most characters will require one byte, but this will
3865                          * need to be overridden for the tricky ones */
3866         need = slen + 1;
3867
3868         if (op_type == OP_LCFIRST) {
3869
3870             /* lower case the first letter: no trickiness for any character */
3871 #ifdef USE_LOCALE_CTYPE
3872             if (IN_LC_RUNTIME(LC_CTYPE)) {
3873                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3874                 *tmpbuf = toLOWER_LC(*s);
3875             }
3876             else
3877 #endif
3878             {
3879                 *tmpbuf = (IN_UNI_8_BIT)
3880                           ? toLOWER_LATIN1(*s)
3881                           : toLOWER(*s);
3882             }
3883         }
3884 #ifdef USE_LOCALE_CTYPE
3885         /* is ucfirst() */
3886         else if (IN_LC_RUNTIME(LC_CTYPE)) {
3887             if (IN_UTF8_CTYPE_LOCALE) {
3888                 goto do_uni_rules;
3889             }
3890
3891             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3892             *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3893                                               locales have upper and title case
3894                                               different */
3895         }
3896 #endif
3897         else if (! IN_UNI_8_BIT) {
3898             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3899                                          * on EBCDIC machines whatever the
3900                                          * native function does */
3901         }
3902         else {
3903             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3904              * UTF-8, which we treat as not in locale), and cased latin1 */
3905             UV title_ord;
3906 #ifdef USE_LOCALE_CTYPE
3907       do_uni_rules:
3908 #endif
3909
3910             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3911             if (tculen > 1) {
3912                 assert(tculen == 2);
3913
3914                 /* If the result is an upper Latin1-range character, it can
3915                  * still be represented in one byte, which is its ordinal */
3916                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3917                     *tmpbuf = (U8) title_ord;
3918                     tculen = 1;
3919                 }
3920                 else {
3921                     /* Otherwise it became more than one ASCII character (in
3922                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3923                      * beyond Latin1, so the number of bytes changed, so can't
3924                      * replace just the first character in place. */
3925                     inplace = FALSE;
3926
3927                     /* If the result won't fit in a byte, the entire result
3928                      * will have to be in UTF-8.  Assume worst case sizing in
3929                      * conversion. (all latin1 characters occupy at most two
3930                      * bytes in utf8) */
3931                     if (title_ord > 255) {
3932                         doing_utf8 = TRUE;
3933                         convert_source_to_utf8 = TRUE;
3934                         need = slen * 2 + 1;
3935
3936                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3937                          * (both) characters whose title case is above 255 is
3938                          * 2. */
3939                         ulen = 2;
3940                     }
3941                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3942                         need = slen + 1 + 1;
3943                     }
3944                 }
3945             }
3946         } /* End of use Unicode (Latin1) semantics */
3947     } /* End of changing the case of the first character */
3948
3949     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3950      * generate the result */
3951     if (inplace) {
3952
3953         /* We can convert in place.  This means we change just the first
3954          * character without disturbing the rest; no need to grow */
3955         dest = source;
3956         s = d = (U8*)SvPV_force_nomg(source, slen);
3957     } else {
3958         dTARGET;
3959
3960         dest = TARG;
3961
3962         /* Here, we can't convert in place; we earlier calculated how much
3963          * space we will need, so grow to accommodate that */
3964         SvUPGRADE(dest, SVt_PV);
3965         d = (U8*)SvGROW(dest, need);
3966         (void)SvPOK_only(dest);
3967
3968         SETs(dest);
3969     }
3970
3971     if (doing_utf8) {
3972         if (! inplace) {
3973             if (! convert_source_to_utf8) {
3974
3975                 /* Here  both source and dest are in UTF-8, but have to create
3976                  * the entire output.  We initialize the result to be the
3977                  * title/lower cased first character, and then append the rest
3978                  * of the string. */
3979                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3980                 if (slen > ulen) {
3981                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3982                 }
3983             }
3984             else {
3985                 const U8 *const send = s + slen;
3986
3987                 /* Here the dest needs to be in UTF-8, but the source isn't,
3988                  * except we earlier UTF-8'd the first character of the source
3989                  * into tmpbuf.  First put that into dest, and then append the
3990                  * rest of the source, converting it to UTF-8 as we go. */
3991
3992                 /* Assert tculen is 2 here because the only two characters that
3993                  * get to this part of the code have 2-byte UTF-8 equivalents */
3994                 *d++ = *tmpbuf;
3995                 *d++ = *(tmpbuf + 1);
3996                 s++;    /* We have just processed the 1st char */
3997
3998                 for (; s < send; s++) {
3999                     d = uvchr_to_utf8(d, *s);
4000                 }
4001                 *d = '\0';
4002                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4003             }
4004             SvUTF8_on(dest);
4005         }
4006         else {   /* in-place UTF-8.  Just overwrite the first character */
4007             Copy(tmpbuf, d, tculen, U8);
4008             SvCUR_set(dest, need - 1);
4009         }
4010
4011     }
4012     else {  /* Neither source nor dest are in or need to be UTF-8 */
4013         if (slen) {
4014             if (inplace) {  /* in-place, only need to change the 1st char */
4015                 *d = *tmpbuf;
4016             }
4017             else {      /* Not in-place */
4018
4019                 /* Copy the case-changed character(s) from tmpbuf */
4020                 Copy(tmpbuf, d, tculen, U8);
4021                 d += tculen - 1; /* Code below expects d to point to final
4022                                   * character stored */
4023             }
4024         }
4025         else {  /* empty source */
4026             /* See bug #39028: Don't taint if empty  */
4027             *d = *s;
4028         }
4029
4030         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4031          * the destination to retain that flag */
4032         if (SvUTF8(source) && ! IN_BYTES)
4033             SvUTF8_on(dest);
4034
4035         if (!inplace) { /* Finish the rest of the string, unchanged */
4036             /* This will copy the trailing NUL  */
4037             Copy(s + 1, d + 1, slen, U8);
4038             SvCUR_set(dest, need - 1);
4039         }
4040     }
4041 #ifdef USE_LOCALE_CTYPE
4042     if (IN_LC_RUNTIME(LC_CTYPE)) {
4043         TAINT;
4044         SvTAINTED_on(dest);
4045     }
4046 #endif
4047     if (dest != source && SvTAINTED(source))
4048         SvTAINT(dest);
4049     SvSETMAGIC(dest);
4050     return NORMAL;
4051 }
4052
4053 /* There's so much setup/teardown code common between uc and lc, I wonder if
4054    it would be worth merging the two, and just having a switch outside each
4055    of the three tight loops.  There is less and less commonality though */
4056 PP(pp_uc)
4057 {
4058     dSP;
4059     SV *source = TOPs;
4060     STRLEN len;
4061     STRLEN min;
4062     SV *dest;
4063     const U8 *s;
4064     U8 *d;
4065
4066     SvGETMAGIC(source);
4067
4068     if (   SvPADTMP(source)
4069         && !SvREADONLY(source) && SvPOK(source)
4070         && !DO_UTF8(source)
4071         && (
4072 #ifdef USE_LOCALE_CTYPE
4073             (IN_LC_RUNTIME(LC_CTYPE))
4074             ? ! IN_UTF8_CTYPE_LOCALE
4075             :
4076 #endif
4077               ! IN_UNI_8_BIT))
4078     {
4079
4080         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4081          * make the loop tight, so we overwrite the source with the dest before
4082          * looking at it, and we need to look at the original source
4083          * afterwards.  There would also need to be code added to handle
4084          * switching to not in-place in midstream if we run into characters
4085          * that change the length.  Since being in locale overrides UNI_8_BIT,
4086          * that latter becomes irrelevant in the above test; instead for
4087          * locale, the size can't normally change, except if the locale is a
4088          * UTF-8 one */
4089         dest = source;
4090         s = d = (U8*)SvPV_force_nomg(source, len);
4091         min = len + 1;
4092     } else {
4093         dTARGET;
4094
4095         dest = TARG;
4096
4097         s = (const U8*)SvPV_nomg_const(source, len);
4098         min = len + 1;
4099
4100         SvUPGRADE(dest, SVt_PV);
4101         d = (U8*)SvGROW(dest, min);
4102         (void)SvPOK_only(dest);
4103
4104         SETs(dest);
4105     }
4106
4107     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4108        to check DO_UTF8 again here.  */
4109
4110     if (DO_UTF8(source)) {
4111         const U8 *const send = s + len;
4112         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4113
4114         /* All occurrences of these are to be moved to follow any other marks.
4115          * This is context-dependent.  We may not be passed enough context to
4116          * move the iota subscript beyond all of them, but we do the best we can
4117          * with what we're given.  The result is always better than if we
4118          * hadn't done this.  And, the problem would only arise if we are
4119          * passed a character without all its combining marks, which would be
4120          * the caller's mistake.  The information this is based on comes from a
4121          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4122          * itself) and so can't be checked properly to see if it ever gets
4123          * revised.  But the likelihood of it changing is remote */
4124         bool in_iota_subscript = FALSE;
4125
4126         while (s < send) {
4127             STRLEN u;
4128             STRLEN ulen;
4129             UV uv;
4130             if (in_iota_subscript && ! _is_utf8_mark(s)) {
4131
4132                 /* A non-mark.  Time to output the iota subscript */
4133                 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4134                 d += capital_iota_len;
4135                 in_iota_subscript = FALSE;
4136             }
4137
4138             /* Then handle the current character.  Get the changed case value
4139              * and copy it to the output buffer */
4140
4141             u = UTF8SKIP(s);
4142 #ifdef USE_LOCALE_CTYPE
4143             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4144 #else
4145             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
4146 #endif
4147 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4148 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4149             if (uv == GREEK_CAPITAL_LETTER_IOTA
4150                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4151             {
4152                 in_iota_subscript = TRUE;
4153             }
4154             else {
4155                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4156                     /* If the eventually required minimum size outgrows the
4157                      * available space, we need to grow. */
4158                     const UV o = d - (U8*)SvPVX_const(dest);
4159
4160                     /* If someone uppercases one million U+03B0s we SvGROW()
4161                      * one million times.  Or we could try guessing how much to
4162                      * allocate without allocating too much.  Such is life.
4163                      * See corresponding comment in lc code for another option
4164                      * */
4165                     SvGROW(dest, min);
4166                     d = (U8*)SvPVX(dest) + o;
4167                 }
4168                 Copy(tmpbuf, d, ulen, U8);
4169                 d += ulen;
4170             }
4171             s += u;
4172         }
4173         if (in_iota_subscript) {
4174             Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4175             d += capital_iota_len;
4176         }
4177         SvUTF8_on(dest);
4178         *d = '\0';
4179
4180         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4181     }
4182     else {      /* Not UTF-8 */
4183         if (len) {
4184             const U8 *const send = s + len;
4185
4186             /* Use locale casing if in locale; regular style if not treating
4187              * latin1 as having case; otherwise the latin1 casing.  Do the
4188              * whole thing in a tight loop, for speed, */
4189 #ifdef USE_LOCALE_CTYPE
4190             if (IN_LC_RUNTIME(LC_CTYPE)) {
4191                 if (IN_UTF8_CTYPE_LOCALE) {
4192                     goto do_uni_rules;
4193                 }
4194                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4195                 for (; s < send; d++, s++)
4196                     *d = (U8) toUPPER_LC(*s);
4197             }
4198             else
4199 #endif
4200                  if (! IN_UNI_8_BIT) {
4201                 for (; s < send; d++, s++) {
4202                     *d = toUPPER(*s);
4203                 }
4204             }
4205             else {
4206 #ifdef USE_LOCALE_CTYPE
4207           do_uni_rules:
4208 #endif
4209                 for (; s < send; d++, s++) {
4210                     *d = toUPPER_LATIN1_MOD(*s);
4211                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4212                         continue;
4213                     }
4214
4215                     /* The mainstream case is the tight loop above.  To avoid
4216                      * extra tests in that, all three characters that require
4217                      * special handling are mapped by the MOD to the one tested
4218                      * just above.  
4219                      * Use the source to distinguish between the three cases */
4220
4221 #if    UNICODE_MAJOR_VERSION > 2                                        \
4222    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4223                                   && UNICODE_DOT_DOT_VERSION >= 8)
4224                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4225
4226                         /* uc() of this requires 2 characters, but they are
4227                          * ASCII.  If not enough room, grow the string */
4228                         if (SvLEN(dest) < ++min) {      
4229                             const UV o = d - (U8*)SvPVX_const(dest);
4230                             SvGROW(dest, min);
4231                             d = (U8*)SvPVX(dest) + o;
4232                         }
4233                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4234                         continue;   /* Back to the tight loop; still in ASCII */
4235                     }
4236 #endif
4237
4238                     /* The other two special handling characters have their
4239                      * upper cases outside the latin1 range, hence need to be
4240                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4241                      * here we are somewhere in the middle of processing a
4242                      * non-UTF-8 string, and realize that we will have to convert
4243                      * the whole thing to UTF-8.  What to do?  There are
4244                      * several possibilities.  The simplest to code is to
4245                      * convert what we have so far, set a flag, and continue on
4246                      * in the loop.  The flag would be tested each time through
4247                      * the loop, and if set, the next character would be
4248                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4249                      * to slow down the mainstream case at all for this fairly
4250                      * rare case, so I didn't want to add a test that didn't
4251                      * absolutely have to be there in the loop, besides the
4252                      * possibility that it would get too complicated for
4253                      * optimizers to deal with.  Another possibility is to just
4254                      * give up, convert the source to UTF-8, and restart the
4255                      * function that way.  Another possibility is to convert
4256                      * both what has already been processed and what is yet to
4257                      * come separately to UTF-8, then jump into the loop that
4258                      * handles UTF-8.  But the most efficient time-wise of the
4259                      * ones I could think of is what follows, and turned out to
4260                      * not require much extra code.  */
4261
4262                     /* Convert what we have so far into UTF-8, telling the
4263                      * function that we know it should be converted, and to
4264                      * allow extra space for what we haven't processed yet.
4265                      * Assume the worst case space requirements for converting
4266                      * what we haven't processed so far: that it will require
4267                      * two bytes for each remaining source character, plus the
4268                      * NUL at the end.  This may cause the string pointer to
4269                      * move, so re-find it. */
4270
4271                     len = d - (U8*)SvPVX_const(dest);
4272                     SvCUR_set(dest, len);
4273                     len = sv_utf8_upgrade_flags_grow(dest,
4274                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4275                                                 (send -s) * 2 + 1);
4276                     d = (U8*)SvPVX(dest) + len;
4277
4278                     /* Now process the remainder of the source, converting to
4279                      * upper and UTF-8.  If a resulting byte is invariant in
4280                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4281                      * append it to the output. */
4282                     for (; s < send; s++) {
4283                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
4284                         d += len;
4285                     }
4286
4287                     /* Here have processed the whole source; no need to continue
4288                      * with the outer loop.  Each character has been converted
4289                      * to upper case and converted to UTF-8 */
4290
4291                     break;
4292                 } /* End of processing all latin1-style chars */
4293             } /* End of processing all chars */
4294         } /* End of source is not empty */
4295
4296         if (source != dest) {
4297             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4298             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4299         }
4300     } /* End of isn't utf8 */
4301 #ifdef USE_LOCALE_CTYPE
4302     if (IN_LC_RUNTIME(LC_CTYPE)) {
4303         TAINT;
4304         SvTAINTED_on(dest);
4305     }
4306 #endif
4307     if (dest != source && SvTAINTED(source))
4308         SvTAINT(dest);
4309     SvSETMAGIC(dest);
4310     return NORMAL;
4311 }
4312
4313 PP(pp_lc)
4314 {
4315     dSP;
4316     SV *source = TOPs;
4317     STRLEN len;
4318     STRLEN min;
4319     SV *dest;
4320     const U8 *s;
4321     U8 *d;
4322
4323     SvGETMAGIC(source);
4324
4325     if (   SvPADTMP(source)
4326         && !SvREADONLY(source) && SvPOK(source)
4327         && !DO_UTF8(source)) {
4328
4329         /* We can convert in place, as lowercasing anything in the latin1 range
4330          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4331         dest = source;
4332         s = d = (U8*)SvPV_force_nomg(source, len);
4333         min = len + 1;
4334     } else {
4335         dTARGET;
4336
4337         dest = TARG;
4338
4339         s = (const U8*)SvPV_nomg_const(source, len);
4340         min = len + 1;
4341
4342         SvUPGRADE(dest, SVt_PV);
4343         d = (U8*)SvGROW(dest, min);
4344         (void)SvPOK_only(dest);
4345
4346         SETs(dest);
4347     }
4348
4349     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4350        to check DO_UTF8 again here.  */
4351
4352     if (DO_UTF8(source)) {
4353         const U8 *const send = s + len;
4354         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4355
4356         while (s < send) {
4357             const STRLEN u = UTF8SKIP(s);
4358             STRLEN ulen;
4359
4360 #ifdef USE_LOCALE_CTYPE
4361             _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4362 #else
4363             _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4364 #endif
4365
4366             /* Here is where we would do context-sensitive actions.  See the
4367              * commit message for 86510fb15 for why there isn't any */
4368
4369             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4370
4371                 /* If the eventually required minimum size outgrows the
4372                  * available space, we need to grow. */
4373                 const UV o = d - (U8*)SvPVX_const(dest);
4374
4375                 /* If someone lowercases one million U+0130s we SvGROW() one
4376                  * million times.  Or we could try guessing how much to
4377                  * allocate without allocating too much.  Such is life.
4378                  * Another option would be to grow an extra byte or two more
4379                  * each time we need to grow, which would cut down the million
4380                  * to 500K, with little waste */
4381                 SvGROW(dest, min);
4382                 d = (U8*)SvPVX(dest) + o;
4383             }
4384
4385             /* Copy the newly lowercased letter to the output buffer we're
4386              * building */
4387             Copy(tmpbuf, d, ulen, U8);
4388             d += ulen;
4389             s += u;
4390         }   /* End of looping through the source string */
4391         SvUTF8_on(dest);
4392         *d = '\0';
4393         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4394     } else {    /* Not utf8 */
4395         if (len) {
4396             const U8 *const send = s + len;
4397
4398             /* Use locale casing if in locale; regular style if not treating
4399              * latin1 as having case; otherwise the latin1 casing.  Do the
4400              * whole thing in a tight loop, for speed, */
4401 #ifdef USE_LOCALE_CTYPE
4402             if (IN_LC_RUNTIME(LC_CTYPE)) {
4403                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4404                 for (; s < send; d++, s++)
4405                     *d = toLOWER_LC(*s);
4406             }
4407             else
4408 #endif
4409             if (! IN_UNI_8_BIT) {
4410                 for (; s < send; d++, s++) {
4411                     *d = toLOWER(*s);
4412                 }
4413             }
4414             else {
4415                 for (; s < send; d++, s++) {
4416                     *d = toLOWER_LATIN1(*s);
4417                 }
4418             }
4419         }
4420         if (source != dest) {
4421             *d = '\0';
4422             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4423         }
4424     }
4425 #ifdef USE_LOCALE_CTYPE
4426     if (IN_LC_RUNTIME(LC_CTYPE)) {
4427         TAINT;
4428         SvTAINTED_on(dest);
4429     }
4430 #endif
4431     if (dest != source && SvTAINTED(source))
4432         SvTAINT(dest);
4433     SvSETMAGIC(dest);
4434     return NORMAL;
4435 }
4436
4437 PP(pp_quotemeta)
4438 {
4439     dSP; dTARGET;
4440     SV * const sv = TOPs;
4441     STRLEN len;
4442     const char *s = SvPV_const(sv,len);
4443
4444     SvUTF8_off(TARG);                           /* decontaminate */
4445     if (len) {
4446         char *d;
4447         SvUPGRADE(TARG, SVt_PV);
4448         SvGROW(TARG, (len * 2) + 1);
4449         d = SvPVX(TARG);
4450         if (DO_UTF8(sv)) {
4451             while (len) {
4452                 STRLEN ulen = UTF8SKIP(s);
4453                 bool to_quote = FALSE;
4454
4455                 if (UTF8_IS_INVARIANT(*s)) {
4456                     if (_isQUOTEMETA(*s)) {
4457                         to_quote = TRUE;
4458                     }
4459                 }
4460                 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4461                     if (
4462 #ifdef USE_LOCALE_CTYPE
4463                     /* In locale, we quote all non-ASCII Latin1 chars.
4464                      * Otherwise use the quoting rules */
4465                     
4466                     IN_LC_RUNTIME(LC_CTYPE)
4467                         ||
4468 #endif
4469                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4470                     {
4471                         to_quote = TRUE;
4472                     }
4473                 }
4474                 else if (is_QUOTEMETA_high(s)) {
4475                     to_quote = TRUE;
4476                 }
4477
4478                 if (to_quote) {
4479                     *d++ = '\\';
4480                 }
4481                 if (ulen > len)
4482                     ulen = len;
4483                 len -= ulen;
4484                 while (ulen--)
4485                     *d++ = *s++;
4486             }
4487             SvUTF8_on(TARG);
4488         }
4489         else if (IN_UNI_8_BIT) {
4490             while (len--) {
4491                 if (_isQUOTEMETA(*s))
4492                     *d++ = '\\';
4493                 *d++ = *s++;
4494             }
4495         }
4496         else {
4497             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4498              * including everything above ASCII */
4499             while (len--) {
4500                 if (!isWORDCHAR_A(*s))
4501                     *d++ = '\\';
4502                 *d++ = *s++;
4503             }
4504         }
4505         *d = '\0';
4506         SvCUR_set(TARG, d - SvPVX_const(TARG));
4507         (void)SvPOK_only_UTF8(TARG);
4508     }
4509     else
4510         sv_setpvn(TARG, s, len);
4511     SETTARG;
4512     return NORMAL;
4513 }
4514
4515 PP(pp_fc)
4516 {
4517     dTARGET;
4518     dSP;
4519     SV *source = TOPs;
4520     STRLEN len;
4521     STRLEN min;
4522     SV *dest;
4523     const U8 *s;
4524     const U8 *send;
4525     U8 *d;
4526     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4527 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4528    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4529                                       || UNICODE_DOT_DOT_VERSION > 0)
4530     const bool full_folding = TRUE; /* This variable is here so we can easily
4531                                        move to more generality later */
4532 #else
4533     const bool full_folding = FALSE;
4534 #endif
4535     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4536 #ifdef USE_LOCALE_CTYPE
4537                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4538 #endif
4539     ;
4540
4541     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4542      * You are welcome(?) -Hugmeir
4543      */
4544
4545     SvGETMAGIC(source);
4546
4547     dest = TARG;
4548
4549     if (SvOK(source)) {
4550         s = (const U8*)SvPV_nomg_const(source, len);
4551     } else {
4552         if (ckWARN(WARN_UNINITIALIZED))
4553             report_uninit(source);
4554         s = (const U8*)"";
4555         len = 0;
4556     }
4557
4558     min = len + 1;
4559
4560     SvUPGRADE(dest, SVt_PV);
4561     d = (U8*)SvGROW(dest, min);
4562     (void)SvPOK_only(dest);
4563
4564     SETs(dest);
4565
4566     send = s + len;
4567     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4568         while (s < send) {
4569             const STRLEN u = UTF8SKIP(s);
4570             STRLEN ulen;
4571
4572             _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4573
4574             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4575                 const UV o = d - (U8*)SvPVX_const(dest);
4576                 SvGROW(dest, min);
4577                 d = (U8*)SvPVX(dest) + o;
4578             }
4579
4580             Copy(tmpbuf, d, ulen, U8);
4581             d += ulen;
4582             s += u;
4583         }
4584         SvUTF8_on(dest);
4585     } /* Unflagged string */
4586     else if (len) {
4587 #ifdef USE_LOCALE_CTYPE
4588         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4589             if (IN_UTF8_CTYPE_LOCALE) {
4590                 goto do_uni_folding;
4591             }
4592             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4593             for (; s < send; d++, s++)
4594                 *d = (U8) toFOLD_LC(*s);
4595         }
4596         else
4597 #endif
4598         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4599             for (; s < send; d++, s++)
4600                 *d = toFOLD(*s);
4601         }
4602         else {
4603 #ifdef USE_LOCALE_CTYPE
4604       do_uni_folding:
4605 #endif
4606             /* For ASCII and the Latin-1 range, there's only two troublesome
4607              * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4608              * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4609              * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4610              * For the rest, the casefold is their lowercase.  */
4611             for (; s < send; d++, s++) {
4612                 if (*s == MICRO_SIGN) {
4613                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4614                      * which is outside of the latin-1 range. There's a couple
4615                      * of ways to deal with this -- khw discusses them in
4616                      * pp_lc/uc, so go there :) What we do here is upgrade what
4617                      * we had already casefolded, then enter an inner loop that
4618                      * appends the rest of the characters as UTF-8. */
4619                     len = d - (U8*)SvPVX_const(dest);
4620                     SvCUR_set(dest, len);
4621                     len = sv_utf8_upgrade_flags_grow(dest,
4622                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4623                                                 /* The max expansion for latin1
4624                                                  * chars is 1 byte becomes 2 */
4625                                                 (send -s) * 2 + 1);
4626                     d = (U8*)SvPVX(dest) + len;
4627
4628                     Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4629                     d += small_mu_len;
4630                     s++;
4631                     for (; s < send; s++) {
4632                         STRLEN ulen;
4633                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4634                         if UVCHR_IS_INVARIANT(fc) {
4635                             if (full_folding
4636                                 && *s == LATIN_SMALL_LETTER_SHARP_S)
4637                             {
4638                                 *d++ = 's';
4639                                 *d++ = 's';
4640                             }
4641                             else
4642                                 *d++ = (U8)fc;
4643                         }
4644                         else {
4645                             Copy(tmpbuf, d, ulen, U8);
4646                             d += ulen;
4647                         }
4648                     }
4649                     break;
4650                 }
4651                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4652                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4653                      * becomes "ss", which may require growing the SV. */
4654                     if (SvLEN(dest) < ++min) {
4655                         const UV o = d - (U8*)SvPVX_const(dest);
4656                         SvGROW(dest, min);
4657                         d = (U8*)SvPVX(dest) + o;
4658                      }
4659                     *(d)++ = 's';
4660                     *d = 's';
4661                 }
4662                 else { /* If it's not one of those two, the fold is their lower
4663                           case */
4664                     *d = toLOWER_LATIN1(*s);
4665                 }
4666              }
4667         }
4668     }
4669     *d = '\0';
4670     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4671
4672 #ifdef USE_LOCALE_CTYPE
4673     if (IN_LC_RUNTIME(LC_CTYPE)) {
4674         TAINT;
4675         SvTAINTED_on(dest);
4676     }
4677 #endif
4678     if (SvTAINTED(source))
4679         SvTAINT(dest);
4680     SvSETMAGIC(dest);
4681     RETURN;
4682 }
4683
4684 /* Arrays. */
4685
4686 PP(pp_aslice)
4687 {
4688     dSP; dMARK; dORIGMARK;
4689     AV *const av = MUTABLE_AV(POPs);
4690     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4691
4692     if (SvTYPE(av) == SVt_PVAV) {
4693         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4694         bool can_preserve = FALSE;
4695
4696         if (localizing) {
4697             MAGIC *mg;
4698             HV *stash;
4699
4700             can_preserve = SvCANEXISTDELETE(av);
4701         }
4702
4703         if (lval && localizing) {
4704             SV **svp;
4705             SSize_t max = -1;
4706             for (svp = MARK + 1; svp <= SP; svp++) {
4707                 const SSize_t elem = SvIV(*svp);
4708                 if (elem > max)
4709                     max = elem;
4710             }
4711             if (max > AvMAX(av))
4712                 av_extend(av, max);
4713         }
4714
4715         while (++MARK <= SP) {
4716             SV **svp;
4717             SSize_t elem = SvIV(*MARK);
4718             bool preeminent = TRUE;
4719
4720             if (localizing && can_preserve) {
4721                 /* If we can determine whether the element exist,
4722                  * Try to preserve the existenceness of a tied array
4723                  * element by using EXISTS and DELETE if possible.
4724                  * Fallback to FETCH and STORE otherwise. */
4725                 preeminent = av_exists(av, elem);
4726             }
4727
4728             svp = av_fetch(av, elem, lval);
4729             if (lval) {
4730                 if (!svp || !*svp)
4731                     DIE(aTHX_ PL_no_aelem, elem);
4732                 if (localizing) {
4733                     if (preeminent)
4734                         save_aelem(av, elem, svp);
4735                     else
4736                         SAVEADELETE(av, elem);
4737                 }
4738             }
4739             *MARK = svp ? *svp : &PL_sv_undef;
4740         }
4741     }
4742     if (GIMME_V != G_ARRAY) {
4743         MARK = ORIGMARK;
4744         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4745         SP = MARK;
4746     }
4747     RETURN;
4748 }
4749
4750 PP(pp_kvaslice)
4751 {
4752     dSP; dMARK;
4753     AV *const av = MUTABLE_AV(POPs);
4754     I32 lval = (PL_op->op_flags & OPf_MOD);
4755     SSize_t items = SP - MARK;
4756
4757     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4758        const I32 flags = is_lvalue_sub();
4759        if (flags) {
4760            if (!(flags & OPpENTERSUB_INARGS))
4761                /* diag_listed_as: Can't modify %s in %s */
4762                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4763            lval = flags;
4764        }
4765     }
4766
4767     MEXTEND(SP,items);
4768     while (items > 1) {
4769         *(MARK+items*2-1) = *(MARK+items);
4770         items--;
4771     }
4772     items = SP-MARK;
4773     SP += items;
4774
4775     while (++MARK <= SP) {
4776         SV **svp;
4777
4778         svp = av_fetch(av, SvIV(*MARK), lval);
4779         if (lval) {
4780             if (!svp || !*svp || *svp == &PL_sv_undef) {
4781                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4782             }
4783             *MARK = sv_mortalcopy(*MARK);
4784         }
4785         *++MARK = svp ? *svp : &PL_sv_undef;
4786     }
4787     if (GIMME_V != G_ARRAY) {
4788         MARK = SP - items*2;
4789         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4790         SP = MARK;
4791     }
4792     RETURN;
4793 }
4794
4795
4796 PP(pp_aeach)
4797 {
4798     dSP;
4799     AV *array = MUTABLE_AV(POPs);
4800     const U8 gimme = GIMME_V;
4801     IV *iterp = Perl_av_iter_p(aTHX_ array);
4802     const IV current = (*iterp)++;
4803
4804     if (current > av_tindex(array)) {
4805         *iterp = 0;
4806         if (gimme == G_SCALAR)
4807             RETPUSHUNDEF;
4808         else
4809             RETURN;
4810     }
4811
4812     EXTEND(SP, 2);
4813     mPUSHi(current);
4814     if (gimme == G_ARRAY) {
4815         SV **const element = av_fetch(array, current, 0);
4816         PUSHs(element ? *element : &PL_sv_undef);
4817     }
4818     RETURN;
4819 }
4820
4821 /* also used for: pp_avalues()*/
4822 PP(pp_akeys)
4823 {
4824     dSP;
4825     AV *array = MUTABLE_AV(POPs);
4826     const U8 gimme = GIMME_V;
4827
4828     *Perl_av_iter_p(aTHX_ array) = 0;
4829
4830     if (gimme == G_SCALAR) {
4831         dTARGET;
4832         PUSHi(av_tindex(array) + 1);
4833     }
4834     else if (gimme == G_ARRAY) {
4835       if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
4836         const I32 flags = is_lvalue_sub();
4837         if (flags && !(flags & OPpENTERSUB_INARGS))
4838             /* diag_listed_as: Can't modify %s in %s */
4839             Perl_croak(aTHX_
4840                       "Can't modify keys on array in list assignment");
4841       }
4842       {
4843         IV n = Perl_av_len(aTHX_ array);
4844         IV i;
4845
4846         EXTEND(SP, n + 1);
4847
4848         if (  PL_op->op_type == OP_AKEYS
4849            || (  PL_op->op_type == OP_AVHVSWITCH
4850               && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS  ))
4851         {
4852             for (i = 0;  i <= n;  i++) {
4853                 mPUSHi(i);
4854             }
4855         }
4856         else {
4857             for (i = 0;  i <= n;  i++) {
4858                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4859                 PUSHs(elem ? *elem : &PL_sv_undef);
4860             }
4861         }
4862       }
4863     }
4864     RETURN;
4865 }
4866
4867 /* Associative arrays. */
4868
4869 PP(pp_each)
4870 {
4871     dSP;
4872     HV * hash = MUTABLE_HV(POPs);
4873     HE *entry;
4874     const U8 gimme = GIMME_V;
4875
4876     entry = hv_iternext(hash);
4877
4878     EXTEND(SP, 2);
4879     if (entry) {
4880         SV* const sv = hv_iterkeysv(entry);
4881         PUSHs(sv);
4882         if (gimme == G_ARRAY) {
4883             SV *val;
4884             val = hv_iterval(hash, entry);
4885             PUSHs(val);
4886         }
4887     }
4888     else if (gimme == G_SCALAR)
4889         RETPUSHUNDEF;
4890
4891     RETURN;
4892 }
4893
4894 STATIC OP *
4895 S_do_delete_local(pTHX)
4896 {
4897     dSP;
4898     const U8 gimme = GIMME_V;
4899     const MAGIC *mg;
4900     HV *stash;
4901     const bool sliced = !!(PL_op->op_private & OPpSLICE);
4902     SV **unsliced_keysv = sliced ? NULL : sp--;
4903     SV * const osv = POPs;
4904     SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4905     dORIGMARK;
4906     const bool tied = SvRMAGICAL(osv)
4907                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4908     const bool can_preserve = SvCANEXISTDELETE(osv);
4909     const U32 type = SvTYPE(osv);
4910     SV ** const end = sliced ? SP : unsliced_keysv;
4911
4912     if (type == SVt_PVHV) {                     /* hash element */
4913             HV * const hv = MUTABLE_HV(osv);
4914             while (++MARK <= end) {
4915                 SV * const keysv = *MARK;
4916                 SV *sv = NULL;
4917                 bool preeminent = TRUE;
4918                 if (can_preserve)
4919                     preeminent = hv_exists_ent(hv, keysv, 0);
4920                 if (tied) {
4921                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4922                     if (he)
4923                         sv = HeVAL(he);
4924                     else
4925                         preeminent = FALSE;
4926                 }
4927                 else {
4928                     sv = hv_delete_ent(hv, keysv, 0, 0);
4929                     if (preeminent)
4930                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4931                 }
4932                 if (preeminent) {
4933                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4934                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4935                     if (tied) {
4936                         *MARK = sv_mortalcopy(sv);
4937                         mg_clear(sv);
4938                     } else
4939                         *MARK = sv;
4940                 }
4941                 else {
4942                     SAVEHDELETE(hv, keysv);
4943                     *MARK = &PL_sv_undef;
4944                 }
4945             }
4946     }
4947     else if (type == SVt_PVAV) {                  /* array element */
4948             if (PL_op->op_flags & OPf_SPECIAL) {
4949                 AV * const av = MUTABLE_AV(osv);
4950                 while (++MARK <= end) {
4951                     SSize_t idx = SvIV(*MARK);
4952                     SV *sv = NULL;
4953                     bool preeminent = TRUE;
4954                     if (can_preserve)
4955                         preeminent = av_exists(av, idx);
4956                     if (tied) {
4957                         SV **svp = av_fetch(av, idx, 1);
4958                         if (svp)
4959                             sv = *svp;
4960                         else
4961                             preeminent = FALSE;
4962                     }
4963                     else {
4964                         sv = av_delete(av, idx, 0);
4965                         if (preeminent)
4966                            SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4967                     }
4968                     if (preeminent) {
4969                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4970                         if (tied) {
4971                             *MARK = sv_mortalcopy(sv);
4972                             mg_clear(sv);
4973                         } else
4974                             *MARK = sv;
4975                     }
4976                     else {
4977                         SAVEADELETE(av, idx);
4978                         *MARK = &PL_sv_undef;
4979                     }
4980                 }
4981             }
4982             else
4983                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4984     }
4985     else
4986             DIE(aTHX_ "Not a HASH reference");
4987     if (sliced) {
4988         if (gimme == G_VOID)
4989             SP = ORIGMARK;
4990         else if (gimme == G_SCALAR) {
4991             MARK = ORIGMARK;
4992             if (SP > MARK)
4993                 *++MARK = *SP;
4994             else
4995                 *++MARK = &PL_sv_undef;
4996             SP = MARK;
4997         }
4998     }
4999     else if (gimme != G_VOID)
5000         PUSHs(*unsliced_keysv);
5001
5002     RETURN;
5003 }
5004
5005 PP(pp_delete)
5006 {
5007     dSP;
5008     U8 gimme;
5009     I32 discard;
5010
5011     if (PL_op->op_private & OPpLVAL_INTRO)
5012         return do_delete_local();
5013
5014     gimme = GIMME_V;
5015     discard = (gimme == G_VOID) ? G_DISCARD : 0;
5016
5017     if (PL_op->op_private & OPpSLICE) {
5018         dMARK; dORIGMARK;
5019         HV * const hv = MUTABLE_HV(POPs);
5020         const U32 hvtype = SvTYPE(hv);
5021         if (hvtype == SVt_PVHV) {                       /* hash element */
5022             while (++MARK <= SP) {
5023                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
5024                 *MARK = sv ? sv : &PL_sv_undef;
5025             }
5026         }
5027         else if (hvtype == SVt_PVAV) {                  /* array element */
5028             if (PL_op->op_flags & OPf_SPECIAL) {
5029                 while (++MARK <= SP) {
5030                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
5031                     *MARK = sv ? sv : &PL_sv_undef;
5032                 }
5033             }
5034         }
5035         else
5036             DIE(aTHX_ "Not a HASH reference");
5037         if (discard)
5038             SP = ORIGMARK;
5039         else if (gimme == G_SCALAR) {
5040             MARK = ORIGMARK;
5041             if (SP > MARK)
5042                 *++MARK = *SP;
5043             else
5044                 *++MARK = &PL_sv_undef;
5045             SP = MARK;
5046         }
5047     }
5048     else {
5049         SV *keysv = POPs;
5050         HV * const hv = MUTABLE_HV(POPs);
5051         SV *sv = NULL;
5052         if (SvTYPE(hv) == SVt_PVHV)
5053             sv = hv_delete_ent(hv, keysv, discard, 0);
5054         else if (SvTYPE(hv) == SVt_PVAV) {
5055             if (PL_op->op_flags & OPf_SPECIAL)
5056                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5057             else
5058                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5059         }
5060         else
5061             DIE(aTHX_ "Not a HASH reference");
5062         if (!sv)
5063             sv = &PL_sv_undef;
5064         if (!discard)
5065             PUSHs(sv);
5066     }
5067     RETURN;
5068 }
5069
5070 PP(pp_exists)
5071 {
5072     dSP;
5073     SV *tmpsv;
5074     HV *hv;
5075
5076     if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5077         GV *gv;
5078         SV * const sv = POPs;
5079         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5080         if (cv)
5081             RETPUSHYES;
5082         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5083             RETPUSHYES;
5084         RETPUSHNO;
5085     }
5086     tmpsv = POPs;
5087     hv = MUTABLE_HV(POPs);
5088     if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5089         if (hv_exists_ent(hv, tmpsv, 0))
5090             RETPUSHYES;
5091     }
5092     else if (SvTYPE(hv) == SVt_PVAV) {
5093         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
5094             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5095                 RETPUSHYES;
5096         }
5097     }
5098     else {
5099         DIE(aTHX_ "Not a HASH reference");
5100     }
5101     RETPUSHNO;
5102 }
5103
5104 PP(pp_hslice)
5105 {
5106     dSP; dMARK; dORIGMARK;
5107     HV * const hv = MUTABLE_HV(POPs);
5108     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5109     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5110     bool can_preserve = FALSE;
5111
5112     if (localizing) {
5113         MAGIC *mg;
5114         HV *stash;
5115
5116         if (SvCANEXISTDELETE(hv))
5117             can_preserve = TRUE;
5118     }
5119
5120     while (++MARK <= SP) {
5121         SV * const keysv = *MARK;
5122         SV **svp;
5123         HE *he;
5124         bool preeminent = TRUE;
5125
5126         if (localizing && can_preserve) {
5127             /* If we can determine whether the element exist,
5128              * try to preserve the existenceness of a tied hash
5129              * element by using EXISTS and DELETE if possible.
5130              * Fallback to FETCH and STORE otherwise. */
5131             preeminent = hv_exists_ent(hv, keysv, 0);
5132         }
5133
5134         he = hv_fetch_ent(hv, keysv, lval, 0);
5135         svp = he ? &HeVAL(he) : NULL;
5136
5137         if (lval) {
5138             if (!svp || !*svp || *svp == &PL_sv_undef) {
5139                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5140             }
5141             if (localizing) {
5142                 if (HvNAME_get(hv) && isGV(*svp))
5143                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5144                 else if (preeminent)
5145                     save_helem_flags(hv, keysv, svp,
5146                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5147                 else
5148                     SAVEHDELETE(hv, keysv);
5149             }
5150         }
5151         *MARK = svp && *svp ? *svp : &PL_sv_undef;
5152     }
5153     if (GIMME_V != G_ARRAY) {
5154         MARK = ORIGMARK;
5155         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5156         SP = MARK;
5157     }
5158     RETURN;
5159 }
5160
5161 PP(pp_kvhslice)
5162 {
5163     dSP; dMARK;
5164     HV * const hv = MUTABLE_HV(POPs);
5165     I32 lval = (PL_op->op_flags & OPf_MOD);
5166     SSize_t items = SP - MARK;
5167
5168     if (PL_op->op_private & OPpMAYBE_LVSUB) {
5169        const I32 flags = is_lvalue_sub();
5170        if (flags) {
5171            if (!(flags & OPpENTERSUB_INARGS))
5172                /* diag_listed_as: Can't modify %s in %s */
5173                Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5174                                  GIMME_V == G_ARRAY ? "list" : "scalar");
5175            lval = flags;
5176        }
5177     }
5178
5179     MEXTEND(SP,items);
5180     while (items > 1) {
5181         *(MARK+items*2-1) = *(MARK+items);
5182         items--;
5183     }
5184     items = SP-MARK;
5185     SP += items;
5186
5187     while (++MARK <= SP) {
5188         SV * const keysv = *MARK;
5189         SV **svp;
5190         HE *he;
5191
5192         he = hv_fetch_ent(hv, keysv, lval, 0);
5193         svp = he ? &HeVAL(he) : NULL;
5194
5195         if (lval) {
5196             if (!svp || !*svp || *svp == &PL_sv_undef) {
5197                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5198             }
5199             *MARK = sv_mortalcopy(*MARK);
5200         }
5201         *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5202     }
5203     if (GIMME_V != G_ARRAY) {
5204         MARK = SP - items*2;
5205         *++MARK = items > 0 ? *SP : &PL_sv_undef;
5206         SP = MARK;
5207     }
5208     RETURN;
5209 }
5210
5211 /* List operators. */
5212
5213 PP(pp_list)
5214 {
5215     I32 markidx = POPMARK;
5216     if (GIMME_V != G_ARRAY) {
5217         SV **mark = PL_stack_base + markidx;
5218         dSP;
5219         if (++MARK <= SP)
5220             *MARK = *SP;                /* unwanted list, return last item */
5221         else
5222             *MARK = &PL_sv_undef;
5223         SP = MARK;
5224         PUTBACK;
5225     }
5226     return NORMAL;
5227 }
5228
5229 PP(pp_lslice)
5230 {
5231     dSP;
5232     SV ** const lastrelem = PL_stack_sp;
5233     SV ** const lastlelem = PL_stack_base + POPMARK;
5234     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5235     SV ** const firstrelem = lastlelem + 1;
5236     const U8 mod = PL_op->op_flags & OPf_MOD;
5237
5238     const I32 max = lastrelem - lastlelem;
5239     SV **lelem;
5240
5241     if (GIMME_V != G_ARRAY) {
5242         if (lastlelem < firstlelem) {
5243             *firstlelem = &PL_sv_undef;
5244         }
5245         else {
5246             I32 ix = SvIV(*lastlelem);
5247             if (ix < 0)
5248                 ix += max;
5249             if (ix < 0 || ix >= max)
5250                 *firstlelem = &PL_sv_undef;
5251             else
5252                 *firstlelem = firstrelem[ix];
5253         }
5254         SP = firstlelem;
5255         RETURN;
5256     }
5257
5258     if (max == 0) {
5259         SP = firstlelem - 1;
5260         RETURN;
5261     }
5262
5263     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5264         I32 ix = SvIV(*lelem);
5265         if (ix < 0)
5266             ix += max;
5267         if (ix < 0 || ix >= max)
5268             *lelem = &PL_sv_undef;
5269         else {
5270             if (!(*lelem = firstrelem[ix]))
5271                 *lelem = &PL_sv_undef;
5272             else if (mod && SvPADTMP(*lelem)) {
5273                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5274             }
5275         }
5276     }
5277     SP = lastlelem;
5278     RETURN;
5279 }
5280
5281 PP(pp_anonlist)
5282 {
5283     dSP; dMARK;
5284     const I32 items = SP - MARK;
5285     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5286     SP = MARK;
5287     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5288             ? newRV_noinc(av) : av);
5289     RETURN;
5290 }
5291
5292 PP(pp_anonhash)
5293 {
5294     dSP; dMARK; dORIGMARK;
5295     HV* const hv = newHV();
5296     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5297                                     ? newRV_noinc(MUTABLE_SV(hv))
5298                                     : MUTABLE_SV(hv) );
5299
5300     while (MARK < SP) {
5301         SV * const key =
5302             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5303         SV *val;
5304         if (MARK < SP)
5305         {
5306             MARK++;
5307             SvGETMAGIC(*MARK);
5308             val = newSV(0);
5309             sv_setsv_nomg(val, *MARK);
5310         }
5311         else
5312         {
5313             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5314             val = newSV(0);
5315         }
5316         (void)hv_store_ent(hv,key,val,0);
5317     }
5318     SP = ORIGMARK;
5319     XPUSHs(retval);
5320     RETURN;
5321 }
5322
5323 PP(pp_splice)
5324 {
5325     dSP; dMARK; dORIGMARK;
5326     int num_args = (SP - MARK);
5327     AV *ary = MUTABLE_AV(*++MARK);
5328     SV **src;
5329     SV **dst;
5330     SSize_t i;
5331     SSize_t offset;
5332     SSize_t length;
5333     SSize_t newlen;
5334     SSize_t after;
5335     SSize_t diff;
5336     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5337
5338     if (mg) {
5339         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5340                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5341                                     sp - mark);
5342     }
5343
5344     SP++;
5345
5346     if (++MARK < SP) {
5347         offset = i = SvIV(*MARK);
5348         if (offset < 0)
5349             offset += AvFILLp(ary) + 1;
5350         if (offset < 0)
5351             DIE(aTHX_ PL_no_aelem, i);
5352         if (++MARK < SP) {
5353             length = SvIVx(*MARK++);
5354             if (length < 0) {
5355                 length += AvFILLp(ary) - offset + 1;
5356                 if (length < 0)
5357                     length = 0;
5358             }
5359         }
5360         else
5361             length = AvMAX(ary) + 1;            /* close enough to infinity */
5362     }
5363     else {
5364         offset = 0;
5365         length = AvMAX(ary) + 1;
5366     }
5367     if (offset > AvFILLp(ary) + 1) {
5368         if (num_args > 2)
5369             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5370         offset = AvFILLp(ary) + 1;
5371     }
5372     after = AvFILLp(ary) + 1 - (offset + length);
5373     if (after < 0) {                            /* not that much array */
5374         length += after;                        /* offset+length now in array */
5375         after = 0;
5376         if (!AvALLOC(ary))
5377             av_extend(ary, 0);
5378     }
5379
5380     /* At this point, MARK .. SP-1 is our new LIST */
5381
5382     newlen = SP - MARK;
5383     diff = newlen - length;
5384     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5385         av_reify(ary);
5386
5387     /* make new elements SVs now: avoid problems if they're from the array */
5388     for (dst = MARK, i = newlen; i; i--) {
5389         SV * const h = *dst;
5390         *dst++ = newSVsv(h);
5391     }
5392
5393     if (diff < 0) {                             /* shrinking the area */
5394         SV **tmparyval = NULL;
5395         if (newlen) {
5396             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5397             Copy(MARK, tmparyval, newlen, SV*);
5398         }
5399
5400         MARK = ORIGMARK + 1;
5401         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5402             const bool real = cBOOL(AvREAL(ary));
5403             MEXTEND(MARK, length);
5404             if (real)
5405                 EXTEND_MORTAL(length);
5406             for (i = 0, dst = MARK; i < length; i++) {
5407                 if ((*dst = AvARRAY(ary)[i+offset])) {
5408                   if (real)
5409                     sv_2mortal(*dst);   /* free them eventually */
5410                 }
5411                 else
5412                     *dst = &PL_sv_undef;
5413                 dst++;
5414             }
5415             MARK += length - 1;
5416         }
5417         else {
5418             *MARK = AvARRAY(ary)[offset+length-1];
5419             if (AvREAL(ary)) {
5420                 sv_2mortal(*MARK);
5421                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5422                     SvREFCNT_dec(*dst++);       /* free them now */
5423             }
5424         }
5425         AvFILLp(ary) += diff;
5426
5427         /* pull up or down? */
5428
5429         if (offset < after) {                   /* easier to pull up */
5430             if (offset) {                       /* esp. if nothing to pull */
5431                 src = &AvARRAY(ary)[offset-1];
5432                 dst = src - diff;               /* diff is negative */
5433                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5434                     *dst-- = *src--;
5435             }
5436             dst = AvARRAY(ary);
5437             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5438             AvMAX(ary) += diff;
5439         }
5440         else {
5441             if (after) {                        /* anything to pull down? */
5442                 src = AvARRAY(ary) + offset + length;
5443                 dst = src + diff;               /* diff is negative */
5444                 Move(src, dst, after, SV*);
5445             }
5446             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5447                                                 /* avoid later double free */
5448         }
5449         i = -diff;
5450         while (i)
5451             dst[--i] = NULL;
5452         
5453         if (newlen) {
5454             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5455             Safefree(tmparyval);
5456         }
5457     }
5458     else {                                      /* no, expanding (or same) */
5459         SV** tmparyval = NULL;
5460         if (length) {
5461             Newx(tmparyval, length, SV*);       /* so remember deletion */
5462             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5463         }
5464
5465         if (diff > 0) {                         /* expanding */
5466             /* push up or down? */
5467             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5468                 if (offset) {
5469                     src = AvARRAY(ary);
5470                     dst = src - diff;
5471                     Move(src, dst, offset, SV*);
5472                 }
5473                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5474                 AvMAX(ary) += diff;
5475                 AvFILLp(ary) += diff;
5476             }
5477             else {
5478                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5479                     av_extend(ary, AvFILLp(ary) + diff);
5480                 AvFILLp(ary) += diff;
5481
5482                 if (after) {
5483                     dst = AvARRAY(ary) + AvFILLp(ary);
5484                     src = dst - diff;
5485                     for (i = after; i; i--) {
5486                         *dst-- = *src--;
5487                     }
5488                 }
5489             }
5490         }
5491
5492         if (newlen) {
5493             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5494         }
5495
5496         MARK = ORIGMARK + 1;
5497         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5498             if (length) {
5499                 const bool real = cBOOL(AvREAL(ary));
5500                 if (real)
5501                     EXTEND_MORTAL(length);
5502                 for (i = 0, dst = MARK; i < length; i++) {
5503                     if ((*dst = tmparyval[i])) {
5504                       if (real)
5505                         sv_2mortal(*dst);       /* free them eventually */
5506                     }
5507                     else *dst = &PL_sv_undef;
5508                     dst++;
5509                 }
5510             }
5511             MARK += length - 1;
5512         }
5513         else if (length--) {
5514             *MARK = tmparyval[length];
5515             if (AvREAL(ary)) {
5516                 sv_2mortal(*MARK);
5517                 while (length-- > 0)
5518                     SvREFCNT_dec(tmparyval[length]);
5519             }
5520         }
5521         else
5522             *MARK = &PL_sv_undef;
5523         Safefree(tmparyval);
5524     }
5525
5526     if (SvMAGICAL(ary))
5527         mg_set(MUTABLE_SV(ary));
5528
5529     SP = MARK;
5530     RETURN;
5531 }
5532
5533 PP(pp_push)
5534 {
5535     dSP; dMARK; dORIGMARK; dTARGET;
5536     AV * const ary = MUTABLE_AV(*++MARK);
5537     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5538
5539     if (mg) {
5540         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5541         PUSHMARK(MARK);
5542         PUTBACK;
5543         ENTER_with_name("call_PUSH");
5544         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5545         LEAVE_with_name("call_PUSH");
5546         /* SPAGAIN; not needed: SP is assigned to immediately below */
5547     }
5548     else {
5549         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5550          * only need to save locally, not on the save stack */
5551         U16 old_delaymagic = PL_delaymagic;
5552
5553         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5554         PL_delaymagic = DM_DELAY;
5555         for (++MARK; MARK <= SP; MARK++) {
5556             SV *sv;
5557             if (*MARK) SvGETMAGIC(*MARK);
5558             sv = newSV(0);
5559             if (*MARK)
5560                 sv_setsv_nomg(sv, *MARK);
5561             av_store(ary, AvFILLp(ary)+1, sv);
5562         }
5563         if (PL_delaymagic & DM_ARRAY_ISA)
5564             mg_set(MUTABLE_SV(ary));
5565         PL_delaymagic = old_delaymagic;
5566     }
5567     SP = ORIGMARK;
5568     if (OP_GIMME(PL_op, 0) != G_VOID) {
5569         PUSHi( AvFILL(ary) + 1 );
5570     }
5571     RETURN;
5572 }
5573
5574 /* also used for: pp_pop()*/
5575 PP(pp_shift)
5576 {
5577     dSP;
5578     AV * const av = PL_op->op_flags & OPf_SPECIAL
5579         ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5580     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5581     EXTEND(SP, 1);
5582     assert (sv);
5583     if (AvREAL(av))
5584         (void)sv_2mortal(sv);
5585     PUSHs(sv);
5586     RETURN;
5587 }
5588
5589 PP(pp_unshift)
5590 {
5591     dSP; dMARK; dORIGMARK; dTARGET;
5592     AV *ary = MUTABLE_AV(*++MARK);
5593     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5594
5595     if (mg) {
5596         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5597         PUSHMARK(MARK);
5598         PUTBACK;
5599         ENTER_with_name("call_UNSHIFT");
5600         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5601         LEAVE_with_name("call_UNSHIFT");
5602         /* SPAGAIN; not needed: SP is assigned to immediately below */
5603     }
5604     else {
5605         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5606          * only need to save locally, not on the save stack */
5607         U16 old_delaymagic = PL_delaymagic;
5608         SSize_t i = 0;
5609
5610         av_unshift(ary, SP - MARK);
5611         PL_delaymagic = DM_DELAY;
5612         while (MARK < SP) {
5613             SV * const sv = newSVsv(*++MARK);
5614             (void)av_store(ary, i++, sv);
5615         }
5616         if (PL_delaymagic & DM_ARRAY_ISA)
5617             mg_set(MUTABLE_SV(ary));
5618         PL_delaymagic = old_delaymagic;
5619     }
5620     SP = ORIGMARK;
5621     if (OP_GIMME(PL_op, 0) != G_VOID) {
5622         PUSHi( AvFILL(ary) + 1 );
5623     }
5624     RETURN;
5625 }
5626
5627 PP(pp_reverse)
5628 {
5629     dSP; dMARK;
5630
5631     if (GIMME_V == G_ARRAY) {
5632         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5633             AV *av;
5634
5635             /* See pp_sort() */
5636             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5637             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5638             av = MUTABLE_AV((*SP));
5639             /* In-place reversing only happens in void context for the array
5640              * assignment. We don't need to push anything on the stack. */
5641             SP = MARK;
5642
5643             if (SvMAGICAL(av)) {
5644                 SSize_t i, j;
5645                 SV *tmp = sv_newmortal();
5646                 /* For SvCANEXISTDELETE */
5647                 HV *stash;
5648                 const MAGIC *mg;
5649                 bool can_preserve = SvCANEXISTDELETE(av);
5650
5651                 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5652                     SV *begin, *end;
5653
5654                     if (can_preserve) {
5655                         if (!av_exists(av, i)) {
5656                             if (av_exists(av, j)) {
5657                                 SV *sv = av_delete(av, j, 0);
5658                                 begin = *av_fetch(av, i, TRUE);
5659                                 sv_setsv_mg(begin, sv);
5660                             }
5661                             continue;
5662                         }
5663                         else if (!av_exists(av, j)) {
5664                             SV *sv = av_delete(av, i, 0);
5665                             end = *av_fetch(av, j, TRUE);
5666                             sv_setsv_mg(end, sv);
5667                             continue;
5668                         }
5669                     }
5670
5671                     begin = *av_fetch(av, i, TRUE);
5672                     end   = *av_fetch(av, j, TRUE);
5673                     sv_setsv(tmp,      begin);
5674                     sv_setsv_mg(begin, end);
5675                     sv_setsv_mg(end,   tmp);
5676                 }
5677             }
5678             else {
5679                 SV **begin = AvARRAY(av);
5680
5681                 if (begin) {
5682                     SV **end   = begin + AvFILLp(av);
5683
5684                     while (begin < end) {
5685                         SV * const tmp = *begin;
5686                         *begin++ = *end;
5687                         *end--   = tmp;
5688                     }
5689                 }
5690             }
5691         }
5692         else {
5693             SV **oldsp = SP;
5694             MARK++;
5695             while (MARK < SP) {
5696                 SV * const tmp = *MARK;
5697                 *MARK++ = *SP;
5698                 *SP--   = tmp;
5699             }
5700             /* safe as long as stack cannot get extended in the above */
5701             SP = oldsp;
5702         }
5703     }
5704     else {
5705         char *up;
5706         char *down;
5707         I32 tmp;
5708         dTARGET;
5709         STRLEN len;
5710
5711         SvUTF8_off(TARG);                               /* decontaminate */
5712         if (SP - MARK > 1)
5713             do_join(TARG, &PL_sv_no, MARK, SP);
5714         else {
5715             sv_setsv(TARG, SP > MARK ? *SP : DEFSV);
5716         }
5717
5718         up = SvPV_force(TARG, len);
5719         if (len > 1) {
5720             if (DO_UTF8(TARG)) {        /* first reverse each character */
5721                 U8* s = (U8*)SvPVX(TARG);
5722                 const U8* send = (U8*)(s + len);
5723                 while (s < send) {
5724                     if (UTF8_IS_INVARIANT(*s)) {
5725                         s++;
5726                         continue;
5727                     }
5728                     else {
5729                         if (!utf8_to_uvchr_buf(s, send, 0))
5730                             break;
5731                         up = (char*)s;
5732                         s += UTF8SKIP(s);
5733                         down = (char*)(s - 1);
5734                         /* reverse this character */
5735                         while (down > up) {
5736                             tmp = *up;
5737                             *up++ = *down;
5738                             *down-- = (char)tmp;
5739                         }
5740                     }
5741                 }
5742                 up = SvPVX(TARG);
5743             }
5744             down = SvPVX(TARG) + len - 1;
5745             while (down > up) {
5746                 tmp = *up;
5747                 *up++ = *down;
5748                 *down-- = (char)tmp;
5749             }
5750             (void)SvPOK_only_UTF8(TARG);
5751         }
5752         SP = MARK + 1;
5753         SETTARG;
5754     }
5755     RETURN;
5756 }
5757
5758 PP(pp_split)
5759 {
5760     dSP; dTARG;
5761     AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
5762     IV limit = POPi;                    /* note, negative is forever */
5763     SV * const sv = POPs;
5764     STRLEN len;
5765     const char *s = SvPV_const(sv, len);
5766     const bool do_utf8 = DO_UTF8(sv);
5767     const char *strend = s + len;
5768     PMOP *pm;
5769     REGEXP *rx;
5770     SV *dstr;
5771     const char *m;
5772     SSize_t iters = 0;
5773     const STRLEN slen = do_utf8
5774                         ? utf8_length((U8*)s, (U8*)strend)
5775                         : (STRLEN)(strend - s);
5776     SSize_t maxiters = slen + 10;
5777     I32 trailing_empty = 0;
5778     const char *orig;
5779     const IV origlimit = limit;
5780     I32 realarray = 0;
5781     I32 base;
5782     const U8 gimme = GIMME_V;
5783     bool gimme_scalar;
5784     const I32 oldsave = PL_savestack_ix;
5785     U32 make_mortal = SVs_TEMP;
5786     bool multiline = 0;
5787     MAGIC *mg = NULL;
5788
5789 #ifdef DEBUGGING
5790     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5791 #else
5792     pm = (PMOP*)POPs;
5793 #endif
5794     if (!pm)
5795         DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5796     rx = PM_GETRE(pm);
5797
5798     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5799              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5800
5801 #ifdef USE_ITHREADS
5802     if (pm->op_pmreplrootu.op_pmtargetoff) {
5803         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5804         goto have_av;
5805     }
5806 #else
5807     if (pm->op_pmreplrootu.op_pmtargetgv) {
5808         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5809         goto have_av;
5810     }
5811 #endif
5812     else if (pm->op_targ)
5813         ary = (AV *)PAD_SVl(pm->op_targ);
5814     if (ary) {
5815         have_av:
5816         realarray = 1;
5817         PUTBACK;
5818         av_extend(ary,0);
5819         (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5820         av_clear(ary);
5821         SPAGAIN;
5822         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5823             PUSHMARK(SP);
5824             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5825         }
5826         else {
5827             if (!AvREAL(ary)) {
5828                 I32 i;
5829                 AvREAL_on(ary);
5830                 AvREIFY_off(ary);
5831                 for (i = AvFILLp(ary); i >= 0; i--)
5832                     AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5833             }
5834             /* temporarily switch stacks */
5835             SAVESWITCHSTACK(PL_curstack, ary);
5836             make_mortal = 0;
5837         }
5838     }
5839     base = SP - PL_stack_base;
5840     orig = s;
5841     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5842         if (do_utf8) {
5843             while (isSPACE_utf8(s))
5844                 s += UTF8SKIP(s);
5845         }
5846         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5847             while (isSPACE_LC(*s))
5848                 s++;
5849         }
5850         else {
5851             while (isSPACE(*s))
5852                 s++;
5853         }
5854     }
5855     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5856         multiline = 1;
5857     }
5858
5859     gimme_scalar = gimme == G_SCALAR && !ary;
5860
5861     if (!limit)
5862         limit = maxiters + 2;
5863     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5864         while (--limit) {
5865             m = s;
5866             /* this one uses 'm' and is a negative test */
5867             if (do_utf8) {
5868                 while (m < strend && ! isSPACE_utf8(m) ) {
5869                     const int t = UTF8SKIP(m);
5870                     /* isSPACE_utf8 returns FALSE for malform utf8 */
5871                     if (strend - m < t)
5872                         m = strend;
5873                     else
5874                         m += t;
5875                 }
5876             }
5877             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5878             {
5879                 while (m < strend && !isSPACE_LC(*m))
5880                     ++m;
5881             } else {
5882                 while (m < strend && !isSPACE(*m))
5883                     ++m;
5884             }  
5885             if (m >= strend)
5886                 break;
5887
5888             if (gimme_scalar) {
5889                 iters++;
5890                 if (m-s == 0)
5891                     trailing_empty++;
5892                 else
5893                     trailing_empty = 0;
5894             } else {
5895                 dstr = newSVpvn_flags(s, m-s,
5896                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5897                 XPUSHs(dstr);
5898             }
5899
5900             /* skip the whitespace found last */
5901             if (do_utf8)
5902                 s = m + UTF8SKIP(m);
5903             else
5904                 s = m + 1;
5905
5906             /* this one uses 's' and is a positive test */
5907             if (do_utf8) {
5908                 while (s < strend && isSPACE_utf8(s) )
5909                     s +=  UTF8SKIP(s);
5910             }
5911             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5912             {
5913                 while (s < strend && isSPACE_LC(*s))
5914                     ++s;
5915             } else {
5916                 while (s < strend && isSPACE(*s))
5917                     ++s;
5918             }       
5919         }
5920     }
5921     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5922         while (--limit) {
5923             for (m = s; m < strend && *m != '\n'; m++)
5924                 ;
5925             m++;
5926             if (m >= strend)
5927                 break;
5928
5929             if (gimme_scalar) {
5930                 iters++;
5931                 if (m-s == 0)
5932                     trailing_empty++;
5933                 else
5934                     trailing_empty = 0;
5935             } else {
5936                 dstr = newSVpvn_flags(s, m-s,
5937                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5938                 XPUSHs(dstr);
5939             }
5940             s = m;
5941         }
5942     }
5943     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5944         /*
5945           Pre-extend the stack, either the number of bytes or
5946           characters in the string or a limited amount, triggered by:
5947
5948           my ($x, $y) = split //, $str;
5949             or
5950           split //, $str, $i;
5951         */
5952         if (!gimme_scalar) {
5953             const IV items = limit - 1;
5954             /* setting it to -1 will trigger a panic in EXTEND() */
5955             const SSize_t sslen = slen > SSize_t_MAX ?  -1 : (SSize_t)slen;
5956             if (items >=0 && items < sslen)
5957                 EXTEND(SP, items);
5958             else
5959                 EXTEND(SP, sslen);
5960         }
5961
5962         if (do_utf8) {
5963             while (--limit) {
5964                 /* keep track of how many bytes we skip over */
5965                 m = s;
5966                 s += UTF8SKIP(s);
5967                 if (gimme_scalar) {
5968                     iters++;
5969                     if (s-m == 0)
5970                         trailing_empty++;
5971                     else
5972                         trailing_empty = 0;
5973                 } else {
5974                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5975
5976                     PUSHs(dstr);
5977                 }
5978
5979                 if (s >= strend)
5980                     break;
5981             }
5982         } else {
5983             while (--limit) {
5984                 if (gimme_scalar) {
5985                     iters++;
5986                 } else {
5987                     dstr = newSVpvn(s, 1);
5988
5989
5990                     if (make_mortal)
5991                         sv_2mortal(dstr);
5992
5993                     PUSHs(dstr);
5994                 }
5995
5996                 s++;
5997
5998                 if (s >= strend)
5999                     break;
6000             }
6001         }
6002     }
6003     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6004              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6005              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6006              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6007         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6008         SV * const csv = CALLREG_INTUIT_STRING(rx);
6009
6010         len = RX_MINLENRET(rx);
6011         if (len == 1 && !RX_UTF8(rx) && !tail) {
6012             const char c = *SvPV_nolen_const(csv);
6013             while (--limit) {
6014                 for (m = s; m < strend && *m != c; m++)
6015                     ;
6016                 if (m >= strend)
6017                     break;
6018                 if (gimme_scalar) {
6019                     iters++;
6020                     if (m-s == 0)
6021                         trailing_empty++;
6022                     else
6023                         trailing_empty = 0;
6024                 } else {
6025                     dstr = newSVpvn_flags(s, m-s,
6026                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6027                     XPUSHs(dstr);
6028                 }
6029                 /* The rx->minlen is in characters but we want to step
6030                  * s ahead by bytes. */
6031                 if (do_utf8)
6032                     s = (char*)utf8_hop((U8*)m, len);
6033                 else
6034                     s = m + len; /* Fake \n at the end */
6035             }
6036         }
6037         else {
6038             while (s < strend && --limit &&
6039               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6040                              csv, multiline ? FBMrf_MULTILINE : 0)) )
6041             {
6042                 if (gimme_scalar) {
6043                     iters++;
6044                     if (m-s == 0)
6045                         trailing_empty++;
6046                     else
6047                         trailing_empty = 0;
6048                 } else {
6049                     dstr = newSVpvn_flags(s, m-s,
6050                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6051                     XPUSHs(dstr);
6052                 }
6053                 /* The rx->minlen is in characters but we want to step
6054                  * s ahead by bytes. */
6055                 if (do_utf8)
6056                     s = (char*)utf8_hop((U8*)m, len);
6057                 else
6058                     s = m + len; /* Fake \n at the end */
6059             }
6060         }
6061     }
6062     else {
6063         maxiters += slen * RX_NPARENS(rx);
6064         while (s < strend && --limit)
6065         {
6066             I32 rex_return;
6067             PUTBACK;
6068             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6069                                      sv, NULL, 0);
6070             SPAGAIN;
6071             if (rex_return == 0)
6072                 break;
6073             TAINT_IF(RX_MATCH_TAINTED(rx));
6074             /* we never pass the REXEC_COPY_STR flag, so it should
6075              * never get copied */
6076             assert(!RX_MATCH_COPIED(rx));
6077             m = RX_OFFS(rx)[0].start + orig;
6078
6079             if (gimme_scalar) {
6080                 iters++;
6081                 if (m-s == 0)
6082                     trailing_empty++;
6083                 else
6084                     trailing_empty = 0;
6085             } else {
6086                 dstr = newSVpvn_flags(s, m-s,
6087                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6088                 XPUSHs(dstr);
6089             }
6090             if (RX_NPARENS(rx)) {
6091                 I32 i;
6092                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6093                     s = RX_OFFS(rx)[i].start + orig;
6094                     m = RX_OFFS(rx)[i].end + orig;
6095
6096                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
6097                        parens that didn't match -- they should be set to
6098                        undef, not the empty string */
6099                     if (gimme_scalar) {
6100                         iters++;
6101                         if (m-s == 0)
6102                             trailing_empty++;
6103                         else
6104                             trailing_empty = 0;
6105                     } else {
6106                         if (m >= orig && s >= orig) {
6107                             dstr = newSVpvn_flags(s, m-s,
6108                                                  (do_utf8 ? SVf_UTF8 : 0)
6109                                                   | make_mortal);
6110                         }
6111                         else
6112                             dstr = &PL_sv_undef;  /* undef, not "" */
6113                         XPUSHs(dstr);
6114                     }
6115
6116                 }
6117             }
6118             s = RX_OFFS(rx)[0].end + orig;
6119         }
6120     }
6121
6122     if (!gimme_scalar) {
6123         iters = (SP - PL_stack_base) - base;
6124     }
6125     if (iters > maxiters)
6126         DIE(aTHX_ "Split loop");
6127
6128     /* keep field after final delim? */
6129     if (s < strend || (iters && origlimit)) {
6130         if (!gimme_scalar) {
6131             const STRLEN l = strend - s;
6132             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6133             XPUSHs(dstr);
6134         }
6135         iters++;
6136     }
6137     else if (!origlimit) {
6138         if (gimme_scalar) {
6139             iters -= trailing_empty;
6140         } else {
6141             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6142                 if (TOPs && !make_mortal)
6143                     sv_2mortal(TOPs);
6144                 *SP-- = &PL_sv_undef;
6145                 iters--;
6146             }
6147         }
6148     }
6149
6150     PUTBACK;
6151     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6152     SPAGAIN;
6153     if (realarray) {
6154         if (!mg) {
6155             if (SvSMAGICAL(ary)) {
6156                 PUTBACK;
6157                 mg_set(MUTABLE_SV(ary));
6158                 SPAGAIN;
6159             }
6160             if (gimme == G_ARRAY) {
6161                 EXTEND(SP, iters);
6162                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6163                 SP += iters;
6164                 RETURN;
6165             }
6166         }
6167         else {
6168             PUTBACK;
6169             ENTER_with_name("call_PUSH");
6170             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6171             LEAVE_with_name("call_PUSH");
6172             SPAGAIN;
6173             if (gimme == G_ARRAY) {
6174                 SSize_t i;
6175                 /* EXTEND should not be needed - we just popped them */
6176                 EXTEND(SP, iters);
6177                 for (i=0; i < iters; i++) {
6178                     SV **svp = av_fetch(ary, i, FALSE);
6179                     PUSHs((svp) ? *svp : &PL_sv_undef);
6180                 }
6181                 RETURN;
6182             }
6183         }
6184     }
6185     else {
6186         if (gimme == G_ARRAY)
6187             RETURN;
6188     }
6189
6190     GETTARGET;
6191     PUSHi(iters);
6192     RETURN;
6193 }
6194
6195 PP(pp_once)
6196 {
6197     dSP;
6198     SV *const sv = PAD_SVl(PL_op->op_targ);
6199
6200     if (SvPADSTALE(sv)) {
6201         /* First time. */
6202         SvPADSTALE_off(sv);
6203         RETURNOP(cLOGOP->op_other);
6204     }
6205     RETURNOP(cLOGOP->op_next);
6206 }
6207
6208 PP(pp_lock)
6209 {
6210     dSP;
6211     dTOPss;
6212     SV *retsv = sv;
6213     SvLOCK(sv);
6214     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6215      || SvTYPE(retsv) == SVt_PVCV) {
6216         retsv = refto(retsv);
6217     }
6218     SETs(retsv);
6219     RETURN;
6220 }
6221
6222
6223 /* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
6224  * that aren't implemented on a particular platform */
6225
6226 PP(unimplemented_op)
6227 {
6228     const Optype op_type = PL_op->op_type;
6229     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6230        with out of range op numbers - it only "special" cases op_custom.
6231        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6232        if we get here for a custom op then that means that the custom op didn't
6233        have an implementation. Given that OP_NAME() looks up the custom op
6234        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6235        registers &PL_unimplemented_op as the address of their custom op.
6236        NULL doesn't generate a useful error message. "custom" does. */
6237     const char *const name = op_type >= OP_max
6238         ? "[out of range]" : PL_op_name[PL_op->op_type];
6239     if(OP_IS_SOCKET(op_type))
6240         DIE(aTHX_ PL_no_sock_func, name);
6241     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
6242 }
6243
6244 static void
6245 S_maybe_unwind_defav(pTHX)
6246 {
6247     if (CX_CUR()->cx_type & CXp_HASARGS) {
6248         PERL_CONTEXT *cx = CX_CUR();
6249
6250         assert(CxHASARGS(cx));
6251         cx_popsub_args(cx);
6252         cx->cx_type &= ~CXp_HASARGS;
6253     }
6254 }
6255
6256 /* For sorting out arguments passed to a &CORE:: subroutine */
6257 PP(pp_coreargs)
6258 {
6259     dSP;
6260     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6261     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6262     AV * const at_ = GvAV(PL_defgv);
6263     SV **svp = at_ ? AvARRAY(at_) : NULL;
6264     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6265     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6266     bool seen_question = 0;
6267     const char *err = NULL;
6268     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6269
6270     /* Count how many args there are first, to get some idea how far to
6271        extend the stack. */
6272     while (oa) {
6273         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6274         maxargs++;
6275         if (oa & OA_OPTIONAL) seen_question = 1;
6276         if (!seen_question) minargs++;
6277         oa >>= 4;
6278     }
6279
6280     if(numargs < minargs) err = "Not enough";
6281     else if(numargs > maxargs) err = "Too many";
6282     if (err)
6283         /* diag_listed_as: Too many arguments for %s */
6284         Perl_croak(aTHX_
6285           "%s arguments for %s", err,
6286            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6287         );
6288
6289     /* Reset the stack pointer.  Without this, we end up returning our own
6290        arguments in list context, in addition to the values we are supposed
6291        to return.  nextstate usually does this on sub entry, but we need
6292        to run the next op with the caller's hints, so we cannot have a
6293        nextstate. */
6294     SP = PL_stack_base + CX_CUR()->blk_oldsp;
6295
6296     if(!maxargs) RETURN;
6297
6298     /* We do this here, rather than with a separate pushmark op, as it has
6299        to come in between two things this function does (stack reset and
6300        arg pushing).  This seems the easiest way to do it. */
6301     if (pushmark) {
6302         PUTBACK;
6303         (void)Perl_pp_pushmark(aTHX);
6304     }
6305
6306     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6307     PUTBACK; /* The code below can die in various places. */
6308
6309     oa = PL_opargs[opnum] >> OASHIFT;
6310     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6311         whicharg++;
6312         switch (oa & 7) {
6313         case OA_SCALAR:
6314           try_defsv:
6315             if (!numargs && defgv && whicharg == minargs + 1) {
6316                 PUSHs(DEFSV);
6317             }
6318             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6319             break;
6320         case OA_LIST:
6321             while (numargs--) {
6322                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6323                 svp++;
6324             }
6325             RETURN;
6326         case OA_AVREF:
6327             if (!numargs) {
6328                 GV *gv;
6329                 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6330                     gv = PL_argvgv;
6331                 else {
6332                     S_maybe_unwind_defav(aTHX);
6333                     gv = PL_defgv;
6334                 }
6335                 PUSHs((SV *)GvAVn(gv));
6336                 break;
6337             }
6338             if (!svp || !*svp || !SvROK(*svp)
6339              || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6340                 DIE(aTHX_
6341                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6342                  "Type of arg %d to &CORE::%s must be array reference",
6343                   whicharg, PL_op_desc[opnum]
6344                 );
6345             PUSHs(SvRV(*svp));
6346             break;
6347         case OA_HVREF:
6348             if (!svp || !*svp || !SvROK(*svp)
6349              || (  SvTYPE(SvRV(*svp)) != SVt_PVHV
6350                 && (  opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6351                    || SvTYPE(SvRV(*svp)) != SVt_PVAV  )))
6352                 DIE(aTHX_
6353                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6354                  "Type of arg %d to &CORE::%s must be hash%s reference",
6355                   whicharg, PL_op_desc[opnum],
6356                   opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6357                      ? ""
6358                      : " or array"
6359                 );
6360             PUSHs(SvRV(*svp));
6361             break;
6362         case OA_FILEREF:
6363             if (!numargs) PUSHs(NULL);
6364             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6365                 /* no magic here, as the prototype will have added an extra
6366                    refgen and we just want what was there before that */
6367                 PUSHs(SvRV(*svp));
6368             else {
6369                 const bool constr = PL_op->op_private & whicharg;
6370                 PUSHs(S_rv2gv(aTHX_
6371                     svp && *svp ? *svp : &PL_sv_undef,
6372