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