Remove very obsolete comment
[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 0
1699               /* This code was intended to fix 20010809.028:
1700
1701                  $x = 'abcd';
1702                  for (($x =~ /./g) x 2) {
1703                      print chop; # "abcdabcd" expected as output.
1704                  }
1705
1706                * but that change (#11635) broke this code:
1707
1708                $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1709
1710                * I can't think of a better fix that doesn't introduce
1711                * an efficiency hit by copying the SVs. The stack isn't
1712                * refcounted, and mortalisation obviously doesn't
1713                * Do The Right Thing when the stack has more than
1714                * one pointer to the same mortal value.
1715                * .robin.
1716                */
1717                 if (*SP) {
1718                     *SP = sv_2mortal(newSVsv(*SP));
1719                     SvREADONLY_on(*SP);
1720                 }
1721 #else
1722                 if (*SP) {
1723                    if (mod && SvPADTMP(*SP)) {
1724                        *SP = sv_mortalcopy(*SP);
1725                    }
1726                    SvTEMP_off((*SP));
1727                 }
1728 #endif
1729                 SP--;
1730             }
1731             MARK++;
1732             repeatcpy((char*)(MARK + items), (char*)MARK,
1733                 items * sizeof(const SV *), count - 1);
1734             SP += max;
1735         }
1736         else if (count <= 0)
1737             SP -= items;
1738     }
1739     else {      /* Note: mark already snarfed by pp_list */
1740         SV * const tmpstr = POPs;
1741         STRLEN len;
1742         bool isutf;
1743         static const char* const oom_string_extend =
1744           "Out of memory during string extend";
1745
1746         if (TARG != tmpstr)
1747             sv_setsv_nomg(TARG, tmpstr);
1748         SvPV_force_nomg(TARG, len);
1749         isutf = DO_UTF8(TARG);
1750         if (count != 1) {
1751             if (count < 1)
1752                 SvCUR_set(TARG, 0);
1753             else {
1754                 const STRLEN max = (UV)count * len;
1755                 if (len > MEM_SIZE_MAX / count)
1756                      Perl_croak(aTHX_ "%s", oom_string_extend);
1757                 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1758                 SvGROW(TARG, max + 1);
1759                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1760                 SvCUR_set(TARG, SvCUR(TARG) * count);
1761             }
1762             *SvEND(TARG) = '\0';
1763         }
1764         if (isutf)
1765             (void)SvPOK_only_UTF8(TARG);
1766         else
1767             (void)SvPOK_only(TARG);
1768
1769         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1770             /* The parser saw this as a list repeat, and there
1771                are probably several items on the stack. But we're
1772                in scalar context, and there's no pp_list to save us
1773                now. So drop the rest of the items -- robin@kitsite.com
1774              */
1775             dMARK;
1776             SP = MARK;
1777         }
1778         PUSHTARG;
1779     }
1780     RETURN;
1781 }
1782
1783 PP(pp_subtract)
1784 {
1785     dSP; dATARGET; bool useleft; SV *svl, *svr;
1786     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1787     svr = TOPs;
1788     svl = TOPm1s;
1789     useleft = USE_LEFT(svl);
1790 #ifdef PERL_PRESERVE_IVUV
1791     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1792        "bad things" happen if you rely on signed integers wrapping.  */
1793     if (SvIV_please_nomg(svr)) {
1794         /* Unless the left argument is integer in range we are going to have to
1795            use NV maths. Hence only attempt to coerce the right argument if
1796            we know the left is integer.  */
1797         UV auv = 0;
1798         bool auvok = FALSE;
1799         bool a_valid = 0;
1800
1801         if (!useleft) {
1802             auv = 0;
1803             a_valid = auvok = 1;
1804             /* left operand is undef, treat as zero.  */
1805         } else {
1806             /* Left operand is defined, so is it IV? */
1807             if (SvIV_please_nomg(svl)) {
1808                 if ((auvok = SvUOK(svl)))
1809                     auv = SvUVX(svl);
1810                 else {
1811                     const IV aiv = SvIVX(svl);
1812                     if (aiv >= 0) {
1813                         auv = aiv;
1814                         auvok = 1;      /* Now acting as a sign flag.  */
1815                     } else { /* 2s complement assumption for IV_MIN */
1816                         auv = (UV)-aiv;
1817                     }
1818                 }
1819                 a_valid = 1;
1820             }
1821         }
1822         if (a_valid) {
1823             bool result_good = 0;
1824             UV result;
1825             UV buv;
1826             bool buvok = SvUOK(svr);
1827         
1828             if (buvok)
1829                 buv = SvUVX(svr);
1830             else {
1831                 const IV biv = SvIVX(svr);
1832                 if (biv >= 0) {
1833                     buv = biv;
1834                     buvok = 1;
1835                 } else
1836                     buv = (UV)-biv;
1837             }
1838             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1839                else "IV" now, independent of how it came in.
1840                if a, b represents positive, A, B negative, a maps to -A etc
1841                a - b =>  (a - b)
1842                A - b => -(a + b)
1843                a - B =>  (a + b)
1844                A - B => -(a - b)
1845                all UV maths. negate result if A negative.
1846                subtract if signs same, add if signs differ. */
1847
1848             if (auvok ^ buvok) {
1849                 /* Signs differ.  */
1850                 result = auv + buv;
1851                 if (result >= auv)
1852                     result_good = 1;
1853             } else {
1854                 /* Signs same */
1855                 if (auv >= buv) {
1856                     result = auv - buv;
1857                     /* Must get smaller */
1858                     if (result <= auv)
1859                         result_good = 1;
1860                 } else {
1861                     result = buv - auv;
1862                     if (result <= buv) {
1863                         /* result really should be -(auv-buv). as its negation
1864                            of true value, need to swap our result flag  */
1865                         auvok = !auvok;
1866                         result_good = 1;
1867                     }
1868                 }
1869             }
1870             if (result_good) {
1871                 SP--;
1872                 if (auvok)
1873                     SETu( result );
1874                 else {
1875                     /* Negate result */
1876                     if (result <= (UV)IV_MIN)
1877                         SETi( -(IV)result );
1878                     else {
1879                         /* result valid, but out of range for IV.  */
1880                         SETn( -(NV)result );
1881                     }
1882                 }
1883                 RETURN;
1884             } /* Overflow, drop through to NVs.  */
1885         }
1886     }
1887 #endif
1888     {
1889         NV value = SvNV_nomg(svr);
1890         (void)POPs;
1891
1892         if (!useleft) {
1893             /* left operand is undef, treat as zero - value */
1894             SETn(-value);
1895             RETURN;
1896         }
1897         SETn( SvNV_nomg(svl) - value );
1898         RETURN;
1899     }
1900 }
1901
1902 PP(pp_left_shift)
1903 {
1904     dSP; dATARGET; SV *svl, *svr;
1905     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1906     svr = POPs;
1907     svl = TOPs;
1908     {
1909       const IV shift = SvIV_nomg(svr);
1910       if (PL_op->op_private & HINT_INTEGER) {
1911         const IV i = SvIV_nomg(svl);
1912         SETi(i << shift);
1913       }
1914       else {
1915         const UV u = SvUV_nomg(svl);
1916         SETu(u << shift);
1917       }
1918       RETURN;
1919     }
1920 }
1921
1922 PP(pp_right_shift)
1923 {
1924     dSP; dATARGET; SV *svl, *svr;
1925     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1926     svr = POPs;
1927     svl = TOPs;
1928     {
1929       const IV shift = SvIV_nomg(svr);
1930       if (PL_op->op_private & HINT_INTEGER) {
1931         const IV i = SvIV_nomg(svl);
1932         SETi(i >> shift);
1933       }
1934       else {
1935         const UV u = SvUV_nomg(svl);
1936         SETu(u >> shift);
1937       }
1938       RETURN;
1939     }
1940 }
1941
1942 PP(pp_lt)
1943 {
1944     dSP;
1945     SV *left, *right;
1946
1947     tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1948     right = POPs;
1949     left  = TOPs;
1950     SETs(boolSV(
1951         (SvIOK_notUV(left) && SvIOK_notUV(right))
1952         ? (SvIVX(left) < SvIVX(right))
1953         : (do_ncmp(left, right) == -1)
1954     ));
1955     RETURN;
1956 }
1957
1958 PP(pp_gt)
1959 {
1960     dSP;
1961     SV *left, *right;
1962
1963     tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1964     right = POPs;
1965     left  = TOPs;
1966     SETs(boolSV(
1967         (SvIOK_notUV(left) && SvIOK_notUV(right))
1968         ? (SvIVX(left) > SvIVX(right))
1969         : (do_ncmp(left, right) == 1)
1970     ));
1971     RETURN;
1972 }
1973
1974 PP(pp_le)
1975 {
1976     dSP;
1977     SV *left, *right;
1978
1979     tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1980     right = POPs;
1981     left  = TOPs;
1982     SETs(boolSV(
1983         (SvIOK_notUV(left) && SvIOK_notUV(right))
1984         ? (SvIVX(left) <= SvIVX(right))
1985         : (do_ncmp(left, right) <= 0)
1986     ));
1987     RETURN;
1988 }
1989
1990 PP(pp_ge)
1991 {
1992     dSP;
1993     SV *left, *right;
1994
1995     tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1996     right = POPs;
1997     left  = TOPs;
1998     SETs(boolSV(
1999         (SvIOK_notUV(left) && SvIOK_notUV(right))
2000         ? (SvIVX(left) >= SvIVX(right))
2001         : ( (do_ncmp(left, right) & 2) == 0)
2002     ));
2003     RETURN;
2004 }
2005
2006 PP(pp_ne)
2007 {
2008     dSP;
2009     SV *left, *right;
2010
2011     tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2012     right = POPs;
2013     left  = TOPs;
2014     SETs(boolSV(
2015         (SvIOK_notUV(left) && SvIOK_notUV(right))
2016         ? (SvIVX(left) != SvIVX(right))
2017         : (do_ncmp(left, right) != 0)
2018     ));
2019     RETURN;
2020 }
2021
2022 /* compare left and right SVs. Returns:
2023  * -1: <
2024  *  0: ==
2025  *  1: >
2026  *  2: left or right was a NaN
2027  */
2028 I32
2029 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2030 {
2031     PERL_ARGS_ASSERT_DO_NCMP;
2032 #ifdef PERL_PRESERVE_IVUV
2033     /* Fortunately it seems NaN isn't IOK */
2034     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2035             if (!SvUOK(left)) {
2036                 const IV leftiv = SvIVX(left);
2037                 if (!SvUOK(right)) {
2038                     /* ## IV <=> IV ## */
2039                     const IV rightiv = SvIVX(right);
2040                     return (leftiv > rightiv) - (leftiv < rightiv);
2041                 }
2042                 /* ## IV <=> UV ## */
2043                 if (leftiv < 0)
2044                     /* As (b) is a UV, it's >=0, so it must be < */
2045                     return -1;
2046                 {
2047                     const UV rightuv = SvUVX(right);
2048                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2049                 }
2050             }
2051
2052             if (SvUOK(right)) {
2053                 /* ## UV <=> UV ## */
2054                 const UV leftuv = SvUVX(left);
2055                 const UV rightuv = SvUVX(right);
2056                 return (leftuv > rightuv) - (leftuv < rightuv);
2057             }
2058             /* ## UV <=> IV ## */
2059             {
2060                 const IV rightiv = SvIVX(right);
2061                 if (rightiv < 0)
2062                     /* As (a) is a UV, it's >=0, so it cannot be < */
2063                     return 1;
2064                 {
2065                     const UV leftuv = SvUVX(left);
2066                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2067                 }
2068             }
2069             assert(0); /* NOTREACHED */
2070     }
2071 #endif
2072     {
2073       NV const rnv = SvNV_nomg(right);
2074       NV const lnv = SvNV_nomg(left);
2075
2076 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2077       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2078           return 2;
2079        }
2080       return (lnv > rnv) - (lnv < rnv);
2081 #else
2082       if (lnv < rnv)
2083         return -1;
2084       if (lnv > rnv)
2085         return 1;
2086       if (lnv == rnv)
2087         return 0;
2088       return 2;
2089 #endif
2090     }
2091 }
2092
2093
2094 PP(pp_ncmp)
2095 {
2096     dSP;
2097     SV *left, *right;
2098     I32 value;
2099     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2100     right = POPs;
2101     left  = TOPs;
2102     value = do_ncmp(left, right);
2103     if (value == 2) {
2104         SETs(&PL_sv_undef);
2105     }
2106     else {
2107         dTARGET;
2108         SETi(value);
2109     }
2110     RETURN;
2111 }
2112
2113
2114 /* also used for: pp_sge() pp_sgt() pp_slt() */
2115
2116 PP(pp_sle)
2117 {
2118     dSP;
2119
2120     int amg_type = sle_amg;
2121     int multiplier = 1;
2122     int rhs = 1;
2123
2124     switch (PL_op->op_type) {
2125     case OP_SLT:
2126         amg_type = slt_amg;
2127         /* cmp < 0 */
2128         rhs = 0;
2129         break;
2130     case OP_SGT:
2131         amg_type = sgt_amg;
2132         /* cmp > 0 */
2133         multiplier = -1;
2134         rhs = 0;
2135         break;
2136     case OP_SGE:
2137         amg_type = sge_amg;
2138         /* cmp >= 0 */
2139         multiplier = -1;
2140         break;
2141     }
2142
2143     tryAMAGICbin_MG(amg_type, AMGf_set);
2144     {
2145       dPOPTOPssrl;
2146       const int cmp =
2147 #ifdef USE_LOCALE_COLLATE
2148                       (IN_LC_RUNTIME(LC_COLLATE))
2149                       ? sv_cmp_locale_flags(left, right, 0)
2150                       :
2151 #endif
2152                         sv_cmp_flags(left, right, 0);
2153       SETs(boolSV(cmp * multiplier < rhs));
2154       RETURN;
2155     }
2156 }
2157
2158 PP(pp_seq)
2159 {
2160     dSP;
2161     tryAMAGICbin_MG(seq_amg, AMGf_set);
2162     {
2163       dPOPTOPssrl;
2164       SETs(boolSV(sv_eq_flags(left, right, 0)));
2165       RETURN;
2166     }
2167 }
2168
2169 PP(pp_sne)
2170 {
2171     dSP;
2172     tryAMAGICbin_MG(sne_amg, AMGf_set);
2173     {
2174       dPOPTOPssrl;
2175       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2176       RETURN;
2177     }
2178 }
2179
2180 PP(pp_scmp)
2181 {
2182     dSP; dTARGET;
2183     tryAMAGICbin_MG(scmp_amg, 0);
2184     {
2185       dPOPTOPssrl;
2186       const int cmp =
2187 #ifdef USE_LOCALE_COLLATE
2188                       (IN_LC_RUNTIME(LC_COLLATE))
2189                       ? sv_cmp_locale_flags(left, right, 0)
2190                       :
2191 #endif
2192                         sv_cmp_flags(left, right, 0);
2193       SETi( cmp );
2194       RETURN;
2195     }
2196 }
2197
2198 PP(pp_bit_and)
2199 {
2200     dSP; dATARGET;
2201     tryAMAGICbin_MG(band_amg, AMGf_assign);
2202     {
2203       dPOPTOPssrl;
2204       if (SvNIOKp(left) || SvNIOKp(right)) {
2205         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2206         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2207         if (PL_op->op_private & HINT_INTEGER) {
2208           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2209           SETi(i);
2210         }
2211         else {
2212           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2213           SETu(u);
2214         }
2215         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2216         if (right_ro_nonnum) SvNIOK_off(right);
2217       }
2218       else {
2219         do_vop(PL_op->op_type, TARG, left, right);
2220         SETTARG;
2221       }
2222       RETURN;
2223     }
2224 }
2225
2226
2227 /* also used for: pp_bit_xor() */
2228
2229 PP(pp_bit_or)
2230 {
2231     dSP; dATARGET;
2232     const int op_type = PL_op->op_type;
2233
2234     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2235     {
2236       dPOPTOPssrl;
2237       if (SvNIOKp(left) || SvNIOKp(right)) {
2238         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2239         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2240         if (PL_op->op_private & HINT_INTEGER) {
2241           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2242           const IV r = SvIV_nomg(right);
2243           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2244           SETi(result);
2245         }
2246         else {
2247           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2248           const UV r = SvUV_nomg(right);
2249           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2250           SETu(result);
2251         }
2252         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2253         if (right_ro_nonnum) SvNIOK_off(right);
2254       }
2255       else {
2256         do_vop(op_type, TARG, left, right);
2257         SETTARG;
2258       }
2259       RETURN;
2260     }
2261 }
2262
2263 PERL_STATIC_INLINE bool
2264 S_negate_string(pTHX)
2265 {
2266     dTARGET; dSP;
2267     STRLEN len;
2268     const char *s;
2269     SV * const sv = TOPs;
2270     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2271         return FALSE;
2272     s = SvPV_nomg_const(sv, len);
2273     if (isIDFIRST(*s)) {
2274         sv_setpvs(TARG, "-");
2275         sv_catsv(TARG, sv);
2276     }
2277     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2278         sv_setsv_nomg(TARG, sv);
2279         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2280     }
2281     else return FALSE;
2282     SETTARG; PUTBACK;
2283     return TRUE;
2284 }
2285
2286 PP(pp_negate)
2287 {
2288     dSP; dTARGET;
2289     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2290     if (S_negate_string(aTHX)) return NORMAL;
2291     {
2292         SV * const sv = TOPs;
2293
2294         if (SvIOK(sv)) {
2295             /* It's publicly an integer */
2296         oops_its_an_int:
2297             if (SvIsUV(sv)) {
2298                 if (SvIVX(sv) == IV_MIN) {
2299                     /* 2s complement assumption. */
2300                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2301                                            IV_MIN */
2302                     RETURN;
2303                 }
2304                 else if (SvUVX(sv) <= IV_MAX) {
2305                     SETi(-SvIVX(sv));
2306                     RETURN;
2307                 }
2308             }
2309             else if (SvIVX(sv) != IV_MIN) {
2310                 SETi(-SvIVX(sv));
2311                 RETURN;
2312             }
2313 #ifdef PERL_PRESERVE_IVUV
2314             else {
2315                 SETu((UV)IV_MIN);
2316                 RETURN;
2317             }
2318 #endif
2319         }
2320         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2321             SETn(-SvNV_nomg(sv));
2322         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2323                   goto oops_its_an_int;
2324         else
2325             SETn(-SvNV_nomg(sv));
2326     }
2327     RETURN;
2328 }
2329
2330 PP(pp_not)
2331 {
2332     dSP;
2333     tryAMAGICun_MG(not_amg, AMGf_set);
2334     *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2335     return NORMAL;
2336 }
2337
2338 PP(pp_complement)
2339 {
2340     dSP; dTARGET;
2341     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2342     {
2343       dTOPss;
2344       if (SvNIOKp(sv)) {
2345         if (PL_op->op_private & HINT_INTEGER) {
2346           const IV i = ~SvIV_nomg(sv);
2347           SETi(i);
2348         }
2349         else {
2350           const UV u = ~SvUV_nomg(sv);
2351           SETu(u);
2352         }
2353       }
2354       else {
2355         U8 *tmps;
2356         I32 anum;
2357         STRLEN len;
2358
2359         sv_copypv_nomg(TARG, sv);
2360         tmps = (U8*)SvPV_nomg(TARG, len);
2361         anum = len;
2362         if (SvUTF8(TARG)) {
2363           /* Calculate exact length, let's not estimate. */
2364           STRLEN targlen = 0;
2365           STRLEN l;
2366           UV nchar = 0;
2367           UV nwide = 0;
2368           U8 * const send = tmps + len;
2369           U8 * const origtmps = tmps;
2370           const UV utf8flags = UTF8_ALLOW_ANYUV;
2371
2372           while (tmps < send) {
2373             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2374             tmps += l;
2375             targlen += UNISKIP(~c);
2376             nchar++;
2377             if (c > 0xff)
2378                 nwide++;
2379           }
2380
2381           /* Now rewind strings and write them. */
2382           tmps = origtmps;
2383
2384           if (nwide) {
2385               U8 *result;
2386               U8 *p;
2387
2388               Newx(result, targlen + 1, U8);
2389               p = result;
2390               while (tmps < send) {
2391                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2392                   tmps += l;
2393                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2394               }
2395               *p = '\0';
2396               sv_usepvn_flags(TARG, (char*)result, targlen,
2397                               SV_HAS_TRAILING_NUL);
2398               SvUTF8_on(TARG);
2399           }
2400           else {
2401               U8 *result;
2402               U8 *p;
2403
2404               Newx(result, nchar + 1, U8);
2405               p = result;
2406               while (tmps < send) {
2407                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2408                   tmps += l;
2409                   *p++ = ~c;
2410               }
2411               *p = '\0';
2412               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2413               SvUTF8_off(TARG);
2414           }
2415           SETTARG;
2416           RETURN;
2417         }
2418 #ifdef LIBERAL
2419         {
2420             long *tmpl;
2421             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2422                 *tmps = ~*tmps;
2423             tmpl = (long*)tmps;
2424             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2425                 *tmpl = ~*tmpl;
2426             tmps = (U8*)tmpl;
2427         }
2428 #endif
2429         for ( ; anum > 0; anum--, tmps++)
2430             *tmps = ~*tmps;
2431         SETTARG;
2432       }
2433       RETURN;
2434     }
2435 }
2436
2437 /* integer versions of some of the above */
2438
2439 PP(pp_i_multiply)
2440 {
2441     dSP; dATARGET;
2442     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2443     {
2444       dPOPTOPiirl_nomg;
2445       SETi( left * right );
2446       RETURN;
2447     }
2448 }
2449
2450 PP(pp_i_divide)
2451 {
2452     IV num;
2453     dSP; dATARGET;
2454     tryAMAGICbin_MG(div_amg, AMGf_assign);
2455     {
2456       dPOPTOPssrl;
2457       IV value = SvIV_nomg(right);
2458       if (value == 0)
2459           DIE(aTHX_ "Illegal division by zero");
2460       num = SvIV_nomg(left);
2461
2462       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2463       if (value == -1)
2464           value = - num;
2465       else
2466           value = num / value;
2467       SETi(value);
2468       RETURN;
2469     }
2470 }
2471
2472 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2473 STATIC
2474 PP(pp_i_modulo_0)
2475 #else
2476 PP(pp_i_modulo)
2477 #endif
2478 {
2479      /* This is the vanilla old i_modulo. */
2480      dSP; dATARGET;
2481      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2482      {
2483           dPOPTOPiirl_nomg;
2484           if (!right)
2485                DIE(aTHX_ "Illegal modulus zero");
2486           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2487           if (right == -1)
2488               SETi( 0 );
2489           else
2490               SETi( left % right );
2491           RETURN;
2492      }
2493 }
2494
2495 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2496 STATIC
2497 PP(pp_i_modulo_1)
2498
2499 {
2500      /* This is the i_modulo with the workaround for the _moddi3 bug
2501       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2502       * See below for pp_i_modulo. */
2503      dSP; dATARGET;
2504      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2505      {
2506           dPOPTOPiirl_nomg;
2507           if (!right)
2508                DIE(aTHX_ "Illegal modulus zero");
2509           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2510           if (right == -1)
2511               SETi( 0 );
2512           else
2513               SETi( left % PERL_ABS(right) );
2514           RETURN;
2515      }
2516 }
2517
2518 PP(pp_i_modulo)
2519 {
2520      dVAR; dSP; dATARGET;
2521      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2522      {
2523           dPOPTOPiirl_nomg;
2524           if (!right)
2525                DIE(aTHX_ "Illegal modulus zero");
2526           /* The assumption is to use hereafter the old vanilla version... */
2527           PL_op->op_ppaddr =
2528                PL_ppaddr[OP_I_MODULO] =
2529                    Perl_pp_i_modulo_0;
2530           /* .. but if we have glibc, we might have a buggy _moddi3
2531            * (at least glicb 2.2.5 is known to have this bug), in other
2532            * words our integer modulus with negative quad as the second
2533            * argument might be broken.  Test for this and re-patch the
2534            * opcode dispatch table if that is the case, remembering to
2535            * also apply the workaround so that this first round works
2536            * right, too.  See [perl #9402] for more information. */
2537           {
2538                IV l =   3;
2539                IV r = -10;
2540                /* Cannot do this check with inlined IV constants since
2541                 * that seems to work correctly even with the buggy glibc. */
2542                if (l % r == -3) {
2543                     /* Yikes, we have the bug.
2544                      * Patch in the workaround version. */
2545                     PL_op->op_ppaddr =
2546                          PL_ppaddr[OP_I_MODULO] =
2547                              &Perl_pp_i_modulo_1;
2548                     /* Make certain we work right this time, too. */
2549                     right = PERL_ABS(right);
2550                }
2551           }
2552           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2553           if (right == -1)
2554               SETi( 0 );
2555           else
2556               SETi( left % right );
2557           RETURN;
2558      }
2559 }
2560 #endif
2561
2562 PP(pp_i_add)
2563 {
2564     dSP; dATARGET;
2565     tryAMAGICbin_MG(add_amg, AMGf_assign);
2566     {
2567       dPOPTOPiirl_ul_nomg;
2568       SETi( left + right );
2569       RETURN;
2570     }
2571 }
2572
2573 PP(pp_i_subtract)
2574 {
2575     dSP; dATARGET;
2576     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2577     {
2578       dPOPTOPiirl_ul_nomg;
2579       SETi( left - right );
2580       RETURN;
2581     }
2582 }
2583
2584 PP(pp_i_lt)
2585 {
2586     dSP;
2587     tryAMAGICbin_MG(lt_amg, AMGf_set);
2588     {
2589       dPOPTOPiirl_nomg;
2590       SETs(boolSV(left < right));
2591       RETURN;
2592     }
2593 }
2594
2595 PP(pp_i_gt)
2596 {
2597     dSP;
2598     tryAMAGICbin_MG(gt_amg, AMGf_set);
2599     {
2600       dPOPTOPiirl_nomg;
2601       SETs(boolSV(left > right));
2602       RETURN;
2603     }
2604 }
2605
2606 PP(pp_i_le)
2607 {
2608     dSP;
2609     tryAMAGICbin_MG(le_amg, AMGf_set);
2610     {
2611       dPOPTOPiirl_nomg;
2612       SETs(boolSV(left <= right));
2613       RETURN;
2614     }
2615 }
2616
2617 PP(pp_i_ge)
2618 {
2619     dSP;
2620     tryAMAGICbin_MG(ge_amg, AMGf_set);
2621     {
2622       dPOPTOPiirl_nomg;
2623       SETs(boolSV(left >= right));
2624       RETURN;
2625     }
2626 }
2627
2628 PP(pp_i_eq)
2629 {
2630     dSP;
2631     tryAMAGICbin_MG(eq_amg, AMGf_set);
2632     {
2633       dPOPTOPiirl_nomg;
2634       SETs(boolSV(left == right));
2635       RETURN;
2636     }
2637 }
2638
2639 PP(pp_i_ne)
2640 {
2641     dSP;
2642     tryAMAGICbin_MG(ne_amg, AMGf_set);
2643     {
2644       dPOPTOPiirl_nomg;
2645       SETs(boolSV(left != right));
2646       RETURN;
2647     }
2648 }
2649
2650 PP(pp_i_ncmp)
2651 {
2652     dSP; dTARGET;
2653     tryAMAGICbin_MG(ncmp_amg, 0);
2654     {
2655       dPOPTOPiirl_nomg;
2656       I32 value;
2657
2658       if (left > right)
2659         value = 1;
2660       else if (left < right)
2661         value = -1;
2662       else
2663         value = 0;
2664       SETi(value);
2665       RETURN;
2666     }
2667 }
2668
2669 PP(pp_i_negate)
2670 {
2671     dSP; dTARGET;
2672     tryAMAGICun_MG(neg_amg, 0);
2673     if (S_negate_string(aTHX)) return NORMAL;
2674     {
2675         SV * const sv = TOPs;
2676         IV const i = SvIV_nomg(sv);
2677         SETi(-i);
2678         RETURN;
2679     }
2680 }
2681
2682 /* High falutin' math. */
2683
2684 PP(pp_atan2)
2685 {
2686     dSP; dTARGET;
2687     tryAMAGICbin_MG(atan2_amg, 0);
2688     {
2689       dPOPTOPnnrl_nomg;
2690       SETn(Perl_atan2(left, right));
2691       RETURN;
2692     }
2693 }
2694
2695
2696 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2697
2698 PP(pp_sin)
2699 {
2700     dSP; dTARGET;
2701     int amg_type = fallback_amg;
2702     const char *neg_report = NULL;
2703     const int op_type = PL_op->op_type;
2704
2705     switch (op_type) {
2706     case OP_SIN:  amg_type = sin_amg; break;
2707     case OP_COS:  amg_type = cos_amg; break;
2708     case OP_EXP:  amg_type = exp_amg; break;
2709     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2710     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2711     }
2712
2713     assert(amg_type != fallback_amg);
2714
2715     tryAMAGICun_MG(amg_type, 0);
2716     {
2717       SV * const arg = POPs;
2718       const NV value = SvNV_nomg(arg);
2719       NV result = NV_NAN;
2720       if (neg_report) { /* log or sqrt */
2721           if (
2722 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2723               ! Perl_isnan(value) &&
2724 #endif
2725               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2726               SET_NUMERIC_STANDARD();
2727               /* diag_listed_as: Can't take log of %g */
2728               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2729           }
2730       }
2731       switch (op_type) {
2732       default:
2733       case OP_SIN:  result = Perl_sin(value);  break;
2734       case OP_COS:  result = Perl_cos(value);  break;
2735       case OP_EXP:  result = Perl_exp(value);  break;
2736       case OP_LOG:  result = Perl_log(value);  break;
2737       case OP_SQRT: result = Perl_sqrt(value); break;
2738       }
2739       XPUSHn(result);
2740       RETURN;
2741     }
2742 }
2743
2744 /* Support Configure command-line overrides for rand() functions.
2745    After 5.005, perhaps we should replace this by Configure support
2746    for drand48(), random(), or rand().  For 5.005, though, maintain
2747    compatibility by calling rand() but allow the user to override it.
2748    See INSTALL for details.  --Andy Dougherty  15 July 1998
2749 */
2750 /* Now it's after 5.005, and Configure supports drand48() and random(),
2751    in addition to rand().  So the overrides should not be needed any more.
2752    --Jarkko Hietaniemi  27 September 1998
2753  */
2754
2755 PP(pp_rand)
2756 {
2757     if (!PL_srand_called) {
2758         (void)seedDrand01((Rand_seed_t)seed());
2759         PL_srand_called = TRUE;
2760     }
2761     {
2762         dSP;
2763         NV value;
2764         EXTEND(SP, 1);
2765     
2766         if (MAXARG < 1)
2767             value = 1.0;
2768         else {
2769             SV * const sv = POPs;
2770             if(!sv)
2771                 value = 1.0;
2772             else
2773                 value = SvNV(sv);
2774         }
2775     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2776 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2777         if (! Perl_isnan(value) && value == 0.0)
2778 #else
2779         if (value == 0.0)
2780 #endif
2781             value = 1.0;
2782         {
2783             dTARGET;
2784             PUSHs(TARG);
2785             PUTBACK;
2786             value *= Drand01();
2787             sv_setnv_mg(TARG, value);
2788         }
2789     }
2790     return NORMAL;
2791 }
2792
2793 PP(pp_srand)
2794 {
2795     dSP; dTARGET;
2796     UV anum;
2797
2798     if (MAXARG >= 1 && (TOPs || POPs)) {
2799         SV *top;
2800         char *pv;
2801         STRLEN len;
2802         int flags;
2803
2804         top = POPs;
2805         pv = SvPV(top, len);
2806         flags = grok_number(pv, len, &anum);
2807
2808         if (!(flags & IS_NUMBER_IN_UV)) {
2809             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2810                              "Integer overflow in srand");
2811             anum = UV_MAX;
2812         }
2813     }
2814     else {
2815         anum = seed();
2816     }
2817
2818     (void)seedDrand01((Rand_seed_t)anum);
2819     PL_srand_called = TRUE;
2820     if (anum)
2821         XPUSHu(anum);
2822     else {
2823         /* Historically srand always returned true. We can avoid breaking
2824            that like this:  */
2825         sv_setpvs(TARG, "0 but true");
2826         XPUSHTARG;
2827     }
2828     RETURN;
2829 }
2830
2831 PP(pp_int)
2832 {
2833     dSP; dTARGET;
2834     tryAMAGICun_MG(int_amg, AMGf_numeric);
2835     {
2836       SV * const sv = TOPs;
2837       const IV iv = SvIV_nomg(sv);
2838       /* XXX it's arguable that compiler casting to IV might be subtly
2839          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2840          else preferring IV has introduced a subtle behaviour change bug. OTOH
2841          relying on floating point to be accurate is a bug.  */
2842
2843       if (!SvOK(sv)) {
2844         SETu(0);
2845       }
2846       else if (SvIOK(sv)) {
2847         if (SvIsUV(sv))
2848             SETu(SvUV_nomg(sv));
2849         else
2850             SETi(iv);
2851       }
2852       else {
2853           const NV value = SvNV_nomg(sv);
2854           if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNV(sv))))
2855               SETn(SvNV(sv));
2856           else if (value >= 0.0) {
2857               if (value < (NV)UV_MAX + 0.5) {
2858                   SETu(U_V(value));
2859               } else {
2860                   SETn(Perl_floor(value));
2861               }
2862           }
2863           else {
2864               if (value > (NV)IV_MIN - 0.5) {
2865                   SETi(I_V(value));
2866               } else {
2867                   SETn(Perl_ceil(value));
2868               }
2869           }
2870       }
2871     }
2872     RETURN;
2873 }
2874
2875 PP(pp_abs)
2876 {
2877     dSP; dTARGET;
2878     tryAMAGICun_MG(abs_amg, AMGf_numeric);
2879     {
2880       SV * const sv = TOPs;
2881       /* This will cache the NV value if string isn't actually integer  */
2882       const IV iv = SvIV_nomg(sv);
2883
2884       if (!SvOK(sv)) {
2885         SETu(0);
2886       }
2887       else if (SvIOK(sv)) {
2888         /* IVX is precise  */
2889         if (SvIsUV(sv)) {
2890           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
2891         } else {
2892           if (iv >= 0) {
2893             SETi(iv);
2894           } else {
2895             if (iv != IV_MIN) {
2896               SETi(-iv);
2897             } else {
2898               /* 2s complement assumption. Also, not really needed as
2899                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2900               SETu(IV_MIN);
2901             }
2902           }
2903         }
2904       } else{
2905         const NV value = SvNV_nomg(sv);
2906         if (value < 0.0)
2907           SETn(-value);
2908         else
2909           SETn(value);
2910       }
2911     }
2912     RETURN;
2913 }
2914
2915
2916 /* also used for: pp_hex() */
2917
2918 PP(pp_oct)
2919 {
2920     dSP; dTARGET;
2921     const char *tmps;
2922     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2923     STRLEN len;
2924     NV result_nv;
2925     UV result_uv;
2926     SV* const sv = POPs;
2927
2928     tmps = (SvPV_const(sv, len));
2929     if (DO_UTF8(sv)) {
2930          /* If Unicode, try to downgrade
2931           * If not possible, croak. */
2932          SV* const tsv = sv_2mortal(newSVsv(sv));
2933         
2934          SvUTF8_on(tsv);
2935          sv_utf8_downgrade(tsv, FALSE);
2936          tmps = SvPV_const(tsv, len);
2937     }
2938     if (PL_op->op_type == OP_HEX)
2939         goto hex;
2940
2941     while (*tmps && len && isSPACE(*tmps))
2942         tmps++, len--;
2943     if (*tmps == '0')
2944         tmps++, len--;
2945     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
2946     hex:
2947         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2948     }
2949     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
2950         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2951     else
2952         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2953
2954     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2955         XPUSHn(result_nv);
2956     }
2957     else {
2958         XPUSHu(result_uv);
2959     }
2960     RETURN;
2961 }
2962
2963 /* String stuff. */
2964
2965 PP(pp_length)
2966 {
2967     dSP; dTARGET;
2968     SV * const sv = TOPs;
2969
2970     U32 in_bytes = IN_BYTES;
2971     /* simplest case shortcut */
2972     /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
2973     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
2974     assert(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
2975     SETs(TARG);
2976
2977     if(LIKELY(svflags == SVf_POK))
2978         goto simple_pv;
2979     if(svflags & SVs_GMG)
2980         mg_get(sv);
2981     if (SvOK(sv)) {
2982         if (!IN_BYTES) /* reread to avoid using an C auto/register */
2983             sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
2984         else
2985         {
2986             STRLEN len;
2987             /* unrolled SvPV_nomg_const(sv,len) */
2988             if(SvPOK_nog(sv)){
2989                 simple_pv:
2990                 len = SvCUR(sv);
2991             } else  {
2992                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
2993             }
2994             sv_setiv(TARG, (IV)(len));
2995         }
2996     } else {
2997         if (!SvPADTMP(TARG)) {
2998             sv_setsv_nomg(TARG, &PL_sv_undef);
2999         } else { /* TARG is on stack at this point and is overwriten by SETs.
3000                    This branch is the odd one out, so put TARG by default on
3001                    stack earlier to let local SP go out of liveness sooner */
3002             SETs(&PL_sv_undef);
3003             goto no_set_magic;
3004         }
3005     }
3006     SvSETMAGIC(TARG);
3007     no_set_magic:
3008     return NORMAL; /* no putback, SP didn't move in this opcode */
3009 }
3010
3011 /* Returns false if substring is completely outside original string.
3012    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3013    always be true for an explicit 0.
3014 */
3015 bool
3016 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3017                                 bool pos1_is_uv, IV len_iv,
3018                                 bool len_is_uv, STRLEN *posp,
3019                                 STRLEN *lenp)
3020 {
3021     IV pos2_iv;
3022     int    pos2_is_uv;
3023
3024     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3025
3026     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3027         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3028         pos1_iv += curlen;
3029     }
3030     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3031         return FALSE;
3032
3033     if (len_iv || len_is_uv) {
3034         if (!len_is_uv && len_iv < 0) {
3035             pos2_iv = curlen + len_iv;
3036             if (curlen)
3037                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3038             else
3039                 pos2_is_uv = 0;
3040         } else {  /* len_iv >= 0 */
3041             if (!pos1_is_uv && pos1_iv < 0) {
3042                 pos2_iv = pos1_iv + len_iv;
3043                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3044             } else {
3045                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3046                     pos2_iv = curlen;
3047                 else
3048                     pos2_iv = pos1_iv+len_iv;
3049                 pos2_is_uv = 1;
3050             }
3051         }
3052     }
3053     else {
3054         pos2_iv = curlen;
3055         pos2_is_uv = 1;
3056     }
3057
3058     if (!pos2_is_uv && pos2_iv < 0) {
3059         if (!pos1_is_uv && pos1_iv < 0)
3060             return FALSE;
3061         pos2_iv = 0;
3062     }
3063     else if (!pos1_is_uv && pos1_iv < 0)
3064         pos1_iv = 0;
3065
3066     if ((UV)pos2_iv < (UV)pos1_iv)
3067         pos2_iv = pos1_iv;
3068     if ((UV)pos2_iv > curlen)
3069         pos2_iv = curlen;
3070
3071     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3072     *posp = (STRLEN)( (UV)pos1_iv );
3073     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3074
3075     return TRUE;
3076 }
3077
3078 PP(pp_substr)
3079 {
3080     dSP; dTARGET;
3081     SV *sv;
3082     STRLEN curlen;
3083     STRLEN utf8_curlen;
3084     SV *   pos_sv;
3085     IV     pos1_iv;
3086     int    pos1_is_uv;
3087     SV *   len_sv;
3088     IV     len_iv = 0;
3089     int    len_is_uv = 0;
3090     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3091     const bool rvalue = (GIMME_V != G_VOID);
3092     const char *tmps;
3093     SV *repl_sv = NULL;
3094     const char *repl = NULL;
3095     STRLEN repl_len;
3096     int num_args = PL_op->op_private & 7;
3097     bool repl_need_utf8_upgrade = FALSE;
3098
3099     if (num_args > 2) {
3100         if (num_args > 3) {
3101           if(!(repl_sv = POPs)) num_args--;
3102         }
3103         if ((len_sv = POPs)) {
3104             len_iv    = SvIV(len_sv);
3105             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3106         }
3107         else num_args--;
3108     }
3109     pos_sv     = POPs;
3110     pos1_iv    = SvIV(pos_sv);
3111     pos1_is_uv = SvIOK_UV(pos_sv);
3112     sv = POPs;
3113     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3114         assert(!repl_sv);
3115         repl_sv = POPs;
3116     }
3117     PUTBACK;
3118     if (lvalue && !repl_sv) {
3119         SV * ret;
3120         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3121         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3122         LvTYPE(ret) = 'x';
3123         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3124         LvTARGOFF(ret) =
3125             pos1_is_uv || pos1_iv >= 0
3126                 ? (STRLEN)(UV)pos1_iv
3127                 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3128         LvTARGLEN(ret) =
3129             len_is_uv || len_iv > 0
3130                 ? (STRLEN)(UV)len_iv
3131                 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3132
3133         SPAGAIN;
3134         PUSHs(ret);    /* avoid SvSETMAGIC here */
3135         RETURN;
3136     }
3137     if (repl_sv) {
3138         repl = SvPV_const(repl_sv, repl_len);
3139         SvGETMAGIC(sv);
3140         if (SvROK(sv))
3141             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3142                             "Attempt to use reference as lvalue in substr"
3143             );
3144         tmps = SvPV_force_nomg(sv, curlen);
3145         if (DO_UTF8(repl_sv) && repl_len) {
3146             if (!DO_UTF8(sv)) {
3147                 sv_utf8_upgrade_nomg(sv);
3148                 curlen = SvCUR(sv);
3149             }
3150         }
3151         else if (DO_UTF8(sv))
3152             repl_need_utf8_upgrade = TRUE;
3153     }
3154     else tmps = SvPV_const(sv, curlen);
3155     if (DO_UTF8(sv)) {
3156         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3157         if (utf8_curlen == curlen)
3158             utf8_curlen = 0;
3159         else
3160             curlen = utf8_curlen;
3161     }
3162     else
3163         utf8_curlen = 0;
3164
3165     {
3166         STRLEN pos, len, byte_len, byte_pos;
3167
3168         if (!translate_substr_offsets(
3169                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3170         )) goto bound_fail;
3171
3172         byte_len = len;
3173         byte_pos = utf8_curlen
3174             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3175
3176         tmps += byte_pos;
3177
3178         if (rvalue) {
3179             SvTAINTED_off(TARG);                        /* decontaminate */
3180             SvUTF8_off(TARG);                   /* decontaminate */
3181             sv_setpvn(TARG, tmps, byte_len);
3182 #ifdef USE_LOCALE_COLLATE
3183             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3184 #endif
3185             if (utf8_curlen)
3186                 SvUTF8_on(TARG);
3187         }
3188
3189         if (repl) {
3190             SV* repl_sv_copy = NULL;
3191
3192             if (repl_need_utf8_upgrade) {
3193                 repl_sv_copy = newSVsv(repl_sv);
3194                 sv_utf8_upgrade(repl_sv_copy);
3195                 repl = SvPV_const(repl_sv_copy, repl_len);
3196             }
3197             if (!SvOK(sv))
3198                 sv_setpvs(sv, "");
3199             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3200             SvREFCNT_dec(repl_sv_copy);
3201         }
3202     }
3203     SPAGAIN;
3204     if (rvalue) {
3205         SvSETMAGIC(TARG);
3206         PUSHs(TARG);
3207     }
3208     RETURN;
3209
3210 bound_fail:
3211     if (repl)
3212         Perl_croak(aTHX_ "substr outside of string");
3213     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3214     RETPUSHUNDEF;
3215 }
3216
3217 PP(pp_vec)
3218 {
3219     dSP;
3220     const IV size   = POPi;
3221     const IV offset = POPi;
3222     SV * const src = POPs;
3223     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3224     SV * ret;
3225
3226     if (lvalue) {                       /* it's an lvalue! */
3227         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3228         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3229         LvTYPE(ret) = 'v';
3230         LvTARG(ret) = SvREFCNT_inc_simple(src);
3231         LvTARGOFF(ret) = offset;
3232         LvTARGLEN(ret) = size;
3233     }
3234     else {
3235         dTARGET;
3236         SvTAINTED_off(TARG);            /* decontaminate */
3237         ret = TARG;
3238     }
3239
3240     sv_setuv(ret, do_vecget(src, offset, size));
3241     PUSHs(ret);
3242     RETURN;
3243 }
3244
3245
3246 /* also used for: pp_rindex() */
3247
3248 PP(pp_index)
3249 {
3250     dSP; dTARGET;
3251     SV *big;
3252     SV *little;
3253     SV *temp = NULL;
3254     STRLEN biglen;
3255     STRLEN llen = 0;
3256     SSize_t offset = 0;
3257     SSize_t retval;
3258     const char *big_p;
3259     const char *little_p;
3260     bool big_utf8;
3261     bool little_utf8;
3262     const bool is_index = PL_op->op_type == OP_INDEX;
3263     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3264
3265     if (threeargs)
3266         offset = POPi;
3267     little = POPs;
3268     big = POPs;
3269     big_p = SvPV_const(big, biglen);
3270     little_p = SvPV_const(little, llen);
3271
3272     big_utf8 = DO_UTF8(big);
3273     little_utf8 = DO_UTF8(little);
3274     if (big_utf8 ^ little_utf8) {
3275         /* One needs to be upgraded.  */
3276         if (little_utf8 && !PL_encoding) {
3277             /* Well, maybe instead we might be able to downgrade the small
3278                string?  */
3279             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3280                                                      &little_utf8);
3281             if (little_utf8) {
3282                 /* If the large string is ISO-8859-1, and it's not possible to
3283                    convert the small string to ISO-8859-1, then there is no
3284                    way that it could be found anywhere by index.  */
3285                 retval = -1;
3286                 goto fail;
3287             }
3288
3289             /* At this point, pv is a malloc()ed string. So donate it to temp
3290                to ensure it will get free()d  */
3291             little = temp = newSV(0);
3292             sv_usepvn(temp, pv, llen);
3293             little_p = SvPVX(little);
3294         } else {
3295             temp = little_utf8
3296                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3297
3298             if (PL_encoding) {
3299                 sv_recode_to_utf8(temp, PL_encoding);
3300             } else {
3301                 sv_utf8_upgrade(temp);
3302             }
3303             if (little_utf8) {
3304                 big = temp;
3305                 big_utf8 = TRUE;
3306                 big_p = SvPV_const(big, biglen);
3307             } else {
3308                 little = temp;
3309                 little_p = SvPV_const(little, llen);
3310             }
3311         }
3312     }
3313     if (SvGAMAGIC(big)) {
3314         /* Life just becomes a lot easier if I use a temporary here.
3315            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3316            will trigger magic and overloading again, as will fbm_instr()
3317         */
3318         big = newSVpvn_flags(big_p, biglen,
3319                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3320         big_p = SvPVX(big);
3321     }
3322     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3323         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3324            warn on undef, and we've already triggered a warning with the
3325            SvPV_const some lines above. We can't remove that, as we need to
3326            call some SvPV to trigger overloading early and find out if the
3327            string is UTF-8.
3328            This is all getting to messy. The API isn't quite clean enough,
3329            because data access has side effects.
3330         */
3331         little = newSVpvn_flags(little_p, llen,
3332                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3333         little_p = SvPVX(little);
3334     }
3335
3336     if (!threeargs)
3337         offset = is_index ? 0 : biglen;
3338     else {
3339         if (big_utf8 && offset > 0)
3340             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3341         if (!is_index)
3342             offset += llen;
3343     }
3344     if (offset < 0)
3345         offset = 0;
3346     else if (offset > (SSize_t)biglen)
3347         offset = biglen;
3348     if (!(little_p = is_index
3349           ? fbm_instr((unsigned char*)big_p + offset,
3350                       (unsigned char*)big_p + biglen, little, 0)
3351           : rninstr(big_p,  big_p  + offset,
3352                     little_p, little_p + llen)))
3353         retval = -1;
3354     else {
3355         retval = little_p - big_p;
3356         if (retval > 0 && big_utf8)
3357             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3358     }
3359     SvREFCNT_dec(temp);
3360  fail:
3361     PUSHi(retval);
3362     RETURN;
3363 }
3364
3365 PP(pp_sprintf)
3366 {
3367     dSP; dMARK; dORIGMARK; dTARGET;
3368     SvTAINTED_off(TARG);
3369     do_sprintf(TARG, SP-MARK, MARK+1);
3370     TAINT_IF(SvTAINTED(TARG));
3371     SP = ORIGMARK;
3372     PUSHTARG;
3373     RETURN;
3374 }
3375
3376 PP(pp_ord)
3377 {
3378     dSP; dTARGET;
3379
3380     SV *argsv = POPs;
3381     STRLEN len;
3382     const U8 *s = (U8*)SvPV_const(argsv, len);
3383
3384     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3385         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3386         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3387         len = UTF8SKIP(s);  /* Should be well-formed; so this is its length */
3388         argsv = tmpsv;
3389     }
3390
3391     XPUSHu(DO_UTF8(argsv)
3392            ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3393            : (UV)(*s));
3394
3395     RETURN;
3396 }
3397
3398 PP(pp_chr)
3399 {
3400     dSP; dTARGET;
3401     char *tmps;
3402     UV value;
3403     SV *top = POPs;
3404
3405     SvGETMAGIC(top);
3406     if (UNLIKELY(isinfnansv(top)))
3407         Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3408     else {
3409         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3410             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3411                 ||
3412                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3413                  && SvNV_nomg(top) < 0.0))) {
3414             if (ckWARN(WARN_UTF8)) {
3415                 if (SvGMAGICAL(top)) {
3416                     SV *top2 = sv_newmortal();
3417                     sv_setsv_nomg(top2, top);
3418                     top = top2;
3419                 }
3420                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3421                             "Invalid negative number (%"SVf") in chr", SVfARG(top));
3422             }
3423             value = UNICODE_REPLACEMENT;
3424         } else {
3425             value = SvUV_nomg(top);
3426         }
3427     }
3428
3429     SvUPGRADE(TARG,SVt_PV);
3430
3431     if (value > 255 && !IN_BYTES) {
3432         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3433         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3434         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3435         *tmps = '\0';
3436         (void)SvPOK_only(TARG);
3437         SvUTF8_on(TARG);
3438         XPUSHs(TARG);
3439         RETURN;
3440     }
3441
3442     SvGROW(TARG,2);
3443     SvCUR_set(TARG, 1);
3444     tmps = SvPVX(TARG);
3445     *tmps++ = (char)value;
3446     *tmps = '\0';
3447     (void)SvPOK_only(TARG);
3448
3449     if (PL_encoding && !IN_BYTES) {
3450         sv_recode_to_utf8(TARG, PL_encoding);
3451         tmps = SvPVX(TARG);
3452         if (SvCUR(TARG) == 0
3453             || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3454             || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3455         {
3456             SvGROW(TARG, 2);
3457             tmps = SvPVX(TARG);
3458             SvCUR_set(TARG, 1);
3459             *tmps++ = (char)value;
3460             *tmps = '\0';
3461             SvUTF8_off(TARG);
3462         }
3463     }
3464
3465     XPUSHs(TARG);
3466     RETURN;
3467 }
3468
3469 PP(pp_crypt)
3470 {
3471 #ifdef HAS_CRYPT
3472     dSP; dTARGET;
3473     dPOPTOPssrl;
3474     STRLEN len;
3475     const char *tmps = SvPV_const(left, len);
3476
3477     if (DO_UTF8(left)) {
3478          /* If Unicode, try to downgrade.
3479           * If not possible, croak.
3480           * Yes, we made this up.  */
3481          SV* const tsv = sv_2mortal(newSVsv(left));
3482
3483          SvUTF8_on(tsv);
3484          sv_utf8_downgrade(tsv, FALSE);
3485          tmps = SvPV_const(tsv, len);
3486     }
3487 #   ifdef USE_ITHREADS
3488 #     ifdef HAS_CRYPT_R
3489     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3490       /* This should be threadsafe because in ithreads there is only
3491        * one thread per interpreter.  If this would not be true,
3492        * we would need a mutex to protect this malloc. */
3493         PL_reentrant_buffer->_crypt_struct_buffer =
3494           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3495 #if defined(__GLIBC__) || defined(__EMX__)
3496         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3497             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3498             /* work around glibc-2.2.5 bug */
3499             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3500         }
3501 #endif
3502     }
3503 #     endif /* HAS_CRYPT_R */
3504 #   endif /* USE_ITHREADS */
3505 #   ifdef FCRYPT
3506     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3507 #   else
3508     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3509 #   endif
3510     SETTARG;
3511     RETURN;
3512 #else
3513     DIE(aTHX_
3514       "The crypt() function is unimplemented due to excessive paranoia.");
3515 #endif
3516 }
3517
3518 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So 
3519  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3520
3521
3522 /* also used for: pp_lcfirst() */
3523
3524 PP(pp_ucfirst)
3525 {
3526     /* Actually is both lcfirst() and ucfirst().  Only the first character
3527      * changes.  This means that possibly we can change in-place, ie., just
3528      * take the source and change that one character and store it back, but not
3529      * if read-only etc, or if the length changes */
3530
3531     dSP;
3532     SV *source = TOPs;
3533     STRLEN slen; /* slen is the byte length of the whole SV. */
3534     STRLEN need;
3535     SV *dest;
3536     bool inplace;   /* ? Convert first char only, in-place */
3537     bool doing_utf8 = FALSE;               /* ? using utf8 */
3538     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3539     const int op_type = PL_op->op_type;
3540     const U8 *s;
3541     U8 *d;
3542     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3543     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3544                      * stored as UTF-8 at s. */
3545     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3546                      * lowercased) character stored in tmpbuf.  May be either
3547                      * UTF-8 or not, but in either case is the number of bytes */
3548
3549     s = (const U8*)SvPV_const(source, slen);
3550
3551     /* We may be able to get away with changing only the first character, in
3552      * place, but not if read-only, etc.  Later we may discover more reasons to
3553      * not convert in-place. */
3554     inplace = !SvREADONLY(source)
3555            && (  SvPADTMP(source)
3556               || (  SvTEMP(source) && !SvSMAGICAL(source)
3557                  && SvREFCNT(source) == 1));
3558
3559     /* First calculate what the changed first character should be.  This affects
3560      * whether we can just swap it out, leaving the rest of the string unchanged,
3561      * or even if have to convert the dest to UTF-8 when the source isn't */
3562
3563     if (! slen) {   /* If empty */
3564         need = 1; /* still need a trailing NUL */
3565         ulen = 0;
3566     }
3567     else if (DO_UTF8(source)) { /* Is the source utf8? */
3568         doing_utf8 = TRUE;
3569         ulen = UTF8SKIP(s);
3570         if (op_type == OP_UCFIRST) {
3571 #ifdef USE_LOCALE_CTYPE
3572             _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3573 #else
3574             _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3575 #endif
3576         }
3577         else {
3578 #ifdef USE_LOCALE_CTYPE
3579             _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3580 #else
3581             _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3582 #endif
3583         }
3584
3585         /* we can't do in-place if the length changes.  */
3586         if (ulen != tculen) inplace = FALSE;
3587         need = slen + 1 - ulen + tculen;
3588     }
3589     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3590             * latin1 is treated as caseless.  Note that a locale takes
3591             * precedence */ 
3592         ulen = 1;       /* Original character is 1 byte */
3593         tculen = 1;     /* Most characters will require one byte, but this will
3594                          * need to be overridden for the tricky ones */
3595         need = slen + 1;
3596
3597         if (op_type == OP_LCFIRST) {
3598
3599             /* lower case the first letter: no trickiness for any character */
3600             *tmpbuf =
3601 #ifdef USE_LOCALE_CTYPE
3602                       (IN_LC_RUNTIME(LC_CTYPE))
3603                       ? toLOWER_LC(*s)
3604                       :
3605 #endif
3606                          (IN_UNI_8_BIT)
3607                          ? toLOWER_LATIN1(*s)
3608                          : toLOWER(*s);
3609         }
3610         /* is ucfirst() */
3611 #ifdef USE_LOCALE_CTYPE
3612         else if (IN_LC_RUNTIME(LC_CTYPE)) {
3613             if (IN_UTF8_CTYPE_LOCALE) {
3614                 goto do_uni_rules;
3615             }
3616
3617             *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3618                                               locales have upper and title case
3619                                               different */
3620         }
3621 #endif
3622         else if (! IN_UNI_8_BIT) {
3623             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3624                                          * on EBCDIC machines whatever the
3625                                          * native function does */
3626         }
3627         else {
3628             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3629              * UTF-8, which we treat as not in locale), and cased latin1 */
3630             UV title_ord;
3631 #ifdef USE_LOCALE_CTYPE
3632       do_uni_rules:
3633 #endif
3634
3635             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3636             if (tculen > 1) {
3637                 assert(tculen == 2);
3638
3639                 /* If the result is an upper Latin1-range character, it can
3640                  * still be represented in one byte, which is its ordinal */
3641                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3642                     *tmpbuf = (U8) title_ord;
3643                     tculen = 1;
3644                 }
3645                 else {
3646                     /* Otherwise it became more than one ASCII character (in
3647                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3648                      * beyond Latin1, so the number of bytes changed, so can't
3649                      * replace just the first character in place. */
3650                     inplace = FALSE;
3651
3652                     /* If the result won't fit in a byte, the entire result
3653                      * will have to be in UTF-8.  Assume worst case sizing in
3654                      * conversion. (all latin1 characters occupy at most two
3655                      * bytes in utf8) */
3656                     if (title_ord > 255) {
3657                         doing_utf8 = TRUE;
3658                         convert_source_to_utf8 = TRUE;
3659                         need = slen * 2 + 1;
3660
3661                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3662                          * (both) characters whose title case is above 255 is
3663                          * 2. */
3664                         ulen = 2;
3665                     }
3666                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3667                         need = slen + 1 + 1;
3668                     }
3669                 }
3670             }
3671         } /* End of use Unicode (Latin1) semantics */
3672     } /* End of changing the case of the first character */
3673
3674     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3675      * generate the result */
3676     if (inplace) {
3677
3678         /* We can convert in place.  This means we change just the first
3679          * character without disturbing the rest; no need to grow */
3680         dest = source;
3681         s = d = (U8*)SvPV_force_nomg(source, slen);
3682     } else {
3683         dTARGET;
3684
3685         dest = TARG;
3686
3687         /* Here, we can't convert in place; we earlier calculated how much
3688          * space we will need, so grow to accommodate that */
3689         SvUPGRADE(dest, SVt_PV);
3690         d = (U8*)SvGROW(dest, need);
3691         (void)SvPOK_only(dest);
3692
3693         SETs(dest);
3694     }
3695
3696     if (doing_utf8) {
3697         if (! inplace) {
3698             if (! convert_source_to_utf8) {
3699
3700                 /* Here  both source and dest are in UTF-8, but have to create
3701                  * the entire output.  We initialize the result to be the
3702                  * title/lower cased first character, and then append the rest
3703                  * of the string. */
3704                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3705                 if (slen > ulen) {
3706                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3707                 }
3708             }
3709             else {
3710                 const U8 *const send = s + slen;
3711
3712                 /* Here the dest needs to be in UTF-8, but the source isn't,
3713                  * except we earlier UTF-8'd the first character of the source
3714                  * into tmpbuf.  First put that into dest, and then append the
3715                  * rest of the source, converting it to UTF-8 as we go. */
3716
3717                 /* Assert tculen is 2 here because the only two characters that
3718                  * get to this part of the code have 2-byte UTF-8 equivalents */
3719                 *d++ = *tmpbuf;
3720                 *d++ = *(tmpbuf + 1);
3721                 s++;    /* We have just processed the 1st char */
3722
3723                 for (; s < send; s++) {
3724                     d = uvchr_to_utf8(d, *s);
3725                 }
3726                 *d = '\0';
3727                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3728             }
3729             SvUTF8_on(dest);
3730         }
3731         else {   /* in-place UTF-8.  Just overwrite the first character */
3732             Copy(tmpbuf, d, tculen, U8);
3733             SvCUR_set(dest, need - 1);
3734         }
3735
3736     }
3737     else {  /* Neither source nor dest are in or need to be UTF-8 */
3738         if (slen) {
3739             if (inplace) {  /* in-place, only need to change the 1st char */
3740                 *d = *tmpbuf;
3741             }
3742             else {      /* Not in-place */
3743
3744                 /* Copy the case-changed character(s) from tmpbuf */
3745                 Copy(tmpbuf, d, tculen, U8);
3746                 d += tculen - 1; /* Code below expects d to point to final
3747                                   * character stored */
3748             }
3749         }
3750         else {  /* empty source */
3751             /* See bug #39028: Don't taint if empty  */
3752             *d = *s;
3753         }
3754
3755         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3756          * the destination to retain that flag */
3757         if (SvUTF8(source) && ! IN_BYTES)
3758             SvUTF8_on(dest);
3759
3760         if (!inplace) { /* Finish the rest of the string, unchanged */
3761             /* This will copy the trailing NUL  */
3762             Copy(s + 1, d + 1, slen, U8);
3763             SvCUR_set(dest, need - 1);
3764         }
3765     }
3766 #ifdef USE_LOCALE_CTYPE
3767     if (IN_LC_RUNTIME(LC_CTYPE)) {
3768         TAINT;
3769         SvTAINTED_on(dest);
3770     }
3771 #endif
3772     if (dest != source && SvTAINTED(source))
3773         SvTAINT(dest);
3774     SvSETMAGIC(dest);
3775     RETURN;
3776 }
3777
3778 /* There's so much setup/teardown code common between uc and lc, I wonder if
3779    it would be worth merging the two, and just having a switch outside each
3780    of the three tight loops.  There is less and less commonality though */
3781 PP(pp_uc)
3782 {
3783     dSP;
3784     SV *source = TOPs;
3785     STRLEN len;
3786     STRLEN min;
3787     SV *dest;
3788     const U8 *s;
3789     U8 *d;
3790
3791     SvGETMAGIC(source);
3792
3793     if ((SvPADTMP(source)
3794          ||
3795         (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
3796         && !SvREADONLY(source) && SvPOK(source)
3797         && !DO_UTF8(source)
3798         && (
3799 #ifdef USE_LOCALE_CTYPE
3800             (IN_LC_RUNTIME(LC_CTYPE))
3801             ? ! IN_UTF8_CTYPE_LOCALE
3802             :
3803 #endif
3804               ! IN_UNI_8_BIT))
3805     {
3806
3807         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
3808          * make the loop tight, so we overwrite the source with the dest before
3809          * looking at it, and we need to look at the original source
3810          * afterwards.  There would also need to be code added to handle
3811          * switching to not in-place in midstream if we run into characters
3812          * that change the length.  Since being in locale overrides UNI_8_BIT,
3813          * that latter becomes irrelevant in the above test; instead for
3814          * locale, the size can't normally change, except if the locale is a
3815          * UTF-8 one */
3816         dest = source;
3817         s = d = (U8*)SvPV_force_nomg(source, len);
3818         min = len + 1;
3819     } else {
3820         dTARGET;
3821
3822         dest = TARG;
3823
3824         s = (const U8*)SvPV_nomg_const(source, len);
3825         min = len + 1;
3826
3827         SvUPGRADE(dest, SVt_PV);
3828         d = (U8*)SvGROW(dest, min);
3829         (void)SvPOK_only(dest);
3830
3831         SETs(dest);
3832     }
3833
3834     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3835        to check DO_UTF8 again here.  */
3836
3837     if (DO_UTF8(source)) {
3838         const U8 *const send = s + len;
3839         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3840
3841         /* All occurrences of these are to be moved to follow any other marks.
3842          * This is context-dependent.  We may not be passed enough context to
3843          * move the iota subscript beyond all of them, but we do the best we can
3844          * with what we're given.  The result is always better than if we
3845          * hadn't done this.  And, the problem would only arise if we are
3846          * passed a character without all its combining marks, which would be
3847          * the caller's mistake.  The information this is based on comes from a
3848          * comment in Unicode SpecialCasing.txt, (and the Standard's text
3849          * itself) and so can't be checked properly to see if it ever gets
3850          * revised.  But the likelihood of it changing is remote */
3851         bool in_iota_subscript = FALSE;
3852
3853         while (s < send) {
3854             STRLEN u;
3855             STRLEN ulen;
3856             UV uv;
3857             if (in_iota_subscript && ! _is_utf8_mark(s)) {
3858
3859                 /* A non-mark.  Time to output the iota subscript */
3860                 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3861                 d += capital_iota_len;
3862                 in_iota_subscript = FALSE;
3863             }
3864
3865             /* Then handle the current character.  Get the changed case value
3866              * and copy it to the output buffer */
3867
3868             u = UTF8SKIP(s);
3869 #ifdef USE_LOCALE_CTYPE
3870             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
3871 #else
3872             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
3873 #endif
3874 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3875 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3876             if (uv == GREEK_CAPITAL_LETTER_IOTA
3877                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3878             {
3879                 in_iota_subscript = TRUE;
3880             }
3881             else {
3882                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3883                     /* If the eventually required minimum size outgrows the
3884                      * available space, we need to grow. */
3885                     const UV o = d - (U8*)SvPVX_const(dest);
3886
3887                     /* If someone uppercases one million U+03B0s we SvGROW()
3888                      * one million times.  Or we could try guessing how much to
3889                      * allocate without allocating too much.  Such is life.
3890                      * See corresponding comment in lc code for another option
3891                      * */
3892                     SvGROW(dest, min);
3893                     d = (U8*)SvPVX(dest) + o;
3894                 }
3895                 Copy(tmpbuf, d, ulen, U8);
3896                 d += ulen;
3897             }
3898             s += u;
3899         }
3900         if (in_iota_subscript) {
3901             Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3902             d += capital_iota_len;
3903         }
3904         SvUTF8_on(dest);
3905         *d = '\0';
3906
3907         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3908     }
3909     else {      /* Not UTF-8 */
3910         if (len) {
3911             const U8 *const send = s + len;
3912
3913             /* Use locale casing if in locale; regular style if not treating
3914              * latin1 as having case; otherwise the latin1 casing.  Do the
3915              * whole thing in a tight loop, for speed, */
3916 #ifdef USE_LOCALE_CTYPE
3917             if (IN_LC_RUNTIME(LC_CTYPE)) {
3918                 if (IN_UTF8_CTYPE_LOCALE) {
3919                     goto do_uni_rules;
3920                 }
3921                 for (; s < send; d++, s++)
3922                     *d = (U8) toUPPER_LC(*s);
3923             }
3924             else
3925 #endif
3926                  if (! IN_UNI_8_BIT) {
3927                 for (; s < send; d++, s++) {
3928                     *d = toUPPER(*s);
3929                 }
3930             }
3931             else {
3932 #ifdef USE_LOCALE_CTYPE
3933           do_uni_rules:
3934 #endif
3935                 for (; s < send; d++, s++) {
3936                     *d = toUPPER_LATIN1_MOD(*s);
3937                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3938                         continue;
3939                     }
3940
3941                     /* The mainstream case is the tight loop above.  To avoid
3942                      * extra tests in that, all three characters that require
3943                      * special handling are mapped by the MOD to the one tested
3944                      * just above.  
3945                      * Use the source to distinguish between the three cases */
3946
3947                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3948
3949                         /* uc() of this requires 2 characters, but they are
3950                          * ASCII.  If not enough room, grow the string */
3951                         if (SvLEN(dest) < ++min) {      
3952                             const UV o = d - (U8*)SvPVX_const(dest);
3953                             SvGROW(dest, min);
3954                             d = (U8*)SvPVX(dest) + o;
3955                         }
3956                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3957                         continue;   /* Back to the tight loop; still in ASCII */
3958                     }
3959
3960                     /* The other two special handling characters have their
3961                      * upper cases outside the latin1 range, hence need to be
3962                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
3963                      * here we are somewhere in the middle of processing a
3964                      * non-UTF-8 string, and realize that we will have to convert
3965                      * the whole thing to UTF-8.  What to do?  There are
3966                      * several possibilities.  The simplest to code is to
3967                      * convert what we have so far, set a flag, and continue on
3968                      * in the loop.  The flag would be tested each time through
3969                      * the loop, and if set, the next character would be
3970                      * converted to UTF-8 and stored.  But, I (khw) didn't want
3971                      * to slow down the mainstream case at all for this fairly
3972                      * rare case, so I didn't want to add a test that didn't
3973                      * absolutely have to be there in the loop, besides the
3974                      * possibility that it would get too complicated for
3975                      * optimizers to deal with.  Another possibility is to just
3976                      * give up, convert the source to UTF-8, and restart the
3977                      * function that way.  Another possibility is to convert
3978                      * both what has already been processed and what is yet to
3979                      * come separately to UTF-8, then jump into the loop that
3980                      * handles UTF-8.  But the most efficient time-wise of the
3981                      * ones I could think of is what follows, and turned out to
3982                      * not require much extra code.  */
3983
3984                     /* Convert what we have so far into UTF-8, telling the
3985                      * function that we know it should be converted, and to
3986                      * allow extra space for what we haven't processed yet.
3987                      * Assume the worst case space requirements for converting
3988                      * what we haven't processed so far: that it will require
3989                      * two bytes for each remaining source character, plus the
3990                      * NUL at the end.  This may cause the string pointer to
3991                      * move, so re-find it. */
3992
3993                     len = d - (U8*)SvPVX_const(dest);
3994                     SvCUR_set(dest, len);
3995                     len = sv_utf8_upgrade_flags_grow(dest,
3996                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3997                                                 (send -s) * 2 + 1);
3998                     d = (U8*)SvPVX(dest) + len;
3999
4000                     /* Now process the remainder of the source, converting to
4001                      * upper and UTF-8.  If a resulting byte is invariant in
4002                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4003                      * append it to the output. */
4004                     for (; s < send; s++) {
4005                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
4006                         d += len;
4007                     }
4008
4009                     /* Here have processed the whole source; no need to continue
4010                      * with the outer loop.  Each character has been converted
4011                      * to upper case and converted to UTF-8 */
4012
4013                     break;
4014                 } /* End of processing all latin1-style chars */
4015             } /* End of processing all chars */
4016         } /* End of source is not empty */
4017
4018         if (source != dest) {
4019             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4020             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4021         }
4022     } /* End of isn't utf8 */
4023 #ifdef USE_LOCALE_CTYPE
4024     if (IN_LC_RUNTIME(LC_CTYPE)) {
4025         TAINT;
4026         SvTAINTED_on(dest);
4027     }
4028 #endif
4029     if (dest != source && SvTAINTED(source))
4030         SvTAINT(dest);
4031     SvSETMAGIC(dest);
4032     RETURN;
4033 }
4034
4035 PP(pp_lc)
4036 {
4037     dSP;
4038     SV *source = TOPs;
4039     STRLEN len;
4040     STRLEN min;
4041     SV *dest;
4042     const U8 *s;
4043     U8 *d;
4044
4045     SvGETMAGIC(source);
4046
4047     if (   (  SvPADTMP(source)
4048            || (  SvTEMP(source) && !SvSMAGICAL(source)
4049               && SvREFCNT(source) == 1  )
4050            )
4051         && !SvREADONLY(source) && SvPOK(source)
4052         && !DO_UTF8(source)) {
4053
4054         /* We can convert in place, as lowercasing anything in the latin1 range
4055          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4056         dest = source;
4057         s = d = (U8*)SvPV_force_nomg(source, len);
4058         min = len + 1;
4059     } else {
4060         dTARGET;
4061
4062         dest = TARG;
4063
4064         s = (const U8*)SvPV_nomg_const(source, len);
4065         min = len + 1;
4066
4067         SvUPGRADE(dest, SVt_PV);
4068         d = (U8*)SvGROW(dest, min);
4069         (void)SvPOK_only(dest);
4070
4071         SETs(dest);
4072     }
4073
4074     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4075        to check DO_UTF8 again here.  */
4076
4077     if (DO_UTF8(source)) {
4078         const U8 *const send = s + len;
4079         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4080
4081         while (s < send) {
4082             const STRLEN u = UTF8SKIP(s);
4083             STRLEN ulen;
4084
4085 #ifdef USE_LOCALE_CTYPE
4086             _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4087 #else
4088             _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4089 #endif
4090
4091             /* Here is where we would do context-sensitive actions.  See the
4092              * commit message for 86510fb15 for why there isn't any */
4093
4094             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4095
4096                 /* If the eventually required minimum size outgrows the
4097                  * available space, we need to grow. */
4098                 const UV o = d - (U8*)SvPVX_const(dest);
4099
4100                 /* If someone lowercases one million U+0130s we SvGROW() one
4101                  * million times.  Or we could try guessing how much to
4102                  * allocate without allocating too much.  Such is life.
4103                  * Another option would be to grow an extra byte or two more
4104                  * each time we need to grow, which would cut down the million
4105                  * to 500K, with little waste */
4106                 SvGROW(dest, min);
4107                 d = (U8*)SvPVX(dest) + o;
4108             }
4109
4110             /* Copy the newly lowercased letter to the output buffer we're
4111              * building */
4112             Copy(tmpbuf, d, ulen, U8);
4113             d += ulen;
4114             s += u;
4115         }   /* End of looping through the source string */
4116         SvUTF8_on(dest);
4117         *d = '\0';
4118         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4119     } else {    /* Not utf8 */
4120         if (len) {
4121             const U8 *const send = s + len;
4122
4123             /* Use locale casing if in locale; regular style if not treating
4124              * latin1 as having case; otherwise the latin1 casing.  Do the
4125              * whole thing in a tight loop, for speed, */
4126 #ifdef USE_LOCALE_CTYPE
4127             if (IN_LC_RUNTIME(LC_CTYPE)) {
4128                 for (; s < send; d++, s++)
4129                     *d = toLOWER_LC(*s);
4130             }
4131             else
4132 #endif
4133             if (! IN_UNI_8_BIT) {
4134                 for (; s < send; d++, s++) {
4135                     *d = toLOWER(*s);
4136                 }
4137             }
4138             else {
4139                 for (; s < send; d++, s++) {
4140                     *d = toLOWER_LATIN1(*s);
4141                 }
4142             }
4143         }
4144         if (source != dest) {
4145             *d = '\0';
4146             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4147         }
4148     }
4149 #ifdef USE_LOCALE_CTYPE
4150     if (IN_LC_RUNTIME(LC_CTYPE)) {
4151         TAINT;
4152         SvTAINTED_on(dest);
4153     }
4154 #endif
4155     if (dest != source && SvTAINTED(source))
4156         SvTAINT(dest);
4157     SvSETMAGIC(dest);
4158     RETURN;
4159 }
4160
4161 PP(pp_quotemeta)
4162 {
4163     dSP; dTARGET;
4164     SV * const sv = TOPs;
4165     STRLEN len;
4166     const char *s = SvPV_const(sv,len);
4167
4168     SvUTF8_off(TARG);                           /* decontaminate */
4169     if (len) {
4170         char *d;
4171         SvUPGRADE(TARG, SVt_PV);
4172         SvGROW(TARG, (len * 2) + 1);
4173         d = SvPVX(TARG);
4174         if (DO_UTF8(sv)) {
4175             while (len) {
4176                 STRLEN ulen = UTF8SKIP(s);
4177                 bool to_quote = FALSE;
4178
4179                 if (UTF8_IS_INVARIANT(*s)) {
4180                     if (_isQUOTEMETA(*s)) {
4181                         to_quote = TRUE;
4182                     }
4183                 }
4184                 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4185                     if (
4186 #ifdef USE_LOCALE_CTYPE
4187                     /* In locale, we quote all non-ASCII Latin1 chars.
4188                      * Otherwise use the quoting rules */
4189                     
4190                     IN_LC_RUNTIME(LC_CTYPE)
4191                         ||
4192 #endif
4193                         _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
4194                     {
4195                         to_quote = TRUE;
4196                     }
4197                 }
4198                 else if (is_QUOTEMETA_high(s)) {
4199                     to_quote = TRUE;
4200                 }
4201
4202                 if (to_quote) {
4203                     *d++ = '\\';
4204                 }
4205                 if (ulen > len)
4206                     ulen = len;
4207                 len -= ulen;
4208                 while (ulen--)
4209                     *d++ = *s++;
4210             }
4211             SvUTF8_on(TARG);
4212         }
4213         else if (IN_UNI_8_BIT) {
4214             while (len--) {
4215                 if (_isQUOTEMETA(*s))
4216                     *d++ = '\\';
4217                 *d++ = *s++;
4218             }
4219         }
4220         else {
4221             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4222              * including everything above ASCII */
4223             while (len--) {
4224                 if (!isWORDCHAR_A(*s))
4225                     *d++ = '\\';
4226                 *d++ = *s++;
4227             }
4228         }
4229         *d = '\0';
4230         SvCUR_set(TARG, d - SvPVX_const(TARG));
4231         (void)SvPOK_only_UTF8(TARG);
4232     }
4233     else
4234         sv_setpvn(TARG, s, len);
4235     SETTARG;
4236     RETURN;
4237 }
4238
4239 PP(pp_fc)
4240 {
4241     dTARGET;
4242     dSP;
4243     SV *source = TOPs;
4244     STRLEN len;
4245     STRLEN min;
4246     SV *dest;
4247     const U8 *s;
4248     const U8 *send;
4249     U8 *d;
4250     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4251     const bool full_folding = TRUE; /* This variable is here so we can easily
4252                                        move to more generality later */
4253     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4254 #ifdef USE_LOCALE_CTYPE
4255                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4256 #endif
4257     ;
4258
4259     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4260      * You are welcome(?) -Hugmeir
4261      */
4262
4263     SvGETMAGIC(source);
4264
4265     dest = TARG;
4266
4267     if (SvOK(source)) {
4268         s = (const U8*)SvPV_nomg_const(source, len);
4269     } else {
4270         if (ckWARN(WARN_UNINITIALIZED))
4271             report_uninit(source);
4272         s = (const U8*)"";
4273         len = 0;
4274     }
4275
4276     min = len + 1;
4277
4278     SvUPGRADE(dest, SVt_PV);
4279     d = (U8*)SvGROW(dest, min);
4280     (void)SvPOK_only(dest);
4281
4282     SETs(dest);
4283
4284     send = s + len;
4285     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4286         while (s < send) {
4287             const STRLEN u = UTF8SKIP(s);
4288             STRLEN ulen;
4289
4290             _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4291
4292             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4293                 const UV o = d - (U8*)SvPVX_const(dest);
4294                 SvGROW(dest, min);
4295                 d = (U8*)SvPVX(dest) + o;
4296             }
4297
4298             Copy(tmpbuf, d, ulen, U8);
4299             d += ulen;
4300             s += u;
4301         }
4302         SvUTF8_on(dest);
4303     } /* Unflagged string */
4304     else if (len) {
4305 #ifdef USE_LOCALE_CTYPE
4306         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4307             if (IN_UTF8_CTYPE_LOCALE) {
4308                 goto do_uni_folding;
4309             }
4310             for (; s < send; d++, s++)
4311                 *d = (U8) toFOLD_LC(*s);
4312         }
4313         else
4314 #endif
4315         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4316             for (; s < send; d++, s++)
4317                 *d = toFOLD(*s);
4318         }
4319         else {
4320 #ifdef USE_LOCALE_CTYPE
4321       do_uni_folding:
4322 #endif
4323             /* For ASCII and the Latin-1 range, there's only two troublesome
4324              * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4325              * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4326              * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4327              * For the rest, the casefold is their lowercase.  */
4328             for (; s < send; d++, s++) {
4329                 if (*s == MICRO_SIGN) {
4330                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4331                      * which is outside of the latin-1 range. There's a couple
4332                      * of ways to deal with this -- khw discusses them in
4333                      * pp_lc/uc, so go there :) What we do here is upgrade what
4334                      * we had already casefolded, then enter an inner loop that
4335                      * appends the rest of the characters as UTF-8. */
4336                     len = d - (U8*)SvPVX_const(dest);
4337                     SvCUR_set(dest, len);
4338                     len = sv_utf8_upgrade_flags_grow(dest,
4339                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4340                                                 /* The max expansion for latin1
4341                                                  * chars is 1 byte becomes 2 */
4342                                                 (send -s) * 2 + 1);
4343                     d = (U8*)SvPVX(dest) + len;
4344
4345                     Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4346                     d += small_mu_len;
4347                     s++;
4348                     for (; s < send; s++) {
4349                         STRLEN ulen;
4350                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4351                         if UVCHR_IS_INVARIANT(fc) {
4352                             if (full_folding
4353                                 && *s == LATIN_SMALL_LETTER_SHARP_S)
4354                             {
4355                                 *d++ = 's';
4356                                 *d++ = 's';
4357                             }
4358                             else
4359                                 *d++ = (U8)fc;
4360                         }
4361                         else {
4362                             Copy(tmpbuf, d, ulen, U8);
4363                             d += ulen;
4364                         }
4365                     }
4366                     break;
4367                 }
4368                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4369                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4370                      * becomes "ss", which may require growing the SV. */
4371                     if (SvLEN(dest) < ++min) {
4372                         const UV o = d - (U8*)SvPVX_const(dest);
4373                         SvGROW(dest, min);
4374                         d = (U8*)SvPVX(dest) + o;
4375                      }
4376                     *(d)++ = 's';
4377                     *d = 's';
4378                 }
4379                 else { /* If it's not one of those two, the fold is their lower
4380                           case */
4381                     *d = toLOWER_LATIN1(*s);
4382                 }
4383              }
4384         }
4385     }
4386     *d = '\0';
4387     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4388
4389 #ifdef USE_LOCALE_CTYPE
4390     if (IN_LC_RUNTIME(LC_CTYPE)) {
4391         TAINT;
4392         SvTAINTED_on(dest);
4393     }
4394 #endif
4395     if (SvTAINTED(source))
4396         SvTAINT(dest);
4397     SvSETMAGIC(dest);
4398     RETURN;
4399 }
4400
4401 /* Arrays. */
4402
4403 PP(pp_aslice)
4404 {
4405     dSP; dMARK; dORIGMARK;
4406     AV *const av = MUTABLE_AV(POPs);
4407     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4408
4409     if (SvTYPE(av) == SVt_PVAV) {
4410         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4411         bool can_preserve = FALSE;
4412
4413         if (localizing) {
4414             MAGIC *mg;
4415             HV *stash;
4416
4417             can_preserve = SvCANEXISTDELETE(av);
4418         }
4419
4420         if (lval && localizing) {
4421             SV **svp;
4422             SSize_t max = -1;
4423             for (svp = MARK + 1; svp <= SP; svp++) {
4424                 const SSize_t elem = SvIV(*svp);
4425                 if (elem > max)
4426                     max = elem;
4427             }
4428             if (max > AvMAX(av))
4429                 av_extend(av, max);
4430         }
4431
4432         while (++MARK <= SP) {
4433             SV **svp;
4434             SSize_t elem = SvIV(*MARK);
4435             bool preeminent = TRUE;
4436
4437             if (localizing && can_preserve) {
4438                 /* If we can determine whether the element exist,
4439                  * Try to preserve the existenceness of a tied array
4440                  * element by using EXISTS and DELETE if possible.
4441                  * Fallback to FETCH and STORE otherwise. */
4442                 preeminent = av_exists(av, elem);
4443             }
4444
4445             svp = av_fetch(av, elem, lval);
4446             if (lval) {
4447                 if (!svp || !*svp)
4448                     DIE(aTHX_ PL_no_aelem, elem);
4449                 if (localizing) {
4450                     if (preeminent)
4451                         save_aelem(av, elem, svp);
4452                     else
4453                         SAVEADELETE(av, elem);
4454                 }
4455             }
4456             *MARK = svp ? *svp : &PL_sv_undef;
4457         }
4458     }
4459     if (GIMME != G_ARRAY) {
4460         MARK = ORIGMARK;
4461         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4462         SP = MARK;
4463     }
4464     RETURN;
4465 }
4466
4467 PP(pp_kvaslice)
4468 {
4469     dSP; dMARK;
4470     AV *const av = MUTABLE_AV(POPs);
4471     I32 lval = (PL_op->op_flags & OPf_MOD);
4472     SSize_t items = SP - MARK;
4473
4474     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4475        const I32 flags = is_lvalue_sub();
4476        if (flags) {
4477            if (!(flags & OPpENTERSUB_INARGS))
4478                /* diag_listed_as: Can't modify %s in %s */
4479                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4480            lval = flags;
4481        }
4482     }
4483
4484     MEXTEND(SP,items);
4485     while (items > 1) {
4486         *(MARK+items*2-1) = *(MARK+items);
4487         items--;
4488     }
4489     items = SP-MARK;
4490     SP += items;
4491
4492     while (++MARK <= SP) {
4493         SV **svp;
4494
4495         svp = av_fetch(av, SvIV(*MARK), lval);
4496         if (lval) {
4497             if (!svp || !*svp || *svp == &PL_sv_undef) {
4498                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4499             }
4500             *MARK = sv_mortalcopy(*MARK);
4501         }
4502         *++MARK = svp ? *svp : &PL_sv_undef;
4503     }
4504     if (GIMME != G_ARRAY) {
4505         MARK = SP - items*2;
4506         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4507         SP = MARK;
4508     }
4509     RETURN;
4510 }
4511
4512
4513 /* Smart dereferencing for keys, values and each */
4514
4515 /* also used for: pp_reach() pp_rvalues() */
4516
4517 PP(pp_rkeys)
4518 {
4519     dSP;
4520     dPOPss;
4521
4522     SvGETMAGIC(sv);
4523
4524     if (
4525          !SvROK(sv)
4526       || (sv = SvRV(sv),
4527             (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4528           || SvOBJECT(sv)
4529          )
4530     ) {
4531         DIE(aTHX_
4532            "Type of argument to %s must be unblessed hashref or arrayref",
4533             PL_op_desc[PL_op->op_type] );
4534     }
4535
4536     if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4537         DIE(aTHX_
4538            "Can't modify %s in %s",
4539             PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4540         );
4541
4542     /* Delegate to correct function for op type */
4543     PUSHs(sv);
4544     if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4545         return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4546     }
4547     else {
4548         return (SvTYPE(sv) == SVt_PVHV)
4549                ? Perl_pp_each(aTHX)
4550                : Perl_pp_aeach(aTHX);
4551     }
4552 }
4553
4554 PP(pp_aeach)
4555 {
4556     dSP;
4557     AV *array = MUTABLE_AV(POPs);
4558     const I32 gimme = GIMME_V;
4559     IV *iterp = Perl_av_iter_p(aTHX_ array);
4560     const IV current = (*iterp)++;
4561
4562     if (current > av_tindex(array)) {
4563         *iterp = 0;
4564         if (gimme == G_SCALAR)
4565             RETPUSHUNDEF;
4566         else
4567             RETURN;
4568     }
4569
4570     EXTEND(SP, 2);
4571     mPUSHi(current);
4572     if (gimme == G_ARRAY) {
4573         SV **const element = av_fetch(array, current, 0);
4574         PUSHs(element ? *element : &PL_sv_undef);
4575     }
4576     RETURN;
4577 }
4578
4579 /* also used for: pp_avalues()*/
4580 PP(pp_akeys)
4581 {
4582     dSP;
4583     AV *array = MUTABLE_AV(POPs);
4584     const I32 gimme = GIMME_V;
4585
4586     *Perl_av_iter_p(aTHX_ array) = 0;
4587
4588     if (gimme == G_SCALAR) {
4589         dTARGET;
4590         PUSHi(av_tindex(array) + 1);
4591     }
4592     else if (gimme == G_ARRAY) {
4593         IV n = Perl_av_len(aTHX_ array);
4594         IV i;
4595
4596         EXTEND(SP, n + 1);
4597
4598         if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4599             for (i = 0;  i <= n;  i++) {
4600                 mPUSHi(i);
4601             }
4602         }
4603         else {
4604             for (i = 0;  i <= n;  i++) {
4605                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4606                 PUSHs(elem ? *elem : &PL_sv_undef);
4607             }
4608         }
4609     }
4610     RETURN;
4611 }
4612
4613 /* Associative arrays. */
4614
4615 PP(pp_each)
4616 {
4617     dSP;
4618     HV * hash = MUTABLE_HV(POPs);
4619     HE *entry;
4620     const I32 gimme = GIMME_V;
4621
4622     PUTBACK;
4623     /* might clobber stack_sp */
4624     entry = hv_iternext(hash);
4625     SPAGAIN;
4626
4627     EXTEND(SP, 2);
4628     if (entry) {
4629         SV* const sv = hv_iterkeysv(entry);
4630         PUSHs(sv);      /* won't clobber stack_sp */
4631         if (gimme == G_ARRAY) {
4632             SV *val;
4633             PUTBACK;
4634             /* might clobber stack_sp */
4635             val = hv_iterval(hash, entry);
4636             SPAGAIN;
4637             PUSHs(val);
4638         }
4639     }
4640     else if (gimme == G_SCALAR)
4641         RETPUSHUNDEF;
4642
4643     RETURN;
4644 }
4645
4646 STATIC OP *
4647 S_do_delete_local(pTHX)
4648 {
4649     dSP;
4650     const I32 gimme = GIMME_V;
4651     const MAGIC *mg;
4652     HV *stash;
4653     const bool sliced = !!(PL_op->op_private & OPpSLICE);
4654     SV **unsliced_keysv = sliced ? NULL : sp--;
4655     SV * const osv = POPs;
4656     SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4657     dORIGMARK;
4658     const bool tied = SvRMAGICAL(osv)
4659                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4660     const bool can_preserve = SvCANEXISTDELETE(osv);
4661     const U32 type = SvTYPE(osv);
4662     SV ** const end = sliced ? SP : unsliced_keysv;
4663
4664     if (type == SVt_PVHV) {                     /* hash element */
4665             HV * const hv = MUTABLE_HV(osv);
4666             while (++MARK <= end) {
4667                 SV * const keysv = *MARK;
4668                 SV *sv = NULL;
4669                 bool preeminent = TRUE;
4670                 if (can_preserve)
4671                     preeminent = hv_exists_ent(hv, keysv, 0);
4672                 if (tied) {
4673                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4674                     if (he)
4675                         sv = HeVAL(he);
4676                     else
4677                         preeminent = FALSE;
4678                 }
4679                 else {
4680                     sv = hv_delete_ent(hv, keysv, 0, 0);
4681                     if (preeminent)
4682                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4683                 }
4684                 if (preeminent) {
4685                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4686                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4687                     if (tied) {
4688                         *MARK = sv_mortalcopy(sv);
4689                         mg_clear(sv);
4690                     } else
4691                         *MARK = sv;
4692                 }
4693                 else {
4694                     SAVEHDELETE(hv, keysv);
4695                     *MARK = &PL_sv_undef;
4696                 }
4697             }
4698     }
4699     else if (type == SVt_PVAV) {                  /* array element */
4700             if (PL_op->op_flags & OPf_SPECIAL) {
4701                 AV * const av = MUTABLE_AV(osv);
4702                 while (++MARK <= end) {
4703                     SSize_t idx = SvIV(*MARK);
4704                     SV *sv = NULL;
4705                     bool preeminent = TRUE;
4706                     if (can_preserve)
4707                         preeminent = av_exists(av, idx);
4708                     if (tied) {
4709                         SV **svp = av_fetch(av, idx, 1);
4710                         if (svp)
4711                             sv = *svp;
4712                         else
4713                             preeminent = FALSE;
4714                     }
4715                     else {
4716                         sv = av_delete(av, idx, 0);
4717                         if (preeminent)
4718                            SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4719                     }
4720                     if (preeminent) {
4721                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4722                         if (tied) {
4723                             *MARK = sv_mortalcopy(sv);
4724                             mg_clear(sv);
4725                         } else
4726                             *MARK = sv;
4727                     }
4728                     else {
4729                         SAVEADELETE(av, idx);
4730                         *MARK = &PL_sv_undef;
4731                     }
4732                 }
4733             }
4734             else
4735                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4736     }
4737     else
4738             DIE(aTHX_ "Not a HASH reference");
4739     if (sliced) {
4740         if (gimme == G_VOID)
4741             SP = ORIGMARK;
4742         else if (gimme == G_SCALAR) {
4743             MARK = ORIGMARK;
4744             if (SP > MARK)
4745                 *++MARK = *SP;
4746             else
4747                 *++MARK = &PL_sv_undef;
4748             SP = MARK;
4749         }
4750     }
4751     else if (gimme != G_VOID)
4752         PUSHs(*unsliced_keysv);
4753
4754     RETURN;
4755 }
4756
4757 PP(pp_delete)
4758 {
4759     dSP;
4760     I32 gimme;
4761     I32 discard;
4762
4763     if (PL_op->op_private & OPpLVAL_INTRO)
4764         return do_delete_local();
4765
4766     gimme = GIMME_V;
4767     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4768
4769     if (PL_op->op_private & OPpSLICE) {
4770         dMARK; dORIGMARK;
4771         HV * const hv = MUTABLE_HV(POPs);
4772         const U32 hvtype = SvTYPE(hv);
4773         if (hvtype == SVt_PVHV) {                       /* hash element */
4774             while (++MARK <= SP) {
4775                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4776                 *MARK = sv ? sv : &PL_sv_undef;
4777             }
4778         }
4779         else if (hvtype == SVt_PVAV) {                  /* array element */
4780             if (PL_op->op_flags & OPf_SPECIAL) {
4781                 while (++MARK <= SP) {
4782                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4783                     *MARK = sv ? sv : &PL_sv_undef;
4784                 }
4785             }
4786         }
4787         else
4788             DIE(aTHX_ "Not a HASH reference");
4789         if (discard)
4790             SP = ORIGMARK;
4791         else if (gimme == G_SCALAR) {
4792             MARK = ORIGMARK;
4793             if (SP > MARK)
4794                 *++MARK = *SP;
4795             else
4796                 *++MARK = &PL_sv_undef;
4797             SP = MARK;
4798         }
4799     }
4800     else {
4801         SV *keysv = POPs;
4802         HV * const hv = MUTABLE_HV(POPs);
4803         SV *sv = NULL;
4804         if (SvTYPE(hv) == SVt_PVHV)
4805             sv = hv_delete_ent(hv, keysv, discard, 0);
4806         else if (SvTYPE(hv) == SVt_PVAV) {
4807             if (PL_op->op_flags & OPf_SPECIAL)
4808                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4809             else
4810                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4811         }
4812         else
4813             DIE(aTHX_ "Not a HASH reference");
4814         if (!sv)
4815             sv = &PL_sv_undef;
4816         if (!discard)
4817             PUSHs(sv);
4818     }
4819     RETURN;
4820 }
4821
4822 PP(pp_exists)
4823 {
4824     dSP;
4825     SV *tmpsv;
4826     HV *hv;
4827
4828     if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
4829         GV *gv;
4830         SV * const sv = POPs;
4831         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4832         if (cv)
4833             RETPUSHYES;
4834         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4835             RETPUSHYES;
4836         RETPUSHNO;
4837     }
4838     tmpsv = POPs;
4839     hv = MUTABLE_HV(POPs);
4840     if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
4841         if (hv_exists_ent(hv, tmpsv, 0))
4842             RETPUSHYES;
4843     }
4844     else if (SvTYPE(hv) == SVt_PVAV) {
4845         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4846             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4847                 RETPUSHYES;
4848         }
4849     }
4850     else {
4851         DIE(aTHX_ "Not a HASH reference");
4852     }
4853     RETPUSHNO;
4854 }
4855
4856 PP(pp_hslice)
4857 {
4858     dSP; dMARK; dORIGMARK;
4859     HV * const hv = MUTABLE_HV(POPs);
4860     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4861     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4862     bool can_preserve = FALSE;
4863
4864     if (localizing) {
4865         MAGIC *mg;
4866         HV *stash;
4867
4868         if (SvCANEXISTDELETE(hv))
4869             can_preserve = TRUE;
4870     }
4871
4872     while (++MARK <= SP) {
4873         SV * const keysv = *MARK;
4874         SV **svp;
4875         HE *he;
4876         bool preeminent = TRUE;
4877
4878         if (localizing && can_preserve) {
4879             /* If we can determine whether the element exist,
4880              * try to preserve the existenceness of a tied hash
4881              * element by using EXISTS and DELETE if possible.
4882              * Fallback to FETCH and STORE otherwise. */
4883             preeminent = hv_exists_ent(hv, keysv, 0);
4884         }
4885
4886         he = hv_fetch_ent(hv, keysv, lval, 0);
4887         svp = he ? &HeVAL(he) : NULL;
4888
4889         if (lval) {
4890             if (!svp || !*svp || *svp == &PL_sv_undef) {
4891                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4892             }
4893             if (localizing) {
4894                 if (HvNAME_get(hv) && isGV(*svp))
4895                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4896                 else if (preeminent)
4897                     save_helem_flags(hv, keysv, svp,
4898                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4899                 else
4900                     SAVEHDELETE(hv, keysv);
4901             }
4902         }
4903         *MARK = svp && *svp ? *svp : &PL_sv_undef;
4904     }
4905     if (GIMME != G_ARRAY) {
4906         MARK = ORIGMARK;
4907         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4908         SP = MARK;
4909     }
4910     RETURN;
4911 }
4912
4913 PP(pp_kvhslice)
4914 {
4915     dSP; dMARK;
4916     HV * const hv = MUTABLE_HV(POPs);
4917     I32 lval = (PL_op->op_flags & OPf_MOD);
4918     SSize_t items = SP - MARK;
4919
4920     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4921        const I32 flags = is_lvalue_sub();
4922        if (flags) {
4923            if (!(flags & OPpENTERSUB_INARGS))
4924                /* diag_listed_as: Can't modify %s in %s */
4925                Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
4926            lval = flags;
4927        }
4928     }
4929
4930     MEXTEND(SP,items);
4931     while (items > 1) {
4932         *(MARK+items*2-1) = *(MARK+items);
4933         items--;
4934     }
4935     items = SP-MARK;
4936     SP += items;
4937
4938     while (++MARK <= SP) {
4939         SV * const keysv = *MARK;
4940         SV **svp;
4941         HE *he;
4942
4943         he = hv_fetch_ent(hv, keysv, lval, 0);
4944         svp = he ? &HeVAL(he) : NULL;
4945
4946         if (lval) {
4947             if (!svp || !*svp || *svp == &PL_sv_undef) {
4948                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4949             }
4950             *MARK = sv_mortalcopy(*MARK);
4951         }
4952         *++MARK = svp && *svp ? *svp : &PL_sv_undef;
4953     }
4954     if (GIMME != G_ARRAY) {
4955         MARK = SP - items*2;
4956         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4957         SP = MARK;
4958     }
4959     RETURN;
4960 }
4961
4962 /* List operators. */
4963
4964 PP(pp_list)
4965 {
4966     I32 markidx = POPMARK;
4967     if (GIMME != G_ARRAY) {
4968         SV **mark = PL_stack_base + markidx;
4969         dSP;
4970         if (++MARK <= SP)
4971             *MARK = *SP;                /* unwanted list, return last item */
4972         else
4973             *MARK = &PL_sv_undef;
4974         SP = MARK;
4975         PUTBACK;
4976     }
4977     return NORMAL;
4978 }
4979
4980 PP(pp_lslice)
4981 {
4982     dSP;
4983     SV ** const lastrelem = PL_stack_sp;
4984     SV ** const lastlelem = PL_stack_base + POPMARK;
4985     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4986     SV ** const firstrelem = lastlelem + 1;
4987     I32 is_something_there = FALSE;
4988     const U8 mod = PL_op->op_flags & OPf_MOD;
4989
4990     const I32 max = lastrelem - lastlelem;
4991     SV **lelem;
4992
4993     if (GIMME != G_ARRAY) {
4994         I32 ix = SvIV(*lastlelem);
4995         if (ix < 0)
4996             ix += max;
4997         if (ix < 0 || ix >= max)
4998             *firstlelem = &PL_sv_undef;
4999         else
5000             *firstlelem = firstrelem[ix];
5001         SP = firstlelem;
5002         RETURN;
5003     }
5004
5005     if (max == 0) {
5006         SP = firstlelem - 1;
5007         RETURN;
5008     }
5009
5010     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5011         I32 ix = SvIV(*lelem);
5012         if (ix < 0)
5013             ix += max;
5014         if (ix < 0 || ix >= max)
5015             *lelem = &PL_sv_undef;
5016         else {
5017             is_something_there = TRUE;
5018             if (!(*lelem = firstrelem[ix]))
5019                 *lelem = &PL_sv_undef;
5020             else if (mod && SvPADTMP(*lelem)) {
5021                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5022             }
5023         }
5024     }
5025     if (is_something_there)
5026         SP = lastlelem;
5027     else
5028         SP = firstlelem - 1;
5029     RETURN;
5030 }
5031
5032 PP(pp_anonlist)
5033 {
5034     dSP; dMARK;
5035     const I32 items = SP - MARK;
5036     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5037     SP = MARK;
5038     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5039             ? newRV_noinc(av) : av);
5040     RETURN;
5041 }
5042
5043 PP(pp_anonhash)
5044 {
5045     dSP; dMARK; dORIGMARK;
5046     HV* const hv = newHV();
5047     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5048                                     ? newRV_noinc(MUTABLE_SV(hv))
5049                                     : MUTABLE_SV(hv) );
5050
5051     while (MARK < SP) {
5052         SV * const key =
5053             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5054         SV *val;
5055         if (MARK < SP)
5056         {
5057             MARK++;
5058             SvGETMAGIC(*MARK);
5059             val = newSV(0);
5060             sv_setsv(val, *MARK);
5061         }
5062         else
5063         {
5064             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5065             val = newSV(0);
5066         }
5067         (void)hv_store_ent(hv,key,val,0);
5068     }
5069     SP = ORIGMARK;
5070     XPUSHs(retval);
5071     RETURN;
5072 }
5073
5074 static AV *
5075 S_deref_plain_array(pTHX_ AV *ary)
5076 {
5077     if (SvTYPE(ary) == SVt_PVAV) return ary;
5078     SvGETMAGIC((SV *)ary);
5079     if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5080         Perl_die(aTHX_ "Not an ARRAY reference");
5081     else if (SvOBJECT(SvRV(ary)))
5082         Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5083     return (AV *)SvRV(ary);
5084 }
5085
5086 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5087 # define DEREF_PLAIN_ARRAY(ary)       \
5088    ({                                  \
5089      AV *aRrRay = ary;                  \
5090      SvTYPE(aRrRay) == SVt_PVAV          \
5091       ? aRrRay                            \
5092       : S_deref_plain_array(aTHX_ aRrRay); \
5093    })
5094 #else
5095 # define DEREF_PLAIN_ARRAY(ary)            \
5096    (                                        \
5097      PL_Sv = (SV *)(ary),                    \
5098      SvTYPE(PL_Sv) == SVt_PVAV                \
5099       ? (AV *)PL_Sv                            \
5100       : S_deref_plain_array(aTHX_ (AV *)PL_Sv)  \
5101    )
5102 #endif
5103
5104 PP(pp_splice)
5105 {
5106     dSP; dMARK; dORIGMARK;
5107     int num_args = (SP - MARK);
5108     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5109     SV **src;
5110     SV **dst;
5111     SSize_t i;
5112     SSize_t offset;
5113     SSize_t length;
5114     SSize_t newlen;
5115     SSize_t after;
5116     SSize_t diff;
5117     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5118
5119     if (mg) {
5120         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5121                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5122                                     sp - mark);
5123     }
5124
5125     SP++;
5126
5127     if (++MARK < SP) {
5128         offset = i = SvIV(*MARK);
5129         if (offset < 0)
5130             offset += AvFILLp(ary) + 1;
5131         if (offset < 0)
5132             DIE(aTHX_ PL_no_aelem, i);
5133         if (++MARK < SP) {
5134             length = SvIVx(*MARK++);
5135             if (length < 0) {
5136                 length += AvFILLp(ary) - offset + 1;
5137                 if (length < 0)
5138                     length = 0;
5139             }
5140         }
5141         else
5142             length = AvMAX(ary) + 1;            /* close enough to infinity */
5143     }
5144     else {
5145         offset = 0;
5146         length = AvMAX(ary) + 1;
5147     }
5148     if (offset > AvFILLp(ary) + 1) {
5149         if (num_args > 2)
5150             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5151         offset = AvFILLp(ary) + 1;
5152     }
5153     after = AvFILLp(ary) + 1 - (offset + length);
5154     if (after < 0) {                            /* not that much array */
5155         length += after;                        /* offset+length now in array */
5156         after = 0;
5157         if (!AvALLOC(ary))
5158             av_extend(ary, 0);
5159     }
5160
5161     /* At this point, MARK .. SP-1 is our new LIST */
5162
5163     newlen = SP - MARK;
5164     diff = newlen - length;
5165     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5166         av_reify(ary);
5167
5168     /* make new elements SVs now: avoid problems if they're from the array */
5169     for (dst = MARK, i = newlen; i; i--) {
5170         SV * const h = *dst;
5171         *dst++ = newSVsv(h);
5172     }
5173
5174     if (diff < 0) {                             /* shrinking the area */
5175         SV **tmparyval = NULL;
5176         if (newlen) {
5177             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5178             Copy(MARK, tmparyval, newlen, SV*);
5179         }
5180
5181         MARK = ORIGMARK + 1;
5182         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5183             const bool real = cBOOL(AvREAL(ary));
5184             MEXTEND(MARK, length);
5185             if (real)
5186                 EXTEND_MORTAL(length);
5187             for (i = 0, dst = MARK; i < length; i++) {
5188                 if ((*dst = AvARRAY(ary)[i+offset])) {
5189                   if (real)
5190                     sv_2mortal(*dst);   /* free them eventually */
5191                 }
5192                 else
5193                     *dst = &PL_sv_undef;
5194                 dst++;
5195             }
5196             MARK += length - 1;
5197         }
5198         else {
5199             *MARK = AvARRAY(ary)[offset+length-1];
5200             if (AvREAL(ary)) {
5201                 sv_2mortal(*MARK);
5202                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5203                     SvREFCNT_dec(*dst++);       /* free them now */
5204             }
5205         }
5206         AvFILLp(ary) += diff;
5207
5208         /* pull up or down? */
5209
5210         if (offset < after) {                   /* easier to pull up */
5211             if (offset) {                       /* esp. if nothing to pull */
5212                 src = &AvARRAY(ary)[offset-1];
5213                 dst = src - diff;               /* diff is negative */
5214                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5215                     *dst-- = *src--;
5216             }
5217             dst = AvARRAY(ary);
5218             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5219             AvMAX(ary) += diff;
5220         }
5221         else {
5222             if (after) {                        /* anything to pull down? */
5223                 src = AvARRAY(ary) + offset + length;
5224                 dst = src + diff;               /* diff is negative */
5225                 Move(src, dst, after, SV*);
5226             }
5227             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5228                                                 /* avoid later double free */
5229         }
5230         i = -diff;
5231         while (i)
5232             dst[--i] = NULL;
5233         
5234         if (newlen) {
5235             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5236             Safefree(tmparyval);
5237         }
5238     }
5239     else {                                      /* no, expanding (or same) */
5240         SV** tmparyval = NULL;
5241         if (length) {
5242             Newx(tmparyval, length, SV*);       /* so remember deletion */
5243             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5244         }
5245
5246         if (diff > 0) {                         /* expanding */
5247             /* push up or down? */
5248             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5249                 if (offset) {
5250                     src = AvARRAY(ary);
5251                     dst = src - diff;
5252                     Move(src, dst, offset, SV*);
5253                 }
5254                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5255                 AvMAX(ary) += diff;
5256                 AvFILLp(ary) += diff;
5257             }
5258             else {
5259                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5260                     av_extend(ary, AvFILLp(ary) + diff);
5261                 AvFILLp(ary) += diff;
5262
5263                 if (after) {
5264                     dst = AvARRAY(ary) + AvFILLp(ary);
5265                     src = dst - diff;
5266                     for (i = after; i; i--) {
5267                         *dst-- = *src--;
5268                     }
5269                 }
5270             }
5271         }
5272
5273         if (newlen) {
5274             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5275         }
5276
5277         MARK = ORIGMARK + 1;
5278         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5279             if (length) {
5280                 const bool real = cBOOL(AvREAL(ary));
5281                 if (real)
5282                     EXTEND_MORTAL(length);
5283                 for (i = 0, dst = MARK; i < length; i++) {
5284                     if ((*dst = tmparyval[i])) {
5285                       if (real)
5286                         sv_2mortal(*dst);       /* free them eventually */
5287                     }
5288                     else *dst = &PL_sv_undef;
5289                     dst++;
5290                 }
5291             }
5292             MARK += length - 1;
5293         }
5294         else if (length--) {
5295             *MARK = tmparyval[length];
5296             if (AvREAL(ary)) {
5297                 sv_2mortal(*MARK);
5298                 while (length-- > 0)
5299                     SvREFCNT_dec(tmparyval[length]);
5300             }
5301         }
5302         else
5303             *MARK = &PL_sv_undef;
5304         Safefree(tmparyval);
5305     }
5306
5307     if (SvMAGICAL(ary))
5308         mg_set(MUTABLE_SV(ary));
5309
5310     SP = MARK;
5311     RETURN;
5312 }
5313
5314 PP(pp_push)
5315 {
5316     dSP; dMARK; dORIGMARK; dTARGET;
5317     AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5318     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5319
5320     if (mg) {
5321         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5322         PUSHMARK(MARK);
5323         PUTBACK;
5324         ENTER_with_name("call_PUSH");
5325         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5326         LEAVE_with_name("call_PUSH");
5327         SPAGAIN;
5328     }
5329     else {
5330         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5331         PL_delaymagic = DM_DELAY;
5332         for (++MARK; MARK <= SP; MARK++) {
5333             SV *sv;
5334             if (*MARK) SvGETMAGIC(*MARK);
5335             sv = newSV(0);
5336             if (*MARK)
5337                 sv_setsv_nomg(sv, *MARK);
5338             av_store(ary, AvFILLp(ary)+1, sv);
5339         }
5340         if (PL_delaymagic & DM_ARRAY_ISA)
5341             mg_set(MUTABLE_SV(ary));
5342
5343         PL_delaymagic = 0;
5344     }
5345     SP = ORIGMARK;
5346     if (OP_GIMME(PL_op, 0) != G_VOID) {
5347         PUSHi( AvFILL(ary) + 1 );
5348     }
5349     RETURN;
5350 }
5351
5352 /* also used for: pp_pop()*/
5353 PP(pp_shift)
5354 {
5355     dSP;
5356     AV * const av = PL_op->op_flags & OPf_SPECIAL
5357         ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5358     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5359     EXTEND(SP, 1);
5360     assert (sv);
5361     if (AvREAL(av))
5362         (void)sv_2mortal(sv);
5363     PUSHs(sv);
5364     RETURN;
5365 }
5366
5367 PP(pp_unshift)
5368 {
5369     dSP; dMARK; dORIGMARK; dTARGET;
5370     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5371     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5372
5373     if (mg) {
5374         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5375         PUSHMARK(MARK);
5376         PUTBACK;
5377         ENTER_with_name("call_UNSHIFT");
5378         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5379         LEAVE_with_name("call_UNSHIFT");
5380         SPAGAIN;
5381     }
5382     else {
5383         SSize_t i = 0;
5384         av_unshift(ary, SP - MARK);
5385         while (MARK < SP) {
5386             SV * const sv = newSVsv(*++MARK);
5387             (void)av_store(ary, i++, sv);
5388         }
5389     }
5390     SP = ORIGMARK;
5391     if (OP_GIMME(PL_op, 0) != G_VOID) {
5392         PUSHi( AvFILL(ary) + 1 );
5393     }
5394     RETURN;
5395 }
5396
5397 PP(pp_reverse)
5398 {
5399     dSP; dMARK;
5400
5401     if (GIMME == G_ARRAY) {
5402         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5403             AV *av;
5404
5405             /* See pp_sort() */
5406             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5407             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5408             av = MUTABLE_AV((*SP));
5409             /* In-place reversing only happens in void context for the array
5410              * assignment. We don't need to push anything on the stack. */
5411             SP = MARK;
5412
5413             if (SvMAGICAL(av)) {
5414                 SSize_t i, j;
5415                 SV *tmp = sv_newmortal();
5416                 /* For SvCANEXISTDELETE */
5417                 HV *stash;
5418                 const MAGIC *mg;
5419                 bool can_preserve = SvCANEXISTDELETE(av);
5420
5421                 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5422                     SV *begin, *end;
5423
5424                     if (can_preserve) {
5425                         if (!av_exists(av, i)) {
5426                             if (av_exists(av, j)) {
5427                                 SV *sv = av_delete(av, j, 0);
5428                                 begin = *av_fetch(av, i, TRUE);
5429                                 sv_setsv_mg(begin, sv);
5430                             }
5431                             continue;
5432                         }
5433                         else if (!av_exists(av, j)) {
5434                             SV *sv = av_delete(av, i, 0);
5435                             end = *av_fetch(av, j, TRUE);
5436                             sv_setsv_mg(end, sv);
5437                             continue;
5438                         }
5439                     }
5440
5441                     begin = *av_fetch(av, i, TRUE);
5442                     end   = *av_fetch(av, j, TRUE);
5443                     sv_setsv(tmp,      begin);
5444                     sv_setsv_mg(begin, end);
5445                     sv_setsv_mg(end,   tmp);
5446                 }
5447             }
5448             else {
5449                 SV **begin = AvARRAY(av);
5450
5451                 if (begin) {
5452                     SV **end   = begin + AvFILLp(av);
5453
5454                     while (begin < end) {
5455                         SV * const tmp = *begin;
5456                         *begin++ = *end;
5457                         *end--   = tmp;
5458                     }
5459                 }
5460             }
5461         }
5462         else {
5463             SV **oldsp = SP;
5464             MARK++;
5465             while (MARK < SP) {
5466                 SV * const tmp = *MARK;
5467                 *MARK++ = *SP;
5468                 *SP--   = tmp;
5469             }
5470             /* safe as long as stack cannot get extended in the above */
5471             SP = oldsp;
5472         }
5473     }
5474     else {
5475         char *up;
5476         char *down;
5477         I32 tmp;
5478         dTARGET;
5479         STRLEN len;
5480
5481         SvUTF8_off(TARG);                               /* decontaminate */
5482         if (SP - MARK > 1)
5483             do_join(TARG, &PL_sv_no, MARK, SP);
5484         else {
5485             sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5486         }
5487
5488         up = SvPV_force(TARG, len);
5489         if (len > 1) {
5490             if (DO_UTF8(TARG)) {        /* first reverse each character */
5491                 U8* s = (U8*)SvPVX(TARG);
5492                 const U8* send = (U8*)(s + len);
5493                 while (s < send) {
5494                     if (UTF8_IS_INVARIANT(*s)) {
5495                         s++;
5496                         continue;
5497                     }
5498                     else {
5499                         if (!utf8_to_uvchr_buf(s, send, 0))
5500                             break;
5501                         up = (char*)s;
5502                         s += UTF8SKIP(s);
5503                         down = (char*)(s - 1);
5504                         /* reverse this character */
5505                         while (down > up) {
5506                             tmp = *up;
5507                             *up++ = *down;
5508                             *down-- = (char)tmp;
5509                         }
5510                     }
5511                 }
5512                 up = SvPVX(TARG);
5513             }
5514             down = SvPVX(TARG) + len - 1;
5515             while (down > up) {
5516                 tmp = *up;
5517                 *up++ = *down;
5518                 *down-- = (char)tmp;
5519             }
5520             (void)SvPOK_only_UTF8(TARG);
5521         }
5522         SP = MARK + 1;
5523         SETTARG;
5524     }
5525     RETURN;
5526 }
5527
5528 PP(pp_split)
5529 {
5530     dSP; dTARG;
5531     AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
5532     IV limit = POPi;                    /* note, negative is forever */
5533     SV * const sv = POPs;
5534     STRLEN len;
5535     const char *s = SvPV_const(sv, len);
5536     const bool do_utf8 = DO_UTF8(sv);
5537     const char *strend = s + len;
5538     PMOP *pm;
5539     REGEXP *rx;
5540     SV *dstr;
5541     const char *m;
5542     SSize_t iters = 0;
5543     const STRLEN slen = do_utf8
5544                         ? utf8_length((U8*)s, (U8*)strend)
5545                         : (STRLEN)(strend - s);
5546     SSize_t maxiters = slen + 10;
5547     I32 trailing_empty = 0;
5548     const char *orig;
5549     const I32 origlimit = limit;
5550     I32 realarray = 0;
5551     I32 base;
5552     const I32 gimme = GIMME_V;
5553     bool gimme_scalar;
5554     const I32 oldsave = PL_savestack_ix;
5555     U32 make_mortal = SVs_TEMP;
5556     bool multiline = 0;
5557     MAGIC *mg = NULL;
5558
5559 #ifdef DEBUGGING
5560     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5561 #else
5562     pm = (PMOP*)POPs;
5563 #endif
5564     if (!pm)
5565         DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5566     rx = PM_GETRE(pm);
5567
5568     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5569              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5570
5571 #ifdef USE_ITHREADS
5572     if (pm->op_pmreplrootu.op_pmtargetoff) {
5573         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5574     }
5575 #else
5576     if (pm->op_pmreplrootu.op_pmtargetgv) {
5577         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5578     }
5579 #endif
5580     else if (pm->op_targ)
5581         ary = (AV *)PAD_SVl(pm->op_targ);
5582     if (ary) {
5583         realarray = 1;
5584         PUTBACK;
5585         av_extend(ary,0);
5586         (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5587         av_clear(ary);
5588         SPAGAIN;
5589         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5590             PUSHMARK(SP);
5591             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5592         }
5593         else {
5594             if (!AvREAL(ary)) {
5595                 I32 i;
5596                 AvREAL_on(ary);
5597                 AvREIFY_off(ary);
5598                 for (i = AvFILLp(ary); i >= 0; i--)
5599                     AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5600             }
5601             /* temporarily switch stacks */
5602             SAVESWITCHSTACK(PL_curstack, ary);
5603             make_mortal = 0;
5604         }
5605     }
5606     base = SP - PL_stack_base;
5607     orig = s;
5608     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5609         if (do_utf8) {
5610             while (isSPACE_utf8(s))
5611                 s += UTF8SKIP(s);
5612         }
5613         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5614             while (isSPACE_LC(*s))
5615                 s++;
5616         }
5617         else {
5618             while (isSPACE(*s))
5619                 s++;
5620         }
5621     }
5622     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5623         multiline = 1;
5624     }
5625
5626     gimme_scalar = gimme == G_SCALAR && !ary;
5627
5628     if (!limit)
5629         limit = maxiters + 2;
5630     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5631         while (--limit) {
5632             m = s;
5633             /* this one uses 'm' and is a negative test */
5634             if (do_utf8) {
5635                 while (m < strend && ! isSPACE_utf8(m) ) {
5636                     const int t = UTF8SKIP(m);
5637                     /* isSPACE_utf8 returns FALSE for malform utf8 */
5638                     if (strend - m < t)
5639                         m = strend;
5640                     else
5641                         m += t;
5642                 }
5643             }
5644             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5645             {
5646                 while (m < strend && !isSPACE_LC(*m))
5647                     ++m;
5648             } else {
5649                 while (m < strend && !isSPACE(*m))
5650                     ++m;
5651             }  
5652             if (m >= strend)
5653                 break;
5654
5655             if (gimme_scalar) {
5656                 iters++;
5657                 if (m-s == 0)
5658                     trailing_empty++;
5659                 else
5660                     trailing_empty = 0;
5661             } else {
5662                 dstr = newSVpvn_flags(s, m-s,
5663                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5664                 XPUSHs(dstr);
5665             }
5666
5667             /* skip the whitespace found last */
5668             if (do_utf8)
5669                 s = m + UTF8SKIP(m);
5670             else
5671                 s = m + 1;
5672
5673             /* this one uses 's' and is a positive test */
5674             if (do_utf8) {
5675                 while (s < strend && isSPACE_utf8(s) )
5676                     s +=  UTF8SKIP(s);
5677             }
5678             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5679             {
5680                 while (s < strend && isSPACE_LC(*s))
5681                     ++s;
5682             } else {
5683                 while (s < strend && isSPACE(*s))
5684                     ++s;
5685             }       
5686         }
5687     }
5688     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5689         while (--limit) {
5690             for (m = s; m < strend && *m != '\n'; m++)
5691                 ;
5692             m++;
5693             if (m >= strend)
5694                 break;
5695
5696             if (gimme_scalar) {
5697                 iters++;
5698                 if (m-s == 0)
5699                     trailing_empty++;
5700                 else
5701                     trailing_empty = 0;
5702             } else {
5703                 dstr = newSVpvn_flags(s, m-s,
5704                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5705                 XPUSHs(dstr);
5706             }
5707             s = m;
5708         }
5709     }
5710     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5711         /*
5712           Pre-extend the stack, either the number of bytes or
5713           characters in the string or a limited amount, triggered by:
5714
5715           my ($x, $y) = split //, $str;
5716             or
5717           split //, $str, $i;
5718         */
5719         if (!gimme_scalar) {
5720             const U32 items = limit - 1;
5721             if (items < slen)
5722                 EXTEND(SP, items);
5723             else
5724                 EXTEND(SP, slen);
5725         }
5726
5727         if (do_utf8) {
5728             while (--limit) {
5729                 /* keep track of how many bytes we skip over */
5730                 m = s;
5731                 s += UTF8SKIP(s);
5732                 if (gimme_scalar) {
5733                     iters++;
5734                     if (s-m == 0)
5735                         trailing_empty++;
5736                     else
5737                         trailing_empty = 0;
5738                 } else {
5739                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5740
5741                     PUSHs(dstr);
5742                 }
5743
5744                 if (s >= strend)
5745                     break;
5746             }
5747         } else {
5748             while (--limit) {
5749                 if (gimme_scalar) {
5750                     iters++;
5751                 } else {
5752                     dstr = newSVpvn(s, 1);
5753
5754
5755                     if (make_mortal)
5756                         sv_2mortal(dstr);
5757
5758                     PUSHs(dstr);
5759                 }
5760
5761                 s++;
5762
5763                 if (s >= strend)
5764                     break;
5765             }
5766         }
5767     }
5768     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5769              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5770              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5771              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5772         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5773         SV * const csv = CALLREG_INTUIT_STRING(rx);
5774
5775         len = RX_MINLENRET(rx);
5776         if (len == 1 && !RX_UTF8(rx) && !tail) {
5777             const char c = *SvPV_nolen_const(csv);
5778             while (--limit) {
5779                 for (m = s; m < strend && *m != c; m++)
5780                     ;
5781                 if (m >= strend)
5782                     break;
5783                 if (gimme_scalar) {
5784                     iters++;
5785                     if (m-s == 0)
5786                         trailing_empty++;
5787                     else
5788                         trailing_empty = 0;
5789                 } else {
5790                     dstr = newSVpvn_flags(s, m-s,
5791                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5792                     XPUSHs(dstr);
5793                 }
5794                 /* The rx->minlen is in characters but we want to step
5795                  * s ahead by bytes. */
5796                 if (do_utf8)
5797                     s = (char*)utf8_hop((U8*)m, len);
5798                 else
5799                     s = m + len; /* Fake \n at the end */
5800             }
5801         }
5802         else {
5803             while (s < strend && --limit &&
5804               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5805                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5806             {
5807                 if (gimme_scalar) {
5808                     iters++;
5809                     if (m-s == 0)
5810                         trailing_empty++;
5811                     else
5812                         trailing_empty = 0;
5813                 } else {
5814                     dstr = newSVpvn_flags(s, m-s,
5815                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5816                     XPUSHs(dstr);
5817                 }
5818                 /* The rx->minlen is in characters but we want to step
5819                  * s ahead by bytes. */
5820                 if (do_utf8)
5821                     s = (char*)utf8_hop((U8*)m, len);
5822                 else
5823                     s = m + len; /* Fake \n at the end */
5824             }
5825         }
5826     }
5827     else {
5828         maxiters += slen * RX_NPARENS(rx);
5829         while (s < strend && --limit)
5830         {
5831             I32 rex_return;
5832             PUTBACK;
5833             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5834                                      sv, NULL, 0);
5835             SPAGAIN;
5836             if (rex_return == 0)
5837                 break;
5838             TAINT_IF(RX_MATCH_TAINTED(rx));
5839             /* we never pass the REXEC_COPY_STR flag, so it should
5840              * never get copied */
5841             assert(!RX_MATCH_COPIED(rx));
5842             m = RX_OFFS(rx)[0].start + orig;
5843
5844             if (gimme_scalar) {
5845                 iters++;
5846                 if (m-s == 0)
5847                     trailing_empty++;
5848                 else
5849                     trailing_empty = 0;
5850             } else {
5851                 dstr = newSVpvn_flags(s, m-s,
5852                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5853                 XPUSHs(dstr);
5854             }
5855             if (RX_NPARENS(rx)) {
5856                 I32 i;
5857                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5858                     s = RX_OFFS(rx)[i].start + orig;
5859                     m = RX_OFFS(rx)[i].end + orig;
5860
5861                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
5862                        parens that didn't match -- they should be set to
5863                        undef, not the empty string */
5864                     if (gimme_scalar) {
5865                         iters++;
5866                         if (m-s == 0)
5867                             trailing_empty++;
5868                         else
5869                             trailing_empty = 0;
5870                     } else {
5871                         if (m >= orig && s >= orig) {
5872                             dstr = newSVpvn_flags(s, m-s,
5873                                                  (do_utf8 ? SVf_UTF8 : 0)
5874                                                   | make_mortal);
5875                         }
5876                         else
5877                             dstr = &PL_sv_undef;  /* undef, not "" */
5878                         XPUSHs(dstr);
5879                     }
5880
5881                 }
5882             }
5883             s = RX_OFFS(rx)[0].end + orig;
5884         }
5885     }
5886
5887     if (!gimme_scalar) {
5888         iters = (SP - PL_stack_base) - base;
5889     }
5890     if (iters > maxiters)
5891         DIE(aTHX_ "Split loop");
5892
5893     /* keep field after final delim? */
5894     if (s < strend || (iters && origlimit)) {
5895         if (!gimme_scalar) {
5896             const STRLEN l = strend - s;
5897             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5898             XPUSHs(dstr);
5899         }
5900         iters++;
5901     }
5902     else if (!origlimit) {
5903         if (gimme_scalar) {
5904             iters -= trailing_empty;
5905         } else {
5906             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5907                 if (TOPs && !make_mortal)
5908                     sv_2mortal(TOPs);
5909                 *SP-- = &PL_sv_undef;
5910                 iters--;
5911             }
5912         }
5913     }
5914
5915     PUTBACK;
5916     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5917     SPAGAIN;
5918     if (realarray) {
5919         if (!mg) {
5920             if (SvSMAGICAL(ary)) {
5921                 PUTBACK;
5922                 mg_set(MUTABLE_SV(ary));
5923                 SPAGAIN;
5924             }
5925             if (gimme == G_ARRAY) {
5926                 EXTEND(SP, iters);
5927                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5928                 SP += iters;
5929                 RETURN;
5930             }
5931         }
5932         else {
5933             PUTBACK;
5934             ENTER_with_name("call_PUSH");
5935             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5936             LEAVE_with_name("call_PUSH");
5937             SPAGAIN;
5938             if (gimme == G_ARRAY) {
5939                 SSize_t i;
5940                 /* EXTEND should not be needed - we just popped them */
5941                 EXTEND(SP, iters);
5942                 for (i=0; i < iters; i++) {
5943                     SV **svp = av_fetch(ary, i, FALSE);
5944                     PUSHs((svp) ? *svp : &PL_sv_undef);
5945                 }
5946                 RETURN;
5947             }
5948         }
5949     }
5950     else {
5951         if (gimme == G_ARRAY)
5952             RETURN;
5953     }
5954
5955     GETTARGET;
5956     PUSHi(iters);
5957     RETURN;
5958 }
5959
5960 PP(pp_once)
5961 {
5962     dSP;
5963     SV *const sv = PAD_SVl(PL_op->op_targ);
5964
5965     if (SvPADSTALE(sv)) {
5966         /* First time. */
5967         SvPADSTALE_off(sv);
5968         RETURNOP(cLOGOP->op_other);
5969     }
5970     RETURNOP(cLOGOP->op_next);
5971 }
5972
5973 PP(pp_lock)
5974 {
5975     dSP;
5976     dTOPss;
5977     SV *retsv = sv;
5978     SvLOCK(sv);
5979     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5980      || SvTYPE(retsv) == SVt_PVCV) {
5981         retsv = refto(retsv);
5982     }
5983     SETs(retsv);
5984     RETURN;
5985 }
5986
5987
5988 /* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
5989  * that aren't implemented on a particular platform */
5990
5991 PP(unimplemented_op)
5992 {
5993     const Optype op_type = PL_op->op_type;
5994     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5995        with out of range op numbers - it only "special" cases op_custom.
5996        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5997        if we get here for a custom op then that means that the custom op didn't
5998        have an implementation. Given that OP_NAME() looks up the custom op
5999        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6000        registers &PL_unimplemented_op as the address of their custom op.
6001        NULL doesn't generate a useful error message. "custom" does. */
6002     const char *const name = op_type >= OP_max
6003         ? "[out of range]" : PL_op_name[PL_op->op_type];
6004     if(OP_IS_SOCKET(op_type))
6005         DIE(aTHX_ PL_no_sock_func, name);
6006     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
6007 }
6008
6009 /* For sorting out arguments passed to a &CORE:: subroutine */
6010 PP(pp_coreargs)
6011 {
6012     dSP;
6013     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6014     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6015     AV * const at_ = GvAV(PL_defgv);
6016     SV **svp = at_ ? AvARRAY(at_) : NULL;
6017     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6018     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6019     bool seen_question = 0;
6020     const char *err = NULL;
6021     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6022
6023     /* Count how many args there are first, to get some idea how far to
6024        extend the stack. */
6025     while (oa) {
6026         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6027         maxargs++;
6028         if (oa & OA_OPTIONAL) seen_question = 1;
6029         if (!seen_question) minargs++;
6030         oa >>= 4;
6031     }
6032
6033     if(numargs < minargs) err = "Not enough";
6034     else if(numargs > maxargs) err = "Too many";
6035     if (err)
6036         /* diag_listed_as: Too many arguments for %s */
6037         Perl_croak(aTHX_
6038           "%s arguments for %s", err,
6039            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6040         );
6041
6042     /* Reset the stack pointer.  Without this, we end up returning our own
6043        arguments in list context, in addition to the values we are supposed
6044        to return.  nextstate usually does this on sub entry, but we need
6045        to run the next op with the caller's hints, so we cannot have a
6046        nextstate. */
6047     SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
6048
6049     if(!maxargs) RETURN;
6050
6051     /* We do this here, rather than with a separate pushmark op, as it has
6052        to come in between two things this function does (stack reset and
6053        arg pushing).  This seems the easiest way to do it. */
6054     if (pushmark) {
6055         PUTBACK;
6056         (void)Perl_pp_pushmark(aTHX);
6057     }
6058
6059     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6060     PUTBACK; /* The code below can die in various places. */
6061
6062     oa = PL_opargs[opnum] >> OASHIFT;
6063     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6064         whicharg++;
6065         switch (oa & 7) {
6066         case OA_SCALAR:
6067           try_defsv:
6068             if (!numargs && defgv && whicharg == minargs + 1) {
6069                 PUSHs(find_rundefsv2(
6070                     find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
6071                     cxstack[cxstack_ix].blk_oldcop->cop_seq
6072                 ));
6073             }
6074             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6075             break;
6076         case OA_LIST:
6077             while (numargs--) {
6078                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6079                 svp++;
6080             }
6081             RETURN;
6082         case OA_HVREF:
6083             if (!svp || !*svp || !SvROK(*svp)
6084              || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6085                 DIE(aTHX_
6086                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6087                  "Type of arg %d to &CORE::%s must be hash reference",
6088                   whicharg, OP_DESC(PL_op->op_next)
6089                 );
6090             PUSHs(SvRV(*svp));
6091             break;
6092         case OA_FILEREF:
6093             if (!numargs) PUSHs(NULL);
6094             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6095                 /* no magic here, as the prototype will have added an extra
6096                    refgen and we just want what was there before that */
6097                 PUSHs(SvRV(*svp));
6098             else {
6099                 const bool constr = PL_op->op_private & whicharg;
6100                 PUSHs(S_rv2gv(aTHX_
6101                     svp && *svp ? *svp : &PL_sv_undef,
6102                     constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6103                     !constr
6104                 ));
6105             }
6106             break;
6107         case OA_SCALARREF:
6108           if (!numargs) goto try_defsv;
6109           else {
6110             const bool wantscalar =
6111                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6112             if (!svp || !*svp || !SvROK(*svp)
6113                 /* We have to permit globrefs even for the \$ proto, as
6114                    *foo is indistinguishable from ${\*foo}, and the proto-
6115                    type permits the latter. */
6116              || SvTYPE(SvRV(*svp)) > (
6117                      wantscalar       ? SVt_PVLV
6118                    : opnum == OP_LOCK || opnum == OP_UNDEF
6119                                       ? SVt_PVCV
6120                    :                    SVt_PVHV
6121                 )
6122                )
6123                 DIE(aTHX_
6124                  "Type of arg %d to &CORE::%s must be %s",
6125                   whicharg, PL_op_name[opnum],
6126                   wantscalar
6127                     ? "scalar reference"
6128                     : opnum == OP_LOCK || opnum == OP_UNDEF
6129                        ? "reference to one of [$@%&*]"
6130                        : "reference to one of [$@%*]"
6131                 );
6132             PUSHs(SvRV(*svp));
6133             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6134              && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6135                 /* Undo @_ localisation, so that sub exit does not undo
6136                    part of our undeffing. */
6137                 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6138                 POP_SAVEARRAY();
6139                 cx->cx_type &= ~ CXp_HASARGS;
6140                 assert(!AvREAL(cx->blk_sub.argarray));
6141             }
6142           }
6143           break;
6144         default:
6145             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6146         }
6147         oa = oa >> 4;
6148     }
6149
6150     RETURN;
6151 }
6152
6153 PP(pp_runcv)
6154 {
6155     dSP;
6156     CV *cv;
6157     if (PL_op->op_private & OPpOFFBYONE) {
6158         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6159     }
6160     else cv = find_runcv(NULL);
6161     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6162     RETURN;
6163 }
6164
6165 static void
6166 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6167                             const bool can_preserve)
6168 {
6169     const SSize_t ix = SvIV(keysv);
6170     if (can_preserve ? av_exists(av, ix) : TRUE) {
6171         SV ** const svp = av_fetch(av, ix, 1);
6172         if (!svp || !*svp)
6173             Perl_croak(aTHX_ PL_no_aelem, ix);
6174         save_aelem(av, ix, svp);
6175     }
6176     else
6177         SAVEADELETE(av, ix);
6178 }
6179
6180 static void
6181 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6182                             const bool can_preserve)
6183 {
6184     if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6185         HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6186         SV ** const svp = he ? &HeVAL(he) : NULL;
6187         if (!svp || !*svp)
6188             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6189         save_helem_flags(hv, keysv, svp, 0);
6190     }
6191     else
6192         SAVEHDELETE(hv, keysv);
6193 }
6194
6195 static void
6196 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6197 {
6198     if (type == OPpLVREF_SV) {
6199         save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6200         GvSV(gv) = 0;
6201     }
6202     else if (type == OPpLVREF_AV)
6203         /* XXX Inefficient, as it creates a new AV, which we are
6204                about to clobber.  */
6205         save_ary(gv);
6206     else {
6207         assert(type == OPpLVREF_HV);
6208         /* XXX Likewise inefficient.  */
6209         save_hash(gv);
6210     }
6211 }
6212
6213
6214 PP(pp_refassign)
6215 {
6216     dSP;
6217     SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6218     SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6219     dTOPss;
6220     const char *bad = NULL;
6221     const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6222     if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6223     switch (type) {
6224     case OPpLVREF_SV:
6225         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6226             bad = " SCALAR";
6227         break;
6228     case OPpLVREF_AV:
6229         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6230             bad = "n ARRAY";
6231         break;
6232     case OPpLVREF_HV:
6233         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6234             bad = " HASH";
6235         break;
6236     case OPpLVREF_CV:
6237         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6238             bad = " CODE";
6239     }
6240     if (bad)
6241         /* diag_listed_as: Assigned value is not %s reference */
6242         DIE(aTHX_ "Assigned value is not a%s reference", bad);
6243     switch (left ? SvTYPE(left) : 0) {
6244         MAGIC *mg;
6245         HV *stash;
6246     case 0:
6247     {
6248         SV * const old = PAD_SV(ARGTARG);
6249         PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6250         SvREFCNT_dec(old);
6251         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6252                 == OPpLVAL_INTRO)
6253             SAVECLEARSV(PAD_SVl(ARGTARG));
6254         break;
6255     }
6256     case SVt_PVGV:
6257         if (PL_op->op_private & OPpLVAL_INTRO) {
6258             S_localise_gv_slot(aTHX_ (GV *)left, type);
6259         }
6260         gv_setref(left, sv);
6261         SvSETMAGIC(left);
6262         break;
6263     case SVt_PVAV:
6264         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6265             S_localise_aelem_lval(aTHX_ (AV *)left, key,
6266                                         SvCANEXISTDELETE(left));
6267         }
6268         av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6269         break;
6270     case SVt_PVHV:
6271         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
6272             S_localise_helem_lval(aTHX_ (HV *)left, key,
6273                                         SvCANEXISTDELETE(left));
6274         hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6275     }
6276     if (PL_op->op_flags & OPf_MOD)
6277         SETs(sv_2mortal(newSVsv(sv)));
6278     /* XXX else can weak references go stale before they are read, e.g.,
6279        in leavesub?  */
6280     RETURN;
6281 }
6282
6283 PP(pp_lvref)
6284 {
6285     dSP;
6286     SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6287     SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6288     SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6289     MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6290                                    &PL_vtbl_lvref, (char *)elem,
6291                                    elem ? HEf_SVKEY : (I32)ARGTARG);
6292     mg->mg_private = PL_op->op_private;
6293     if (PL_op->op_private & OPpLVREF_ITER)
6294         mg->mg_flags |= MGf_PERSIST;
6295     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6296       if (elem) {
6297         MAGIC *mg;
6298         HV *stash;
6299         const bool can_preserve = SvCANEXISTDELETE(arg);
6300         if (SvTYPE(arg) == SVt_PVAV)
6301             S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6302         else
6303             S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6304       }
6305       else if (arg) {
6306         S_localise_gv_slot(aTHX_ (GV *)arg, 
6307                                  PL_op->op_private & OPpLVREF_TYPE);
6308       }
6309       else if (!(PL_op->op_private & OPpPAD_STATE))
6310         SAVECLEARSV(PAD_SVl(ARGTARG));
6311     }
6312     XPUSHs(ret);
6313     RETURN;
6314 }
6315
6316 PP(pp_lvrefslice)
6317 {
6318     dSP; dMARK;
6319     AV * const av = (AV *)POPs;
6320     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6321     bool can_preserve = FALSE;
6322
6323     if (UNLIKELY(localizing)) {
6324         MAGIC *mg;
6325         HV *stash;
6326         SV **svp;
6327
6328         can_preserve = SvCANEXISTDELETE(av);
6329
6330         if (SvTYPE(av) == SVt_PVAV) {
6331             SSize_t max = -1;
6332
6333             for (svp = MARK + 1; svp <= SP; svp++) {
6334                 const SSize_t elem = SvIV(*svp);
6335                 if (elem > max)
6336                     max = elem;
6337             }
6338             if (max > AvMAX(av))
6339                 av_extend(av, max);
6340         }
6341     }
6342
6343     while (++MARK <= SP) {
6344         SV * const elemsv = *MARK;
6345         if (SvTYPE(av) == SVt_PVAV)
6346             S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6347         else
6348             S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6349         *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6350         sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6351     }
6352     RETURN;
6353 }
6354
6355 PP(pp_lvavref)
6356 {
6357     if (PL_op->op_flags & OPf_STACKED)
6358         Perl_pp_rv2av(aTHX);
6359     else
6360         Perl_pp_padav(aTHX);
6361     {
6362         dSP;
6363         dTOPss;
6364         SETs(0); /* special alias marker that aassign recognises */
6365         XPUSHs(sv);
6366         RETURN;
6367     }
6368 }
6369
6370 /*
6371  * Local variables:
6372  * c-indentation-style: bsd
6373  * c-basic-offset: 4
6374  * indent-tabs-mode: nil
6375  * End:
6376  *
6377  * ex: set ts=8 sts=4 sw=4 et:
6378  */