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