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