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