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