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