fix ext/B/t/optree_misc.t in unthreaded builds
[perl.git] / pp.c
1 /*    pp.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * 'It's a big house this, and very peculiar.  Always a bit more
13  *  to discover, and no knowing what you'll find round a corner.
14  *  And Elves, sir!'                            --Samwise Gamgee
15  *
16  *     [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
17  */
18
19 /* This file contains general pp ("push/pop") functions that execute the
20  * opcodes that make up a perl program. A typical pp function expects to
21  * find its arguments on the stack, and usually pushes its results onto
22  * the stack, hence the 'pp' terminology. Each OP structure contains
23  * a pointer to the relevant pp_foo() function.
24  */
25
26 #include "EXTERN.h"
27 #define PERL_IN_PP_C
28 #include "perl.h"
29 #include "keywords.h"
30
31 #include "reentr.h"
32 #include "regcharclass.h"
33
34 /* XXX I can't imagine anyone who doesn't have this actually _needs_
35    it, since pid_t is an integral type.
36    --AD  2/20/1998
37 */
38 #ifdef NEED_GETPID_PROTO
39 extern Pid_t getpid (void);
40 #endif
41
42 /*
43  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44  * This switches them over to IEEE.
45  */
46 #if defined(LIBM_LIB_VERSION)
47     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
48 #endif
49
50 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
52
53 /* variations on pp_null */
54
55 PP(pp_stub)
56 {
57     dSP;
58     if (GIMME_V == G_SCALAR)
59         XPUSHs(&PL_sv_undef);
60     RETURN;
61 }
62
63 /* Pushy stuff. */
64
65 /* This is also called directly by pp_lvavref.  */
66 PP(pp_padav)
67 {
68     dSP; dTARGET;
69     I32 gimme;
70     assert(SvTYPE(TARG) == SVt_PVAV);
71     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
72         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
73             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
74     EXTEND(SP, 1);
75     if (PL_op->op_flags & OPf_REF) {
76         PUSHs(TARG);
77         RETURN;
78     } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
79        const I32 flags = is_lvalue_sub();
80        if (flags && !(flags & OPpENTERSUB_INARGS)) {
81         if (GIMME == G_SCALAR)
82             /* diag_listed_as: Can't return %s to lvalue scalar context */
83             Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
84         PUSHs(TARG);
85         RETURN;
86        }
87     }
88     gimme = GIMME_V;
89     if (gimme == G_ARRAY) {
90         /* XXX see also S_pushav in pp_hot.c */
91         const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
92         EXTEND(SP, maxarg);
93         if (SvMAGICAL(TARG)) {
94             Size_t i;
95             for (i=0; i < maxarg; i++) {
96                 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
97                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
98             }
99         }
100         else {
101             PADOFFSET i;
102             for (i=0; i < (PADOFFSET)maxarg; i++) {
103                 SV * const sv = AvARRAY((const AV *)TARG)[i];
104                 SP[i+1] = sv ? sv : &PL_sv_undef;
105             }
106         }
107         SP += maxarg;
108     }
109     else if (gimme == G_SCALAR) {
110         SV* const sv = sv_newmortal();
111         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
112         sv_setiv(sv, maxarg);
113         PUSHs(sv);
114     }
115     RETURN;
116 }
117
118 PP(pp_padhv)
119 {
120     dSP; dTARGET;
121     I32 gimme;
122
123     assert(SvTYPE(TARG) == SVt_PVHV);
124     XPUSHs(TARG);
125     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
126         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
127             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
128     if (PL_op->op_flags & OPf_REF)
129         RETURN;
130     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
131       const I32 flags = is_lvalue_sub();
132       if (flags && !(flags & OPpENTERSUB_INARGS)) {
133         if (GIMME == G_SCALAR)
134             /* diag_listed_as: Can't return %s to lvalue scalar context */
135             Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
136         RETURN;
137       }
138     }
139     gimme = GIMME_V;
140     if (gimme == G_ARRAY) {
141         RETURNOP(Perl_do_kv(aTHX));
142     }
143     else if ((PL_op->op_private & OPpTRUEBOOL
144           || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
145              && block_gimme() == G_VOID  ))
146           && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
147         SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
148     else if (gimme == G_SCALAR) {
149         SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
150         SETs(sv);
151     }
152     RETURN;
153 }
154
155 PP(pp_padcv)
156 {
157     dSP; dTARGET;
158     assert(SvTYPE(TARG) == SVt_PVCV);
159     XPUSHs(TARG);
160     RETURN;
161 }
162
163 PP(pp_introcv)
164 {
165     dTARGET;
166     SvPADSTALE_off(TARG);
167     return NORMAL;
168 }
169
170 PP(pp_clonecv)
171 {
172     dTARGET;
173     MAGIC * const mg =
174         mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
175                 PERL_MAGIC_proto);
176     assert(SvTYPE(TARG) == SVt_PVCV);
177     assert(mg);
178     assert(mg->mg_obj);
179     if (CvISXSUB(mg->mg_obj)) { /* constant */
180         /* XXX Should we clone it here? */
181         /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
182            to introcv and remove the SvPADSTALE_off. */
183         SAVEPADSVANDMORTALIZE(ARGTARG);
184         PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj);
185     }
186     else {
187         if (CvROOT(mg->mg_obj)) {
188             assert(CvCLONE(mg->mg_obj));
189             assert(!CvCLONED(mg->mg_obj));
190         }
191         cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
192         SAVECLEARSV(PAD_SVl(ARGTARG));
193     }
194     return NORMAL;
195 }
196
197 /* Translations. */
198
199 static const char S_no_symref_sv[] =
200     "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
201
202 /* In some cases this function inspects PL_op.  If this function is called
203    for new op types, more bool parameters may need to be added in place of
204    the checks.
205
206    When noinit is true, the absence of a gv will cause a retval of undef.
207    This is unrelated to the cv-to-gv assignment case.
208 */
209
210 static SV *
211 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
212               const bool noinit)
213 {
214     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
215     if (SvROK(sv)) {
216         if (SvAMAGIC(sv)) {
217             sv = amagic_deref_call(sv, to_gv_amg);
218         }
219       wasref:
220         sv = SvRV(sv);
221         if (SvTYPE(sv) == SVt_PVIO) {
222             GV * const gv = MUTABLE_GV(sv_newmortal());
223             gv_init(gv, 0, "__ANONIO__", 10, 0);
224             GvIOp(gv) = MUTABLE_IO(sv);
225             SvREFCNT_inc_void_NN(sv);
226             sv = MUTABLE_SV(gv);
227         }
228         else if (!isGV_with_GP(sv)) {
229             Perl_die(aTHX_ "Not a GLOB reference");
230         }
231     }
232     else {
233         if (!isGV_with_GP(sv)) {
234             if (!SvOK(sv)) {
235                 /* If this is a 'my' scalar and flag is set then vivify
236                  * NI-S 1999/05/07
237                  */
238                 if (vivify_sv && sv != &PL_sv_undef) {
239                     GV *gv;
240                     if (SvREADONLY(sv))
241                         Perl_croak_no_modify();
242                     if (cUNOP->op_targ) {
243                         SV * const namesv = PAD_SV(cUNOP->op_targ);
244                         HV *stash = CopSTASH(PL_curcop);
245                         if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
246                         gv = MUTABLE_GV(newSV(0));
247                         gv_init_sv(gv, stash, namesv, 0);
248                     }
249                     else {
250                         const char * const name = CopSTASHPV(PL_curcop);
251                         gv = newGVgen_flags(name,
252                                 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
253                         SvREFCNT_inc_simple_void_NN(gv);
254                     }
255                     prepare_SV_for_RV(sv);
256                     SvRV_set(sv, MUTABLE_SV(gv));
257                     SvROK_on(sv);
258                     SvSETMAGIC(sv);
259                     goto wasref;
260                 }
261                 if (PL_op->op_flags & OPf_REF || strict) {
262                     Perl_die(aTHX_ PL_no_usym, "a symbol");
263                 }
264                 if (ckWARN(WARN_UNINITIALIZED))
265                     report_uninit(sv);
266                 return &PL_sv_undef;
267             }
268             if (noinit)
269             {
270                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
271                            sv, GV_ADDMG, SVt_PVGV
272                    ))))
273                     return &PL_sv_undef;
274             }
275             else {
276                 if (strict) {
277                     Perl_die(aTHX_
278                              S_no_symref_sv,
279                              sv,
280                              (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
281                              "a symbol"
282                              );
283                 }
284                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
285                     == OPpDONT_INIT_GV) {
286                     /* We are the target of a coderef assignment.  Return
287                        the scalar unchanged, and let pp_sasssign deal with
288                        things.  */
289                     return sv;
290                 }
291                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
292             }
293             /* FAKE globs in the symbol table cause weird bugs (#77810) */
294             SvFAKE_off(sv);
295         }
296     }
297     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
298         SV *newsv = sv_newmortal();
299         sv_setsv_flags(newsv, sv, 0);
300         SvFAKE_off(newsv);
301         sv = newsv;
302     }
303     return sv;
304 }
305
306 PP(pp_rv2gv)
307 {
308     dSP; dTOPss;
309
310     sv = S_rv2gv(aTHX_
311           sv, PL_op->op_private & OPpDEREF,
312           PL_op->op_private & HINT_STRICT_REFS,
313           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
314              || PL_op->op_type == OP_READLINE
315          );
316     if (PL_op->op_private & OPpLVAL_INTRO)
317         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
318     SETs(sv);
319     RETURN;
320 }
321
322 /* Helper function for pp_rv2sv and pp_rv2av  */
323 GV *
324 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
325                 const svtype type, SV ***spp)
326 {
327     GV *gv;
328
329     PERL_ARGS_ASSERT_SOFTREF2XV;
330
331     if (PL_op->op_private & HINT_STRICT_REFS) {
332         if (SvOK(sv))
333             Perl_die(aTHX_ S_no_symref_sv, sv,
334                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
335         else
336             Perl_die(aTHX_ PL_no_usym, what);
337     }
338     if (!SvOK(sv)) {
339         if (
340           PL_op->op_flags & OPf_REF
341         )
342             Perl_die(aTHX_ PL_no_usym, what);
343         if (ckWARN(WARN_UNINITIALIZED))
344             report_uninit(sv);
345         if (type != SVt_PV && GIMME_V == G_ARRAY) {
346             (*spp)--;
347             return NULL;
348         }
349         **spp = &PL_sv_undef;
350         return NULL;
351     }
352     if ((PL_op->op_flags & OPf_SPECIAL) &&
353         !(PL_op->op_flags & OPf_MOD))
354         {
355             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
356                 {
357                     **spp = &PL_sv_undef;
358                     return NULL;
359                 }
360         }
361     else {
362         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
363     }
364     return gv;
365 }
366
367 PP(pp_rv2sv)
368 {
369     dSP; dTOPss;
370     GV *gv = NULL;
371
372     SvGETMAGIC(sv);
373     if (SvROK(sv)) {
374         if (SvAMAGIC(sv)) {
375             sv = amagic_deref_call(sv, to_sv_amg);
376         }
377
378         sv = SvRV(sv);
379         switch (SvTYPE(sv)) {
380         case SVt_PVAV:
381         case SVt_PVHV:
382         case SVt_PVCV:
383         case SVt_PVFM:
384         case SVt_PVIO:
385             DIE(aTHX_ "Not a SCALAR reference");
386         default: NOOP;
387         }
388     }
389     else {
390         gv = MUTABLE_GV(sv);
391
392         if (!isGV_with_GP(gv)) {
393             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
394             if (!gv)
395                 RETURN;
396         }
397         sv = GvSVn(gv);
398     }
399     if (PL_op->op_flags & OPf_MOD) {
400         if (PL_op->op_private & OPpLVAL_INTRO) {
401             if (cUNOP->op_first->op_type == OP_NULL)
402                 sv = save_scalar(MUTABLE_GV(TOPs));
403             else if (gv)
404                 sv = save_scalar(gv);
405             else
406                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
407         }
408         else if (PL_op->op_private & OPpDEREF)
409             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
410     }
411     SETs(sv);
412     RETURN;
413 }
414
415 PP(pp_av2arylen)
416 {
417     dSP;
418     AV * const av = MUTABLE_AV(TOPs);
419     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
420     if (lvalue) {
421         SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
422         if (!*svp) {
423             *svp = newSV_type(SVt_PVMG);
424             sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
425         }
426         SETs(*svp);
427     } else {
428         SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
429     }
430     RETURN;
431 }
432
433 PP(pp_pos)
434 {
435     dSP; dPOPss;
436
437     if (PL_op->op_flags & OPf_MOD || LVRET) {
438         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
439         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
440         LvTYPE(ret) = '.';
441         LvTARG(ret) = SvREFCNT_inc_simple(sv);
442         PUSHs(ret);    /* no SvSETMAGIC */
443         RETURN;
444     }
445     else {
446             const MAGIC * const mg = mg_find_mglob(sv);
447             if (mg && mg->mg_len != -1) {
448                 dTARGET;
449                 STRLEN i = mg->mg_len;
450                 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
451                     i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
452                 PUSHu(i);
453                 RETURN;
454             }
455             RETPUSHUNDEF;
456     }
457 }
458
459 PP(pp_rv2cv)
460 {
461     dSP;
462     GV *gv;
463     HV *stash_unused;
464     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
465         ? GV_ADDMG
466         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
467                                                     == OPpMAY_RETURN_CONSTANT)
468             ? GV_ADD|GV_NOEXPAND
469             : GV_ADD;
470     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
471     /* (But not in defined().) */
472
473     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
474     if (cv) NOOP;
475     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
476         cv = SvTYPE(SvRV(gv)) == SVt_PVCV
477             ? MUTABLE_CV(SvRV(gv))
478             : MUTABLE_CV(gv);
479     }    
480     else
481         cv = MUTABLE_CV(&PL_sv_undef);
482     SETs(MUTABLE_SV(cv));
483     RETURN;
484 }
485
486 PP(pp_prototype)
487 {
488     dSP;
489     CV *cv;
490     HV *stash;
491     GV *gv;
492     SV *ret = &PL_sv_undef;
493
494     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
495     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
496         const char * s = SvPVX_const(TOPs);
497         if (strnEQ(s, "CORE::", 6)) {
498             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
499             if (!code)
500                 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
501                    UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
502             {
503                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
504                 if (sv) ret = sv;
505             }
506             goto set;
507         }
508     }
509     cv = sv_2cv(TOPs, &stash, &gv, 0);
510     if (cv && SvPOK(cv))
511         ret = newSVpvn_flags(
512             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
513         );
514   set:
515     SETs(ret);
516     RETURN;
517 }
518
519 PP(pp_anoncode)
520 {
521     dSP;
522     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
523     if (CvCLONE(cv))
524         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
525     EXTEND(SP,1);
526     PUSHs(MUTABLE_SV(cv));
527     RETURN;
528 }
529
530 PP(pp_srefgen)
531 {
532     dSP;
533     *SP = refto(*SP);
534     RETURN;
535 }
536
537 PP(pp_refgen)
538 {
539     dSP; dMARK;
540     if (GIMME != G_ARRAY) {
541         if (++MARK <= SP)
542             *MARK = *SP;
543         else
544             *MARK = &PL_sv_undef;
545         *MARK = refto(*MARK);
546         SP = MARK;
547         RETURN;
548     }
549     EXTEND_MORTAL(SP - MARK);
550     while (++MARK <= SP)
551         *MARK = refto(*MARK);
552     RETURN;
553 }
554
555 STATIC SV*
556 S_refto(pTHX_ SV *sv)
557 {
558     SV* rv;
559
560     PERL_ARGS_ASSERT_REFTO;
561
562     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
563         if (LvTARGLEN(sv))
564             vivify_defelem(sv);
565         if (!(sv = LvTARG(sv)))
566             sv = &PL_sv_undef;
567         else
568             SvREFCNT_inc_void_NN(sv);
569     }
570     else if (SvTYPE(sv) == SVt_PVAV) {
571         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
572             av_reify(MUTABLE_AV(sv));
573         SvTEMP_off(sv);
574         SvREFCNT_inc_void_NN(sv);
575     }
576     else if (SvPADTMP(sv)) {
577         sv = newSVsv(sv);
578     }
579     else {
580         SvTEMP_off(sv);
581         SvREFCNT_inc_void_NN(sv);
582     }
583     rv = sv_newmortal();
584     sv_upgrade(rv, SVt_IV);
585     SvRV_set(rv, sv);
586     SvROK_on(rv);
587     return rv;
588 }
589
590 PP(pp_ref)
591 {
592     dSP;
593     SV * const sv = TOPs;
594
595     SvGETMAGIC(sv);
596     if (!SvROK(sv))
597         SETs(&PL_sv_no);
598     else {
599         dTARGET;
600         SETs(TARG);
601         /* use the return value that is in a register, its the same as TARG */
602         TARG = sv_ref(TARG,SvRV(sv),TRUE);
603         SvSETMAGIC(TARG);
604     }
605
606     return NORMAL;
607 }
608
609 PP(pp_bless)
610 {
611     dSP;
612     HV *stash;
613
614     if (MAXARG == 1)
615     {
616       curstash:
617         stash = CopSTASH(PL_curcop);
618         if (SvTYPE(stash) != SVt_PVHV)
619             Perl_croak(aTHX_ "Attempt to bless into a freed package");
620     }
621     else {
622         SV * const ssv = POPs;
623         STRLEN len;
624         const char *ptr;
625
626         if (!ssv) goto curstash;
627         SvGETMAGIC(ssv);
628         if (SvROK(ssv)) {
629           if (!SvAMAGIC(ssv)) {
630            frog:
631             Perl_croak(aTHX_ "Attempt to bless into a reference");
632           }
633           /* SvAMAGIC is on here, but it only means potentially overloaded,
634              so after stringification: */
635           ptr = SvPV_nomg_const(ssv,len);
636           /* We need to check the flag again: */
637           if (!SvAMAGIC(ssv)) goto frog;
638         }
639         else ptr = SvPV_nomg_const(ssv,len);
640         if (len == 0)
641             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
642                            "Explicit blessing to '' (assuming package main)");
643         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
644     }
645
646     (void)sv_bless(TOPs, stash);
647     RETURN;
648 }
649
650 PP(pp_gelem)
651 {
652     dSP;
653
654     SV *sv = POPs;
655     STRLEN len;
656     const char * const elem = SvPV_const(sv, len);
657     GV * const gv = MUTABLE_GV(POPs);
658     SV * tmpRef = NULL;
659
660     sv = NULL;
661     if (elem) {
662         /* elem will always be NUL terminated.  */
663         const char * const second_letter = elem + 1;
664         switch (*elem) {
665         case 'A':
666             if (len == 5 && strEQ(second_letter, "RRAY"))
667             {
668                 tmpRef = MUTABLE_SV(GvAV(gv));
669                 if (tmpRef && !AvREAL((const AV *)tmpRef)
670                  && AvREIFY((const AV *)tmpRef))
671                     av_reify(MUTABLE_AV(tmpRef));
672             }
673             break;
674         case 'C':
675             if (len == 4 && strEQ(second_letter, "ODE"))
676                 tmpRef = MUTABLE_SV(GvCVu(gv));
677             break;
678         case 'F':
679             if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
680                 /* finally deprecated in 5.8.0 */
681                 deprecate("*glob{FILEHANDLE}");
682                 tmpRef = MUTABLE_SV(GvIOp(gv));
683             }
684             else
685                 if (len == 6 && strEQ(second_letter, "ORMAT"))
686                     tmpRef = MUTABLE_SV(GvFORM(gv));
687             break;
688         case 'G':
689             if (len == 4 && strEQ(second_letter, "LOB"))
690                 tmpRef = MUTABLE_SV(gv);
691             break;
692         case 'H':
693             if (len == 4 && strEQ(second_letter, "ASH"))
694                 tmpRef = MUTABLE_SV(GvHV(gv));
695             break;
696         case 'I':
697             if (*second_letter == 'O' && !elem[2] && len == 2)
698                 tmpRef = MUTABLE_SV(GvIOp(gv));
699             break;
700         case 'N':
701             if (len == 4 && strEQ(second_letter, "AME"))
702                 sv = newSVhek(GvNAME_HEK(gv));
703             break;
704         case 'P':
705             if (len == 7 && strEQ(second_letter, "ACKAGE")) {
706                 const HV * const stash = GvSTASH(gv);
707                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
708                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
709             }
710             break;
711         case 'S':
712             if (len == 6 && strEQ(second_letter, "CALAR"))
713                 tmpRef = GvSVn(gv);
714             break;
715         }
716     }
717     if (tmpRef)
718         sv = newRV(tmpRef);
719     if (sv)
720         sv_2mortal(sv);
721     else
722         sv = &PL_sv_undef;
723     XPUSHs(sv);
724     RETURN;
725 }
726
727 /* Pattern matching */
728
729 PP(pp_study)
730 {
731     dSP; dPOPss;
732     STRLEN len;
733
734     (void)SvPV(sv, len);
735     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
736         /* Historically, study was skipped in these cases. */
737         RETPUSHNO;
738     }
739
740     /* Make study a no-op. It's no longer useful and its existence
741        complicates matters elsewhere. */
742     RETPUSHYES;
743 }
744
745
746 /* also used for: pp_transr() */
747
748 PP(pp_trans)
749 {
750     dSP; dTARG;
751     SV *sv;
752
753     if (PL_op->op_flags & OPf_STACKED)
754         sv = POPs;
755     else if (ARGTARG)
756         sv = GETTARGET;
757     else {
758         sv = DEFSV;
759         EXTEND(SP,1);
760     }
761     if(PL_op->op_type == OP_TRANSR) {
762         STRLEN len;
763         const char * const pv = SvPV(sv,len);
764         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
765         do_trans(newsv);
766         PUSHs(newsv);
767     }
768     else {
769         TARG = sv_newmortal();
770         PUSHi(do_trans(sv));
771     }
772     RETURN;
773 }
774
775 /* Lvalue operators. */
776
777 static size_t
778 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
779 {
780     STRLEN len;
781     char *s;
782     size_t count = 0;
783
784     PERL_ARGS_ASSERT_DO_CHOMP;
785
786     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
787         return 0;
788     if (SvTYPE(sv) == SVt_PVAV) {
789         I32 i;
790         AV *const av = MUTABLE_AV(sv);
791         const I32 max = AvFILL(av);
792
793         for (i = 0; i <= max; i++) {
794             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
795             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
796                 count += do_chomp(retval, sv, chomping);
797         }
798         return count;
799     }
800     else if (SvTYPE(sv) == SVt_PVHV) {
801         HV* const hv = MUTABLE_HV(sv);
802         HE* entry;
803         (void)hv_iterinit(hv);
804         while ((entry = hv_iternext(hv)))
805             count += do_chomp(retval, hv_iterval(hv,entry), chomping);
806         return count;
807     }
808     else if (SvREADONLY(sv)) {
809             Perl_croak_no_modify();
810     }
811
812     if (IN_ENCODING) {
813         if (!SvUTF8(sv)) {
814             /* XXX, here sv is utf8-ized as a side-effect!
815                If encoding.pm is used properly, almost string-generating
816                operations, including literal strings, chr(), input data, etc.
817                should have been utf8-ized already, right?
818             */
819             sv_recode_to_utf8(sv, _get_encoding());
820         }
821     }
822
823     s = SvPV(sv, len);
824     if (chomping) {
825         char *temp_buffer = NULL;
826         SV *svrecode = NULL;
827
828         if (s && len) {
829             s += --len;
830             if (RsPARA(PL_rs)) {
831                 if (*s != '\n')
832                     goto nope;
833                 ++count;
834                 while (len && s[-1] == '\n') {
835                     --len;
836                     --s;
837                     ++count;
838                 }
839             }
840             else {
841                 STRLEN rslen, rs_charlen;
842                 const char *rsptr = SvPV_const(PL_rs, rslen);
843
844                 rs_charlen = SvUTF8(PL_rs)
845                     ? sv_len_utf8(PL_rs)
846                     : rslen;
847
848                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
849                     /* Assumption is that rs is shorter than the scalar.  */
850                     if (SvUTF8(PL_rs)) {
851                         /* RS is utf8, scalar is 8 bit.  */
852                         bool is_utf8 = TRUE;
853                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
854                                                              &rslen, &is_utf8);
855                         if (is_utf8) {
856                             /* Cannot downgrade, therefore cannot possibly match
857                              */
858                             assert (temp_buffer == rsptr);
859                             temp_buffer = NULL;
860                             goto nope;
861                         }
862                         rsptr = temp_buffer;
863                     }
864                     else if (IN_ENCODING) {
865                         /* RS is 8 bit, encoding.pm is used.
866                          * Do not recode PL_rs as a side-effect. */
867                         svrecode = newSVpvn(rsptr, rslen);
868                         sv_recode_to_utf8(svrecode, _get_encoding());
869                         rsptr = SvPV_const(svrecode, rslen);
870                         rs_charlen = sv_len_utf8(svrecode);
871                     }
872                     else {
873                         /* RS is 8 bit, scalar is utf8.  */
874                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
875                         rsptr = temp_buffer;
876                     }
877                 }
878                 if (rslen == 1) {
879                     if (*s != *rsptr)
880                         goto nope;
881                     ++count;
882                 }
883                 else {
884                     if (len < rslen - 1)
885                         goto nope;
886                     len -= rslen - 1;
887                     s -= rslen - 1;
888                     if (memNE(s, rsptr, rslen))
889                         goto nope;
890                     count += rs_charlen;
891                 }
892             }
893             SvPV_force_nomg_nolen(sv);
894             SvCUR_set(sv, len);
895             *SvEND(sv) = '\0';
896             SvNIOK_off(sv);
897             SvSETMAGIC(sv);
898         }
899     nope:
900
901         SvREFCNT_dec(svrecode);
902
903         Safefree(temp_buffer);
904     } else {
905         if (len && (!SvPOK(sv) || SvIsCOW(sv)))
906             s = SvPV_force_nomg(sv, len);
907         if (DO_UTF8(sv)) {
908             if (s && len) {
909                 char * const send = s + len;
910                 char * const start = s;
911                 s = send - 1;
912                 while (s > start && UTF8_IS_CONTINUATION(*s))
913                     s--;
914                 if (is_utf8_string((U8*)s, send - s)) {
915                     sv_setpvn(retval, s, send - s);
916                     *s = '\0';
917                     SvCUR_set(sv, s - start);
918                     SvNIOK_off(sv);
919                     SvUTF8_on(retval);
920                 }
921             }
922             else
923                 sv_setpvs(retval, "");
924         }
925         else if (s && len) {
926             s += --len;
927             sv_setpvn(retval, s, 1);
928             *s = '\0';
929             SvCUR_set(sv, len);
930             SvUTF8_off(sv);
931             SvNIOK_off(sv);
932         }
933         else
934             sv_setpvs(retval, "");
935         SvSETMAGIC(sv);
936     }
937     return count;
938 }
939
940
941 /* also used for: pp_schomp() */
942
943 PP(pp_schop)
944 {
945     dSP; dTARGET;
946     const bool chomping = PL_op->op_type == OP_SCHOMP;
947
948     const size_t count = do_chomp(TARG, TOPs, chomping);
949     if (chomping)
950         sv_setiv(TARG, count);
951     SETTARG;
952     RETURN;
953 }
954
955
956 /* also used for: pp_chomp() */
957
958 PP(pp_chop)
959 {
960     dSP; dMARK; dTARGET; dORIGMARK;
961     const bool chomping = PL_op->op_type == OP_CHOMP;
962     size_t count = 0;
963
964     while (MARK < SP)
965         count += do_chomp(TARG, *++MARK, chomping);
966     if (chomping)
967         sv_setiv(TARG, count);
968     SP = ORIGMARK;
969     XPUSHTARG;
970     RETURN;
971 }
972
973 PP(pp_undef)
974 {
975     dSP;
976     SV *sv;
977
978     if (!PL_op->op_private) {
979         EXTEND(SP, 1);
980         RETPUSHUNDEF;
981     }
982
983     sv = POPs;
984     if (!sv)
985         RETPUSHUNDEF;
986
987     if (SvTHINKFIRST(sv))
988         sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
989
990     switch (SvTYPE(sv)) {
991     case SVt_NULL:
992         break;
993     case SVt_PVAV:
994         av_undef(MUTABLE_AV(sv));
995         break;
996     case SVt_PVHV:
997         hv_undef(MUTABLE_HV(sv));
998         break;
999     case SVt_PVCV:
1000         if (cv_const_sv((const CV *)sv))
1001             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1002                           "Constant subroutine %"SVf" undefined",
1003                            SVfARG(CvANON((const CV *)sv)
1004                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
1005                              : sv_2mortal(newSVhek(
1006                                 CvNAMED(sv)
1007                                  ? CvNAME_HEK((CV *)sv)
1008                                  : GvENAME_HEK(CvGV((const CV *)sv))
1009                                ))
1010                            ));
1011         /* FALLTHROUGH */
1012     case SVt_PVFM:
1013             /* let user-undef'd sub keep its identity */
1014         cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
1015         break;
1016     case SVt_PVGV:
1017         assert(isGV_with_GP(sv));
1018         assert(!SvFAKE(sv));
1019         {
1020             GP *gp;
1021             HV *stash;
1022
1023             /* undef *Pkg::meth_name ... */
1024             bool method_changed
1025              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1026               && HvENAME_get(stash);
1027             /* undef *Foo:: */
1028             if((stash = GvHV((const GV *)sv))) {
1029                 if(HvENAME_get(stash))
1030                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1031                 else stash = NULL;
1032             }
1033
1034             SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1035             gp_free(MUTABLE_GV(sv));
1036             Newxz(gp, 1, GP);
1037             GvGP_set(sv, gp_ref(gp));
1038 #ifndef PERL_DONT_CREATE_GVSV
1039             GvSV(sv) = newSV(0);
1040 #endif
1041             GvLINE(sv) = CopLINE(PL_curcop);
1042             GvEGV(sv) = MUTABLE_GV(sv);
1043             GvMULTI_on(sv);
1044
1045             if(stash)
1046                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1047             stash = NULL;
1048             /* undef *Foo::ISA */
1049             if( strEQ(GvNAME((const GV *)sv), "ISA")
1050              && (stash = GvSTASH((const GV *)sv))
1051              && (method_changed || HvENAME(stash)) )
1052                 mro_isa_changed_in(stash);
1053             else if(method_changed)
1054                 mro_method_changed_in(
1055                  GvSTASH((const GV *)sv)
1056                 );
1057
1058             break;
1059         }
1060     default:
1061         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1062             SvPV_free(sv);
1063             SvPV_set(sv, NULL);
1064             SvLEN_set(sv, 0);
1065         }
1066         SvOK_off(sv);
1067         SvSETMAGIC(sv);
1068     }
1069
1070     RETPUSHUNDEF;
1071 }
1072
1073
1074 /* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */
1075
1076 PP(pp_postinc)
1077 {
1078     dSP; dTARGET;
1079     const bool inc =
1080         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1081     if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1082         Perl_croak_no_modify();
1083     if (SvROK(TOPs))
1084         TARG = sv_newmortal();
1085     sv_setsv(TARG, TOPs);
1086     if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1087         && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1088     {
1089         SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1090         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1091     }
1092     else if (inc)
1093         sv_inc_nomg(TOPs);
1094     else sv_dec_nomg(TOPs);
1095     SvSETMAGIC(TOPs);
1096     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1097     if (inc && !SvOK(TARG))
1098         sv_setiv(TARG, 0);
1099     SETTARG;
1100     return NORMAL;
1101 }
1102
1103 /* Ordinary operators. */
1104
1105 PP(pp_pow)
1106 {
1107     dSP; dATARGET; SV *svl, *svr;
1108 #ifdef PERL_PRESERVE_IVUV
1109     bool is_int = 0;
1110 #endif
1111     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1112     svr = TOPs;
1113     svl = TOPm1s;
1114 #ifdef PERL_PRESERVE_IVUV
1115     /* For integer to integer power, we do the calculation by hand wherever
1116        we're sure it is safe; otherwise we call pow() and try to convert to
1117        integer afterwards. */
1118     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1119                 UV power;
1120                 bool baseuok;
1121                 UV baseuv;
1122
1123                 if (SvUOK(svr)) {
1124                     power = SvUVX(svr);
1125                 } else {
1126                     const IV iv = SvIVX(svr);
1127                     if (iv >= 0) {
1128                         power = iv;
1129                     } else {
1130                         goto float_it; /* Can't do negative powers this way.  */
1131                     }
1132                 }
1133
1134                 baseuok = SvUOK(svl);
1135                 if (baseuok) {
1136                     baseuv = SvUVX(svl);
1137                 } else {
1138                     const IV iv = SvIVX(svl);
1139                     if (iv >= 0) {
1140                         baseuv = iv;
1141                         baseuok = TRUE; /* effectively it's a UV now */
1142                     } else {
1143                         baseuv = -iv; /* abs, baseuok == false records sign */
1144                     }
1145                 }
1146                 /* now we have integer ** positive integer. */
1147                 is_int = 1;
1148
1149                 /* foo & (foo - 1) is zero only for a power of 2.  */
1150                 if (!(baseuv & (baseuv - 1))) {
1151                     /* We are raising power-of-2 to a positive integer.
1152                        The logic here will work for any base (even non-integer
1153                        bases) but it can be less accurate than
1154                        pow (base,power) or exp (power * log (base)) when the
1155                        intermediate values start to spill out of the mantissa.
1156                        With powers of 2 we know this can't happen.
1157                        And powers of 2 are the favourite thing for perl
1158                        programmers to notice ** not doing what they mean. */
1159                     NV result = 1.0;
1160                     NV base = baseuok ? baseuv : -(NV)baseuv;
1161
1162                     if (power & 1) {
1163                         result *= base;
1164                     }
1165                     while (power >>= 1) {
1166                         base *= base;
1167                         if (power & 1) {
1168                             result *= base;
1169                         }
1170                     }
1171                     SP--;
1172                     SETn( result );
1173                     SvIV_please_nomg(svr);
1174                     RETURN;
1175                 } else {
1176                     unsigned int highbit = 8 * sizeof(UV);
1177                     unsigned int diff = 8 * sizeof(UV);
1178                     while (diff >>= 1) {
1179                         highbit -= diff;
1180                         if (baseuv >> highbit) {
1181                             highbit += diff;
1182                         }
1183                     }
1184                     /* we now have baseuv < 2 ** highbit */
1185                     if (power * highbit <= 8 * sizeof(UV)) {
1186                         /* result will definitely fit in UV, so use UV math
1187                            on same algorithm as above */
1188                         UV result = 1;
1189                         UV base = baseuv;
1190                         const bool odd_power = cBOOL(power & 1);
1191                         if (odd_power) {
1192                             result *= base;
1193                         }
1194                         while (power >>= 1) {
1195                             base *= base;
1196                             if (power & 1) {
1197                                 result *= base;
1198                             }
1199                         }
1200                         SP--;
1201                         if (baseuok || !odd_power)
1202                             /* answer is positive */
1203                             SETu( result );
1204                         else if (result <= (UV)IV_MAX)
1205                             /* answer negative, fits in IV */
1206                             SETi( -(IV)result );
1207                         else if (result == (UV)IV_MIN) 
1208                             /* 2's complement assumption: special case IV_MIN */
1209                             SETi( IV_MIN );
1210                         else
1211                             /* answer negative, doesn't fit */
1212                             SETn( -(NV)result );
1213                         RETURN;
1214                     } 
1215                 }
1216     }
1217   float_it:
1218 #endif    
1219     {
1220         NV right = SvNV_nomg(svr);
1221         NV left  = SvNV_nomg(svl);
1222         (void)POPs;
1223
1224 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1225     /*
1226     We are building perl with long double support and are on an AIX OS
1227     afflicted with a powl() function that wrongly returns NaNQ for any
1228     negative base.  This was reported to IBM as PMR #23047-379 on
1229     03/06/2006.  The problem exists in at least the following versions
1230     of AIX and the libm fileset, and no doubt others as well:
1231
1232         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1233         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1234         AIX 5.2.0           bos.adt.libm 5.2.0.85
1235
1236     So, until IBM fixes powl(), we provide the following workaround to
1237     handle the problem ourselves.  Our logic is as follows: for
1238     negative bases (left), we use fmod(right, 2) to check if the
1239     exponent is an odd or even integer:
1240
1241         - if odd,  powl(left, right) == -powl(-left, right)
1242         - if even, powl(left, right) ==  powl(-left, right)
1243
1244     If the exponent is not an integer, the result is rightly NaNQ, so
1245     we just return that (as NV_NAN).
1246     */
1247
1248         if (left < 0.0) {
1249             NV mod2 = Perl_fmod( right, 2.0 );
1250             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1251                 SETn( -Perl_pow( -left, right) );
1252             } else if (mod2 == 0.0) {           /* even integer */
1253                 SETn( Perl_pow( -left, right) );
1254             } else {                            /* fractional power */
1255                 SETn( NV_NAN );
1256             }
1257         } else {
1258             SETn( Perl_pow( left, right) );
1259         }
1260 #else
1261         SETn( Perl_pow( left, right) );
1262 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1263
1264 #ifdef PERL_PRESERVE_IVUV
1265         if (is_int)
1266             SvIV_please_nomg(svr);
1267 #endif
1268         RETURN;
1269     }
1270 }
1271
1272 PP(pp_multiply)
1273 {
1274     dSP; dATARGET; SV *svl, *svr;
1275     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1276     svr = TOPs;
1277     svl = TOPm1s;
1278 #ifdef PERL_PRESERVE_IVUV
1279     if (SvIV_please_nomg(svr)) {
1280         /* Unless the left argument is integer in range we are going to have to
1281            use NV maths. Hence only attempt to coerce the right argument if
1282            we know the left is integer.  */
1283         /* Left operand is defined, so is it IV? */
1284         if (SvIV_please_nomg(svl)) {
1285             bool auvok = SvUOK(svl);
1286             bool buvok = SvUOK(svr);
1287             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1288             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1289             UV alow;
1290             UV ahigh;
1291             UV blow;
1292             UV bhigh;
1293
1294             if (auvok) {
1295                 alow = SvUVX(svl);
1296             } else {
1297                 const IV aiv = SvIVX(svl);
1298                 if (aiv >= 0) {
1299                     alow = aiv;
1300                     auvok = TRUE; /* effectively it's a UV now */
1301                 } else {
1302                     alow = -aiv; /* abs, auvok == false records sign */
1303                 }
1304             }
1305             if (buvok) {
1306                 blow = SvUVX(svr);
1307             } else {
1308                 const IV biv = SvIVX(svr);
1309                 if (biv >= 0) {
1310                     blow = biv;
1311                     buvok = TRUE; /* effectively it's a UV now */
1312                 } else {
1313                     blow = -biv; /* abs, buvok == false records sign */
1314                 }
1315             }
1316
1317             /* If this does sign extension on unsigned it's time for plan B  */
1318             ahigh = alow >> (4 * sizeof (UV));
1319             alow &= botmask;
1320             bhigh = blow >> (4 * sizeof (UV));
1321             blow &= botmask;
1322             if (ahigh && bhigh) {
1323                 NOOP;
1324                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1325                    which is overflow. Drop to NVs below.  */
1326             } else if (!ahigh && !bhigh) {
1327                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1328                    so the unsigned multiply cannot overflow.  */
1329                 const UV product = alow * blow;
1330                 if (auvok == buvok) {
1331                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1332                     SP--;
1333                     SETu( product );
1334                     RETURN;
1335                 } else if (product <= (UV)IV_MIN) {
1336                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1337                     /* -ve result, which could overflow an IV  */
1338                     SP--;
1339                     SETi( -(IV)product );
1340                     RETURN;
1341                 } /* else drop to NVs below. */
1342             } else {
1343                 /* One operand is large, 1 small */
1344                 UV product_middle;
1345                 if (bhigh) {
1346                     /* swap the operands */
1347                     ahigh = bhigh;
1348                     bhigh = blow; /* bhigh now the temp var for the swap */
1349                     blow = alow;
1350                     alow = bhigh;
1351                 }
1352                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1353                    multiplies can't overflow. shift can, add can, -ve can.  */
1354                 product_middle = ahigh * blow;
1355                 if (!(product_middle & topmask)) {
1356                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1357                     UV product_low;
1358                     product_middle <<= (4 * sizeof (UV));
1359                     product_low = alow * blow;
1360
1361                     /* as for pp_add, UV + something mustn't get smaller.
1362                        IIRC ANSI mandates this wrapping *behaviour* for
1363                        unsigned whatever the actual representation*/
1364                     product_low += product_middle;
1365                     if (product_low >= product_middle) {
1366                         /* didn't overflow */
1367                         if (auvok == buvok) {
1368                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1369                             SP--;
1370                             SETu( product_low );
1371                             RETURN;
1372                         } else if (product_low <= (UV)IV_MIN) {
1373                             /* 2s complement assumption again  */
1374                             /* -ve result, which could overflow an IV  */
1375                             SP--;
1376                             SETi( -(IV)product_low );
1377                             RETURN;
1378                         } /* else drop to NVs below. */
1379                     }
1380                 } /* product_middle too large */
1381             } /* ahigh && bhigh */
1382         } /* SvIOK(svl) */
1383     } /* SvIOK(svr) */
1384 #endif
1385     {
1386       NV right = SvNV_nomg(svr);
1387       NV left  = SvNV_nomg(svl);
1388       (void)POPs;
1389       SETn( left * right );
1390       RETURN;
1391     }
1392 }
1393
1394 PP(pp_divide)
1395 {
1396     dSP; dATARGET; SV *svl, *svr;
1397     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1398     svr = TOPs;
1399     svl = TOPm1s;
1400     /* Only try to do UV divide first
1401        if ((SLOPPYDIVIDE is true) or
1402            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1403             to preserve))
1404        The assumption is that it is better to use floating point divide
1405        whenever possible, only doing integer divide first if we can't be sure.
1406        If NV_PRESERVES_UV is true then we know at compile time that no UV
1407        can be too large to preserve, so don't need to compile the code to
1408        test the size of UVs.  */
1409
1410 #ifdef SLOPPYDIVIDE
1411 #  define PERL_TRY_UV_DIVIDE
1412     /* ensure that 20./5. == 4. */
1413 #else
1414 #  ifdef PERL_PRESERVE_IVUV
1415 #    ifndef NV_PRESERVES_UV
1416 #      define PERL_TRY_UV_DIVIDE
1417 #    endif
1418 #  endif
1419 #endif
1420
1421 #ifdef PERL_TRY_UV_DIVIDE
1422     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1423             bool left_non_neg = SvUOK(svl);
1424             bool right_non_neg = SvUOK(svr);
1425             UV left;
1426             UV right;
1427
1428             if (right_non_neg) {
1429                 right = SvUVX(svr);
1430             }
1431             else {
1432                 const IV biv = SvIVX(svr);
1433                 if (biv >= 0) {
1434                     right = biv;
1435                     right_non_neg = TRUE; /* effectively it's a UV now */
1436                 }
1437                 else {
1438                     right = -biv;
1439                 }
1440             }
1441             /* historically undef()/0 gives a "Use of uninitialized value"
1442                warning before dieing, hence this test goes here.
1443                If it were immediately before the second SvIV_please, then
1444                DIE() would be invoked before left was even inspected, so
1445                no inspection would give no warning.  */
1446             if (right == 0)
1447                 DIE(aTHX_ "Illegal division by zero");
1448
1449             if (left_non_neg) {
1450                 left = SvUVX(svl);
1451             }
1452             else {
1453                 const IV aiv = SvIVX(svl);
1454                 if (aiv >= 0) {
1455                     left = aiv;
1456                     left_non_neg = TRUE; /* effectively it's a UV now */
1457                 }
1458                 else {
1459                     left = -aiv;
1460                 }
1461             }
1462
1463             if (left >= right
1464 #ifdef SLOPPYDIVIDE
1465                 /* For sloppy divide we always attempt integer division.  */
1466 #else
1467                 /* Otherwise we only attempt it if either or both operands
1468                    would not be preserved by an NV.  If both fit in NVs
1469                    we fall through to the NV divide code below.  However,
1470                    as left >= right to ensure integer result here, we know that
1471                    we can skip the test on the right operand - right big
1472                    enough not to be preserved can't get here unless left is
1473                    also too big.  */
1474
1475                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1476 #endif
1477                 ) {
1478                 /* Integer division can't overflow, but it can be imprecise.  */
1479                 const UV result = left / right;
1480                 if (result * right == left) {
1481                     SP--; /* result is valid */
1482                     if (left_non_neg == right_non_neg) {
1483                         /* signs identical, result is positive.  */
1484                         SETu( result );
1485                         RETURN;
1486                     }
1487                     /* 2s complement assumption */
1488                     if (result <= (UV)IV_MIN)
1489                         SETi( -(IV)result );
1490                     else {
1491                         /* It's exact but too negative for IV. */
1492                         SETn( -(NV)result );
1493                     }
1494                     RETURN;
1495                 } /* tried integer divide but it was not an integer result */
1496             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1497     } /* one operand wasn't SvIOK */
1498 #endif /* PERL_TRY_UV_DIVIDE */
1499     {
1500         NV right = SvNV_nomg(svr);
1501         NV left  = SvNV_nomg(svl);
1502         (void)POPs;(void)POPs;
1503 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1504         if (! Perl_isnan(right) && right == 0.0)
1505 #else
1506         if (right == 0.0)
1507 #endif
1508             DIE(aTHX_ "Illegal division by zero");
1509         PUSHn( left / right );
1510         RETURN;
1511     }
1512 }
1513
1514 PP(pp_modulo)
1515 {
1516     dSP; dATARGET;
1517     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1518     {
1519         UV left  = 0;
1520         UV right = 0;
1521         bool left_neg = FALSE;
1522         bool right_neg = FALSE;
1523         bool use_double = FALSE;
1524         bool dright_valid = FALSE;
1525         NV dright = 0.0;
1526         NV dleft  = 0.0;
1527         SV * const svr = TOPs;
1528         SV * const svl = TOPm1s;
1529         if (SvIV_please_nomg(svr)) {
1530             right_neg = !SvUOK(svr);
1531             if (!right_neg) {
1532                 right = SvUVX(svr);
1533             } else {
1534                 const IV biv = SvIVX(svr);
1535                 if (biv >= 0) {
1536                     right = biv;
1537                     right_neg = FALSE; /* effectively it's a UV now */
1538                 } else {
1539                     right = -biv;
1540                 }
1541             }
1542         }
1543         else {
1544             dright = SvNV_nomg(svr);
1545             right_neg = dright < 0;
1546             if (right_neg)
1547                 dright = -dright;
1548             if (dright < UV_MAX_P1) {
1549                 right = U_V(dright);
1550                 dright_valid = TRUE; /* In case we need to use double below.  */
1551             } else {
1552                 use_double = TRUE;
1553             }
1554         }
1555
1556         /* At this point use_double is only true if right is out of range for
1557            a UV.  In range NV has been rounded down to nearest UV and
1558            use_double false.  */
1559         if (!use_double && SvIV_please_nomg(svl)) {
1560                 left_neg = !SvUOK(svl);
1561                 if (!left_neg) {
1562                     left = SvUVX(svl);
1563                 } else {
1564                     const IV aiv = SvIVX(svl);
1565                     if (aiv >= 0) {
1566                         left = aiv;
1567                         left_neg = FALSE; /* effectively it's a UV now */
1568                     } else {
1569                         left = -aiv;
1570                     }
1571                 }
1572         }
1573         else {
1574             dleft = SvNV_nomg(svl);
1575             left_neg = dleft < 0;
1576             if (left_neg)
1577                 dleft = -dleft;
1578
1579             /* This should be exactly the 5.6 behaviour - if left and right are
1580                both in range for UV then use U_V() rather than floor.  */
1581             if (!use_double) {
1582                 if (dleft < UV_MAX_P1) {
1583                     /* right was in range, so is dleft, so use UVs not double.
1584                      */
1585                     left = U_V(dleft);
1586                 }
1587                 /* left is out of range for UV, right was in range, so promote
1588                    right (back) to double.  */
1589                 else {
1590                     /* The +0.5 is used in 5.6 even though it is not strictly
1591                        consistent with the implicit +0 floor in the U_V()
1592                        inside the #if 1. */
1593                     dleft = Perl_floor(dleft + 0.5);
1594                     use_double = TRUE;
1595                     if (dright_valid)
1596                         dright = Perl_floor(dright + 0.5);
1597                     else
1598                         dright = right;
1599                 }
1600             }
1601         }
1602         sp -= 2;
1603         if (use_double) {
1604             NV dans;
1605
1606             if (!dright)
1607                 DIE(aTHX_ "Illegal modulus zero");
1608
1609             dans = Perl_fmod(dleft, dright);
1610             if ((left_neg != right_neg) && dans)
1611                 dans = dright - dans;
1612             if (right_neg)
1613                 dans = -dans;
1614             sv_setnv(TARG, dans);
1615         }
1616         else {
1617             UV ans;
1618
1619             if (!right)
1620                 DIE(aTHX_ "Illegal modulus zero");
1621
1622             ans = left % right;
1623             if ((left_neg != right_neg) && ans)
1624                 ans = right - ans;
1625             if (right_neg) {
1626                 /* XXX may warn: unary minus operator applied to unsigned type */
1627                 /* could change -foo to be (~foo)+1 instead     */
1628                 if (ans <= ~((UV)IV_MAX)+1)
1629                     sv_setiv(TARG, ~ans+1);
1630                 else
1631                     sv_setnv(TARG, -(NV)ans);
1632             }
1633             else
1634                 sv_setuv(TARG, ans);
1635         }
1636         PUSHTARG;
1637         RETURN;
1638     }
1639 }
1640
1641 PP(pp_repeat)
1642 {
1643     dSP; dATARGET;
1644     IV count;
1645     SV *sv;
1646
1647     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1648         /* TODO: think of some way of doing list-repeat overloading ??? */
1649         sv = POPs;
1650         SvGETMAGIC(sv);
1651     }
1652     else {
1653         if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1654             /* The parser saw this as a list repeat, and there
1655                are probably several items on the stack. But we're
1656                in scalar/void context, and there's no pp_list to save us
1657                now. So drop the rest of the items -- robin@kitsite.com
1658              */
1659             dMARK;
1660             if (MARK + 1 < SP) {
1661                 MARK[1] = TOPm1s;
1662                 MARK[2] = TOPs;
1663             }
1664             else {
1665                 dTOPss;
1666                 ASSUME(MARK + 1 == SP);
1667                 XPUSHs(sv);
1668                 MARK[1] = &PL_sv_undef;
1669             }
1670             SP = MARK + 2;
1671         }
1672         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1673         sv = POPs;
1674     }
1675
1676     if (SvIOKp(sv)) {
1677          if (SvUOK(sv)) {
1678               const UV uv = SvUV_nomg(sv);
1679               if (uv > IV_MAX)
1680                    count = IV_MAX; /* The best we can do? */
1681               else
1682                    count = uv;
1683          } else {
1684               count = SvIV_nomg(sv);
1685          }
1686     }
1687     else if (SvNOKp(sv)) {
1688          const NV nv = SvNV_nomg(sv);
1689          if (nv < 0.0)
1690               count = -1;   /* An arbitrary negative integer */
1691          else
1692               count = (IV)nv;
1693     }
1694     else
1695          count = SvIV_nomg(sv);
1696
1697     if (count < 0) {
1698         count = 0;
1699         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1700                                          "Negative repeat count does nothing");
1701     }
1702
1703     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1704         dMARK;
1705         static const char* const oom_list_extend = "Out of memory during list extend";
1706         const I32 items = SP - MARK;
1707         const I32 max = items * count;
1708         const U8 mod = PL_op->op_flags & OPf_MOD;
1709
1710         MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1711         /* Did the max computation overflow? */
1712         if (items > 0 && max > 0 && (max < items || max < count))
1713            Perl_croak(aTHX_ "%s", oom_list_extend);
1714         MEXTEND(MARK, max);
1715         if (count > 1) {
1716             while (SP > MARK) {
1717                 if (*SP) {
1718                    if (mod && SvPADTMP(*SP)) {
1719                        *SP = sv_mortalcopy(*SP);
1720                    }
1721                    SvTEMP_off((*SP));
1722                 }
1723                 SP--;
1724             }
1725             MARK++;
1726             repeatcpy((char*)(MARK + items), (char*)MARK,
1727                 items * sizeof(const SV *), count - 1);
1728             SP += max;
1729         }
1730         else if (count <= 0)
1731             SP -= items;
1732     }
1733     else {      /* Note: mark already snarfed by pp_list */
1734         SV * const tmpstr = POPs;
1735         STRLEN len;
1736         bool isutf;
1737         static const char* const oom_string_extend =
1738           "Out of memory during string extend";
1739
1740         if (TARG != tmpstr)
1741             sv_setsv_nomg(TARG, tmpstr);
1742         SvPV_force_nomg(TARG, len);
1743         isutf = DO_UTF8(TARG);
1744         if (count != 1) {
1745             if (count < 1)
1746                 SvCUR_set(TARG, 0);
1747             else {
1748                 const STRLEN max = (UV)count * len;
1749                 if (len > MEM_SIZE_MAX / count)
1750                      Perl_croak(aTHX_ "%s", oom_string_extend);
1751                 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1752                 SvGROW(TARG, max + 1);
1753                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1754                 SvCUR_set(TARG, SvCUR(TARG) * count);
1755             }
1756             *SvEND(TARG) = '\0';
1757         }
1758         if (isutf)
1759             (void)SvPOK_only_UTF8(TARG);
1760         else
1761             (void)SvPOK_only(TARG);
1762
1763         PUSHTARG;
1764     }
1765     RETURN;
1766 }
1767
1768 PP(pp_subtract)
1769 {
1770     dSP; dATARGET; bool useleft; SV *svl, *svr;
1771     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1772     svr = TOPs;
1773     svl = TOPm1s;
1774     useleft = USE_LEFT(svl);
1775 #ifdef PERL_PRESERVE_IVUV
1776     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1777        "bad things" happen if you rely on signed integers wrapping.  */
1778     if (SvIV_please_nomg(svr)) {
1779         /* Unless the left argument is integer in range we are going to have to
1780            use NV maths. Hence only attempt to coerce the right argument if
1781            we know the left is integer.  */
1782         UV auv = 0;
1783         bool auvok = FALSE;
1784         bool a_valid = 0;
1785
1786         if (!useleft) {
1787             auv = 0;
1788             a_valid = auvok = 1;
1789             /* left operand is undef, treat as zero.  */
1790         } else {
1791             /* Left operand is defined, so is it IV? */
1792             if (SvIV_please_nomg(svl)) {
1793                 if ((auvok = SvUOK(svl)))
1794                     auv = SvUVX(svl);
1795                 else {
1796                     const IV aiv = SvIVX(svl);
1797                     if (aiv >= 0) {
1798                         auv = aiv;
1799                         auvok = 1;      /* Now acting as a sign flag.  */
1800                     } else { /* 2s complement assumption for IV_MIN */
1801                         auv = (UV)-aiv;
1802                     }
1803                 }
1804                 a_valid = 1;
1805             }
1806         }
1807         if (a_valid) {
1808             bool result_good = 0;
1809             UV result;
1810             UV buv;
1811             bool buvok = SvUOK(svr);
1812         
1813             if (buvok)
1814                 buv = SvUVX(svr);
1815             else {
1816                 const IV biv = SvIVX(svr);
1817                 if (biv >= 0) {
1818                     buv = biv;
1819                     buvok = 1;
1820                 } else
1821                     buv = (UV)-biv;
1822             }
1823             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1824                else "IV" now, independent of how it came in.
1825                if a, b represents positive, A, B negative, a maps to -A etc
1826                a - b =>  (a - b)
1827                A - b => -(a + b)
1828                a - B =>  (a + b)
1829                A - B => -(a - b)
1830                all UV maths. negate result if A negative.
1831                subtract if signs same, add if signs differ. */
1832
1833             if (auvok ^ buvok) {
1834                 /* Signs differ.  */
1835                 result = auv + buv;
1836                 if (result >= auv)
1837                     result_good = 1;
1838             } else {
1839                 /* Signs same */
1840                 if (auv >= buv) {
1841                     result = auv - buv;
1842                     /* Must get smaller */
1843                     if (result <= auv)
1844                         result_good = 1;
1845                 } else {
1846                     result = buv - auv;
1847                     if (result <= buv) {
1848                         /* result really should be -(auv-buv). as its negation
1849                            of true value, need to swap our result flag  */
1850                         auvok = !auvok;
1851                         result_good = 1;
1852                     }
1853                 }
1854             }
1855             if (result_good) {
1856                 SP--;
1857                 if (auvok)
1858                     SETu( result );
1859                 else {
1860                     /* Negate result */
1861                     if (result <= (UV)IV_MIN)
1862                         SETi( -(IV)result );
1863                     else {
1864                         /* result valid, but out of range for IV.  */
1865                         SETn( -(NV)result );
1866                     }
1867                 }
1868                 RETURN;
1869             } /* Overflow, drop through to NVs.  */
1870         }
1871     }
1872 #endif
1873     {
1874         NV value = SvNV_nomg(svr);
1875         (void)POPs;
1876
1877         if (!useleft) {
1878             /* left operand is undef, treat as zero - value */
1879             SETn(-value);
1880             RETURN;
1881         }
1882         SETn( SvNV_nomg(svl) - value );
1883         RETURN;
1884     }
1885 }
1886
1887 PP(pp_left_shift)
1888 {
1889     dSP; dATARGET; SV *svl, *svr;
1890     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1891     svr = POPs;
1892     svl = TOPs;
1893     {
1894       const IV shift = SvIV_nomg(svr);
1895       if (PL_op->op_private & HINT_INTEGER) {
1896         const IV i = SvIV_nomg(svl);
1897         SETi(i << shift);
1898       }
1899       else {
1900         const UV u = SvUV_nomg(svl);
1901         SETu(u << shift);
1902       }
1903       RETURN;
1904     }
1905 }
1906
1907 PP(pp_right_shift)
1908 {
1909     dSP; dATARGET; SV *svl, *svr;
1910     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1911     svr = POPs;
1912     svl = TOPs;
1913     {
1914       const IV shift = SvIV_nomg(svr);
1915       if (PL_op->op_private & HINT_INTEGER) {
1916         const IV i = SvIV_nomg(svl);
1917         SETi(i >> shift);
1918       }
1919       else {
1920         const UV u = SvUV_nomg(svl);
1921         SETu(u >> shift);
1922       }
1923       RETURN;
1924     }
1925 }
1926
1927 PP(pp_lt)
1928 {
1929     dSP;
1930     SV *left, *right;
1931
1932     tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1933     right = POPs;
1934     left  = TOPs;
1935     SETs(boolSV(
1936         (SvIOK_notUV(left) && SvIOK_notUV(right))
1937         ? (SvIVX(left) < SvIVX(right))
1938         : (do_ncmp(left, right) == -1)
1939     ));
1940     RETURN;
1941 }
1942
1943 PP(pp_gt)
1944 {
1945     dSP;
1946     SV *left, *right;
1947
1948     tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1949     right = POPs;
1950     left  = TOPs;
1951     SETs(boolSV(
1952         (SvIOK_notUV(left) && SvIOK_notUV(right))
1953         ? (SvIVX(left) > SvIVX(right))
1954         : (do_ncmp(left, right) == 1)
1955     ));
1956     RETURN;
1957 }
1958
1959 PP(pp_le)
1960 {
1961     dSP;
1962     SV *left, *right;
1963
1964     tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1965     right = POPs;
1966     left  = TOPs;
1967     SETs(boolSV(
1968         (SvIOK_notUV(left) && SvIOK_notUV(right))
1969         ? (SvIVX(left) <= SvIVX(right))
1970         : (do_ncmp(left, right) <= 0)
1971     ));
1972     RETURN;
1973 }
1974
1975 PP(pp_ge)
1976 {
1977     dSP;
1978     SV *left, *right;
1979
1980     tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1981     right = POPs;
1982     left  = TOPs;
1983     SETs(boolSV(
1984         (SvIOK_notUV(left) && SvIOK_notUV(right))
1985         ? (SvIVX(left) >= SvIVX(right))
1986         : ( (do_ncmp(left, right) & 2) == 0)
1987     ));
1988     RETURN;
1989 }
1990
1991 PP(pp_ne)
1992 {
1993     dSP;
1994     SV *left, *right;
1995
1996     tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1997     right = POPs;
1998     left  = TOPs;
1999     SETs(boolSV(
2000         (SvIOK_notUV(left) && SvIOK_notUV(right))
2001         ? (SvIVX(left) != SvIVX(right))
2002         : (do_ncmp(left, right) != 0)
2003     ));
2004     RETURN;
2005 }
2006
2007 /* compare left and right SVs. Returns:
2008  * -1: <
2009  *  0: ==
2010  *  1: >
2011  *  2: left or right was a NaN
2012  */
2013 I32
2014 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2015 {
2016     PERL_ARGS_ASSERT_DO_NCMP;
2017 #ifdef PERL_PRESERVE_IVUV
2018     /* Fortunately it seems NaN isn't IOK */
2019     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2020             if (!SvUOK(left)) {
2021                 const IV leftiv = SvIVX(left);
2022                 if (!SvUOK(right)) {
2023                     /* ## IV <=> IV ## */
2024                     const IV rightiv = SvIVX(right);
2025                     return (leftiv > rightiv) - (leftiv < rightiv);
2026                 }
2027                 /* ## IV <=> UV ## */
2028                 if (leftiv < 0)
2029                     /* As (b) is a UV, it's >=0, so it must be < */
2030                     return -1;
2031                 {
2032                     const UV rightuv = SvUVX(right);
2033                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2034                 }
2035             }
2036
2037             if (SvUOK(right)) {
2038                 /* ## UV <=> UV ## */
2039                 const UV leftuv = SvUVX(left);
2040                 const UV rightuv = SvUVX(right);
2041                 return (leftuv > rightuv) - (leftuv < rightuv);
2042             }
2043             /* ## UV <=> IV ## */
2044             {
2045                 const IV rightiv = SvIVX(right);
2046                 if (rightiv < 0)
2047                     /* As (a) is a UV, it's >=0, so it cannot be < */
2048                     return 1;
2049                 {
2050                     const UV leftuv = SvUVX(left);
2051                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2052                 }
2053             }
2054             assert(0); /* NOTREACHED */
2055     }
2056 #endif
2057     {
2058       NV const rnv = SvNV_nomg(right);
2059       NV const lnv = SvNV_nomg(left);
2060
2061 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2062       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2063           return 2;
2064        }
2065       return (lnv > rnv) - (lnv < rnv);
2066 #else
2067       if (lnv < rnv)
2068         return -1;
2069       if (lnv > rnv)
2070         return 1;
2071       if (lnv == rnv)
2072         return 0;
2073       return 2;
2074 #endif
2075     }
2076 }
2077
2078
2079 PP(pp_ncmp)
2080 {
2081     dSP;
2082     SV *left, *right;
2083     I32 value;
2084     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2085     right = POPs;
2086     left  = TOPs;
2087     value = do_ncmp(left, right);
2088     if (value == 2) {
2089         SETs(&PL_sv_undef);
2090     }
2091     else {
2092         dTARGET;
2093         SETi(value);
2094     }
2095     RETURN;
2096 }
2097
2098
2099 /* also used for: pp_sge() pp_sgt() pp_slt() */
2100
2101 PP(pp_sle)
2102 {
2103     dSP;
2104
2105     int amg_type = sle_amg;
2106     int multiplier = 1;
2107     int rhs = 1;
2108
2109     switch (PL_op->op_type) {
2110     case OP_SLT:
2111         amg_type = slt_amg;
2112         /* cmp < 0 */
2113         rhs = 0;
2114         break;
2115     case OP_SGT:
2116         amg_type = sgt_amg;
2117         /* cmp > 0 */
2118         multiplier = -1;
2119         rhs = 0;
2120         break;
2121     case OP_SGE:
2122         amg_type = sge_amg;
2123         /* cmp >= 0 */
2124         multiplier = -1;
2125         break;
2126     }
2127
2128     tryAMAGICbin_MG(amg_type, AMGf_set);
2129     {
2130       dPOPTOPssrl;
2131       const int cmp =
2132 #ifdef USE_LOCALE_COLLATE
2133                       (IN_LC_RUNTIME(LC_COLLATE))
2134                       ? sv_cmp_locale_flags(left, right, 0)
2135                       :
2136 #endif
2137                         sv_cmp_flags(left, right, 0);
2138       SETs(boolSV(cmp * multiplier < rhs));
2139       RETURN;
2140     }
2141 }
2142
2143 PP(pp_seq)
2144 {
2145     dSP;
2146     tryAMAGICbin_MG(seq_amg, AMGf_set);
2147     {
2148       dPOPTOPssrl;
2149       SETs(boolSV(sv_eq_flags(left, right, 0)));
2150       RETURN;
2151     }
2152 }
2153
2154 PP(pp_sne)
2155 {
2156     dSP;
2157     tryAMAGICbin_MG(sne_amg, AMGf_set);
2158     {
2159       dPOPTOPssrl;
2160       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2161       RETURN;
2162     }
2163 }
2164
2165 PP(pp_scmp)
2166 {
2167     dSP; dTARGET;
2168     tryAMAGICbin_MG(scmp_amg, 0);
2169     {
2170       dPOPTOPssrl;
2171       const int cmp =
2172 #ifdef USE_LOCALE_COLLATE
2173                       (IN_LC_RUNTIME(LC_COLLATE))
2174                       ? sv_cmp_locale_flags(left, right, 0)
2175                       :
2176 #endif
2177                         sv_cmp_flags(left, right, 0);
2178       SETi( cmp );
2179       RETURN;
2180     }
2181 }
2182
2183 PP(pp_bit_and)
2184 {
2185     dSP; dATARGET;
2186     tryAMAGICbin_MG(band_amg, AMGf_assign);
2187     {
2188       dPOPTOPssrl;
2189       if (SvNIOKp(left) || SvNIOKp(right)) {
2190         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2191         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2192         if (PL_op->op_private & HINT_INTEGER) {
2193           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2194           SETi(i);
2195         }
2196         else {
2197           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2198           SETu(u);
2199         }
2200         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2201         if (right_ro_nonnum) SvNIOK_off(right);
2202       }
2203       else {
2204         do_vop(PL_op->op_type, TARG, left, right);
2205         SETTARG;
2206       }
2207       RETURN;
2208     }
2209 }
2210
2211
2212 /* also used for: pp_bit_xor() */
2213
2214 PP(pp_bit_or)
2215 {
2216     dSP; dATARGET;
2217     const int op_type = PL_op->op_type;
2218
2219     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2220     {
2221       dPOPTOPssrl;
2222       if (SvNIOKp(left) || SvNIOKp(right)) {
2223         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2224         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2225         if (PL_op->op_private & HINT_INTEGER) {
2226           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2227           const IV r = SvIV_nomg(right);
2228           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2229           SETi(result);
2230         }
2231         else {
2232           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2233           const UV r = SvUV_nomg(right);
2234           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2235           SETu(result);
2236         }
2237         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2238         if (right_ro_nonnum) SvNIOK_off(right);
2239       }
2240       else {
2241         do_vop(op_type, TARG, left, right);
2242         SETTARG;
2243       }
2244       RETURN;
2245     }
2246 }
2247
2248 PERL_STATIC_INLINE bool
2249 S_negate_string(pTHX)
2250 {
2251     dTARGET; dSP;
2252     STRLEN len;
2253     const char *s;
2254     SV * const sv = TOPs;
2255     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2256         return FALSE;
2257     s = SvPV_nomg_const(sv, len);
2258     if (isIDFIRST(*s)) {
2259         sv_setpvs(TARG, "-");
2260         sv_catsv(TARG, sv);
2261     }
2262     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2263         sv_setsv_nomg(TARG, sv);
2264         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2265     }
2266     else return FALSE;
2267     SETTARG; PUTBACK;
2268     return TRUE;
2269 }
2270
2271 PP(pp_negate)
2272 {
2273     dSP; dTARGET;
2274     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2275     if (S_negate_string(aTHX)) return NORMAL;
2276     {
2277         SV * const sv = TOPs;
2278
2279         if (SvIOK(sv)) {
2280             /* It's publicly an integer */
2281         oops_its_an_int:
2282             if (SvIsUV(sv)) {
2283                 if (SvIVX(sv) == IV_MIN) {
2284                     /* 2s complement assumption. */
2285                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2286                                            IV_MIN */
2287                     RETURN;
2288                 }
2289                 else if (SvUVX(sv) <= IV_MAX) {
2290                     SETi(-SvIVX(sv));
2291                     RETURN;
2292                 }
2293             }
2294             else if (SvIVX(sv) != IV_MIN) {
2295                 SETi(-SvIVX(sv));
2296                 RETURN;
2297             }
2298 #ifdef PERL_PRESERVE_IVUV
2299             else {
2300                 SETu((UV)IV_MIN);
2301                 RETURN;
2302             }
2303 #endif
2304         }
2305         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2306             SETn(-SvNV_nomg(sv));
2307         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2308                   goto oops_its_an_int;
2309         else
2310             SETn(-SvNV_nomg(sv));
2311     }
2312     RETURN;
2313 }
2314
2315 PP(pp_not)
2316 {
2317     dSP;
2318     tryAMAGICun_MG(not_amg, AMGf_set);
2319     *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2320     return NORMAL;
2321 }
2322
2323 PP(pp_complement)
2324 {
2325     dSP; dTARGET;
2326     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2327     {
2328       dTOPss;
2329       if (SvNIOKp(sv)) {
2330         if (PL_op->op_private & HINT_INTEGER) {
2331           const IV i = ~SvIV_nomg(sv);
2332           SETi(i);
2333         }
2334         else {
2335           const UV u = ~SvUV_nomg(sv);
2336           SETu(u);
2337         }
2338       }
2339       else {
2340         U8 *tmps;
2341         I32 anum;
2342         STRLEN len;
2343
2344         sv_copypv_nomg(TARG, sv);
2345         tmps = (U8*)SvPV_nomg(TARG, len);
2346         anum = len;
2347         if (SvUTF8(TARG)) {
2348           /* Calculate exact length, let's not estimate. */
2349           STRLEN targlen = 0;
2350           STRLEN l;
2351           UV nchar = 0;
2352           UV nwide = 0;
2353           U8 * const send = tmps + len;
2354           U8 * const origtmps = tmps;
2355           const UV utf8flags = UTF8_ALLOW_ANYUV;
2356
2357           while (tmps < send) {
2358             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2359             tmps += l;
2360             targlen += UNISKIP(~c);
2361             nchar++;
2362             if (c > 0xff)
2363                 nwide++;
2364           }
2365
2366           /* Now rewind strings and write them. */
2367           tmps = origtmps;
2368
2369           if (nwide) {
2370               U8 *result;
2371               U8 *p;
2372
2373               Newx(result, targlen + 1, U8);
2374               p = result;
2375               while (tmps < send) {
2376                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2377                   tmps += l;
2378                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2379               }
2380               *p = '\0';
2381               sv_usepvn_flags(TARG, (char*)result, targlen,
2382                               SV_HAS_TRAILING_NUL);
2383               SvUTF8_on(TARG);
2384           }
2385           else {
2386               U8 *result;
2387               U8 *p;
2388
2389               Newx(result, nchar + 1, U8);
2390               p = result;
2391               while (tmps < send) {
2392                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2393                   tmps += l;
2394                   *p++ = ~c;
2395               }
2396               *p = '\0';
2397               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2398               SvUTF8_off(TARG);
2399           }
2400           SETTARG;
2401           RETURN;
2402         }
2403 #ifdef LIBERAL
2404         {
2405             long *tmpl;
2406             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2407                 *tmps = ~*tmps;
2408             tmpl = (long*)tmps;
2409             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2410                 *tmpl = ~*tmpl;
2411             tmps = (U8*)tmpl;
2412         }
2413 #endif
2414         for ( ; anum > 0; anum--, tmps++)
2415             *tmps = ~*tmps;
2416         SETTARG;
2417       }
2418       RETURN;
2419     }
2420 }
2421
2422 /* integer versions of some of the above */
2423
2424 PP(pp_i_multiply)
2425 {
2426     dSP; dATARGET;
2427     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2428     {
2429       dPOPTOPiirl_nomg;
2430       SETi( left * right );
2431       RETURN;
2432     }
2433 }
2434
2435 PP(pp_i_divide)
2436 {
2437     IV num;
2438     dSP; dATARGET;
2439     tryAMAGICbin_MG(div_amg, AMGf_assign);
2440     {
2441       dPOPTOPssrl;
2442       IV value = SvIV_nomg(right);
2443       if (value == 0)
2444           DIE(aTHX_ "Illegal division by zero");
2445       num = SvIV_nomg(left);
2446
2447       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2448       if (value == -1)
2449           value = - num;
2450       else
2451           value = num / value;
2452       SETi(value);
2453       RETURN;
2454     }
2455 }
2456
2457 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2458 STATIC
2459 PP(pp_i_modulo_0)
2460 #else
2461 PP(pp_i_modulo)
2462 #endif
2463 {
2464      /* This is the vanilla old i_modulo. */
2465      dSP; dATARGET;
2466      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2467      {
2468           dPOPTOPiirl_nomg;
2469           if (!right)
2470                DIE(aTHX_ "Illegal modulus zero");
2471           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2472           if (right == -1)
2473               SETi( 0 );
2474           else
2475               SETi( left % right );
2476           RETURN;
2477      }
2478 }
2479
2480 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2481 STATIC
2482 PP(pp_i_modulo_1)
2483
2484 {
2485      /* This is the i_modulo with the workaround for the _moddi3 bug
2486       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2487       * See below for pp_i_modulo. */
2488      dSP; dATARGET;
2489      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2490      {
2491           dPOPTOPiirl_nomg;
2492           if (!right)
2493                DIE(aTHX_ "Illegal modulus zero");
2494           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2495           if (right == -1)
2496               SETi( 0 );
2497           else
2498               SETi( left % PERL_ABS(right) );
2499           RETURN;
2500      }
2501 }
2502
2503 PP(pp_i_modulo)
2504 {
2505      dVAR; dSP; dATARGET;
2506      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2507      {
2508           dPOPTOPiirl_nomg;
2509           if (!right)
2510                DIE(aTHX_ "Illegal modulus zero");
2511           /* The assumption is to use hereafter the old vanilla version... */
2512           PL_op->op_ppaddr =
2513                PL_ppaddr[OP_I_MODULO] =
2514                    Perl_pp_i_modulo_0;
2515           /* .. but if we have glibc, we might have a buggy _moddi3
2516            * (at least glicb 2.2.5 is known to have this bug), in other
2517            * words our integer modulus with negative quad as the second
2518            * argument might be broken.  Test for this and re-patch the
2519            * opcode dispatch table if that is the case, remembering to
2520            * also apply the workaround so that this first round works
2521            * right, too.  See [perl #9402] for more information. */
2522           {
2523                IV l =   3;
2524                IV r = -10;
2525                /* Cannot do this check with inlined IV constants since
2526                 * that seems to work correctly even with the buggy glibc. */
2527                if (l % r == -3) {
2528                     /* Yikes, we have the bug.
2529                      * Patch in the workaround version. */
2530                     PL_op->op_ppaddr =
2531                          PL_ppaddr[OP_I_MODULO] =
2532                              &Perl_pp_i_modulo_1;
2533                     /* Make certain we work right this time, too. */
2534                     right = PERL_ABS(right);
2535                }
2536           }
2537           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2538           if (right == -1)
2539               SETi( 0 );
2540           else
2541               SETi( left % right );
2542           RETURN;
2543      }
2544 }
2545 #endif
2546
2547 PP(pp_i_add)
2548 {
2549     dSP; dATARGET;
2550     tryAMAGICbin_MG(add_amg, AMGf_assign);
2551     {
2552       dPOPTOPiirl_ul_nomg;
2553       SETi( left + right );
2554       RETURN;
2555     }
2556 }
2557
2558 PP(pp_i_subtract)
2559 {
2560     dSP; dATARGET;
2561     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2562     {
2563       dPOPTOPiirl_ul_nomg;
2564       SETi( left - right );
2565       RETURN;
2566     }
2567 }
2568
2569 PP(pp_i_lt)
2570 {
2571     dSP;
2572     tryAMAGICbin_MG(lt_amg, AMGf_set);
2573     {
2574       dPOPTOPiirl_nomg;
2575       SETs(boolSV(left < right));
2576       RETURN;
2577     }
2578 }
2579
2580 PP(pp_i_gt)
2581 {
2582     dSP;
2583     tryAMAGICbin_MG(gt_amg, AMGf_set);
2584     {
2585       dPOPTOPiirl_nomg;
2586       SETs(boolSV(left > right));
2587       RETURN;
2588     }
2589 }
2590
2591 PP(pp_i_le)
2592 {
2593     dSP;
2594     tryAMAGICbin_MG(le_amg, AMGf_set);
2595     {
2596       dPOPTOPiirl_nomg;
2597       SETs(boolSV(left <= right));
2598       RETURN;
2599     }
2600 }
2601
2602 PP(pp_i_ge)
2603 {
2604     dSP;
2605     tryAMAGICbin_MG(ge_amg, AMGf_set);
2606     {
2607       dPOPTOPiirl_nomg;
2608       SETs(boolSV(left >= right));
2609       RETURN;
2610     }
2611 }
2612
2613 PP(pp_i_eq)
2614 {
2615     dSP;
2616     tryAMAGICbin_MG(eq_amg, AMGf_set);
2617     {
2618       dPOPTOPiirl_nomg;
2619       SETs(boolSV(left == right));
2620       RETURN;
2621     }
2622 }
2623
2624 PP(pp_i_ne)
2625 {
2626     dSP;
2627     tryAMAGICbin_MG(ne_amg, AMGf_set);
2628     {
2629       dPOPTOPiirl_nomg;
2630       SETs(boolSV(left != right));
2631       RETURN;
2632     }
2633 }
2634
2635 PP(pp_i_ncmp)
2636 {
2637     dSP; dTARGET;
2638     tryAMAGICbin_MG(ncmp_amg, 0);
2639     {
2640       dPOPTOPiirl_nomg;
2641       I32 value;
2642
2643       if (left > right)
2644         value = 1;
2645       else if (left < right)
2646         value = -1;
2647       else
2648         value = 0;
2649       SETi(value);
2650       RETURN;
2651     }
2652 }
2653
2654 PP(pp_i_negate)
2655 {
2656     dSP; dTARGET;
2657     tryAMAGICun_MG(neg_amg, 0);
2658     if (S_negate_string(aTHX)) return NORMAL;
2659     {
2660         SV * const sv = TOPs;
2661         IV const i = SvIV_nomg(sv);
2662         SETi(-i);
2663         RETURN;
2664     }
2665 }
2666
2667 /* High falutin' math. */
2668
2669 PP(pp_atan2)
2670 {
2671     dSP; dTARGET;
2672     tryAMAGICbin_MG(atan2_amg, 0);
2673     {
2674       dPOPTOPnnrl_nomg;
2675       SETn(Perl_atan2(left, right));
2676       RETURN;
2677     }
2678 }
2679
2680
2681 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2682
2683 PP(pp_sin)
2684 {
2685     dSP; dTARGET;
2686     int amg_type = fallback_amg;
2687     const char *neg_report = NULL;
2688     const int op_type = PL_op->op_type;
2689
2690     switch (op_type) {
2691     case OP_SIN:  amg_type = sin_amg; break;
2692     case OP_COS:  amg_type = cos_amg; break;
2693     case OP_EXP:  amg_type = exp_amg; break;
2694     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2695     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2696     }
2697
2698     assert(amg_type != fallback_amg);
2699
2700     tryAMAGICun_MG(amg_type, 0);
2701     {
2702       SV * const arg = POPs;
2703       const NV value = SvNV_nomg(arg);
2704       NV result = NV_NAN;
2705       if (neg_report) { /* log or sqrt */
2706           if (
2707 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2708               ! Perl_isnan(value) &&
2709 #endif
2710               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2711               SET_NUMERIC_STANDARD();
2712               /* diag_listed_as: Can't take log of %g */
2713               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2714           }
2715       }
2716       switch (op_type) {
2717       default:
2718       case OP_SIN:  result = Perl_sin(value);  break;
2719       case OP_COS:  result = Perl_cos(value);  break;
2720       case OP_EXP:  result = Perl_exp(value);  break;
2721       case OP_LOG:  result = Perl_log(value);  break;
2722       case OP_SQRT: result = Perl_sqrt(value); break;
2723       }
2724       XPUSHn(result);
2725       RETURN;
2726     }
2727 }
2728
2729 /* Support Configure command-line overrides for rand() functions.
2730    After 5.005, perhaps we should replace this by Configure support
2731    for drand48(), random(), or rand().  For 5.005, though, maintain
2732    compatibility by calling rand() but allow the user to override it.
2733    See INSTALL for details.  --Andy Dougherty  15 July 1998
2734 */
2735 /* Now it's after 5.005, and Configure supports drand48() and random(),
2736    in addition to rand().  So the overrides should not be needed any more.
2737    --Jarkko Hietaniemi  27 September 1998
2738  */
2739
2740 PP(pp_rand)
2741 {
2742     if (!PL_srand_called) {
2743         (void)seedDrand01((Rand_seed_t)seed());
2744         PL_srand_called = TRUE;
2745     }
2746     {
2747         dSP;
2748         NV value;
2749         EXTEND(SP, 1);
2750     
2751         if (MAXARG < 1)
2752             value = 1.0;
2753         else {
2754             SV * const sv = POPs;
2755             if(!sv)
2756                 value = 1.0;
2757             else
2758                 value = SvNV(sv);
2759         }
2760     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2761 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2762         if (! Perl_isnan(value) && value == 0.0)
2763 #else
2764         if (value == 0.0)
2765 #endif
2766             value = 1.0;
2767         {
2768             dTARGET;
2769             PUSHs(TARG);
2770             PUTBACK;
2771             value *= Drand01();
2772             sv_setnv_mg(TARG, value);
2773         }
2774     }
2775     return NORMAL;
2776 }
2777
2778 PP(pp_srand)
2779 {
2780     dSP; dTARGET;
2781     UV anum;
2782
2783     if (MAXARG >= 1 && (TOPs || POPs)) {
2784         SV *top;
2785         char *pv;
2786         STRLEN len;
2787         int flags;
2788
2789         top = POPs;
2790         pv = SvPV(top, len);
2791         flags = grok_number(pv, len, &anum);
2792
2793         if (!(flags & IS_NUMBER_IN_UV)) {
2794             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2795                              "Integer overflow in srand");
2796             anum = UV_MAX;
2797         }
2798     }
2799     else {
2800         anum = seed();
2801     }
2802
2803     (void)seedDrand01((Rand_seed_t)anum);
2804     PL_srand_called = TRUE;
2805     if (anum)
2806         XPUSHu(anum);
2807     else {
2808         /* Historically srand always returned true. We can avoid breaking
2809            that like this:  */
2810         sv_setpvs(TARG, "0 but true");
2811         XPUSHTARG;
2812     }
2813     RETURN;
2814 }
2815
2816 PP(pp_int)
2817 {
2818     dSP; dTARGET;
2819     tryAMAGICun_MG(int_amg, AMGf_numeric);
2820     {
2821       SV * const sv = TOPs;
2822       const IV iv = SvIV_nomg(sv);
2823       /* XXX it's arguable that compiler casting to IV might be subtly
2824          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2825          else preferring IV has introduced a subtle behaviour change bug. OTOH
2826          relying on floating point to be accurate is a bug.  */
2827
2828       if (!SvOK(sv)) {
2829         SETu(0);
2830       }
2831       else if (SvIOK(sv)) {
2832         if (SvIsUV(sv))
2833             SETu(SvUV_nomg(sv));
2834         else
2835             SETi(iv);
2836       }
2837       else {
2838           const NV value = SvNV_nomg(sv);
2839           if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNV(sv))))
2840               SETn(SvNV(sv));
2841           else if (value >= 0.0) {
2842               if (value < (NV)UV_MAX + 0.5) {
2843                   SETu(U_V(value));
2844               } else {
2845                   SETn(Perl_floor(value));
2846               }
2847           }
2848           else {
2849               if (value > (NV)IV_MIN - 0.5) {
2850                   SETi(I_V(value));
2851               } else {
2852                   SETn(Perl_ceil(value));
2853               }
2854           }
2855       }
2856     }
2857     RETURN;
2858 }
2859
2860 PP(pp_abs)
2861 {
2862     dSP; dTARGET;
2863     tryAMAGICun_MG(abs_amg, AMGf_numeric);
2864     {
2865       SV * const sv = TOPs;
2866       /* This will cache the NV value if string isn't actually integer  */
2867       const IV iv = SvIV_nomg(sv);
2868
2869       if (!SvOK(sv)) {
2870         SETu(0);
2871       }
2872       else if (SvIOK(sv)) {
2873         /* IVX is precise  */
2874         if (SvIsUV(sv)) {
2875           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
2876         } else {
2877           if (iv >= 0) {
2878             SETi(iv);
2879           } else {
2880             if (iv != IV_MIN) {
2881               SETi(-iv);
2882             } else {
2883               /* 2s complement assumption. Also, not really needed as
2884                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2885               SETu(IV_MIN);
2886             }
2887           }
2888         }
2889       } else{
2890         const NV value = SvNV_nomg(sv);
2891         if (value < 0.0)
2892           SETn(-value);
2893         else
2894           SETn(value);
2895       }
2896     }
2897     RETURN;
2898 }
2899
2900
2901 /* also used for: pp_hex() */
2902
2903 PP(pp_oct)
2904 {
2905     dSP; dTARGET;
2906     const char *tmps;
2907     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2908     STRLEN len;
2909     NV result_nv;
2910     UV result_uv;
2911     SV* const sv = POPs;
2912
2913     tmps = (SvPV_const(sv, len));
2914     if (DO_UTF8(sv)) {
2915          /* If Unicode, try to downgrade
2916           * If not possible, croak. */
2917          SV* const tsv = sv_2mortal(newSVsv(sv));
2918         
2919          SvUTF8_on(tsv);
2920          sv_utf8_downgrade(tsv, FALSE);
2921          tmps = SvPV_const(tsv, len);
2922     }
2923     if (PL_op->op_type == OP_HEX)
2924         goto hex;
2925
2926     while (*tmps && len && isSPACE(*tmps))
2927         tmps++, len--;
2928     if (*tmps == '0')
2929         tmps++, len--;
2930     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
2931     hex:
2932         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2933     }
2934     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
2935         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2936     else
2937         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2938
2939     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2940         XPUSHn(result_nv);
2941     }
2942     else {
2943         XPUSHu(result_uv);
2944     }
2945     RETURN;
2946 }
2947
2948 /* String stuff. */
2949
2950 PP(pp_length)
2951 {
2952     dSP; dTARGET;
2953     SV * const sv = TOPs;
2954
2955     U32 in_bytes = IN_BYTES;
2956     /* simplest case shortcut */
2957     /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
2958     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
2959     assert(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
2960     SETs(TARG);
2961
2962     if(LIKELY(svflags == SVf_POK))
2963         goto simple_pv;
2964     if(svflags & SVs_GMG)
2965         mg_get(sv);
2966     if (SvOK(sv)) {
2967         if (!IN_BYTES) /* reread to avoid using an C auto/register */
2968             sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
2969         else
2970         {
2971             STRLEN len;
2972             /* unrolled SvPV_nomg_const(sv,len) */
2973             if(SvPOK_nog(sv)){
2974                 simple_pv:
2975                 len = SvCUR(sv);
2976             } else  {
2977                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
2978             }
2979             sv_setiv(TARG, (IV)(len));
2980         }
2981     } else {
2982         if (!SvPADTMP(TARG)) {
2983             sv_setsv_nomg(TARG, &PL_sv_undef);
2984         } else { /* TARG is on stack at this point and is overwriten by SETs.
2985                    This branch is the odd one out, so put TARG by default on
2986                    stack earlier to let local SP go out of liveness sooner */
2987             SETs(&PL_sv_undef);
2988             goto no_set_magic;
2989         }
2990     }
2991     SvSETMAGIC(TARG);
2992     no_set_magic:
2993     return NORMAL; /* no putback, SP didn't move in this opcode */
2994 }
2995
2996 /* Returns false if substring is completely outside original string.
2997    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
2998    always be true for an explicit 0.
2999 */
3000 bool
3001 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3002                                 bool pos1_is_uv, IV len_iv,
3003                                 bool len_is_uv, STRLEN *posp,
3004                                 STRLEN *lenp)
3005 {
3006     IV pos2_iv;
3007     int    pos2_is_uv;
3008
3009     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3010
3011     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3012         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3013         pos1_iv += curlen;
3014     }
3015     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3016         return FALSE;
3017
3018     if (len_iv || len_is_uv) {
3019         if (!len_is_uv && len_iv < 0) {
3020             pos2_iv = curlen + len_iv;
3021             if (curlen)
3022                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3023             else
3024                 pos2_is_uv = 0;
3025         } else {  /* len_iv >= 0 */
3026             if (!pos1_is_uv && pos1_iv < 0) {
3027                 pos2_iv = pos1_iv + len_iv;
3028                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3029             } else {
3030                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3031                     pos2_iv = curlen;
3032                 else
3033                     pos2_iv = pos1_iv+len_iv;
3034                 pos2_is_uv = 1;
3035             }
3036         }
3037     }
3038     else {
3039         pos2_iv = curlen;
3040         pos2_is_uv = 1;
3041     }
3042
3043     if (!pos2_is_uv && pos2_iv < 0) {
3044         if (!pos1_is_uv && pos1_iv < 0)
3045             return FALSE;
3046         pos2_iv = 0;
3047     }
3048     else if (!pos1_is_uv && pos1_iv < 0)
3049         pos1_iv = 0;
3050
3051     if ((UV)pos2_iv < (UV)pos1_iv)
3052         pos2_iv = pos1_iv;
3053     if ((UV)pos2_iv > curlen)
3054         pos2_iv = curlen;
3055
3056     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3057     *posp = (STRLEN)( (UV)pos1_iv );
3058     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3059
3060     return TRUE;
3061 }
3062
3063 PP(pp_substr)
3064 {
3065     dSP; dTARGET;
3066     SV *sv;
3067     STRLEN curlen;
3068     STRLEN utf8_curlen;
3069     SV *   pos_sv;
3070     IV     pos1_iv;
3071     int    pos1_is_uv;
3072     SV *   len_sv;
3073     IV     len_iv = 0;
3074     int    len_is_uv = 0;
3075     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3076     const bool rvalue = (GIMME_V != G_VOID);
3077     const char *tmps;
3078     SV *repl_sv = NULL;
3079     const char *repl = NULL;
3080     STRLEN repl_len;
3081     int num_args = PL_op->op_private & 7;
3082     bool repl_need_utf8_upgrade = FALSE;
3083
3084     if (num_args > 2) {
3085         if (num_args > 3) {
3086           if(!(repl_sv = POPs)) num_args--;
3087         }
3088         if ((len_sv = POPs)) {
3089             len_iv    = SvIV(len_sv);
3090             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3091         }
3092         else num_args--;
3093     }
3094     pos_sv     = POPs;
3095     pos1_iv    = SvIV(pos_sv);
3096     pos1_is_uv = SvIOK_UV(pos_sv);
3097     sv = POPs;
3098     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3099         assert(!repl_sv);
3100         repl_sv = POPs;
3101     }
3102     PUTBACK;
3103     if (lvalue && !repl_sv) {
3104         SV * ret;
3105         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3106         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3107         LvTYPE(ret) = 'x';
3108         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3109         LvTARGOFF(ret) =
3110             pos1_is_uv || pos1_iv >= 0
3111                 ? (STRLEN)(UV)pos1_iv
3112                 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3113         LvTARGLEN(ret) =
3114             len_is_uv || len_iv > 0
3115                 ? (STRLEN)(UV)len_iv
3116                 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3117
3118         SPAGAIN;
3119         PUSHs(ret);    /* avoid SvSETMAGIC here */
3120         RETURN;
3121     }
3122     if (repl_sv) {
3123         repl = SvPV_const(repl_sv, repl_len);
3124         SvGETMAGIC(sv);
3125         if (SvROK(sv))
3126             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3127                             "Attempt to use reference as lvalue in substr"
3128             );
3129         tmps = SvPV_force_nomg(sv, curlen);
3130         if (DO_UTF8(repl_sv) && repl_len) {
3131             if (!DO_UTF8(sv)) {
3132                 sv_utf8_upgrade_nomg(sv);
3133                 curlen = SvCUR(sv);
3134             }
3135         }
3136         else if (DO_UTF8(sv))
3137             repl_need_utf8_upgrade = TRUE;
3138     }
3139     else tmps = SvPV_const(sv, curlen);
3140     if (DO_UTF8(sv)) {
3141         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3142         if (utf8_curlen == curlen)
3143             utf8_curlen = 0;
3144         else
3145             curlen = utf8_curlen;
3146     }
3147     else
3148         utf8_curlen = 0;
3149
3150     {
3151         STRLEN pos, len, byte_len, byte_pos;
3152
3153         if (!translate_substr_offsets(
3154                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3155         )) goto bound_fail;
3156
3157         byte_len = len;
3158         byte_pos = utf8_curlen
3159             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3160
3161         tmps += byte_pos;
3162
3163         if (rvalue) {
3164             SvTAINTED_off(TARG);                        /* decontaminate */
3165             SvUTF8_off(TARG);                   /* decontaminate */
3166             sv_setpvn(TARG, tmps, byte_len);
3167 #ifdef USE_LOCALE_COLLATE
3168             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3169 #endif
3170             if (utf8_curlen)
3171                 SvUTF8_on(TARG);
3172         }
3173
3174         if (repl) {
3175             SV* repl_sv_copy = NULL;
3176
3177             if (repl_need_utf8_upgrade) {
3178                 repl_sv_copy = newSVsv(repl_sv);
3179                 sv_utf8_upgrade(repl_sv_copy);
3180                 repl = SvPV_const(repl_sv_copy, repl_len);
3181             }
3182             if (!SvOK(sv))
3183                 sv_setpvs(sv, "");
3184             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3185             SvREFCNT_dec(repl_sv_copy);
3186         }
3187     }
3188     SPAGAIN;
3189     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3190         SP++;
3191     else if (rvalue) {
3192         SvSETMAGIC(TARG);
3193         PUSHs(TARG);
3194     }
3195     RETURN;
3196
3197 bound_fail:
3198     if (repl)
3199         Perl_croak(aTHX_ "substr outside of string");
3200     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3201     RETPUSHUNDEF;
3202 }
3203
3204 PP(pp_vec)
3205 {
3206     dSP;
3207     const IV size   = POPi;
3208     const IV offset = POPi;
3209     SV * const src = POPs;
3210     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3211     SV * ret;
3212
3213     if (lvalue) {                       /* it's an lvalue! */
3214         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3215         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3216         LvTYPE(ret) = 'v';
3217         LvTARG(ret) = SvREFCNT_inc_simple(src);
3218         LvTARGOFF(ret) = offset;
3219         LvTARGLEN(ret) = size;
3220     }
3221     else {
3222         dTARGET;
3223         SvTAINTED_off(TARG);            /* decontaminate */
3224         ret = TARG;
3225     }
3226
3227     sv_setuv(ret, do_vecget(src, offset, size));
3228     if (!lvalue)
3229         SvSETMAGIC(ret);
3230     PUSHs(ret);
3231     RETURN;
3232 }
3233
3234
3235 /* also used for: pp_rindex() */
3236
3237 PP(pp_index)
3238 {
3239     dSP; dTARGET;
3240     SV *big;
3241     SV *little;
3242     SV *temp = NULL;
3243     STRLEN biglen;
3244     STRLEN llen = 0;
3245     SSize_t offset = 0;
3246     SSize_t retval;
3247     const char *big_p;
3248     const char *little_p;
3249     bool big_utf8;
3250     bool little_utf8;
3251     const bool is_index = PL_op->op_type == OP_INDEX;
3252     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3253
3254     if (threeargs)
3255         offset = POPi;
3256     little = POPs;
3257     big = POPs;
3258     big_p = SvPV_const(big, biglen);
3259     little_p = SvPV_const(little, llen);
3260
3261     big_utf8 = DO_UTF8(big);
3262     little_utf8 = DO_UTF8(little);
3263     if (big_utf8 ^ little_utf8) {
3264         /* One needs to be upgraded.  */
3265         if (little_utf8 && !IN_ENCODING) {
3266             /* Well, maybe instead we might be able to downgrade the small
3267                string?  */
3268             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3269                                                      &little_utf8);
3270             if (little_utf8) {
3271                 /* If the large string is ISO-8859-1, and it's not possible to
3272                    convert the small string to ISO-8859-1, then there is no
3273                    way that it could be found anywhere by index.  */
3274                 retval = -1;
3275                 goto fail;
3276             }
3277
3278             /* At this point, pv is a malloc()ed string. So donate it to temp
3279                to ensure it will get free()d  */
3280             little = temp = newSV(0);
3281             sv_usepvn(temp, pv, llen);
3282             little_p = SvPVX(little);
3283         } else {
3284             temp = little_utf8
3285                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3286
3287             if (IN_ENCODING) {
3288                 sv_recode_to_utf8(temp, _get_encoding());
3289             } else {
3290                 sv_utf8_upgrade(temp);
3291             }
3292             if (little_utf8) {
3293                 big = temp;
3294                 big_utf8 = TRUE;
3295                 big_p = SvPV_const(big, biglen);
3296             } else {
3297                 little = temp;
3298                 little_p = SvPV_const(little, llen);
3299             }
3300         }
3301     }
3302     if (SvGAMAGIC(big)) {
3303         /* Life just becomes a lot easier if I use a temporary here.
3304            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3305            will trigger magic and overloading again, as will fbm_instr()
3306         */
3307         big = newSVpvn_flags(big_p, biglen,
3308                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3309         big_p = SvPVX(big);
3310     }
3311     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3312         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3313            warn on undef, and we've already triggered a warning with the
3314            SvPV_const some lines above. We can't remove that, as we need to
3315            call some SvPV to trigger overloading early and find out if the
3316            string is UTF-8.
3317            This is all getting to messy. The API isn't quite clean enough,
3318            because data access has side effects.
3319         */
3320         little = newSVpvn_flags(little_p, llen,
3321                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3322         little_p = SvPVX(little);
3323     }
3324
3325     if (!threeargs)
3326         offset = is_index ? 0 : biglen;
3327     else {
3328         if (big_utf8 && offset > 0)
3329             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3330         if (!is_index)
3331             offset += llen;
3332     }
3333     if (offset < 0)
3334         offset = 0;
3335     else if (offset > (SSize_t)biglen)
3336         offset = biglen;
3337     if (!(little_p = is_index
3338           ? fbm_instr((unsigned char*)big_p + offset,
3339                       (unsigned char*)big_p + biglen, little, 0)
3340           : rninstr(big_p,  big_p  + offset,
3341                     little_p, little_p + llen)))
3342         retval = -1;
3343     else {
3344         retval = little_p - big_p;
3345         if (retval > 0 && big_utf8)
3346             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3347     }
3348     SvREFCNT_dec(temp);
3349  fail:
3350     PUSHi(retval);
3351     RETURN;
3352 }
3353
3354 PP(pp_sprintf)
3355 {
3356     dSP; dMARK; dORIGMARK; dTARGET;
3357     SvTAINTED_off(TARG);
3358     do_sprintf(TARG, SP-MARK, MARK+1);
3359     TAINT_IF(SvTAINTED(TARG));
3360     SP = ORIGMARK;
3361     PUSHTARG;
3362     RETURN;
3363 }
3364
3365 PP(pp_ord)
3366 {
3367     dSP; dTARGET;
3368
3369     SV *argsv = POPs;
3370     STRLEN len;
3371     const U8 *s = (U8*)SvPV_const(argsv, len);
3372
3373     if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
3374         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3375         s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
3376         len = UTF8SKIP(s);  /* Should be well-formed; so this is its length */
3377         argsv = tmpsv;
3378     }
3379
3380     XPUSHu(DO_UTF8(argsv)
3381            ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3382            : (UV)(*s));
3383
3384     RETURN;
3385 }
3386
3387 PP(pp_chr)
3388 {
3389     dSP; dTARGET;
3390     char *tmps;
3391     UV value;
3392     SV *top = POPs;
3393
3394     SvGETMAGIC(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     I32 is_something_there = FALSE;
4977     const U8 mod = PL_op->op_flags & OPf_MOD;
4978
4979     const I32 max = lastrelem - lastlelem;
4980     SV **lelem;
4981
4982     if (GIMME != G_ARRAY) {
4983         I32 ix = SvIV(*lastlelem);
4984         if (ix < 0)
4985             ix += max;
4986         if (ix < 0 || ix >= max)
4987             *firstlelem = &PL_sv_undef;
4988         else
4989             *firstlelem = firstrelem[ix];
4990         SP = firstlelem;
4991         RETURN;
4992     }
4993
4994     if (max == 0) {
4995         SP = firstlelem - 1;
4996         RETURN;
4997     }
4998
4999     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5000         I32 ix = SvIV(*lelem);
5001         if (ix < 0)
5002             ix += max;
5003         if (ix < 0 || ix >= max)
5004             *lelem = &PL_sv_undef;
5005         else {
5006             is_something_there = TRUE;
5007             if (!(*lelem = firstrelem[ix]))
5008                 *lelem = &PL_sv_undef;
5009             else if (mod && SvPADTMP(*lelem)) {
5010                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5011             }
5012         }
5013     }
5014     if (is_something_there)
5015         SP = lastlelem;
5016     else
5017         SP = firstlelem - 1;
5018     RETURN;
5019 }
5020
5021 PP(pp_anonlist)
5022 {
5023     dSP; dMARK;
5024     const I32 items = SP - MARK;
5025     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5026     SP = MARK;
5027     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5028             ? newRV_noinc(av) : av);
5029     RETURN;
5030 }
5031
5032 PP(pp_anonhash)
5033 {
5034     dSP; dMARK; dORIGMARK;
5035     HV* const hv = newHV();
5036     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5037                                     ? newRV_noinc(MUTABLE_SV(hv))
5038                                     : MUTABLE_SV(hv) );
5039
5040     while (MARK < SP) {
5041         SV * const key =
5042             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5043         SV *val;
5044         if (MARK < SP)
5045         {
5046             MARK++;
5047             SvGETMAGIC(*MARK);
5048             val = newSV(0);
5049             sv_setsv(val, *MARK);
5050         }
5051         else
5052         {
5053             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5054             val = newSV(0);
5055         }
5056         (void)hv_store_ent(hv,key,val,0);
5057     }
5058     SP = ORIGMARK;
5059     XPUSHs(retval);
5060     RETURN;
5061 }
5062
5063 static AV *
5064 S_deref_plain_array(pTHX_ AV *ary)
5065 {
5066     if (SvTYPE(ary) == SVt_PVAV) return ary;
5067     SvGETMAGIC((SV *)ary);
5068     if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5069         Perl_die(aTHX_ "Not an ARRAY reference");
5070     else if (SvOBJECT(SvRV(ary)))
5071         Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5072     return (AV *)SvRV(ary);
5073 }
5074
5075 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5076 # define DEREF_PLAIN_ARRAY(ary)       \
5077    ({                                  \
5078      AV *aRrRay = ary;                  \
5079      SvTYPE(aRrRay) == SVt_PVAV          \
5080       ? aRrRay                            \
5081       : S_deref_plain_array(aTHX_ aRrRay); \
5082    })
5083 #else
5084 # define DEREF_PLAIN_ARRAY(ary)            \
5085    (                                        \
5086      PL_Sv = (SV *)(ary),                    \
5087      SvTYPE(PL_Sv) == SVt_PVAV                \
5088       ? (AV *)PL_Sv                            \
5089       : S_deref_plain_array(aTHX_ (AV *)PL_Sv)  \
5090    )
5091 #endif
5092
5093 PP(pp_splice)
5094 {
5095     dSP; dMARK; dORIGMARK;
5096     int num_args = (SP - MARK);
5097     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5098     SV **src;
5099     SV **dst;
5100     SSize_t i;
5101     SSize_t offset;
5102     SSize_t length;
5103     SSize_t newlen;
5104     SSize_t after;
5105     SSize_t diff;
5106     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5107
5108     if (mg) {
5109         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5110                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5111                                     sp - mark);
5112     }
5113
5114     SP++;
5115
5116     if (++MARK < SP) {
5117         offset = i = SvIV(*MARK);
5118         if (offset < 0)
5119             offset += AvFILLp(ary) + 1;
5120         if (offset < 0)
5121             DIE(aTHX_ PL_no_aelem, i);
5122         if (++MARK < SP) {
5123             length = SvIVx(*MARK++);
5124             if (length < 0) {
5125                 length += AvFILLp(ary) - offset + 1;
5126                 if (length < 0)
5127                     length = 0;
5128             }
5129         }
5130         else
5131             length = AvMAX(ary) + 1;            /* close enough to infinity */
5132     }
5133     else {
5134         offset = 0;
5135         length = AvMAX(ary) + 1;
5136     }
5137     if (offset > AvFILLp(ary) + 1) {
5138         if (num_args > 2)
5139             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5140         offset = AvFILLp(ary) + 1;
5141     }
5142     after = AvFILLp(ary) + 1 - (offset + length);
5143     if (after < 0) {                            /* not that much array */
5144         length += after;                        /* offset+length now in array */
5145         after = 0;
5146         if (!AvALLOC(ary))
5147             av_extend(ary, 0);
5148     }
5149
5150     /* At this point, MARK .. SP-1 is our new LIST */
5151
5152     newlen = SP - MARK;
5153     diff = newlen - length;
5154     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5155         av_reify(ary);
5156
5157     /* make new elements SVs now: avoid problems if they're from the array */
5158     for (dst = MARK, i = newlen; i; i--) {
5159         SV * const h = *dst;
5160         *dst++ = newSVsv(h);
5161     }
5162
5163     if (diff < 0) {                             /* shrinking the area */
5164         SV **tmparyval = NULL;
5165         if (newlen) {
5166             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5167             Copy(MARK, tmparyval, newlen, SV*);
5168         }
5169
5170         MARK = ORIGMARK + 1;
5171         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5172             const bool real = cBOOL(AvREAL(ary));
5173             MEXTEND(MARK, length);
5174             if (real)
5175                 EXTEND_MORTAL(length);
5176             for (i = 0, dst = MARK; i < length; i++) {
5177                 if ((*dst = AvARRAY(ary)[i+offset])) {
5178                   if (real)
5179                     sv_2mortal(*dst);   /* free them eventually */
5180                 }
5181                 else
5182                     *dst = &PL_sv_undef;
5183                 dst++;
5184             }
5185             MARK += length - 1;
5186         }
5187         else {
5188             *MARK = AvARRAY(ary)[offset+length-1];
5189             if (AvREAL(ary)) {
5190                 sv_2mortal(*MARK);
5191                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5192                     SvREFCNT_dec(*dst++);       /* free them now */
5193             }
5194         }
5195         AvFILLp(ary) += diff;
5196
5197         /* pull up or down? */
5198
5199         if (offset < after) {                   /* easier to pull up */
5200             if (offset) {                       /* esp. if nothing to pull */
5201                 src = &AvARRAY(ary)[offset-1];
5202                 dst = src - diff;               /* diff is negative */
5203                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5204                     *dst-- = *src--;
5205             }
5206             dst = AvARRAY(ary);
5207             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5208             AvMAX(ary) += diff;
5209         }
5210         else {
5211             if (after) {                        /* anything to pull down? */
5212                 src = AvARRAY(ary) + offset + length;
5213                 dst = src + diff;               /* diff is negative */
5214                 Move(src, dst, after, SV*);
5215             }
5216             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5217                                                 /* avoid later double free */
5218         }
5219         i = -diff;
5220         while (i)
5221             dst[--i] = NULL;
5222         
5223         if (newlen) {
5224             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5225             Safefree(tmparyval);
5226         }
5227     }
5228     else {                                      /* no, expanding (or same) */
5229         SV** tmparyval = NULL;
5230         if (length) {
5231             Newx(tmparyval, length, SV*);       /* so remember deletion */
5232             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5233         }
5234
5235         if (diff > 0) {                         /* expanding */
5236             /* push up or down? */
5237             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5238                 if (offset) {
5239                     src = AvARRAY(ary);
5240                     dst = src - diff;
5241                     Move(src, dst, offset, SV*);
5242                 }
5243                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5244                 AvMAX(ary) += diff;
5245                 AvFILLp(ary) += diff;
5246             }
5247             else {
5248                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5249                     av_extend(ary, AvFILLp(ary) + diff);
5250                 AvFILLp(ary) += diff;
5251
5252                 if (after) {
5253                     dst = AvARRAY(ary) + AvFILLp(ary);
5254                     src = dst - diff;
5255                     for (i = after; i; i--) {
5256                         *dst-- = *src--;
5257                     }
5258                 }
5259             }
5260         }
5261
5262         if (newlen) {
5263             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5264         }
5265
5266         MARK = ORIGMARK + 1;
5267         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5268             if (length) {
5269                 const bool real = cBOOL(AvREAL(ary));
5270                 if (real)
5271                     EXTEND_MORTAL(length);
5272                 for (i = 0, dst = MARK; i < length; i++) {
5273                     if ((*dst = tmparyval[i])) {
5274                       if (real)
5275                         sv_2mortal(*dst);       /* free them eventually */
5276                     }
5277                     else *dst = &PL_sv_undef;
5278                     dst++;
5279                 }
5280             }
5281             MARK += length - 1;
5282         }
5283         else if (length--) {
5284             *MARK = tmparyval[length];
5285             if (AvREAL(ary)) {
5286                 sv_2mortal(*MARK);
5287                 while (length-- > 0)
5288                     SvREFCNT_dec(tmparyval[length]);
5289             }
5290         }
5291         else
5292             *MARK = &PL_sv_undef;
5293         Safefree(tmparyval);
5294     }
5295
5296     if (SvMAGICAL(ary))
5297         mg_set(MUTABLE_SV(ary));
5298
5299     SP = MARK;
5300     RETURN;
5301 }
5302
5303 PP(pp_push)
5304 {
5305     dSP; dMARK; dORIGMARK; dTARGET;
5306     AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5307     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5308
5309     if (mg) {
5310         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5311         PUSHMARK(MARK);
5312         PUTBACK;
5313         ENTER_with_name("call_PUSH");
5314         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5315         LEAVE_with_name("call_PUSH");
5316         SPAGAIN;
5317     }
5318     else {
5319         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5320         PL_delaymagic = DM_DELAY;
5321         for (++MARK; MARK <= SP; MARK++) {
5322             SV *sv;
5323             if (*MARK) SvGETMAGIC(*MARK);
5324             sv = newSV(0);
5325             if (*MARK)
5326                 sv_setsv_nomg(sv, *MARK);
5327             av_store(ary, AvFILLp(ary)+1, sv);
5328         }
5329         if (PL_delaymagic & DM_ARRAY_ISA)
5330             mg_set(MUTABLE_SV(ary));
5331
5332         PL_delaymagic = 0;
5333     }
5334     SP = ORIGMARK;
5335     if (OP_GIMME(PL_op, 0) != G_VOID) {
5336         PUSHi( AvFILL(ary) + 1 );
5337     }
5338     RETURN;
5339 }
5340
5341 /* also used for: pp_pop()*/
5342 PP(pp_shift)
5343 {
5344     dSP;
5345     AV * const av = PL_op->op_flags & OPf_SPECIAL
5346         ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5347     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5348     EXTEND(SP, 1);
5349     assert (sv);
5350     if (AvREAL(av))
5351         (void)sv_2mortal(sv);
5352     PUSHs(sv);
5353     RETURN;
5354 }
5355
5356 PP(pp_unshift)
5357 {
5358     dSP; dMARK; dORIGMARK; dTARGET;
5359     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5360     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5361
5362     if (mg) {
5363         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5364         PUSHMARK(MARK);
5365         PUTBACK;
5366         ENTER_with_name("call_UNSHIFT");
5367         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5368         LEAVE_with_name("call_UNSHIFT");
5369         SPAGAIN;
5370     }
5371     else {
5372         SSize_t i = 0;
5373         av_unshift(ary, SP - MARK);
5374         while (MARK < SP) {
5375             SV * const sv = newSVsv(*++MARK);
5376             (void)av_store(ary, i++, sv);
5377         }
5378     }
5379     SP = ORIGMARK;
5380     if (OP_GIMME(PL_op, 0) != G_VOID) {
5381         PUSHi( AvFILL(ary) + 1 );
5382     }
5383     RETURN;
5384 }
5385
5386 PP(pp_reverse)
5387 {
5388     dSP; dMARK;
5389
5390     if (GIMME == G_ARRAY) {
5391         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5392             AV *av;
5393
5394             /* See pp_sort() */
5395             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5396             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5397             av = MUTABLE_AV((*SP));
5398             /* In-place reversing only happens in void context for the array
5399              * assignment. We don't need to push anything on the stack. */
5400             SP = MARK;
5401
5402             if (SvMAGICAL(av)) {
5403                 SSize_t i, j;
5404                 SV *tmp = sv_newmortal();
5405                 /* For SvCANEXISTDELETE */
5406                 HV *stash;
5407                 const MAGIC *mg;
5408                 bool can_preserve = SvCANEXISTDELETE(av);
5409
5410                 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5411                     SV *begin, *end;
5412
5413                     if (can_preserve) {
5414                         if (!av_exists(av, i)) {
5415                             if (av_exists(av, j)) {
5416                                 SV *sv = av_delete(av, j, 0);
5417                                 begin = *av_fetch(av, i, TRUE);
5418                                 sv_setsv_mg(begin, sv);
5419                             }
5420                             continue;
5421                         }
5422                         else if (!av_exists(av, j)) {
5423                             SV *sv = av_delete(av, i, 0);
5424                             end = *av_fetch(av, j, TRUE);
5425                             sv_setsv_mg(end, sv);
5426                             continue;
5427                         }
5428                     }
5429
5430                     begin = *av_fetch(av, i, TRUE);
5431                     end   = *av_fetch(av, j, TRUE);
5432                     sv_setsv(tmp,      begin);
5433                     sv_setsv_mg(begin, end);
5434                     sv_setsv_mg(end,   tmp);
5435                 }
5436             }
5437             else {
5438                 SV **begin = AvARRAY(av);
5439
5440                 if (begin) {
5441                     SV **end   = begin + AvFILLp(av);
5442
5443                     while (begin < end) {
5444                         SV * const tmp = *begin;
5445                         *begin++ = *end;
5446                         *end--   = tmp;
5447                     }
5448                 }
5449             }
5450         }
5451         else {
5452             SV **oldsp = SP;
5453             MARK++;
5454             while (MARK < SP) {
5455                 SV * const tmp = *MARK;
5456                 *MARK++ = *SP;
5457                 *SP--   = tmp;
5458             }
5459             /* safe as long as stack cannot get extended in the above */
5460             SP = oldsp;
5461         }
5462     }
5463     else {
5464         char *up;
5465         char *down;
5466         I32 tmp;
5467         dTARGET;
5468         STRLEN len;
5469
5470         SvUTF8_off(TARG);                               /* decontaminate */
5471         if (SP - MARK > 1)
5472             do_join(TARG, &PL_sv_no, MARK, SP);
5473         else {
5474             sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5475         }
5476
5477         up = SvPV_force(TARG, len);
5478         if (len > 1) {
5479             if (DO_UTF8(TARG)) {        /* first reverse each character */
5480                 U8* s = (U8*)SvPVX(TARG);
5481                 const U8* send = (U8*)(s + len);
5482                 while (s < send) {
5483                     if (UTF8_IS_INVARIANT(*s)) {
5484                         s++;
5485                         continue;
5486                     }
5487                     else {
5488                         if (!utf8_to_uvchr_buf(s, send, 0))
5489                             break;
5490                         up = (char*)s;
5491                         s += UTF8SKIP(s);
5492                         down = (char*)(s - 1);
5493                         /* reverse this character */
5494                         while (down > up) {
5495                             tmp = *up;
5496                             *up++ = *down;
5497                             *down-- = (char)tmp;
5498                         }
5499                     }
5500                 }
5501                 up = SvPVX(TARG);
5502             }
5503             down = SvPVX(TARG) + len - 1;
5504             while (down > up) {
5505                 tmp = *up;
5506                 *up++ = *down;
5507                 *down-- = (char)tmp;
5508             }
5509             (void)SvPOK_only_UTF8(TARG);
5510         }
5511         SP = MARK + 1;
5512         SETTARG;
5513     }
5514     RETURN;
5515 }
5516
5517 PP(pp_split)
5518 {
5519     dSP; dTARG;
5520     AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
5521     IV limit = POPi;                    /* note, negative is forever */
5522     SV * const sv = POPs;
5523     STRLEN len;
5524     const char *s = SvPV_const(sv, len);
5525     const bool do_utf8 = DO_UTF8(sv);
5526     const char *strend = s + len;
5527     PMOP *pm;
5528     REGEXP *rx;
5529     SV *dstr;
5530     const char *m;
5531     SSize_t iters = 0;
5532     const STRLEN slen = do_utf8
5533                         ? utf8_length((U8*)s, (U8*)strend)
5534                         : (STRLEN)(strend - s);
5535     SSize_t maxiters = slen + 10;
5536     I32 trailing_empty = 0;
5537     const char *orig;
5538     const I32 origlimit = limit;
5539     I32 realarray = 0;
5540     I32 base;
5541     const I32 gimme = GIMME_V;
5542     bool gimme_scalar;
5543     const I32 oldsave = PL_savestack_ix;
5544     U32 make_mortal = SVs_TEMP;
5545     bool multiline = 0;
5546     MAGIC *mg = NULL;
5547
5548 #ifdef DEBUGGING
5549     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5550 #else
5551     pm = (PMOP*)POPs;
5552 #endif
5553     if (!pm)
5554         DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5555     rx = PM_GETRE(pm);
5556
5557     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5558              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5559
5560 #ifdef USE_ITHREADS
5561     if (pm->op_pmreplrootu.op_pmtargetoff) {
5562         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5563     }
5564 #else
5565     if (pm->op_pmreplrootu.op_pmtargetgv) {
5566         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5567     }
5568 #endif
5569     else if (pm->op_targ)
5570         ary = (AV *)PAD_SVl(pm->op_targ);
5571     if (ary) {
5572         realarray = 1;
5573         PUTBACK;
5574         av_extend(ary,0);
5575         (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5576         av_clear(ary);
5577         SPAGAIN;
5578         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5579             PUSHMARK(SP);
5580             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5581         }
5582         else {
5583             if (!AvREAL(ary)) {
5584                 I32 i;
5585                 AvREAL_on(ary);
5586                 AvREIFY_off(ary);
5587                 for (i = AvFILLp(ary); i >= 0; i--)
5588                     AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5589             }
5590             /* temporarily switch stacks */
5591             SAVESWITCHSTACK(PL_curstack, ary);
5592             make_mortal = 0;
5593         }
5594     }
5595     base = SP - PL_stack_base;
5596     orig = s;
5597     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5598         if (do_utf8) {
5599             while (isSPACE_utf8(s))
5600                 s += UTF8SKIP(s);
5601         }
5602         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5603             while (isSPACE_LC(*s))
5604                 s++;
5605         }
5606         else {
5607             while (isSPACE(*s))
5608                 s++;
5609         }
5610     }
5611     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5612         multiline = 1;
5613     }
5614
5615     gimme_scalar = gimme == G_SCALAR && !ary;
5616
5617     if (!limit)
5618         limit = maxiters + 2;
5619     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5620         while (--limit) {
5621             m = s;
5622             /* this one uses 'm' and is a negative test */
5623             if (do_utf8) {
5624                 while (m < strend && ! isSPACE_utf8(m) ) {
5625                     const int t = UTF8SKIP(m);
5626                     /* isSPACE_utf8 returns FALSE for malform utf8 */
5627                     if (strend - m < t)
5628                         m = strend;
5629                     else
5630                         m += t;
5631                 }
5632             }
5633             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5634             {
5635                 while (m < strend && !isSPACE_LC(*m))
5636                     ++m;
5637             } else {
5638                 while (m < strend && !isSPACE(*m))
5639                     ++m;
5640             }  
5641             if (m >= strend)
5642                 break;
5643
5644             if (gimme_scalar) {
5645                 iters++;
5646                 if (m-s == 0)
5647                     trailing_empty++;
5648                 else
5649                     trailing_empty = 0;
5650             } else {
5651                 dstr = newSVpvn_flags(s, m-s,
5652                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5653                 XPUSHs(dstr);
5654             }
5655
5656             /* skip the whitespace found last */
5657             if (do_utf8)
5658                 s = m + UTF8SKIP(m);
5659             else
5660                 s = m + 1;
5661
5662             /* this one uses 's' and is a positive test */
5663             if (do_utf8) {
5664                 while (s < strend && isSPACE_utf8(s) )
5665                     s +=  UTF8SKIP(s);
5666             }
5667             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5668             {
5669                 while (s < strend && isSPACE_LC(*s))
5670                     ++s;
5671             } else {
5672                 while (s < strend && isSPACE(*s))
5673                     ++s;
5674             }       
5675         }
5676     }
5677     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5678         while (--limit) {
5679             for (m = s; m < strend && *m != '\n'; m++)
5680                 ;
5681             m++;
5682             if (m >= strend)
5683                 break;
5684
5685             if (gimme_scalar) {
5686                 iters++;
5687                 if (m-s == 0)
5688                     trailing_empty++;
5689                 else
5690                     trailing_empty = 0;
5691             } else {
5692                 dstr = newSVpvn_flags(s, m-s,
5693                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5694                 XPUSHs(dstr);
5695             }
5696             s = m;
5697         }
5698     }
5699     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5700         /*
5701           Pre-extend the stack, either the number of bytes or
5702           characters in the string or a limited amount, triggered by:
5703
5704           my ($x, $y) = split //, $str;
5705             or
5706           split //, $str, $i;
5707         */
5708         if (!gimme_scalar) {
5709             const U32 items = limit - 1;
5710             if (items < slen)
5711                 EXTEND(SP, items);
5712             else
5713                 EXTEND(SP, slen);
5714         }
5715
5716         if (do_utf8) {
5717             while (--limit) {
5718                 /* keep track of how many bytes we skip over */
5719                 m = s;
5720                 s += UTF8SKIP(s);
5721                 if (gimme_scalar) {
5722                     iters++;
5723                     if (s-m == 0)
5724                         trailing_empty++;
5725                     else
5726                         trailing_empty = 0;
5727                 } else {
5728                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5729
5730                     PUSHs(dstr);
5731                 }
5732
5733                 if (s >= strend)
5734                     break;
5735             }
5736         } else {
5737             while (--limit) {
5738                 if (gimme_scalar) {
5739                     iters++;
5740                 } else {
5741                     dstr = newSVpvn(s, 1);
5742
5743
5744                     if (make_mortal)
5745                         sv_2mortal(dstr);
5746
5747                     PUSHs(dstr);
5748                 }
5749
5750                 s++;
5751
5752                 if (s >= strend)
5753                     break;
5754             }
5755         }
5756     }
5757     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5758              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5759              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5760              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5761         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5762         SV * const csv = CALLREG_INTUIT_STRING(rx);
5763
5764         len = RX_MINLENRET(rx);
5765         if (len == 1 && !RX_UTF8(rx) && !tail) {
5766             const char c = *SvPV_nolen_const(csv);
5767             while (--limit) {
5768                 for (m = s; m < strend && *m != c; m++)
5769                     ;
5770                 if (m >= strend)
5771                     break;
5772                 if (gimme_scalar) {
5773                     iters++;
5774                     if (m-s == 0)
5775                         trailing_empty++;
5776                     else
5777                         trailing_empty = 0;
5778                 } else {
5779                     dstr = newSVpvn_flags(s, m-s,
5780                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5781                     XPUSHs(dstr);
5782                 }
5783                 /* The rx->minlen is in characters but we want to step
5784                  * s ahead by bytes. */
5785                 if (do_utf8)
5786                     s = (char*)utf8_hop((U8*)m, len);
5787                 else
5788                     s = m + len; /* Fake \n at the end */
5789             }
5790         }
5791         else {
5792             while (s < strend && --limit &&
5793               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5794                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5795             {
5796                 if (gimme_scalar) {
5797                     iters++;
5798                     if (m-s == 0)
5799                         trailing_empty++;
5800                     else
5801                         trailing_empty = 0;
5802                 } else {
5803                     dstr = newSVpvn_flags(s, m-s,
5804                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5805                     XPUSHs(dstr);
5806                 }
5807                 /* The rx->minlen is in characters but we want to step
5808                  * s ahead by bytes. */
5809                 if (do_utf8)
5810                     s = (char*)utf8_hop((U8*)m, len);
5811                 else
5812                     s = m + len; /* Fake \n at the end */
5813             }
5814         }
5815     }
5816     else {
5817         maxiters += slen * RX_NPARENS(rx);
5818         while (s < strend && --limit)
5819         {
5820             I32 rex_return;
5821             PUTBACK;
5822             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5823                                      sv, NULL, 0);
5824             SPAGAIN;
5825             if (rex_return == 0)
5826                 break;
5827             TAINT_IF(RX_MATCH_TAINTED(rx));
5828             /* we never pass the REXEC_COPY_STR flag, so it should
5829              * never get copied */
5830             assert(!RX_MATCH_COPIED(rx));
5831             m = RX_OFFS(rx)[0].start + orig;
5832
5833             if (gimme_scalar) {
5834                 iters++;
5835                 if (m-s == 0)
5836                     trailing_empty++;
5837                 else
5838                     trailing_empty = 0;
5839             } else {
5840                 dstr = newSVpvn_flags(s, m-s,
5841                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5842                 XPUSHs(dstr);
5843             }
5844             if (RX_NPARENS(rx)) {
5845                 I32 i;
5846                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5847                     s = RX_OFFS(rx)[i].start + orig;
5848                     m = RX_OFFS(rx)[i].end + orig;
5849
5850                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
5851                        parens that didn't match -- they should be set to
5852                        undef, not the empty string */
5853                     if (gimme_scalar) {
5854                         iters++;
5855                         if (m-s == 0)
5856                             trailing_empty++;
5857                         else
5858                             trailing_empty = 0;
5859                     } else {
5860                         if (m >= orig && s >= orig) {
5861                             dstr = newSVpvn_flags(s, m-s,
5862                                                  (do_utf8 ? SVf_UTF8 : 0)
5863                                                   | make_mortal);
5864                         }
5865                         else
5866                             dstr = &PL_sv_undef;  /* undef, not "" */
5867                         XPUSHs(dstr);
5868                     }
5869
5870                 }
5871             }
5872             s = RX_OFFS(rx)[0].end + orig;
5873         }
5874     }
5875
5876     if (!gimme_scalar) {
5877         iters = (SP - PL_stack_base) - base;
5878     }
5879     if (iters > maxiters)
5880         DIE(aTHX_ "Split loop");
5881
5882     /* keep field after final delim? */
5883     if (s < strend || (iters && origlimit)) {
5884         if (!gimme_scalar) {
5885             const STRLEN l = strend - s;
5886             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5887             XPUSHs(dstr);
5888         }
5889         iters++;
5890     }
5891     else if (!origlimit) {
5892         if (gimme_scalar) {
5893             iters -= trailing_empty;
5894         } else {
5895             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5896                 if (TOPs && !make_mortal)
5897                     sv_2mortal(TOPs);
5898                 *SP-- = &PL_sv_undef;
5899                 iters--;
5900             }
5901         }
5902     }
5903
5904     PUTBACK;
5905     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5906     SPAGAIN;
5907     if (realarray) {
5908         if (!mg) {
5909             if (SvSMAGICAL(ary)) {
5910                 PUTBACK;
5911                 mg_set(MUTABLE_SV(ary));
5912                 SPAGAIN;
5913             }
5914             if (gimme == G_ARRAY) {
5915                 EXTEND(SP, iters);
5916                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5917                 SP += iters;
5918                 RETURN;
5919             }
5920         }
5921         else {
5922             PUTBACK;
5923             ENTER_with_name("call_PUSH");
5924             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5925             LEAVE_with_name("call_PUSH");
5926             SPAGAIN;
5927             if (gimme == G_ARRAY) {
5928                 SSize_t i;
5929                 /* EXTEND should not be needed - we just popped them */
5930                 EXTEND(SP, iters);
5931                 for (i=0; i < iters; i++) {
5932                     SV **svp = av_fetch(ary, i, FALSE);
5933                     PUSHs((svp) ? *svp : &PL_sv_undef);
5934                 }
5935                 RETURN;
5936             }
5937         }
5938     }
5939     else {
5940         if (gimme == G_ARRAY)
5941             RETURN;
5942     }
5943
5944     GETTARGET;
5945     PUSHi(iters);
5946     RETURN;
5947 }
5948
5949 PP(pp_once)
5950 {
5951     dSP;
5952     SV *const sv = PAD_SVl(PL_op->op_targ);
5953
5954     if (SvPADSTALE(sv)) {
5955         /* First time. */
5956         SvPADSTALE_off(sv);
5957         RETURNOP(cLOGOP->op_other);
5958     }
5959     RETURNOP(cLOGOP->op_next);
5960 }
5961
5962 PP(pp_lock)
5963 {
5964     dSP;
5965     dTOPss;
5966     SV *retsv = sv;
5967     SvLOCK(sv);
5968     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5969      || SvTYPE(retsv) == SVt_PVCV) {
5970         retsv = refto(retsv);
5971     }
5972     SETs(retsv);
5973     RETURN;
5974 }
5975
5976
5977 /* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
5978  * that aren't implemented on a particular platform */
5979
5980 PP(unimplemented_op)
5981 {
5982     const Optype op_type = PL_op->op_type;
5983     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5984        with out of range op numbers - it only "special" cases op_custom.
5985        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5986        if we get here for a custom op then that means that the custom op didn't
5987        have an implementation. Given that OP_NAME() looks up the custom op
5988        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5989        registers &PL_unimplemented_op as the address of their custom op.
5990        NULL doesn't generate a useful error message. "custom" does. */
5991     const char *const name = op_type >= OP_max
5992         ? "[out of range]" : PL_op_name[PL_op->op_type];
5993     if(OP_IS_SOCKET(op_type))
5994         DIE(aTHX_ PL_no_sock_func, name);
5995     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
5996 }
5997
5998 /* For sorting out arguments passed to a &CORE:: subroutine */
5999 PP(pp_coreargs)
6000 {
6001     dSP;
6002     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6003     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6004     AV * const at_ = GvAV(PL_defgv);
6005     SV **svp = at_ ? AvARRAY(at_) : NULL;
6006     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6007     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6008     bool seen_question = 0;
6009     const char *err = NULL;
6010     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6011
6012     /* Count how many args there are first, to get some idea how far to
6013        extend the stack. */
6014     while (oa) {
6015         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6016         maxargs++;
6017         if (oa & OA_OPTIONAL) seen_question = 1;
6018         if (!seen_question) minargs++;
6019         oa >>= 4;
6020     }
6021
6022     if(numargs < minargs) err = "Not enough";
6023     else if(numargs > maxargs) err = "Too many";
6024     if (err)
6025         /* diag_listed_as: Too many arguments for %s */
6026         Perl_croak(aTHX_
6027           "%s arguments for %s", err,
6028            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6029         );
6030
6031     /* Reset the stack pointer.  Without this, we end up returning our own
6032        arguments in list context, in addition to the values we are supposed
6033        to return.  nextstate usually does this on sub entry, but we need
6034        to run the next op with the caller's hints, so we cannot have a
6035        nextstate. */
6036     SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
6037
6038     if(!maxargs) RETURN;
6039
6040     /* We do this here, rather than with a separate pushmark op, as it has
6041        to come in between two things this function does (stack reset and
6042        arg pushing).  This seems the easiest way to do it. */
6043     if (pushmark) {
6044         PUTBACK;
6045         (void)Perl_pp_pushmark(aTHX);
6046     }
6047
6048     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6049     PUTBACK; /* The code below can die in various places. */
6050
6051     oa = PL_opargs[opnum] >> OASHIFT;
6052     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6053         whicharg++;
6054         switch (oa & 7) {
6055         case OA_SCALAR:
6056           try_defsv:
6057             if (!numargs && defgv && whicharg == minargs + 1) {
6058                 PUSHs(find_rundefsv2(
6059                     find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
6060                     cxstack[cxstack_ix].blk_oldcop->cop_seq
6061                 ));
6062             }
6063             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6064             break;
6065         case OA_LIST:
6066             while (numargs--) {
6067                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6068                 svp++;
6069             }
6070             RETURN;
6071         case OA_HVREF:
6072             if (!svp || !*svp || !SvROK(*svp)
6073              || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6074                 DIE(aTHX_
6075                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6076                  "Type of arg %d to &CORE::%s must be hash reference",
6077                   whicharg, OP_DESC(PL_op->op_next)
6078                 );
6079             PUSHs(SvRV(*svp));
6080             break;
6081         case OA_FILEREF:
6082             if (!numargs) PUSHs(NULL);
6083             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6084                 /* no magic here, as the prototype will have added an extra
6085                    refgen and we just want what was there before that */
6086                 PUSHs(SvRV(*svp));
6087             else {
6088                 const bool constr = PL_op->op_private & whicharg;
6089                 PUSHs(S_rv2gv(aTHX_
6090                     svp && *svp ? *svp : &PL_sv_undef,
6091                     constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6092                     !constr
6093                 ));
6094             }
6095             break;
6096         case OA_SCALARREF:
6097           if (!numargs) goto try_defsv;
6098           else {
6099             const bool wantscalar =
6100                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6101             if (!svp || !*svp || !SvROK(*svp)
6102                 /* We have to permit globrefs even for the \$ proto, as
6103                    *foo is indistinguishable from ${\*foo}, and the proto-
6104                    type permits the latter. */
6105              || SvTYPE(SvRV(*svp)) > (
6106                      wantscalar       ? SVt_PVLV
6107                    : opnum == OP_LOCK || opnum == OP_UNDEF
6108                                       ? SVt_PVCV
6109                    :                    SVt_PVHV
6110                 )
6111                )
6112                 DIE(aTHX_
6113                  "Type of arg %d to &CORE::%s must be %s",
6114                   whicharg, PL_op_name[opnum],
6115                   wantscalar
6116                     ? "scalar reference"
6117                     : opnum == OP_LOCK || opnum == OP_UNDEF
6118                        ? "reference to one of [$@%&*]"
6119                        : "reference to one of [$@%*]"
6120                 );
6121             PUSHs(SvRV(*svp));
6122             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6123              && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6124                 /* Undo @_ localisation, so that sub exit does not undo
6125                    part of our undeffing. */
6126                 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6127                 POP_SAVEARRAY();
6128                 cx->cx_type &= ~ CXp_HASARGS;
6129                 assert(!AvREAL(cx->blk_sub.argarray));
6130             }
6131           }
6132           break;
6133         default:
6134             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6135         }
6136         oa = oa >> 4;
6137     }
6138
6139     RETURN;
6140 }
6141
6142 PP(pp_runcv)
6143 {
6144     dSP;
6145     CV *cv;
6146     if (PL_op->op_private & OPpOFFBYONE) {
6147         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6148     }
6149     else cv = find_runcv(NULL);
6150     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6151     RETURN;
6152 }
6153
6154 static void
6155 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6156                             const bool can_preserve)
6157 {
6158     const SSize_t ix = SvIV(keysv);
6159     if (can_preserve ? av_exists(av, ix) : TRUE) {
6160         SV ** const svp = av_fetch(av, ix, 1);
6161         if (!svp || !*svp)
6162             Perl_croak(aTHX_ PL_no_aelem, ix);
6163         save_aelem(av, ix, svp);
6164     }
6165     else
6166         SAVEADELETE(av, ix);
6167 }
6168
6169 static void
6170 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6171                             const bool can_preserve)
6172 {
6173     if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6174         HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6175         SV ** const svp = he ? &HeVAL(he) : NULL;
6176         if (!svp || !*svp)
6177             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6178         save_helem_flags(hv, keysv, svp, 0);
6179     }
6180     else
6181         SAVEHDELETE(hv, keysv);
6182 }
6183
6184 static void
6185 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6186 {
6187     if (type == OPpLVREF_SV) {
6188         save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6189         GvSV(gv) = 0;
6190     }
6191     else if (type == OPpLVREF_AV)
6192         /* XXX Inefficient, as it creates a new AV, which we are
6193                about to clobber.  */
6194         save_ary(gv);
6195     else {
6196         assert(type == OPpLVREF_HV);
6197         /* XXX Likewise inefficient.  */
6198         save_hash(gv);
6199     }
6200 }
6201
6202
6203 PP(pp_refassign)
6204 {
6205     dSP;
6206     SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6207     SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6208     dTOPss;
6209     const char *bad = NULL;
6210     const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6211     if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6212     switch (type) {
6213     case OPpLVREF_SV:
6214         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6215             bad = " SCALAR";
6216         break;
6217     case OPpLVREF_AV:
6218         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6219             bad = "n ARRAY";
6220         break;
6221     case OPpLVREF_HV:
6222         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6223             bad = " HASH";
6224         break;
6225     case OPpLVREF_CV:
6226         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6227             bad = " CODE";
6228     }
6229     if (bad)
6230         /* diag_listed_as: Assigned value is not %s reference */
6231         DIE(aTHX_ "Assigned value is not a%s reference", bad);
6232     switch (left ? SvTYPE(left) : 0) {
6233         MAGIC *mg;
6234         HV *stash;
6235     case 0:
6236     {
6237         SV * const old = PAD_SV(ARGTARG);
6238         PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6239         SvREFCNT_dec(old);
6240         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6241                 == OPpLVAL_INTRO)
6242             SAVECLEARSV(PAD_SVl(ARGTARG));
6243         break;
6244     }
6245     case SVt_PVGV:
6246         if (PL_op->op_private & OPpLVAL_INTRO) {
6247             S_localise_gv_slot(aTHX_ (GV *)left, type);
6248         }
6249         gv_setref(left, sv);
6250         SvSETMAGIC(left);
6251         break;
6252     case SVt_PVAV:
6253         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6254             S_localise_aelem_lval(aTHX_ (AV *)left, key,
6255                                         SvCANEXISTDELETE(left));
6256         }
6257         av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6258         break;
6259     case SVt_PVHV:
6260         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
6261             S_localise_helem_lval(aTHX_ (HV *)left, key,
6262                                         SvCANEXISTDELETE(left));
6263         hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6264     }
6265     if (PL_op->op_flags & OPf_MOD)
6266         SETs(sv_2mortal(newSVsv(sv)));
6267     /* XXX else can weak references go stale before they are read, e.g.,
6268        in leavesub?  */
6269     RETURN;
6270 }
6271
6272 PP(pp_lvref)
6273 {
6274     dSP;
6275     SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6276     SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6277     SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6278     MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6279                                    &PL_vtbl_lvref, (char *)elem,
6280                                    elem ? HEf_SVKEY : (I32)ARGTARG);
6281     mg->mg_private = PL_op->op_private;
6282     if (PL_op->op_private & OPpLVREF_ITER)
6283         mg->mg_flags |= MGf_PERSIST;
6284     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6285       if (elem) {
6286         MAGIC *mg;
6287         HV *stash;
6288         const bool can_preserve = SvCANEXISTDELETE(arg);
6289         if (SvTYPE(arg) == SVt_PVAV)
6290             S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6291         else
6292             S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6293       }
6294       else if (arg) {
6295         S_localise_gv_slot(aTHX_ (GV *)arg, 
6296                                  PL_op->op_private & OPpLVREF_TYPE);
6297       }
6298       else if (!(PL_op->op_private & OPpPAD_STATE))
6299         SAVECLEARSV(PAD_SVl(ARGTARG));
6300     }
6301     XPUSHs(ret);
6302     RETURN;
6303 }
6304
6305 PP(pp_lvrefslice)
6306 {
6307     dSP; dMARK;
6308     AV * const av = (AV *)POPs;
6309     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6310     bool can_preserve = FALSE;
6311
6312     if (UNLIKELY(localizing)) {
6313         MAGIC *mg;
6314         HV *stash;
6315         SV **svp;
6316
6317         can_preserve = SvCANEXISTDELETE(av);
6318
6319         if (SvTYPE(av) == SVt_PVAV) {
6320             SSize_t max = -1;
6321
6322             for (svp = MARK + 1; svp <= SP; svp++) {
6323                 const SSize_t elem = SvIV(*svp);
6324                 if (elem > max)
6325                     max = elem;
6326             }
6327             if (max > AvMAX(av))
6328                 av_extend(av, max);
6329         }
6330     }
6331
6332     while (++MARK <= SP) {
6333         SV * const elemsv = *MARK;
6334         if (SvTYPE(av) == SVt_PVAV)
6335             S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6336         else
6337             S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6338         *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6339         sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6340     }
6341     RETURN;
6342 }
6343
6344 PP(pp_lvavref)
6345 {
6346     if (PL_op->op_flags & OPf_STACKED)
6347         Perl_pp_rv2av(aTHX);
6348     else
6349         Perl_pp_padav(aTHX);
6350     {
6351         dSP;
6352         dTOPss;
6353         SETs(0); /* special alias marker that aassign recognises */
6354         XPUSHs(sv);
6355         RETURN;
6356     }
6357 }
6358
6359 /*
6360  * Local variables:
6361  * c-indentation-style: bsd
6362  * c-basic-offset: 4
6363  * indent-tabs-mode: nil
6364  * End:
6365  *
6366  * ex: set ts=8 sts=4 sw=4 et:
6367  */