This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make prototype("CORE::foo") return prototypes with _ when it should
[perl5.git] / pp.c
1 /*    pp.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 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 to discover,
13  * and no knowing what you'll find around a corner.  And Elves, sir!" --Samwise
14  */
15
16 /* This file contains general pp ("push/pop") functions that execute the
17  * opcodes that make up a perl program. A typical pp function expects to
18  * find its arguments on the stack, and usually pushes its results onto
19  * the stack, hence the 'pp' terminology. Each OP structure contains
20  * a pointer to the relevant pp_foo() function.
21  */
22
23 #include "EXTERN.h"
24 #define PERL_IN_PP_C
25 #include "perl.h"
26 #include "keywords.h"
27
28 #include "reentr.h"
29
30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
31    it, since pid_t is an integral type.
32    --AD  2/20/1998
33 */
34 #ifdef NEED_GETPID_PROTO
35 extern Pid_t getpid (void);
36 #endif
37
38 /*
39  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
40  * This switches them over to IEEE.
41  */
42 #if defined(LIBM_LIB_VERSION)
43     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
44 #endif
45
46 /* variations on pp_null */
47
48 PP(pp_stub)
49 {
50     dVAR;
51     dSP;
52     if (GIMME_V == G_SCALAR)
53         XPUSHs(&PL_sv_undef);
54     RETURN;
55 }
56
57 /* Pushy stuff. */
58
59 PP(pp_padav)
60 {
61     dVAR; dSP; dTARGET;
62     I32 gimme;
63     if (PL_op->op_private & OPpLVAL_INTRO)
64         if (!(PL_op->op_private & OPpPAD_STATE))
65             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
66     EXTEND(SP, 1);
67     if (PL_op->op_flags & OPf_REF) {
68         PUSHs(TARG);
69         RETURN;
70     } else if (LVRET) {
71         if (GIMME == G_SCALAR)
72             Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
73         PUSHs(TARG);
74         RETURN;
75     }
76     gimme = GIMME_V;
77     if (gimme == G_ARRAY) {
78         const I32 maxarg = AvFILL((AV*)TARG) + 1;
79         EXTEND(SP, maxarg);
80         if (SvMAGICAL(TARG)) {
81             U32 i;
82             for (i=0; i < (U32)maxarg; i++) {
83                 SV * const * const svp = av_fetch((AV*)TARG, i, FALSE);
84                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
85             }
86         }
87         else {
88             Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
89         }
90         SP += maxarg;
91     }
92     else if (gimme == G_SCALAR) {
93         SV* const sv = sv_newmortal();
94         const I32 maxarg = AvFILL((AV*)TARG) + 1;
95         sv_setiv(sv, maxarg);
96         PUSHs(sv);
97     }
98     RETURN;
99 }
100
101 PP(pp_padhv)
102 {
103     dVAR; dSP; dTARGET;
104     I32 gimme;
105
106     XPUSHs(TARG);
107     if (PL_op->op_private & OPpLVAL_INTRO)
108         if (!(PL_op->op_private & OPpPAD_STATE))
109             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
110     if (PL_op->op_flags & OPf_REF)
111         RETURN;
112     else if (LVRET) {
113         if (GIMME == G_SCALAR)
114             Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
115         RETURN;
116     }
117     gimme = GIMME_V;
118     if (gimme == G_ARRAY) {
119         RETURNOP(do_kv());
120     }
121     else if (gimme == G_SCALAR) {
122         SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
123         SETs(sv);
124     }
125     RETURN;
126 }
127
128 /* Translations. */
129
130 PP(pp_rv2gv)
131 {
132     dVAR; dSP; dTOPss;
133
134     if (SvROK(sv)) {
135       wasref:
136         tryAMAGICunDEREF(to_gv);
137
138         sv = SvRV(sv);
139         if (SvTYPE(sv) == SVt_PVIO) {
140             GV * const gv = (GV*) sv_newmortal();
141             gv_init(gv, 0, "", 0, 0);
142             GvIOp(gv) = (IO *)sv;
143             SvREFCNT_inc_void_NN(sv);
144             sv = (SV*) gv;
145         }
146         else if (SvTYPE(sv) != SVt_PVGV)
147             DIE(aTHX_ "Not a GLOB reference");
148     }
149     else {
150         if (SvTYPE(sv) != SVt_PVGV) {
151             if (SvGMAGICAL(sv)) {
152                 mg_get(sv);
153                 if (SvROK(sv))
154                     goto wasref;
155             }
156             if (!SvOK(sv) && sv != &PL_sv_undef) {
157                 /* If this is a 'my' scalar and flag is set then vivify
158                  * NI-S 1999/05/07
159                  */
160                 if (SvREADONLY(sv))
161                     Perl_croak(aTHX_ PL_no_modify);
162                 if (PL_op->op_private & OPpDEREF) {
163                     GV *gv;
164                     if (cUNOP->op_targ) {
165                         STRLEN len;
166                         SV * const namesv = PAD_SV(cUNOP->op_targ);
167                         const char * const name = SvPV(namesv, len);
168                         gv = (GV*)newSV(0);
169                         gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
170                     }
171                     else {
172                         const char * const name = CopSTASHPV(PL_curcop);
173                         gv = newGVgen(name);
174                     }
175                     if (SvTYPE(sv) < SVt_RV)
176                         sv_upgrade(sv, SVt_RV);
177                     else if (SvPVX_const(sv)) {
178                         SvPV_free(sv);
179                         SvLEN_set(sv, 0);
180                         SvCUR_set(sv, 0);
181                     }
182                     SvRV_set(sv, (SV*)gv);
183                     SvROK_on(sv);
184                     SvSETMAGIC(sv);
185                     goto wasref;
186                 }
187                 if (PL_op->op_flags & OPf_REF ||
188                     PL_op->op_private & HINT_STRICT_REFS)
189                     DIE(aTHX_ PL_no_usym, "a symbol");
190                 if (ckWARN(WARN_UNINITIALIZED))
191                     report_uninit(sv);
192                 RETSETUNDEF;
193             }
194             if ((PL_op->op_flags & OPf_SPECIAL) &&
195                 !(PL_op->op_flags & OPf_MOD))
196             {
197                 SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
198                 if (!temp
199                     && (!is_gv_magical_sv(sv,0)
200                         || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
201                     RETSETUNDEF;
202                 }
203                 sv = temp;
204             }
205             else {
206                 if (PL_op->op_private & HINT_STRICT_REFS)
207                     DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
208                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
209                     == OPpDONT_INIT_GV) {
210                     /* We are the target of a coderef assignment.  Return
211                        the scalar unchanged, and let pp_sasssign deal with
212                        things.  */
213                     RETURN;
214                 }
215                 sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
216             }
217         }
218     }
219     if (PL_op->op_private & OPpLVAL_INTRO)
220         save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
221     SETs(sv);
222     RETURN;
223 }
224
225 PP(pp_rv2sv)
226 {
227     dVAR; dSP; dTOPss;
228     GV *gv = NULL;
229
230     if (SvROK(sv)) {
231       wasref:
232         tryAMAGICunDEREF(to_sv);
233
234         sv = SvRV(sv);
235         switch (SvTYPE(sv)) {
236         case SVt_PVAV:
237         case SVt_PVHV:
238         case SVt_PVCV:
239         case SVt_PVFM:
240         case SVt_PVIO:
241             DIE(aTHX_ "Not a SCALAR reference");
242         default: NOOP;
243         }
244     }
245     else {
246         gv = (GV*)sv;
247
248         if (SvTYPE(gv) != SVt_PVGV) {
249             if (SvGMAGICAL(sv)) {
250                 mg_get(sv);
251                 if (SvROK(sv))
252                     goto wasref;
253             }
254             if (PL_op->op_private & HINT_STRICT_REFS) {
255                 if (SvOK(sv))
256                     DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
257                 else
258                     DIE(aTHX_ PL_no_usym, "a SCALAR");
259             }
260             if (!SvOK(sv)) {
261                 if (PL_op->op_flags & OPf_REF)
262                     DIE(aTHX_ PL_no_usym, "a SCALAR");
263                 if (ckWARN(WARN_UNINITIALIZED))
264                     report_uninit(sv);
265                 RETSETUNDEF;
266             }
267             if ((PL_op->op_flags & OPf_SPECIAL) &&
268                 !(PL_op->op_flags & OPf_MOD))
269             {
270                 gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
271                 if (!gv
272                     && (!is_gv_magical_sv(sv, 0)
273                         || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
274                 {
275                     RETSETUNDEF;
276                 }
277             }
278             else {
279                 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV);
280             }
281         }
282         sv = GvSVn(gv);
283     }
284     if (PL_op->op_flags & OPf_MOD) {
285         if (PL_op->op_private & OPpLVAL_INTRO) {
286             if (cUNOP->op_first->op_type == OP_NULL)
287                 sv = save_scalar((GV*)TOPs);
288             else if (gv)
289                 sv = save_scalar(gv);
290             else
291                 Perl_croak(aTHX_ PL_no_localize_ref);
292         }
293         else if (PL_op->op_private & OPpDEREF)
294             vivify_ref(sv, PL_op->op_private & OPpDEREF);
295     }
296     SETs(sv);
297     RETURN;
298 }
299
300 PP(pp_av2arylen)
301 {
302     dVAR; dSP;
303     AV * const av = (AV*)TOPs;
304     SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
305     if (!*sv) {
306         *sv = newSV(0);
307         sv_upgrade(*sv, SVt_PVMG);
308         sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
309     }
310     SETs(*sv);
311     RETURN;
312 }
313
314 PP(pp_pos)
315 {
316     dVAR; dSP; dTARGET; dPOPss;
317
318     if (PL_op->op_flags & OPf_MOD || LVRET) {
319         if (SvTYPE(TARG) < SVt_PVLV) {
320             sv_upgrade(TARG, SVt_PVLV);
321             sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
322         }
323
324         LvTYPE(TARG) = '.';
325         if (LvTARG(TARG) != sv) {
326             if (LvTARG(TARG))
327                 SvREFCNT_dec(LvTARG(TARG));
328             LvTARG(TARG) = SvREFCNT_inc_simple(sv);
329         }
330         PUSHs(TARG);    /* no SvSETMAGIC */
331         RETURN;
332     }
333     else {
334         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
335             const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
336             if (mg && mg->mg_len >= 0) {
337                 I32 i = mg->mg_len;
338                 if (DO_UTF8(sv))
339                     sv_pos_b2u(sv, &i);
340                 PUSHi(i + CopARYBASE_get(PL_curcop));
341                 RETURN;
342             }
343         }
344         RETPUSHUNDEF;
345     }
346 }
347
348 PP(pp_rv2cv)
349 {
350     dVAR; dSP;
351     GV *gv;
352     HV *stash_unused;
353     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
354         ? 0
355         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == 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) {
363         if (CvCLONE(cv))
364             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
365         if ((PL_op->op_private & OPpLVAL_INTRO)) {
366             if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
367                 cv = GvCV(gv);
368             if (!CvLVALUE(cv))
369                 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
370         }
371     }
372     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
373         cv = (CV*)gv;
374     }    
375     else
376         cv = (CV*)&PL_sv_undef;
377     SETs((SV*)cv);
378     RETURN;
379 }
380
381 PP(pp_prototype)
382 {
383     dVAR; dSP;
384     CV *cv;
385     HV *stash;
386     GV *gv;
387     SV *ret = &PL_sv_undef;
388
389     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
390         const char * const s = SvPVX_const(TOPs);
391         if (strnEQ(s, "CORE::", 6)) {
392             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
393             if (code < 0) {     /* Overridable. */
394 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
395                 int i = 0, n = 0, seen_question = 0, defgv = 0;
396                 I32 oa;
397                 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
398
399                 if (code == -KEY_chop || code == -KEY_chomp
400                         || code == -KEY_exec || code == -KEY_system || code == -KEY_err)
401                     goto set;
402                 while (i < MAXO) {      /* The slow way. */
403                     if (strEQ(s + 6, PL_op_name[i])
404                         || strEQ(s + 6, PL_op_desc[i]))
405                     {
406                         goto found;
407                     }
408                     i++;
409                 }
410                 goto nonesuch;          /* Should not happen... */
411               found:
412                 defgv = PL_opargs[i] & OA_DEFGV;
413                 oa = PL_opargs[i] >> OASHIFT;
414                 while (oa) {
415                     if (oa & OA_OPTIONAL && !seen_question && !defgv) {
416                         seen_question = 1;
417                         str[n++] = ';';
418                     }
419                     if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
420                         && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
421                         /* But globs are already references (kinda) */
422                         && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
423                     ) {
424                         str[n++] = '\\';
425                     }
426                     str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
427                     oa = oa >> 4;
428                 }
429                 if (defgv && str[n - 1] == '$')
430                     str[n - 1] = '_';
431                 str[n++] = '\0';
432                 ret = sv_2mortal(newSVpvn(str, n - 1));
433             }
434             else if (code)              /* Non-Overridable */
435                 goto set;
436             else {                      /* None such */
437               nonesuch:
438                 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
439             }
440         }
441     }
442     cv = sv_2cv(TOPs, &stash, &gv, 0);
443     if (cv && SvPOK(cv))
444         ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
445   set:
446     SETs(ret);
447     RETURN;
448 }
449
450 PP(pp_anoncode)
451 {
452     dVAR; dSP;
453     CV* cv = (CV*)PAD_SV(PL_op->op_targ);
454     if (CvCLONE(cv))
455         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
456     EXTEND(SP,1);
457     PUSHs((SV*)cv);
458     RETURN;
459 }
460
461 PP(pp_srefgen)
462 {
463     dVAR; dSP;
464     *SP = refto(*SP);
465     RETURN;
466 }
467
468 PP(pp_refgen)
469 {
470     dVAR; dSP; dMARK;
471     if (GIMME != G_ARRAY) {
472         if (++MARK <= SP)
473             *MARK = *SP;
474         else
475             *MARK = &PL_sv_undef;
476         *MARK = refto(*MARK);
477         SP = MARK;
478         RETURN;
479     }
480     EXTEND_MORTAL(SP - MARK);
481     while (++MARK <= SP)
482         *MARK = refto(*MARK);
483     RETURN;
484 }
485
486 STATIC SV*
487 S_refto(pTHX_ SV *sv)
488 {
489     dVAR;
490     SV* rv;
491
492     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
493         if (LvTARGLEN(sv))
494             vivify_defelem(sv);
495         if (!(sv = LvTARG(sv)))
496             sv = &PL_sv_undef;
497         else
498             SvREFCNT_inc_void_NN(sv);
499     }
500     else if (SvTYPE(sv) == SVt_PVAV) {
501         if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
502             av_reify((AV*)sv);
503         SvTEMP_off(sv);
504         SvREFCNT_inc_void_NN(sv);
505     }
506     else if (SvPADTMP(sv) && !IS_PADGV(sv))
507         sv = newSVsv(sv);
508     else {
509         SvTEMP_off(sv);
510         SvREFCNT_inc_void_NN(sv);
511     }
512     rv = sv_newmortal();
513     sv_upgrade(rv, SVt_RV);
514     SvRV_set(rv, sv);
515     SvROK_on(rv);
516     return rv;
517 }
518
519 PP(pp_ref)
520 {
521     dVAR; dSP; dTARGET;
522     const char *pv;
523     SV * const sv = POPs;
524
525     if (sv)
526         SvGETMAGIC(sv);
527
528     if (!sv || !SvROK(sv))
529         RETPUSHNO;
530
531     pv = sv_reftype(SvRV(sv),TRUE);
532     PUSHp(pv, strlen(pv));
533     RETURN;
534 }
535
536 PP(pp_bless)
537 {
538     dVAR; dSP;
539     HV *stash;
540
541     if (MAXARG == 1)
542         stash = CopSTASH(PL_curcop);
543     else {
544         SV * const ssv = POPs;
545         STRLEN len;
546         const char *ptr;
547
548         if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
549             Perl_croak(aTHX_ "Attempt to bless into a reference");
550         ptr = SvPV_const(ssv,len);
551         if (len == 0 && ckWARN(WARN_MISC))
552             Perl_warner(aTHX_ packWARN(WARN_MISC),
553                    "Explicit blessing to '' (assuming package main)");
554         stash = gv_stashpvn(ptr, len, TRUE);
555     }
556
557     (void)sv_bless(TOPs, stash);
558     RETURN;
559 }
560
561 PP(pp_gelem)
562 {
563     dVAR; dSP;
564
565     SV *sv = POPs;
566     const char * const elem = SvPV_nolen_const(sv);
567     GV * const gv = (GV*)POPs;
568     SV * tmpRef = NULL;
569
570     sv = NULL;
571     if (elem) {
572         /* elem will always be NUL terminated.  */
573         const char * const second_letter = elem + 1;
574         switch (*elem) {
575         case 'A':
576             if (strEQ(second_letter, "RRAY"))
577                 tmpRef = (SV*)GvAV(gv);
578             break;
579         case 'C':
580             if (strEQ(second_letter, "ODE"))
581                 tmpRef = (SV*)GvCVu(gv);
582             break;
583         case 'F':
584             if (strEQ(second_letter, "ILEHANDLE")) {
585                 /* finally deprecated in 5.8.0 */
586                 deprecate("*glob{FILEHANDLE}");
587                 tmpRef = (SV*)GvIOp(gv);
588             }
589             else
590                 if (strEQ(second_letter, "ORMAT"))
591                     tmpRef = (SV*)GvFORM(gv);
592             break;
593         case 'G':
594             if (strEQ(second_letter, "LOB"))
595                 tmpRef = (SV*)gv;
596             break;
597         case 'H':
598             if (strEQ(second_letter, "ASH"))
599                 tmpRef = (SV*)GvHV(gv);
600             break;
601         case 'I':
602             if (*second_letter == 'O' && !elem[2])
603                 tmpRef = (SV*)GvIOp(gv);
604             break;
605         case 'N':
606             if (strEQ(second_letter, "AME"))
607                 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
608             break;
609         case 'P':
610             if (strEQ(second_letter, "ACKAGE")) {
611                 const HV * const stash = GvSTASH(gv);
612                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
613                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
614             }
615             break;
616         case 'S':
617             if (strEQ(second_letter, "CALAR"))
618                 tmpRef = GvSVn(gv);
619             break;
620         }
621     }
622     if (tmpRef)
623         sv = newRV(tmpRef);
624     if (sv)
625         sv_2mortal(sv);
626     else
627         sv = &PL_sv_undef;
628     XPUSHs(sv);
629     RETURN;
630 }
631
632 /* Pattern matching */
633
634 PP(pp_study)
635 {
636     dVAR; dSP; dPOPss;
637     register unsigned char *s;
638     register I32 pos;
639     register I32 ch;
640     register I32 *sfirst;
641     register I32 *snext;
642     STRLEN len;
643
644     if (sv == PL_lastscream) {
645         if (SvSCREAM(sv))
646             RETPUSHYES;
647     }
648     s = (unsigned char*)(SvPV(sv, len));
649     pos = len;
650     if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
651         /* No point in studying a zero length string, and not safe to study
652            anything that doesn't appear to be a simple scalar (and hence might
653            change between now and when the regexp engine runs without our set
654            magic ever running) such as a reference to an object with overloaded
655            stringification.  */
656         RETPUSHNO;
657     }
658
659     if (PL_lastscream) {
660         SvSCREAM_off(PL_lastscream);
661         SvREFCNT_dec(PL_lastscream);
662     }
663     PL_lastscream = SvREFCNT_inc_simple(sv);
664
665     s = (unsigned char*)(SvPV(sv, len));
666     pos = len;
667     if (pos <= 0)
668         RETPUSHNO;
669     if (pos > PL_maxscream) {
670         if (PL_maxscream < 0) {
671             PL_maxscream = pos + 80;
672             Newx(PL_screamfirst, 256, I32);
673             Newx(PL_screamnext, PL_maxscream, I32);
674         }
675         else {
676             PL_maxscream = pos + pos / 4;
677             Renew(PL_screamnext, PL_maxscream, I32);
678         }
679     }
680
681     sfirst = PL_screamfirst;
682     snext = PL_screamnext;
683
684     if (!sfirst || !snext)
685         DIE(aTHX_ "do_study: out of memory");
686
687     for (ch = 256; ch; --ch)
688         *sfirst++ = -1;
689     sfirst -= 256;
690
691     while (--pos >= 0) {
692         register const I32 ch = s[pos];
693         if (sfirst[ch] >= 0)
694             snext[pos] = sfirst[ch] - pos;
695         else
696             snext[pos] = -pos;
697         sfirst[ch] = pos;
698     }
699
700     SvSCREAM_on(sv);
701     /* piggyback on m//g magic */
702     sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
703     RETPUSHYES;
704 }
705
706 PP(pp_trans)
707 {
708     dVAR; dSP; dTARG;
709     SV *sv;
710
711     if (PL_op->op_flags & OPf_STACKED)
712         sv = POPs;
713     else if (PL_op->op_private & OPpTARGET_MY)
714         sv = GETTARGET;
715     else {
716         sv = DEFSV;
717         EXTEND(SP,1);
718     }
719     TARG = sv_newmortal();
720     PUSHi(do_trans(sv));
721     RETURN;
722 }
723
724 /* Lvalue operators. */
725
726 PP(pp_schop)
727 {
728     dVAR; dSP; dTARGET;
729     do_chop(TARG, TOPs);
730     SETTARG;
731     RETURN;
732 }
733
734 PP(pp_chop)
735 {
736     dVAR; dSP; dMARK; dTARGET; dORIGMARK;
737     while (MARK < SP)
738         do_chop(TARG, *++MARK);
739     SP = ORIGMARK;
740     XPUSHTARG;
741     RETURN;
742 }
743
744 PP(pp_schomp)
745 {
746     dVAR; dSP; dTARGET;
747     SETi(do_chomp(TOPs));
748     RETURN;
749 }
750
751 PP(pp_chomp)
752 {
753     dVAR; dSP; dMARK; dTARGET;
754     register I32 count = 0;
755
756     while (SP > MARK)
757         count += do_chomp(POPs);
758     XPUSHi(count);
759     RETURN;
760 }
761
762 PP(pp_undef)
763 {
764     dVAR; dSP;
765     SV *sv;
766
767     if (!PL_op->op_private) {
768         EXTEND(SP, 1);
769         RETPUSHUNDEF;
770     }
771
772     sv = POPs;
773     if (!sv)
774         RETPUSHUNDEF;
775
776     SV_CHECK_THINKFIRST_COW_DROP(sv);
777
778     switch (SvTYPE(sv)) {
779     case SVt_NULL:
780         break;
781     case SVt_PVAV:
782         av_undef((AV*)sv);
783         break;
784     case SVt_PVHV:
785         hv_undef((HV*)sv);
786         break;
787     case SVt_PVCV:
788         if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
789             Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
790                  CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
791         /* FALLTHROUGH */
792     case SVt_PVFM:
793         {
794             /* let user-undef'd sub keep its identity */
795             GV* const gv = CvGV((CV*)sv);
796             cv_undef((CV*)sv);
797             CvGV((CV*)sv) = gv;
798         }
799         break;
800     case SVt_PVGV:
801         if (SvFAKE(sv))
802             SvSetMagicSV(sv, &PL_sv_undef);
803         else {
804             GP *gp;
805             gp_free((GV*)sv);
806             Newxz(gp, 1, GP);
807             GvGP(sv) = gp_ref(gp);
808             GvSV(sv) = newSV(0);
809             GvLINE(sv) = CopLINE(PL_curcop);
810             GvEGV(sv) = (GV*)sv;
811             GvMULTI_on(sv);
812         }
813         break;
814     default:
815         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
816             SvPV_free(sv);
817             SvPV_set(sv, NULL);
818             SvLEN_set(sv, 0);
819         }
820         SvOK_off(sv);
821         SvSETMAGIC(sv);
822     }
823
824     RETPUSHUNDEF;
825 }
826
827 PP(pp_predec)
828 {
829     dVAR; dSP;
830     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
831         DIE(aTHX_ PL_no_modify);
832     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
833         && SvIVX(TOPs) != IV_MIN)
834     {
835         SvIV_set(TOPs, SvIVX(TOPs) - 1);
836         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
837     }
838     else
839         sv_dec(TOPs);
840     SvSETMAGIC(TOPs);
841     return NORMAL;
842 }
843
844 PP(pp_postinc)
845 {
846     dVAR; dSP; dTARGET;
847     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
848         DIE(aTHX_ PL_no_modify);
849     sv_setsv(TARG, TOPs);
850     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
851         && SvIVX(TOPs) != IV_MAX)
852     {
853         SvIV_set(TOPs, SvIVX(TOPs) + 1);
854         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
855     }
856     else
857         sv_inc(TOPs);
858     SvSETMAGIC(TOPs);
859     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
860     if (!SvOK(TARG))
861         sv_setiv(TARG, 0);
862     SETs(TARG);
863     return NORMAL;
864 }
865
866 PP(pp_postdec)
867 {
868     dVAR; dSP; dTARGET;
869     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
870         DIE(aTHX_ PL_no_modify);
871     sv_setsv(TARG, TOPs);
872     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
873         && SvIVX(TOPs) != IV_MIN)
874     {
875         SvIV_set(TOPs, SvIVX(TOPs) - 1);
876         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
877     }
878     else
879         sv_dec(TOPs);
880     SvSETMAGIC(TOPs);
881     SETs(TARG);
882     return NORMAL;
883 }
884
885 /* Ordinary operators. */
886
887 PP(pp_pow)
888 {
889     dVAR; dSP; dATARGET;
890 #ifdef PERL_PRESERVE_IVUV
891     bool is_int = 0;
892 #endif
893     tryAMAGICbin(pow,opASSIGN);
894 #ifdef PERL_PRESERVE_IVUV
895     /* For integer to integer power, we do the calculation by hand wherever
896        we're sure it is safe; otherwise we call pow() and try to convert to
897        integer afterwards. */
898     {
899         SvIV_please(TOPs);
900         if (SvIOK(TOPs)) {
901             SvIV_please(TOPm1s);
902             if (SvIOK(TOPm1s)) {
903                 UV power;
904                 bool baseuok;
905                 UV baseuv;
906
907                 if (SvUOK(TOPs)) {
908                     power = SvUVX(TOPs);
909                 } else {
910                     const IV iv = SvIVX(TOPs);
911                     if (iv >= 0) {
912                         power = iv;
913                     } else {
914                         goto float_it; /* Can't do negative powers this way.  */
915                     }
916                 }
917
918                 baseuok = SvUOK(TOPm1s);
919                 if (baseuok) {
920                     baseuv = SvUVX(TOPm1s);
921                 } else {
922                     const IV iv = SvIVX(TOPm1s);
923                     if (iv >= 0) {
924                         baseuv = iv;
925                         baseuok = TRUE; /* effectively it's a UV now */
926                     } else {
927                         baseuv = -iv; /* abs, baseuok == false records sign */
928                     }
929                 }
930                 /* now we have integer ** positive integer. */
931                 is_int = 1;
932
933                 /* foo & (foo - 1) is zero only for a power of 2.  */
934                 if (!(baseuv & (baseuv - 1))) {
935                     /* We are raising power-of-2 to a positive integer.
936                        The logic here will work for any base (even non-integer
937                        bases) but it can be less accurate than
938                        pow (base,power) or exp (power * log (base)) when the
939                        intermediate values start to spill out of the mantissa.
940                        With powers of 2 we know this can't happen.
941                        And powers of 2 are the favourite thing for perl
942                        programmers to notice ** not doing what they mean. */
943                     NV result = 1.0;
944                     NV base = baseuok ? baseuv : -(NV)baseuv;
945
946                     if (power & 1) {
947                         result *= base;
948                     }
949                     while (power >>= 1) {
950                         base *= base;
951                         if (power & 1) {
952                             result *= base;
953                         }
954                     }
955                     SP--;
956                     SETn( result );
957                     SvIV_please(TOPs);
958                     RETURN;
959                 } else {
960                     register unsigned int highbit = 8 * sizeof(UV);
961                     register unsigned int diff = 8 * sizeof(UV);
962                     while (diff >>= 1) {
963                         highbit -= diff;
964                         if (baseuv >> highbit) {
965                             highbit += diff;
966                         }
967                     }
968                     /* we now have baseuv < 2 ** highbit */
969                     if (power * highbit <= 8 * sizeof(UV)) {
970                         /* result will definitely fit in UV, so use UV math
971                            on same algorithm as above */
972                         register UV result = 1;
973                         register UV base = baseuv;
974                         const bool odd_power = (bool)(power & 1);
975                         if (odd_power) {
976                             result *= base;
977                         }
978                         while (power >>= 1) {
979                             base *= base;
980                             if (power & 1) {
981                                 result *= base;
982                             }
983                         }
984                         SP--;
985                         if (baseuok || !odd_power)
986                             /* answer is positive */
987                             SETu( result );
988                         else if (result <= (UV)IV_MAX)
989                             /* answer negative, fits in IV */
990                             SETi( -(IV)result );
991                         else if (result == (UV)IV_MIN) 
992                             /* 2's complement assumption: special case IV_MIN */
993                             SETi( IV_MIN );
994                         else
995                             /* answer negative, doesn't fit */
996                             SETn( -(NV)result );
997                         RETURN;
998                     } 
999                 }
1000             }
1001         }
1002     }
1003   float_it:
1004 #endif    
1005     {
1006         dPOPTOPnnrl;
1007
1008 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1009     /*
1010     We are building perl with long double support and are on an AIX OS
1011     afflicted with a powl() function that wrongly returns NaNQ for any
1012     negative base.  This was reported to IBM as PMR #23047-379 on
1013     03/06/2006.  The problem exists in at least the following versions
1014     of AIX and the libm fileset, and no doubt others as well:
1015
1016         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1017         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1018         AIX 5.2.0           bos.adt.libm 5.2.0.85
1019
1020     So, until IBM fixes powl(), we provide the following workaround to
1021     handle the problem ourselves.  Our logic is as follows: for
1022     negative bases (left), we use fmod(right, 2) to check if the
1023     exponent is an odd or even integer:
1024
1025         - if odd,  powl(left, right) == -powl(-left, right)
1026         - if even, powl(left, right) ==  powl(-left, right)
1027
1028     If the exponent is not an integer, the result is rightly NaNQ, so
1029     we just return that (as NV_NAN).
1030     */
1031
1032         if (left < 0.0) {
1033             NV mod2 = Perl_fmod( right, 2.0 );
1034             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1035                 SETn( -Perl_pow( -left, right) );
1036             } else if (mod2 == 0.0) {           /* even integer */
1037                 SETn( Perl_pow( -left, right) );
1038             } else {                            /* fractional power */
1039                 SETn( NV_NAN );
1040             }
1041         } else {
1042             SETn( Perl_pow( left, right) );
1043         }
1044 #else
1045         SETn( Perl_pow( left, right) );
1046 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1047
1048 #ifdef PERL_PRESERVE_IVUV
1049         if (is_int)
1050             SvIV_please(TOPs);
1051 #endif
1052         RETURN;
1053     }
1054 }
1055
1056 PP(pp_multiply)
1057 {
1058     dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1059 #ifdef PERL_PRESERVE_IVUV
1060     SvIV_please(TOPs);
1061     if (SvIOK(TOPs)) {
1062         /* Unless the left argument is integer in range we are going to have to
1063            use NV maths. Hence only attempt to coerce the right argument if
1064            we know the left is integer.  */
1065         /* Left operand is defined, so is it IV? */
1066         SvIV_please(TOPm1s);
1067         if (SvIOK(TOPm1s)) {
1068             bool auvok = SvUOK(TOPm1s);
1069             bool buvok = SvUOK(TOPs);
1070             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1071             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1072             UV alow;
1073             UV ahigh;
1074             UV blow;
1075             UV bhigh;
1076
1077             if (auvok) {
1078                 alow = SvUVX(TOPm1s);
1079             } else {
1080                 const IV aiv = SvIVX(TOPm1s);
1081                 if (aiv >= 0) {
1082                     alow = aiv;
1083                     auvok = TRUE; /* effectively it's a UV now */
1084                 } else {
1085                     alow = -aiv; /* abs, auvok == false records sign */
1086                 }
1087             }
1088             if (buvok) {
1089                 blow = SvUVX(TOPs);
1090             } else {
1091                 const IV biv = SvIVX(TOPs);
1092                 if (biv >= 0) {
1093                     blow = biv;
1094                     buvok = TRUE; /* effectively it's a UV now */
1095                 } else {
1096                     blow = -biv; /* abs, buvok == false records sign */
1097                 }
1098             }
1099
1100             /* If this does sign extension on unsigned it's time for plan B  */
1101             ahigh = alow >> (4 * sizeof (UV));
1102             alow &= botmask;
1103             bhigh = blow >> (4 * sizeof (UV));
1104             blow &= botmask;
1105             if (ahigh && bhigh) {
1106                 NOOP;
1107                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1108                    which is overflow. Drop to NVs below.  */
1109             } else if (!ahigh && !bhigh) {
1110                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1111                    so the unsigned multiply cannot overflow.  */
1112                 const UV product = alow * blow;
1113                 if (auvok == buvok) {
1114                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1115                     SP--;
1116                     SETu( product );
1117                     RETURN;
1118                 } else if (product <= (UV)IV_MIN) {
1119                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1120                     /* -ve result, which could overflow an IV  */
1121                     SP--;
1122                     SETi( -(IV)product );
1123                     RETURN;
1124                 } /* else drop to NVs below. */
1125             } else {
1126                 /* One operand is large, 1 small */
1127                 UV product_middle;
1128                 if (bhigh) {
1129                     /* swap the operands */
1130                     ahigh = bhigh;
1131                     bhigh = blow; /* bhigh now the temp var for the swap */
1132                     blow = alow;
1133                     alow = bhigh;
1134                 }
1135                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1136                    multiplies can't overflow. shift can, add can, -ve can.  */
1137                 product_middle = ahigh * blow;
1138                 if (!(product_middle & topmask)) {
1139                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1140                     UV product_low;
1141                     product_middle <<= (4 * sizeof (UV));
1142                     product_low = alow * blow;
1143
1144                     /* as for pp_add, UV + something mustn't get smaller.
1145                        IIRC ANSI mandates this wrapping *behaviour* for
1146                        unsigned whatever the actual representation*/
1147                     product_low += product_middle;
1148                     if (product_low >= product_middle) {
1149                         /* didn't overflow */
1150                         if (auvok == buvok) {
1151                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1152                             SP--;
1153                             SETu( product_low );
1154                             RETURN;
1155                         } else if (product_low <= (UV)IV_MIN) {
1156                             /* 2s complement assumption again  */
1157                             /* -ve result, which could overflow an IV  */
1158                             SP--;
1159                             SETi( -(IV)product_low );
1160                             RETURN;
1161                         } /* else drop to NVs below. */
1162                     }
1163                 } /* product_middle too large */
1164             } /* ahigh && bhigh */
1165         } /* SvIOK(TOPm1s) */
1166     } /* SvIOK(TOPs) */
1167 #endif
1168     {
1169       dPOPTOPnnrl;
1170       SETn( left * right );
1171       RETURN;
1172     }
1173 }
1174
1175 PP(pp_divide)
1176 {
1177     dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1178     /* Only try to do UV divide first
1179        if ((SLOPPYDIVIDE is true) or
1180            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1181             to preserve))
1182        The assumption is that it is better to use floating point divide
1183        whenever possible, only doing integer divide first if we can't be sure.
1184        If NV_PRESERVES_UV is true then we know at compile time that no UV
1185        can be too large to preserve, so don't need to compile the code to
1186        test the size of UVs.  */
1187
1188 #ifdef SLOPPYDIVIDE
1189 #  define PERL_TRY_UV_DIVIDE
1190     /* ensure that 20./5. == 4. */
1191 #else
1192 #  ifdef PERL_PRESERVE_IVUV
1193 #    ifndef NV_PRESERVES_UV
1194 #      define PERL_TRY_UV_DIVIDE
1195 #    endif
1196 #  endif
1197 #endif
1198
1199 #ifdef PERL_TRY_UV_DIVIDE
1200     SvIV_please(TOPs);
1201     if (SvIOK(TOPs)) {
1202         SvIV_please(TOPm1s);
1203         if (SvIOK(TOPm1s)) {
1204             bool left_non_neg = SvUOK(TOPm1s);
1205             bool right_non_neg = SvUOK(TOPs);
1206             UV left;
1207             UV right;
1208
1209             if (right_non_neg) {
1210                 right = SvUVX(TOPs);
1211             }
1212             else {
1213                 const IV biv = SvIVX(TOPs);
1214                 if (biv >= 0) {
1215                     right = biv;
1216                     right_non_neg = TRUE; /* effectively it's a UV now */
1217                 }
1218                 else {
1219                     right = -biv;
1220                 }
1221             }
1222             /* historically undef()/0 gives a "Use of uninitialized value"
1223                warning before dieing, hence this test goes here.
1224                If it were immediately before the second SvIV_please, then
1225                DIE() would be invoked before left was even inspected, so
1226                no inpsection would give no warning.  */
1227             if (right == 0)
1228                 DIE(aTHX_ "Illegal division by zero");
1229
1230             if (left_non_neg) {
1231                 left = SvUVX(TOPm1s);
1232             }
1233             else {
1234                 const IV aiv = SvIVX(TOPm1s);
1235                 if (aiv >= 0) {
1236                     left = aiv;
1237                     left_non_neg = TRUE; /* effectively it's a UV now */
1238                 }
1239                 else {
1240                     left = -aiv;
1241                 }
1242             }
1243
1244             if (left >= right
1245 #ifdef SLOPPYDIVIDE
1246                 /* For sloppy divide we always attempt integer division.  */
1247 #else
1248                 /* Otherwise we only attempt it if either or both operands
1249                    would not be preserved by an NV.  If both fit in NVs
1250                    we fall through to the NV divide code below.  However,
1251                    as left >= right to ensure integer result here, we know that
1252                    we can skip the test on the right operand - right big
1253                    enough not to be preserved can't get here unless left is
1254                    also too big.  */
1255
1256                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1257 #endif
1258                 ) {
1259                 /* Integer division can't overflow, but it can be imprecise.  */
1260                 const UV result = left / right;
1261                 if (result * right == left) {
1262                     SP--; /* result is valid */
1263                     if (left_non_neg == right_non_neg) {
1264                         /* signs identical, result is positive.  */
1265                         SETu( result );
1266                         RETURN;
1267                     }
1268                     /* 2s complement assumption */
1269                     if (result <= (UV)IV_MIN)
1270                         SETi( -(IV)result );
1271                     else {
1272                         /* It's exact but too negative for IV. */
1273                         SETn( -(NV)result );
1274                     }
1275                     RETURN;
1276                 } /* tried integer divide but it was not an integer result */
1277             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1278         } /* left wasn't SvIOK */
1279     } /* right wasn't SvIOK */
1280 #endif /* PERL_TRY_UV_DIVIDE */
1281     {
1282         dPOPPOPnnrl;
1283         if (right == 0.0)
1284             DIE(aTHX_ "Illegal division by zero");
1285         PUSHn( left / right );
1286         RETURN;
1287     }
1288 }
1289
1290 PP(pp_modulo)
1291 {
1292     dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1293     {
1294         UV left  = 0;
1295         UV right = 0;
1296         bool left_neg = FALSE;
1297         bool right_neg = FALSE;
1298         bool use_double = FALSE;
1299         bool dright_valid = FALSE;
1300         NV dright = 0.0;
1301         NV dleft  = 0.0;
1302
1303         SvIV_please(TOPs);
1304         if (SvIOK(TOPs)) {
1305             right_neg = !SvUOK(TOPs);
1306             if (!right_neg) {
1307                 right = SvUVX(POPs);
1308             } else {
1309                 const IV biv = SvIVX(POPs);
1310                 if (biv >= 0) {
1311                     right = biv;
1312                     right_neg = FALSE; /* effectively it's a UV now */
1313                 } else {
1314                     right = -biv;
1315                 }
1316             }
1317         }
1318         else {
1319             dright = POPn;
1320             right_neg = dright < 0;
1321             if (right_neg)
1322                 dright = -dright;
1323             if (dright < UV_MAX_P1) {
1324                 right = U_V(dright);
1325                 dright_valid = TRUE; /* In case we need to use double below.  */
1326             } else {
1327                 use_double = TRUE;
1328             }
1329         }
1330
1331         /* At this point use_double is only true if right is out of range for
1332            a UV.  In range NV has been rounded down to nearest UV and
1333            use_double false.  */
1334         SvIV_please(TOPs);
1335         if (!use_double && SvIOK(TOPs)) {
1336             if (SvIOK(TOPs)) {
1337                 left_neg = !SvUOK(TOPs);
1338                 if (!left_neg) {
1339                     left = SvUVX(POPs);
1340                 } else {
1341                     const IV aiv = SvIVX(POPs);
1342                     if (aiv >= 0) {
1343                         left = aiv;
1344                         left_neg = FALSE; /* effectively it's a UV now */
1345                     } else {
1346                         left = -aiv;
1347                     }
1348                 }
1349             }
1350         }
1351         else {
1352             dleft = POPn;
1353             left_neg = dleft < 0;
1354             if (left_neg)
1355                 dleft = -dleft;
1356
1357             /* This should be exactly the 5.6 behaviour - if left and right are
1358                both in range for UV then use U_V() rather than floor.  */
1359             if (!use_double) {
1360                 if (dleft < UV_MAX_P1) {
1361                     /* right was in range, so is dleft, so use UVs not double.
1362                      */
1363                     left = U_V(dleft);
1364                 }
1365                 /* left is out of range for UV, right was in range, so promote
1366                    right (back) to double.  */
1367                 else {
1368                     /* The +0.5 is used in 5.6 even though it is not strictly
1369                        consistent with the implicit +0 floor in the U_V()
1370                        inside the #if 1. */
1371                     dleft = Perl_floor(dleft + 0.5);
1372                     use_double = TRUE;
1373                     if (dright_valid)
1374                         dright = Perl_floor(dright + 0.5);
1375                     else
1376                         dright = right;
1377                 }
1378             }
1379         }
1380         if (use_double) {
1381             NV dans;
1382
1383             if (!dright)
1384                 DIE(aTHX_ "Illegal modulus zero");
1385
1386             dans = Perl_fmod(dleft, dright);
1387             if ((left_neg != right_neg) && dans)
1388                 dans = dright - dans;
1389             if (right_neg)
1390                 dans = -dans;
1391             sv_setnv(TARG, dans);
1392         }
1393         else {
1394             UV ans;
1395
1396             if (!right)
1397                 DIE(aTHX_ "Illegal modulus zero");
1398
1399             ans = left % right;
1400             if ((left_neg != right_neg) && ans)
1401                 ans = right - ans;
1402             if (right_neg) {
1403                 /* XXX may warn: unary minus operator applied to unsigned type */
1404                 /* could change -foo to be (~foo)+1 instead     */
1405                 if (ans <= ~((UV)IV_MAX)+1)
1406                     sv_setiv(TARG, ~ans+1);
1407                 else
1408                     sv_setnv(TARG, -(NV)ans);
1409             }
1410             else
1411                 sv_setuv(TARG, ans);
1412         }
1413         PUSHTARG;
1414         RETURN;
1415     }
1416 }
1417
1418 PP(pp_repeat)
1419 {
1420   dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1421   {
1422     register IV count;
1423     dPOPss;
1424     SvGETMAGIC(sv);
1425     if (SvIOKp(sv)) {
1426          if (SvUOK(sv)) {
1427               const UV uv = SvUV(sv);
1428               if (uv > IV_MAX)
1429                    count = IV_MAX; /* The best we can do? */
1430               else
1431                    count = uv;
1432          } else {
1433               const IV iv = SvIV(sv);
1434               if (iv < 0)
1435                    count = 0;
1436               else
1437                    count = iv;
1438          }
1439     }
1440     else if (SvNOKp(sv)) {
1441          const NV nv = SvNV(sv);
1442          if (nv < 0.0)
1443               count = 0;
1444          else
1445               count = (IV)nv;
1446     }
1447     else
1448          count = SvIVx(sv);
1449     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1450         dMARK;
1451         static const char oom_list_extend[] = "Out of memory during list extend";
1452         const I32 items = SP - MARK;
1453         const I32 max = items * count;
1454
1455         MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1456         /* Did the max computation overflow? */
1457         if (items > 0 && max > 0 && (max < items || max < count))
1458            Perl_croak(aTHX_ oom_list_extend);
1459         MEXTEND(MARK, max);
1460         if (count > 1) {
1461             while (SP > MARK) {
1462 #if 0
1463               /* This code was intended to fix 20010809.028:
1464
1465                  $x = 'abcd';
1466                  for (($x =~ /./g) x 2) {
1467                      print chop; # "abcdabcd" expected as output.
1468                  }
1469
1470                * but that change (#11635) broke this code:
1471
1472                $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1473
1474                * I can't think of a better fix that doesn't introduce
1475                * an efficiency hit by copying the SVs. The stack isn't
1476                * refcounted, and mortalisation obviously doesn't
1477                * Do The Right Thing when the stack has more than
1478                * one pointer to the same mortal value.
1479                * .robin.
1480                */
1481                 if (*SP) {
1482                     *SP = sv_2mortal(newSVsv(*SP));
1483                     SvREADONLY_on(*SP);
1484                 }
1485 #else
1486                if (*SP)
1487                    SvTEMP_off((*SP));
1488 #endif
1489                 SP--;
1490             }
1491             MARK++;
1492             repeatcpy((char*)(MARK + items), (char*)MARK,
1493                 items * sizeof(SV*), count - 1);
1494             SP += max;
1495         }
1496         else if (count <= 0)
1497             SP -= items;
1498     }
1499     else {      /* Note: mark already snarfed by pp_list */
1500         SV * const tmpstr = POPs;
1501         STRLEN len;
1502         bool isutf;
1503         static const char oom_string_extend[] =
1504           "Out of memory during string extend";
1505
1506         SvSetSV(TARG, tmpstr);
1507         SvPV_force(TARG, len);
1508         isutf = DO_UTF8(TARG);
1509         if (count != 1) {
1510             if (count < 1)
1511                 SvCUR_set(TARG, 0);
1512             else {
1513                 const STRLEN max = (UV)count * len;
1514                 if (len > ((MEM_SIZE)~0)/count)
1515                      Perl_croak(aTHX_ oom_string_extend);
1516                 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1517                 SvGROW(TARG, max + 1);
1518                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1519                 SvCUR_set(TARG, SvCUR(TARG) * count);
1520             }
1521             *SvEND(TARG) = '\0';
1522         }
1523         if (isutf)
1524             (void)SvPOK_only_UTF8(TARG);
1525         else
1526             (void)SvPOK_only(TARG);
1527
1528         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1529             /* The parser saw this as a list repeat, and there
1530                are probably several items on the stack. But we're
1531                in scalar context, and there's no pp_list to save us
1532                now. So drop the rest of the items -- robin@kitsite.com
1533              */
1534             dMARK;
1535             SP = MARK;
1536         }
1537         PUSHTARG;
1538     }
1539     RETURN;
1540   }
1541 }
1542
1543 PP(pp_subtract)
1544 {
1545     dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1546     useleft = USE_LEFT(TOPm1s);
1547 #ifdef PERL_PRESERVE_IVUV
1548     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1549        "bad things" happen if you rely on signed integers wrapping.  */
1550     SvIV_please(TOPs);
1551     if (SvIOK(TOPs)) {
1552         /* Unless the left argument is integer in range we are going to have to
1553            use NV maths. Hence only attempt to coerce the right argument if
1554            we know the left is integer.  */
1555         register UV auv = 0;
1556         bool auvok = FALSE;
1557         bool a_valid = 0;
1558
1559         if (!useleft) {
1560             auv = 0;
1561             a_valid = auvok = 1;
1562             /* left operand is undef, treat as zero.  */
1563         } else {
1564             /* Left operand is defined, so is it IV? */
1565             SvIV_please(TOPm1s);
1566             if (SvIOK(TOPm1s)) {
1567                 if ((auvok = SvUOK(TOPm1s)))
1568                     auv = SvUVX(TOPm1s);
1569                 else {
1570                     register const IV aiv = SvIVX(TOPm1s);
1571                     if (aiv >= 0) {
1572                         auv = aiv;
1573                         auvok = 1;      /* Now acting as a sign flag.  */
1574                     } else { /* 2s complement assumption for IV_MIN */
1575                         auv = (UV)-aiv;
1576                     }
1577                 }
1578                 a_valid = 1;
1579             }
1580         }
1581         if (a_valid) {
1582             bool result_good = 0;
1583             UV result;
1584             register UV buv;
1585             bool buvok = SvUOK(TOPs);
1586         
1587             if (buvok)
1588                 buv = SvUVX(TOPs);
1589             else {
1590                 register const IV biv = SvIVX(TOPs);
1591                 if (biv >= 0) {
1592                     buv = biv;
1593                     buvok = 1;
1594                 } else
1595                     buv = (UV)-biv;
1596             }
1597             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1598                else "IV" now, independent of how it came in.
1599                if a, b represents positive, A, B negative, a maps to -A etc
1600                a - b =>  (a - b)
1601                A - b => -(a + b)
1602                a - B =>  (a + b)
1603                A - B => -(a - b)
1604                all UV maths. negate result if A negative.
1605                subtract if signs same, add if signs differ. */
1606
1607             if (auvok ^ buvok) {
1608                 /* Signs differ.  */
1609                 result = auv + buv;
1610                 if (result >= auv)
1611                     result_good = 1;
1612             } else {
1613                 /* Signs same */
1614                 if (auv >= buv) {
1615                     result = auv - buv;
1616                     /* Must get smaller */
1617                     if (result <= auv)
1618                         result_good = 1;
1619                 } else {
1620                     result = buv - auv;
1621                     if (result <= buv) {
1622                         /* result really should be -(auv-buv). as its negation
1623                            of true value, need to swap our result flag  */
1624                         auvok = !auvok;
1625                         result_good = 1;
1626                     }
1627                 }
1628             }
1629             if (result_good) {
1630                 SP--;
1631                 if (auvok)
1632                     SETu( result );
1633                 else {
1634                     /* Negate result */
1635                     if (result <= (UV)IV_MIN)
1636                         SETi( -(IV)result );
1637                     else {
1638                         /* result valid, but out of range for IV.  */
1639                         SETn( -(NV)result );
1640                     }
1641                 }
1642                 RETURN;
1643             } /* Overflow, drop through to NVs.  */
1644         }
1645     }
1646 #endif
1647     useleft = USE_LEFT(TOPm1s);
1648     {
1649         dPOPnv;
1650         if (!useleft) {
1651             /* left operand is undef, treat as zero - value */
1652             SETn(-value);
1653             RETURN;
1654         }
1655         SETn( TOPn - value );
1656         RETURN;
1657     }
1658 }
1659
1660 PP(pp_left_shift)
1661 {
1662     dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1663     {
1664       const IV shift = POPi;
1665       if (PL_op->op_private & HINT_INTEGER) {
1666         const IV i = TOPi;
1667         SETi(i << shift);
1668       }
1669       else {
1670         const UV u = TOPu;
1671         SETu(u << shift);
1672       }
1673       RETURN;
1674     }
1675 }
1676
1677 PP(pp_right_shift)
1678 {
1679     dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1680     {
1681       const IV shift = POPi;
1682       if (PL_op->op_private & HINT_INTEGER) {
1683         const IV i = TOPi;
1684         SETi(i >> shift);
1685       }
1686       else {
1687         const UV u = TOPu;
1688         SETu(u >> shift);
1689       }
1690       RETURN;
1691     }
1692 }
1693
1694 PP(pp_lt)
1695 {
1696     dVAR; dSP; tryAMAGICbinSET(lt,0);
1697 #ifdef PERL_PRESERVE_IVUV
1698     SvIV_please(TOPs);
1699     if (SvIOK(TOPs)) {
1700         SvIV_please(TOPm1s);
1701         if (SvIOK(TOPm1s)) {
1702             bool auvok = SvUOK(TOPm1s);
1703             bool buvok = SvUOK(TOPs);
1704         
1705             if (!auvok && !buvok) { /* ## IV < IV ## */
1706                 const IV aiv = SvIVX(TOPm1s);
1707                 const IV biv = SvIVX(TOPs);
1708                 
1709                 SP--;
1710                 SETs(boolSV(aiv < biv));
1711                 RETURN;
1712             }
1713             if (auvok && buvok) { /* ## UV < UV ## */
1714                 const UV auv = SvUVX(TOPm1s);
1715                 const UV buv = SvUVX(TOPs);
1716                 
1717                 SP--;
1718                 SETs(boolSV(auv < buv));
1719                 RETURN;
1720             }
1721             if (auvok) { /* ## UV < IV ## */
1722                 UV auv;
1723                 const IV biv = SvIVX(TOPs);
1724                 SP--;
1725                 if (biv < 0) {
1726                     /* As (a) is a UV, it's >=0, so it cannot be < */
1727                     SETs(&PL_sv_no);
1728                     RETURN;
1729                 }
1730                 auv = SvUVX(TOPs);
1731                 SETs(boolSV(auv < (UV)biv));
1732                 RETURN;
1733             }
1734             { /* ## IV < UV ## */
1735                 const IV aiv = SvIVX(TOPm1s);
1736                 UV buv;
1737                 
1738                 if (aiv < 0) {
1739                     /* As (b) is a UV, it's >=0, so it must be < */
1740                     SP--;
1741                     SETs(&PL_sv_yes);
1742                     RETURN;
1743                 }
1744                 buv = SvUVX(TOPs);
1745                 SP--;
1746                 SETs(boolSV((UV)aiv < buv));
1747                 RETURN;
1748             }
1749         }
1750     }
1751 #endif
1752 #ifndef NV_PRESERVES_UV
1753 #ifdef PERL_PRESERVE_IVUV
1754     else
1755 #endif
1756     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1757         SP--;
1758         SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1759         RETURN;
1760     }
1761 #endif
1762     {
1763 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1764       dPOPTOPnnrl;
1765       if (Perl_isnan(left) || Perl_isnan(right))
1766           RETSETNO;
1767       SETs(boolSV(left < right));
1768 #else
1769       dPOPnv;
1770       SETs(boolSV(TOPn < value));
1771 #endif
1772       RETURN;
1773     }
1774 }
1775
1776 PP(pp_gt)
1777 {
1778     dVAR; dSP; tryAMAGICbinSET(gt,0);
1779 #ifdef PERL_PRESERVE_IVUV
1780     SvIV_please(TOPs);
1781     if (SvIOK(TOPs)) {
1782         SvIV_please(TOPm1s);
1783         if (SvIOK(TOPm1s)) {
1784             bool auvok = SvUOK(TOPm1s);
1785             bool buvok = SvUOK(TOPs);
1786         
1787             if (!auvok && !buvok) { /* ## IV > IV ## */
1788                 const IV aiv = SvIVX(TOPm1s);
1789                 const IV biv = SvIVX(TOPs);
1790
1791                 SP--;
1792                 SETs(boolSV(aiv > biv));
1793                 RETURN;
1794             }
1795             if (auvok && buvok) { /* ## UV > UV ## */
1796                 const UV auv = SvUVX(TOPm1s);
1797                 const UV buv = SvUVX(TOPs);
1798                 
1799                 SP--;
1800                 SETs(boolSV(auv > buv));
1801                 RETURN;
1802             }
1803             if (auvok) { /* ## UV > IV ## */
1804                 UV auv;
1805                 const IV biv = SvIVX(TOPs);
1806
1807                 SP--;
1808                 if (biv < 0) {
1809                     /* As (a) is a UV, it's >=0, so it must be > */
1810                     SETs(&PL_sv_yes);
1811                     RETURN;
1812                 }
1813                 auv = SvUVX(TOPs);
1814                 SETs(boolSV(auv > (UV)biv));
1815                 RETURN;
1816             }
1817             { /* ## IV > UV ## */
1818                 const IV aiv = SvIVX(TOPm1s);
1819                 UV buv;
1820                 
1821                 if (aiv < 0) {
1822                     /* As (b) is a UV, it's >=0, so it cannot be > */
1823                     SP--;
1824                     SETs(&PL_sv_no);
1825                     RETURN;
1826                 }
1827                 buv = SvUVX(TOPs);
1828                 SP--;
1829                 SETs(boolSV((UV)aiv > buv));
1830                 RETURN;
1831             }
1832         }
1833     }
1834 #endif
1835 #ifndef NV_PRESERVES_UV
1836 #ifdef PERL_PRESERVE_IVUV
1837     else
1838 #endif
1839     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1840         SP--;
1841         SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1842         RETURN;
1843     }
1844 #endif
1845     {
1846 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1847       dPOPTOPnnrl;
1848       if (Perl_isnan(left) || Perl_isnan(right))
1849           RETSETNO;
1850       SETs(boolSV(left > right));
1851 #else
1852       dPOPnv;
1853       SETs(boolSV(TOPn > value));
1854 #endif
1855       RETURN;
1856     }
1857 }
1858
1859 PP(pp_le)
1860 {
1861     dVAR; dSP; tryAMAGICbinSET(le,0);
1862 #ifdef PERL_PRESERVE_IVUV
1863     SvIV_please(TOPs);
1864     if (SvIOK(TOPs)) {
1865         SvIV_please(TOPm1s);
1866         if (SvIOK(TOPm1s)) {
1867             bool auvok = SvUOK(TOPm1s);
1868             bool buvok = SvUOK(TOPs);
1869         
1870             if (!auvok && !buvok) { /* ## IV <= IV ## */
1871                 const IV aiv = SvIVX(TOPm1s);
1872                 const IV biv = SvIVX(TOPs);
1873                 
1874                 SP--;
1875                 SETs(boolSV(aiv <= biv));
1876                 RETURN;
1877             }
1878             if (auvok && buvok) { /* ## UV <= UV ## */
1879                 UV auv = SvUVX(TOPm1s);
1880                 UV buv = SvUVX(TOPs);
1881                 
1882                 SP--;
1883                 SETs(boolSV(auv <= buv));
1884                 RETURN;
1885             }
1886             if (auvok) { /* ## UV <= IV ## */
1887                 UV auv;
1888                 const IV biv = SvIVX(TOPs);
1889
1890                 SP--;
1891                 if (biv < 0) {
1892                     /* As (a) is a UV, it's >=0, so a cannot be <= */
1893                     SETs(&PL_sv_no);
1894                     RETURN;
1895                 }
1896                 auv = SvUVX(TOPs);
1897                 SETs(boolSV(auv <= (UV)biv));
1898                 RETURN;
1899             }
1900             { /* ## IV <= UV ## */
1901                 const IV aiv = SvIVX(TOPm1s);
1902                 UV buv;
1903
1904                 if (aiv < 0) {
1905                     /* As (b) is a UV, it's >=0, so a must be <= */
1906                     SP--;
1907                     SETs(&PL_sv_yes);
1908                     RETURN;
1909                 }
1910                 buv = SvUVX(TOPs);
1911                 SP--;
1912                 SETs(boolSV((UV)aiv <= buv));
1913                 RETURN;
1914             }
1915         }
1916     }
1917 #endif
1918 #ifndef NV_PRESERVES_UV
1919 #ifdef PERL_PRESERVE_IVUV
1920     else
1921 #endif
1922     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1923         SP--;
1924         SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1925         RETURN;
1926     }
1927 #endif
1928     {
1929 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1930       dPOPTOPnnrl;
1931       if (Perl_isnan(left) || Perl_isnan(right))
1932           RETSETNO;
1933       SETs(boolSV(left <= right));
1934 #else
1935       dPOPnv;
1936       SETs(boolSV(TOPn <= value));
1937 #endif
1938       RETURN;
1939     }
1940 }
1941
1942 PP(pp_ge)
1943 {
1944     dVAR; dSP; tryAMAGICbinSET(ge,0);
1945 #ifdef PERL_PRESERVE_IVUV
1946     SvIV_please(TOPs);
1947     if (SvIOK(TOPs)) {
1948         SvIV_please(TOPm1s);
1949         if (SvIOK(TOPm1s)) {
1950             bool auvok = SvUOK(TOPm1s);
1951             bool buvok = SvUOK(TOPs);
1952         
1953             if (!auvok && !buvok) { /* ## IV >= IV ## */
1954                 const IV aiv = SvIVX(TOPm1s);
1955                 const IV biv = SvIVX(TOPs);
1956
1957                 SP--;
1958                 SETs(boolSV(aiv >= biv));
1959                 RETURN;
1960             }
1961             if (auvok && buvok) { /* ## UV >= UV ## */
1962                 const UV auv = SvUVX(TOPm1s);
1963                 const UV buv = SvUVX(TOPs);
1964
1965                 SP--;
1966                 SETs(boolSV(auv >= buv));
1967                 RETURN;
1968             }
1969             if (auvok) { /* ## UV >= IV ## */
1970                 UV auv;
1971                 const IV biv = SvIVX(TOPs);
1972
1973                 SP--;
1974                 if (biv < 0) {
1975                     /* As (a) is a UV, it's >=0, so it must be >= */
1976                     SETs(&PL_sv_yes);
1977                     RETURN;
1978                 }
1979                 auv = SvUVX(TOPs);
1980                 SETs(boolSV(auv >= (UV)biv));
1981                 RETURN;
1982             }
1983             { /* ## IV >= UV ## */
1984                 const IV aiv = SvIVX(TOPm1s);
1985                 UV buv;
1986
1987                 if (aiv < 0) {
1988                     /* As (b) is a UV, it's >=0, so a cannot be >= */
1989                     SP--;
1990                     SETs(&PL_sv_no);
1991                     RETURN;
1992                 }
1993                 buv = SvUVX(TOPs);
1994                 SP--;
1995                 SETs(boolSV((UV)aiv >= buv));
1996                 RETURN;
1997             }
1998         }
1999     }
2000 #endif
2001 #ifndef NV_PRESERVES_UV
2002 #ifdef PERL_PRESERVE_IVUV
2003     else
2004 #endif
2005     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2006         SP--;
2007         SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2008         RETURN;
2009     }
2010 #endif
2011     {
2012 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2013       dPOPTOPnnrl;
2014       if (Perl_isnan(left) || Perl_isnan(right))
2015           RETSETNO;
2016       SETs(boolSV(left >= right));
2017 #else
2018       dPOPnv;
2019       SETs(boolSV(TOPn >= value));
2020 #endif
2021       RETURN;
2022     }
2023 }
2024
2025 PP(pp_ne)
2026 {
2027     dVAR; dSP; tryAMAGICbinSET(ne,0);
2028 #ifndef NV_PRESERVES_UV
2029     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2030         SP--;
2031         SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2032         RETURN;
2033     }
2034 #endif
2035 #ifdef PERL_PRESERVE_IVUV
2036     SvIV_please(TOPs);
2037     if (SvIOK(TOPs)) {
2038         SvIV_please(TOPm1s);
2039         if (SvIOK(TOPm1s)) {
2040             const bool auvok = SvUOK(TOPm1s);
2041             const bool buvok = SvUOK(TOPs);
2042         
2043             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2044                 /* Casting IV to UV before comparison isn't going to matter
2045                    on 2s complement. On 1s complement or sign&magnitude
2046                    (if we have any of them) it could make negative zero
2047                    differ from normal zero. As I understand it. (Need to
2048                    check - is negative zero implementation defined behaviour
2049                    anyway?). NWC  */
2050                 const UV buv = SvUVX(POPs);
2051                 const UV auv = SvUVX(TOPs);
2052
2053                 SETs(boolSV(auv != buv));
2054                 RETURN;
2055             }
2056             {                   /* ## Mixed IV,UV ## */
2057                 IV iv;
2058                 UV uv;
2059                 
2060                 /* != is commutative so swap if needed (save code) */
2061                 if (auvok) {
2062                     /* swap. top of stack (b) is the iv */
2063                     iv = SvIVX(TOPs);
2064                     SP--;
2065                     if (iv < 0) {
2066                         /* As (a) is a UV, it's >0, so it cannot be == */
2067                         SETs(&PL_sv_yes);
2068                         RETURN;
2069                     }
2070                     uv = SvUVX(TOPs);
2071                 } else {
2072                     iv = SvIVX(TOPm1s);
2073                     SP--;
2074                     if (iv < 0) {
2075                         /* As (b) is a UV, it's >0, so it cannot be == */
2076                         SETs(&PL_sv_yes);
2077                         RETURN;
2078                     }
2079                     uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2080                 }
2081                 SETs(boolSV((UV)iv != uv));
2082                 RETURN;
2083             }
2084         }
2085     }
2086 #endif
2087     {
2088 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2089       dPOPTOPnnrl;
2090       if (Perl_isnan(left) || Perl_isnan(right))
2091           RETSETYES;
2092       SETs(boolSV(left != right));
2093 #else
2094       dPOPnv;
2095       SETs(boolSV(TOPn != value));
2096 #endif
2097       RETURN;
2098     }
2099 }
2100
2101 PP(pp_ncmp)
2102 {
2103     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2104 #ifndef NV_PRESERVES_UV
2105     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2106         const UV right = PTR2UV(SvRV(POPs));
2107         const UV left = PTR2UV(SvRV(TOPs));
2108         SETi((left > right) - (left < right));
2109         RETURN;
2110     }
2111 #endif
2112 #ifdef PERL_PRESERVE_IVUV
2113     /* Fortunately it seems NaN isn't IOK */
2114     SvIV_please(TOPs);
2115     if (SvIOK(TOPs)) {
2116         SvIV_please(TOPm1s);
2117         if (SvIOK(TOPm1s)) {
2118             const bool leftuvok = SvUOK(TOPm1s);
2119             const bool rightuvok = SvUOK(TOPs);
2120             I32 value;
2121             if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2122                 const IV leftiv = SvIVX(TOPm1s);
2123                 const IV rightiv = SvIVX(TOPs);
2124                 
2125                 if (leftiv > rightiv)
2126                     value = 1;
2127                 else if (leftiv < rightiv)
2128                     value = -1;
2129                 else
2130                     value = 0;
2131             } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2132                 const UV leftuv = SvUVX(TOPm1s);
2133                 const UV rightuv = SvUVX(TOPs);
2134                 
2135                 if (leftuv > rightuv)
2136                     value = 1;
2137                 else if (leftuv < rightuv)
2138                     value = -1;
2139                 else
2140                     value = 0;
2141             } else if (leftuvok) { /* ## UV <=> IV ## */
2142                 const IV rightiv = SvIVX(TOPs);
2143                 if (rightiv < 0) {
2144                     /* As (a) is a UV, it's >=0, so it cannot be < */
2145                     value = 1;
2146                 } else {
2147                     const UV leftuv = SvUVX(TOPm1s);
2148                     if (leftuv > (UV)rightiv) {
2149                         value = 1;
2150                     } else if (leftuv < (UV)rightiv) {
2151                         value = -1;
2152                     } else {
2153                         value = 0;
2154                     }
2155                 }
2156             } else { /* ## IV <=> UV ## */
2157                 const IV leftiv = SvIVX(TOPm1s);
2158                 if (leftiv < 0) {
2159                     /* As (b) is a UV, it's >=0, so it must be < */
2160                     value = -1;
2161                 } else {
2162                     const UV rightuv = SvUVX(TOPs);
2163                     if ((UV)leftiv > rightuv) {
2164                         value = 1;
2165                     } else if ((UV)leftiv < rightuv) {
2166                         value = -1;
2167                     } else {
2168                         value = 0;
2169                     }
2170                 }
2171             }
2172             SP--;
2173             SETi(value);
2174             RETURN;
2175         }
2176     }
2177 #endif
2178     {
2179       dPOPTOPnnrl;
2180       I32 value;
2181
2182 #ifdef Perl_isnan
2183       if (Perl_isnan(left) || Perl_isnan(right)) {
2184           SETs(&PL_sv_undef);
2185           RETURN;
2186        }
2187       value = (left > right) - (left < right);
2188 #else
2189       if (left == right)
2190         value = 0;
2191       else if (left < right)
2192         value = -1;
2193       else if (left > right)
2194         value = 1;
2195       else {
2196         SETs(&PL_sv_undef);
2197         RETURN;
2198       }
2199 #endif
2200       SETi(value);
2201       RETURN;
2202     }
2203 }
2204
2205 PP(pp_sle)
2206 {
2207     dVAR; dSP;
2208
2209     int amg_type = sle_amg;
2210     int multiplier = 1;
2211     int rhs = 1;
2212
2213     switch (PL_op->op_type) {
2214     case OP_SLT:
2215         amg_type = slt_amg;
2216         /* cmp < 0 */
2217         rhs = 0;
2218         break;
2219     case OP_SGT:
2220         amg_type = sgt_amg;
2221         /* cmp > 0 */
2222         multiplier = -1;
2223         rhs = 0;
2224         break;
2225     case OP_SGE:
2226         amg_type = sge_amg;
2227         /* cmp >= 0 */
2228         multiplier = -1;
2229         break;
2230     }
2231
2232     tryAMAGICbinSET_var(amg_type,0);
2233     {
2234       dPOPTOPssrl;
2235       const int cmp = (IN_LOCALE_RUNTIME
2236                  ? sv_cmp_locale(left, right)
2237                  : sv_cmp(left, right));
2238       SETs(boolSV(cmp * multiplier < rhs));
2239       RETURN;
2240     }
2241 }
2242
2243 PP(pp_seq)
2244 {
2245     dVAR; dSP; tryAMAGICbinSET(seq,0);
2246     {
2247       dPOPTOPssrl;
2248       SETs(boolSV(sv_eq(left, right)));
2249       RETURN;
2250     }
2251 }
2252
2253 PP(pp_sne)
2254 {
2255     dVAR; dSP; tryAMAGICbinSET(sne,0);
2256     {
2257       dPOPTOPssrl;
2258       SETs(boolSV(!sv_eq(left, right)));
2259       RETURN;
2260     }
2261 }
2262
2263 PP(pp_scmp)
2264 {
2265     dVAR; dSP; dTARGET;  tryAMAGICbin(scmp,0);
2266     {
2267       dPOPTOPssrl;
2268       const int cmp = (IN_LOCALE_RUNTIME
2269                  ? sv_cmp_locale(left, right)
2270                  : sv_cmp(left, right));
2271       SETi( cmp );
2272       RETURN;
2273     }
2274 }
2275
2276 PP(pp_bit_and)
2277 {
2278     dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2279     {
2280       dPOPTOPssrl;
2281       SvGETMAGIC(left);
2282       SvGETMAGIC(right);
2283       if (SvNIOKp(left) || SvNIOKp(right)) {
2284         if (PL_op->op_private & HINT_INTEGER) {
2285           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2286           SETi(i);
2287         }
2288         else {
2289           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2290           SETu(u);
2291         }
2292       }
2293       else {
2294         do_vop(PL_op->op_type, TARG, left, right);
2295         SETTARG;
2296       }
2297       RETURN;
2298     }
2299 }
2300
2301 PP(pp_bit_or)
2302 {
2303     dVAR; dSP; dATARGET;
2304     const int op_type = PL_op->op_type;
2305
2306     tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2307     {
2308       dPOPTOPssrl;
2309       SvGETMAGIC(left);
2310       SvGETMAGIC(right);
2311       if (SvNIOKp(left) || SvNIOKp(right)) {
2312         if (PL_op->op_private & HINT_INTEGER) {
2313           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2314           const IV r = SvIV_nomg(right);
2315           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2316           SETi(result);
2317         }
2318         else {
2319           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2320           const UV r = SvUV_nomg(right);
2321           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2322           SETu(result);
2323         }
2324       }
2325       else {
2326         do_vop(op_type, TARG, left, right);
2327         SETTARG;
2328       }
2329       RETURN;
2330     }
2331 }
2332
2333 PP(pp_negate)
2334 {
2335     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2336     {
2337         dTOPss;
2338         const int flags = SvFLAGS(sv);
2339         SvGETMAGIC(sv);
2340         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2341             /* It's publicly an integer, or privately an integer-not-float */
2342         oops_its_an_int:
2343             if (SvIsUV(sv)) {
2344                 if (SvIVX(sv) == IV_MIN) {
2345                     /* 2s complement assumption. */
2346                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2347                     RETURN;
2348                 }
2349                 else if (SvUVX(sv) <= IV_MAX) {
2350                     SETi(-SvIVX(sv));
2351                     RETURN;
2352                 }
2353             }
2354             else if (SvIVX(sv) != IV_MIN) {
2355                 SETi(-SvIVX(sv));
2356                 RETURN;
2357             }
2358 #ifdef PERL_PRESERVE_IVUV
2359             else {
2360                 SETu((UV)IV_MIN);
2361                 RETURN;
2362             }
2363 #endif
2364         }
2365         if (SvNIOKp(sv))
2366             SETn(-SvNV(sv));
2367         else if (SvPOKp(sv)) {
2368             STRLEN len;
2369             const char * const s = SvPV_const(sv, len);
2370             if (isIDFIRST(*s)) {
2371                 sv_setpvn(TARG, "-", 1);
2372                 sv_catsv(TARG, sv);
2373             }
2374             else if (*s == '+' || *s == '-') {
2375                 sv_setsv(TARG, sv);
2376                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2377             }
2378             else if (DO_UTF8(sv)) {
2379                 SvIV_please(sv);
2380                 if (SvIOK(sv))
2381                     goto oops_its_an_int;
2382                 if (SvNOK(sv))
2383                     sv_setnv(TARG, -SvNV(sv));
2384                 else {
2385                     sv_setpvn(TARG, "-", 1);
2386                     sv_catsv(TARG, sv);
2387                 }
2388             }
2389             else {
2390                 SvIV_please(sv);
2391                 if (SvIOK(sv))
2392                   goto oops_its_an_int;
2393                 sv_setnv(TARG, -SvNV(sv));
2394             }
2395             SETTARG;
2396         }
2397         else
2398             SETn(-SvNV(sv));
2399     }
2400     RETURN;
2401 }
2402
2403 PP(pp_not)
2404 {
2405     dVAR; dSP; tryAMAGICunSET(not);
2406     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2407     return NORMAL;
2408 }
2409
2410 PP(pp_complement)
2411 {
2412     dVAR; dSP; dTARGET; tryAMAGICun(compl);
2413     {
2414       dTOPss;
2415       SvGETMAGIC(sv);
2416       if (SvNIOKp(sv)) {
2417         if (PL_op->op_private & HINT_INTEGER) {
2418           const IV i = ~SvIV_nomg(sv);
2419           SETi(i);
2420         }
2421         else {
2422           const UV u = ~SvUV_nomg(sv);
2423           SETu(u);
2424         }
2425       }
2426       else {
2427         register U8 *tmps;
2428         register I32 anum;
2429         STRLEN len;
2430
2431         (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2432         sv_setsv_nomg(TARG, sv);
2433         tmps = (U8*)SvPV_force(TARG, len);
2434         anum = len;
2435         if (SvUTF8(TARG)) {
2436           /* Calculate exact length, let's not estimate. */
2437           STRLEN targlen = 0;
2438           STRLEN l;
2439           UV nchar = 0;
2440           UV nwide = 0;
2441           U8 * const send = tmps + len;
2442           U8 * const origtmps = tmps;
2443           const UV utf8flags = UTF8_ALLOW_ANYUV;
2444
2445           while (tmps < send) {
2446             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2447             tmps += l;
2448             targlen += UNISKIP(~c);
2449             nchar++;
2450             if (c > 0xff)
2451                 nwide++;
2452           }
2453
2454           /* Now rewind strings and write them. */
2455           tmps = origtmps;
2456
2457           if (nwide) {
2458               U8 *result;
2459               U8 *p;
2460
2461               Newx(result, targlen + 1, U8);
2462               p = result;
2463               while (tmps < send) {
2464                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2465                   tmps += l;
2466                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2467               }
2468               *p = '\0';
2469               sv_usepvn_flags(TARG, (char*)result, targlen,
2470                               SV_HAS_TRAILING_NUL);
2471               SvUTF8_on(TARG);
2472           }
2473           else {
2474               U8 *result;
2475               U8 *p;
2476
2477               Newx(result, nchar + 1, U8);
2478               p = result;
2479               while (tmps < send) {
2480                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2481                   tmps += l;
2482                   *p++ = ~c;
2483               }
2484               *p = '\0';
2485               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2486               SvUTF8_off(TARG);
2487           }
2488           SETs(TARG);
2489           RETURN;
2490         }
2491 #ifdef LIBERAL
2492         {
2493             register long *tmpl;
2494             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2495                 *tmps = ~*tmps;
2496             tmpl = (long*)tmps;
2497             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2498                 *tmpl = ~*tmpl;
2499             tmps = (U8*)tmpl;
2500         }
2501 #endif
2502         for ( ; anum > 0; anum--, tmps++)
2503             *tmps = ~*tmps;
2504
2505         SETs(TARG);
2506       }
2507       RETURN;
2508     }
2509 }
2510
2511 /* integer versions of some of the above */
2512
2513 PP(pp_i_multiply)
2514 {
2515     dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2516     {
2517       dPOPTOPiirl;
2518       SETi( left * right );
2519       RETURN;
2520     }
2521 }
2522
2523 PP(pp_i_divide)
2524 {
2525     IV num;
2526     dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2527     {
2528       dPOPiv;
2529       if (value == 0)
2530           DIE(aTHX_ "Illegal division by zero");
2531       num = POPi;
2532
2533       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2534       if (value == -1)
2535           value = - num;
2536       else
2537           value = num / value;
2538       PUSHi( value );
2539       RETURN;
2540     }
2541 }
2542
2543 STATIC
2544 PP(pp_i_modulo_0)
2545 {
2546      /* This is the vanilla old i_modulo. */
2547      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2548      {
2549           dPOPTOPiirl;
2550           if (!right)
2551                DIE(aTHX_ "Illegal modulus zero");
2552           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2553           if (right == -1)
2554               SETi( 0 );
2555           else
2556               SETi( left % right );
2557           RETURN;
2558      }
2559 }
2560
2561 #if defined(__GLIBC__) && IVSIZE == 8
2562 STATIC
2563 PP(pp_i_modulo_1)
2564 {
2565      /* This is the i_modulo with the workaround for the _moddi3 bug
2566       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2567       * See below for pp_i_modulo. */
2568      dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2569      {
2570           dPOPTOPiirl;
2571           if (!right)
2572                DIE(aTHX_ "Illegal modulus zero");
2573           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2574           if (right == -1)
2575               SETi( 0 );
2576           else
2577               SETi( left % PERL_ABS(right) );
2578           RETURN;
2579      }
2580 }
2581 #endif
2582
2583 PP(pp_i_modulo)
2584 {
2585      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2586      {
2587           dPOPTOPiirl;
2588           if (!right)
2589                DIE(aTHX_ "Illegal modulus zero");
2590           /* The assumption is to use hereafter the old vanilla version... */
2591           PL_op->op_ppaddr =
2592                PL_ppaddr[OP_I_MODULO] =
2593                    Perl_pp_i_modulo_0;
2594           /* .. but if we have glibc, we might have a buggy _moddi3
2595            * (at least glicb 2.2.5 is known to have this bug), in other
2596            * words our integer modulus with negative quad as the second
2597            * argument might be broken.  Test for this and re-patch the
2598            * opcode dispatch table if that is the case, remembering to
2599            * also apply the workaround so that this first round works
2600            * right, too.  See [perl #9402] for more information. */
2601 #if defined(__GLIBC__) && IVSIZE == 8
2602           {
2603                IV l =   3;
2604                IV r = -10;
2605                /* Cannot do this check with inlined IV constants since
2606                 * that seems to work correctly even with the buggy glibc. */
2607                if (l % r == -3) {
2608                     /* Yikes, we have the bug.
2609                      * Patch in the workaround version. */
2610                     PL_op->op_ppaddr =
2611                          PL_ppaddr[OP_I_MODULO] =
2612                              &Perl_pp_i_modulo_1;
2613                     /* Make certain we work right this time, too. */
2614                     right = PERL_ABS(right);
2615                }
2616           }
2617 #endif
2618           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2619           if (right == -1)
2620               SETi( 0 );
2621           else
2622               SETi( left % right );
2623           RETURN;
2624      }
2625 }
2626
2627 PP(pp_i_add)
2628 {
2629     dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2630     {
2631       dPOPTOPiirl_ul;
2632       SETi( left + right );
2633       RETURN;
2634     }
2635 }
2636
2637 PP(pp_i_subtract)
2638 {
2639     dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2640     {
2641       dPOPTOPiirl_ul;
2642       SETi( left - right );
2643       RETURN;
2644     }
2645 }
2646
2647 PP(pp_i_lt)
2648 {
2649     dVAR; dSP; tryAMAGICbinSET(lt,0);
2650     {
2651       dPOPTOPiirl;
2652       SETs(boolSV(left < right));
2653       RETURN;
2654     }
2655 }
2656
2657 PP(pp_i_gt)
2658 {
2659     dVAR; dSP; tryAMAGICbinSET(gt,0);
2660     {
2661       dPOPTOPiirl;
2662       SETs(boolSV(left > right));
2663       RETURN;
2664     }
2665 }
2666
2667 PP(pp_i_le)
2668 {
2669     dVAR; dSP; tryAMAGICbinSET(le,0);
2670     {
2671       dPOPTOPiirl;
2672       SETs(boolSV(left <= right));
2673       RETURN;
2674     }
2675 }
2676
2677 PP(pp_i_ge)
2678 {
2679     dVAR; dSP; tryAMAGICbinSET(ge,0);
2680     {
2681       dPOPTOPiirl;
2682       SETs(boolSV(left >= right));
2683       RETURN;
2684     }
2685 }
2686
2687 PP(pp_i_eq)
2688 {
2689     dVAR; dSP; tryAMAGICbinSET(eq,0);
2690     {
2691       dPOPTOPiirl;
2692       SETs(boolSV(left == right));
2693       RETURN;
2694     }
2695 }
2696
2697 PP(pp_i_ne)
2698 {
2699     dVAR; dSP; tryAMAGICbinSET(ne,0);
2700     {
2701       dPOPTOPiirl;
2702       SETs(boolSV(left != right));
2703       RETURN;
2704     }
2705 }
2706
2707 PP(pp_i_ncmp)
2708 {
2709     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2710     {
2711       dPOPTOPiirl;
2712       I32 value;
2713
2714       if (left > right)
2715         value = 1;
2716       else if (left < right)
2717         value = -1;
2718       else
2719         value = 0;
2720       SETi(value);
2721       RETURN;
2722     }
2723 }
2724
2725 PP(pp_i_negate)
2726 {
2727     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2728     SETi(-TOPi);
2729     RETURN;
2730 }
2731
2732 /* High falutin' math. */
2733
2734 PP(pp_atan2)
2735 {
2736     dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2737     {
2738       dPOPTOPnnrl;
2739       SETn(Perl_atan2(left, right));
2740       RETURN;
2741     }
2742 }
2743
2744 PP(pp_sin)
2745 {
2746     dVAR; dSP; dTARGET;
2747     int amg_type = sin_amg;
2748     const char *neg_report = NULL;
2749     NV (*func)(NV) = Perl_sin;
2750     const int op_type = PL_op->op_type;
2751
2752     switch (op_type) {
2753     case OP_COS:
2754         amg_type = cos_amg;
2755         func = Perl_cos;
2756         break;
2757     case OP_EXP:
2758         amg_type = exp_amg;
2759         func = Perl_exp;
2760         break;
2761     case OP_LOG:
2762         amg_type = log_amg;
2763         func = Perl_log;
2764         neg_report = "log";
2765         break;
2766     case OP_SQRT:
2767         amg_type = sqrt_amg;
2768         func = Perl_sqrt;
2769         neg_report = "sqrt";
2770         break;
2771     }
2772
2773     tryAMAGICun_var(amg_type);
2774     {
2775       const NV value = POPn;
2776       if (neg_report) {
2777           if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2778               SET_NUMERIC_STANDARD();
2779               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2780           }
2781       }
2782       XPUSHn(func(value));
2783       RETURN;
2784     }
2785 }
2786
2787 /* Support Configure command-line overrides for rand() functions.
2788    After 5.005, perhaps we should replace this by Configure support
2789    for drand48(), random(), or rand().  For 5.005, though, maintain
2790    compatibility by calling rand() but allow the user to override it.
2791    See INSTALL for details.  --Andy Dougherty  15 July 1998
2792 */
2793 /* Now it's after 5.005, and Configure supports drand48() and random(),
2794    in addition to rand().  So the overrides should not be needed any more.
2795    --Jarkko Hietaniemi  27 September 1998
2796  */
2797
2798 #ifndef HAS_DRAND48_PROTO
2799 extern double drand48 (void);
2800 #endif
2801
2802 PP(pp_rand)
2803 {
2804     dVAR; dSP; dTARGET;
2805     NV value;
2806     if (MAXARG < 1)
2807         value = 1.0;
2808     else
2809         value = POPn;
2810     if (value == 0.0)
2811         value = 1.0;
2812     if (!PL_srand_called) {
2813         (void)seedDrand01((Rand_seed_t)seed());
2814         PL_srand_called = TRUE;
2815     }
2816     value *= Drand01();
2817     XPUSHn(value);
2818     RETURN;
2819 }
2820
2821 PP(pp_srand)
2822 {
2823     dVAR; dSP;
2824     const UV anum = (MAXARG < 1) ? seed() : POPu;
2825     (void)seedDrand01((Rand_seed_t)anum);
2826     PL_srand_called = TRUE;
2827     EXTEND(SP, 1);
2828     RETPUSHYES;
2829 }
2830
2831 PP(pp_int)
2832 {
2833     dVAR; dSP; dTARGET; tryAMAGICun(int);
2834     {
2835       const IV iv = TOPi; /* attempt to convert to IV if possible. */
2836       /* XXX it's arguable that compiler casting to IV might be subtly
2837          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2838          else preferring IV has introduced a subtle behaviour change bug. OTOH
2839          relying on floating point to be accurate is a bug.  */
2840
2841       if (!SvOK(TOPs))
2842         SETu(0);
2843       else if (SvIOK(TOPs)) {
2844         if (SvIsUV(TOPs)) {
2845             const UV uv = TOPu;
2846             SETu(uv);
2847         } else
2848             SETi(iv);
2849       } else {
2850           const NV value = TOPn;
2851           if (value >= 0.0) {
2852               if (value < (NV)UV_MAX + 0.5) {
2853                   SETu(U_V(value));
2854               } else {
2855                   SETn(Perl_floor(value));
2856               }
2857           }
2858           else {
2859               if (value > (NV)IV_MIN - 0.5) {
2860                   SETi(I_V(value));
2861               } else {
2862                   SETn(Perl_ceil(value));
2863               }
2864           }
2865       }
2866     }
2867     RETURN;
2868 }
2869
2870 PP(pp_abs)
2871 {
2872     dVAR; dSP; dTARGET; tryAMAGICun(abs);
2873     {
2874       /* This will cache the NV value if string isn't actually integer  */
2875       const IV iv = TOPi;
2876
2877       if (!SvOK(TOPs))
2878         SETu(0);
2879       else if (SvIOK(TOPs)) {
2880         /* IVX is precise  */
2881         if (SvIsUV(TOPs)) {
2882           SETu(TOPu);   /* force it to be numeric only */
2883         } else {
2884           if (iv >= 0) {
2885             SETi(iv);
2886           } else {
2887             if (iv != IV_MIN) {
2888               SETi(-iv);
2889             } else {
2890               /* 2s complement assumption. Also, not really needed as
2891                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2892               SETu(IV_MIN);
2893             }
2894           }
2895         }
2896       } else{
2897         const NV value = TOPn;
2898         if (value < 0.0)
2899           SETn(-value);
2900         else
2901           SETn(value);
2902       }
2903     }
2904     RETURN;
2905 }
2906
2907 PP(pp_oct)
2908 {
2909     dVAR; dSP; dTARGET;
2910     const char *tmps;
2911     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2912     STRLEN len;
2913     NV result_nv;
2914     UV result_uv;
2915     SV* const sv = POPs;
2916
2917     tmps = (SvPV_const(sv, len));
2918     if (DO_UTF8(sv)) {
2919          /* If Unicode, try to downgrade
2920           * If not possible, croak. */
2921          SV* const tsv = sv_2mortal(newSVsv(sv));
2922         
2923          SvUTF8_on(tsv);
2924          sv_utf8_downgrade(tsv, FALSE);
2925          tmps = SvPV_const(tsv, len);
2926     }
2927     if (PL_op->op_type == OP_HEX)
2928         goto hex;
2929
2930     while (*tmps && len && isSPACE(*tmps))
2931         tmps++, len--;
2932     if (*tmps == '0')
2933         tmps++, len--;
2934     if (*tmps == 'x') {
2935     hex:
2936         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2937     }
2938     else if (*tmps == 'b')
2939         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2940     else
2941         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2942
2943     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2944         XPUSHn(result_nv);
2945     }
2946     else {
2947         XPUSHu(result_uv);
2948     }
2949     RETURN;
2950 }
2951
2952 /* String stuff. */
2953
2954 PP(pp_length)
2955 {
2956     dVAR; dSP; dTARGET;
2957     SV * const sv = TOPs;
2958
2959     if (SvAMAGIC(sv)) {
2960         /* For an overloaded scalar, we can't know in advance if it's going to
2961            be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
2962            cache the length. Maybe that should be a documented feature of it.
2963         */
2964         STRLEN len;
2965         const char *const p = SvPV_const(sv, len);
2966
2967         if (DO_UTF8(sv)) {
2968             SETi(utf8_length((U8*)p, (U8*)p + len));
2969         }
2970         else
2971             SETi(len);
2972
2973     }
2974     else if (DO_UTF8(sv))
2975         SETi(sv_len_utf8(sv));
2976     else
2977         SETi(sv_len(sv));
2978     RETURN;
2979 }
2980
2981 PP(pp_substr)
2982 {
2983     dVAR; dSP; dTARGET;
2984     SV *sv;
2985     I32 len = 0;
2986     STRLEN curlen;
2987     STRLEN utf8_curlen;
2988     I32 pos;
2989     I32 rem;
2990     I32 fail;
2991     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2992     const char *tmps;
2993     const I32 arybase = CopARYBASE_get(PL_curcop);
2994     SV *repl_sv = NULL;
2995     const char *repl = NULL;
2996     STRLEN repl_len;
2997     const int num_args = PL_op->op_private & 7;
2998     bool repl_need_utf8_upgrade = FALSE;
2999     bool repl_is_utf8 = FALSE;
3000
3001     SvTAINTED_off(TARG);                        /* decontaminate */
3002     SvUTF8_off(TARG);                           /* decontaminate */
3003     if (num_args > 2) {
3004         if (num_args > 3) {
3005             repl_sv = POPs;
3006             repl = SvPV_const(repl_sv, repl_len);
3007             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3008         }
3009         len = POPi;
3010     }
3011     pos = POPi;
3012     sv = POPs;
3013     PUTBACK;
3014     if (repl_sv) {
3015         if (repl_is_utf8) {
3016             if (!DO_UTF8(sv))
3017                 sv_utf8_upgrade(sv);
3018         }
3019         else if (DO_UTF8(sv))
3020             repl_need_utf8_upgrade = TRUE;
3021     }
3022     tmps = SvPV_const(sv, curlen);
3023     if (DO_UTF8(sv)) {
3024         utf8_curlen = sv_len_utf8(sv);
3025         if (utf8_curlen == curlen)
3026             utf8_curlen = 0;
3027         else
3028             curlen = utf8_curlen;
3029     }
3030     else
3031         utf8_curlen = 0;
3032
3033     if (pos >= arybase) {
3034         pos -= arybase;
3035         rem = curlen-pos;
3036         fail = rem;
3037         if (num_args > 2) {
3038             if (len < 0) {
3039                 rem += len;
3040                 if (rem < 0)
3041                     rem = 0;
3042             }
3043             else if (rem > len)
3044                      rem = len;
3045         }
3046     }
3047     else {
3048         pos += curlen;
3049         if (num_args < 3)
3050             rem = curlen;
3051         else if (len >= 0) {
3052             rem = pos+len;
3053             if (rem > (I32)curlen)
3054                 rem = curlen;
3055         }
3056         else {
3057             rem = curlen+len;
3058             if (rem < pos)
3059                 rem = pos;
3060         }
3061         if (pos < 0)
3062             pos = 0;
3063         fail = rem;
3064         rem -= pos;
3065     }
3066     if (fail < 0) {
3067         if (lvalue || repl)
3068             Perl_croak(aTHX_ "substr outside of string");
3069         if (ckWARN(WARN_SUBSTR))
3070             Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3071         RETPUSHUNDEF;
3072     }
3073     else {
3074         const I32 upos = pos;
3075         const I32 urem = rem;
3076         if (utf8_curlen)
3077             sv_pos_u2b(sv, &pos, &rem);
3078         tmps += pos;
3079         /* we either return a PV or an LV. If the TARG hasn't been used
3080          * before, or is of that type, reuse it; otherwise use a mortal
3081          * instead. Note that LVs can have an extended lifetime, so also
3082          * dont reuse if refcount > 1 (bug #20933) */
3083         if (SvTYPE(TARG) > SVt_NULL) {
3084             if ( (SvTYPE(TARG) == SVt_PVLV)
3085                     ? (!lvalue || SvREFCNT(TARG) > 1)
3086                     : lvalue)
3087             {
3088                 TARG = sv_newmortal();
3089             }
3090         }
3091
3092         sv_setpvn(TARG, tmps, rem);
3093 #ifdef USE_LOCALE_COLLATE
3094         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3095 #endif
3096         if (utf8_curlen)
3097             SvUTF8_on(TARG);
3098         if (repl) {
3099             SV* repl_sv_copy = NULL;
3100
3101             if (repl_need_utf8_upgrade) {
3102                 repl_sv_copy = newSVsv(repl_sv);
3103                 sv_utf8_upgrade(repl_sv_copy);
3104                 repl = SvPV_const(repl_sv_copy, repl_len);
3105                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3106             }
3107             sv_insert(sv, pos, rem, repl, repl_len);
3108             if (repl_is_utf8)
3109                 SvUTF8_on(sv);
3110             if (repl_sv_copy)
3111                 SvREFCNT_dec(repl_sv_copy);
3112         }
3113         else if (lvalue) {              /* it's an lvalue! */
3114             if (!SvGMAGICAL(sv)) {
3115                 if (SvROK(sv)) {
3116                     SvPV_force_nolen(sv);
3117                     if (ckWARN(WARN_SUBSTR))
3118                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3119                                 "Attempt to use reference as lvalue in substr");
3120                 }
3121                 if (isGV_with_GP(sv))
3122                     SvPV_force_nolen(sv);
3123                 else if (SvOK(sv))      /* is it defined ? */
3124                     (void)SvPOK_only_UTF8(sv);
3125                 else
3126                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3127             }
3128
3129             if (SvTYPE(TARG) < SVt_PVLV) {
3130                 sv_upgrade(TARG, SVt_PVLV);
3131                 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3132             }
3133
3134             LvTYPE(TARG) = 'x';
3135             if (LvTARG(TARG) != sv) {
3136                 if (LvTARG(TARG))
3137                     SvREFCNT_dec(LvTARG(TARG));
3138                 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3139             }
3140             LvTARGOFF(TARG) = upos;
3141             LvTARGLEN(TARG) = urem;
3142         }
3143     }
3144     SPAGAIN;
3145     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3146     RETURN;
3147 }
3148
3149 PP(pp_vec)
3150 {
3151     dVAR; dSP; dTARGET;
3152     register const IV size   = POPi;
3153     register const IV offset = POPi;
3154     register SV * const src = POPs;
3155     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3156
3157     SvTAINTED_off(TARG);                /* decontaminate */
3158     if (lvalue) {                       /* it's an lvalue! */
3159         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3160             TARG = sv_newmortal();
3161         if (SvTYPE(TARG) < SVt_PVLV) {
3162             sv_upgrade(TARG, SVt_PVLV);
3163             sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3164         }
3165         LvTYPE(TARG) = 'v';
3166         if (LvTARG(TARG) != src) {
3167             if (LvTARG(TARG))
3168                 SvREFCNT_dec(LvTARG(TARG));
3169             LvTARG(TARG) = SvREFCNT_inc_simple(src);
3170         }
3171         LvTARGOFF(TARG) = offset;
3172         LvTARGLEN(TARG) = size;
3173     }
3174
3175     sv_setuv(TARG, do_vecget(src, offset, size));
3176     PUSHs(TARG);
3177     RETURN;
3178 }
3179
3180 PP(pp_index)
3181 {
3182     dVAR; dSP; dTARGET;
3183     SV *big;
3184     SV *little;
3185     SV *temp = NULL;
3186     STRLEN biglen;
3187     STRLEN llen = 0;
3188     I32 offset;
3189     I32 retval;
3190     const char *big_p;
3191     const char *little_p;
3192     const I32 arybase = CopARYBASE_get(PL_curcop);
3193     bool big_utf8;
3194     bool little_utf8;
3195     const bool is_index = PL_op->op_type == OP_INDEX;
3196
3197     if (MAXARG >= 3) {
3198         /* arybase is in characters, like offset, so combine prior to the
3199            UTF-8 to bytes calculation.  */
3200         offset = POPi - arybase;
3201     }
3202     little = POPs;
3203     big = POPs;
3204     big_p = SvPV_const(big, biglen);
3205     little_p = SvPV_const(little, llen);
3206
3207     big_utf8 = DO_UTF8(big);
3208     little_utf8 = DO_UTF8(little);
3209     if (big_utf8 ^ little_utf8) {
3210         /* One needs to be upgraded.  */
3211         if (little_utf8 && !PL_encoding) {
3212             /* Well, maybe instead we might be able to downgrade the small
3213                string?  */
3214             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3215                                                      &little_utf8);
3216             if (little_utf8) {
3217                 /* If the large string is ISO-8859-1, and it's not possible to
3218                    convert the small string to ISO-8859-1, then there is no
3219                    way that it could be found anywhere by index.  */
3220                 retval = -1;
3221                 goto fail;
3222             }
3223
3224             /* At this point, pv is a malloc()ed string. So donate it to temp
3225                to ensure it will get free()d  */
3226             little = temp = newSV(0);
3227             sv_usepvn(temp, pv, llen);
3228             little_p = SvPVX(little);
3229         } else {
3230             temp = little_utf8
3231                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3232
3233             if (PL_encoding) {
3234                 sv_recode_to_utf8(temp, PL_encoding);
3235             } else {
3236                 sv_utf8_upgrade(temp);
3237             }
3238             if (little_utf8) {
3239                 big = temp;
3240                 big_utf8 = TRUE;
3241                 big_p = SvPV_const(big, biglen);
3242             } else {
3243                 little = temp;
3244                 little_p = SvPV_const(little, llen);
3245             }
3246         }
3247     }
3248     if (SvGAMAGIC(big)) {
3249         /* Life just becomes a lot easier if I use a temporary here.
3250            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3251            will trigger magic and overloading again, as will fbm_instr()
3252         */
3253         big = sv_2mortal(newSVpvn(big_p, biglen));
3254         if (big_utf8)
3255             SvUTF8_on(big);
3256         big_p = SvPVX(big);
3257     }
3258     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3259         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3260            warn on undef, and we've already triggered a warning with the
3261            SvPV_const some lines above. We can't remove that, as we need to
3262            call some SvPV to trigger overloading early and find out if the
3263            string is UTF-8.
3264            This is all getting to messy. The API isn't quite clean enough,
3265            because data access has side effects.
3266         */
3267         little = sv_2mortal(newSVpvn(little_p, llen));
3268         if (little_utf8)
3269             SvUTF8_on(little);
3270         little_p = SvPVX(little);
3271     }
3272
3273     if (MAXARG < 3)
3274         offset = is_index ? 0 : biglen;
3275     else {
3276         if (big_utf8 && offset > 0)
3277             sv_pos_u2b(big, &offset, 0);
3278         if (!is_index)
3279             offset += llen;
3280     }
3281     if (offset < 0)
3282         offset = 0;
3283     else if (offset > (I32)biglen)
3284         offset = biglen;
3285     if (!(little_p = is_index
3286           ? fbm_instr((unsigned char*)big_p + offset,
3287                       (unsigned char*)big_p + biglen, little, 0)
3288           : rninstr(big_p,  big_p  + offset,
3289                     little_p, little_p + llen)))
3290         retval = -1;
3291     else {
3292         retval = little_p - big_p;
3293         if (retval > 0 && big_utf8)
3294             sv_pos_b2u(big, &retval);
3295     }
3296     if (temp)
3297         SvREFCNT_dec(temp);
3298  fail:
3299     PUSHi(retval + arybase);
3300     RETURN;
3301 }
3302
3303 PP(pp_sprintf)
3304 {
3305     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3306     do_sprintf(TARG, SP-MARK, MARK+1);
3307     TAINT_IF(SvTAINTED(TARG));
3308     SP = ORIGMARK;
3309     PUSHTARG;
3310     RETURN;
3311 }
3312
3313 PP(pp_ord)
3314 {
3315     dVAR; dSP; dTARGET;
3316
3317     SV *argsv = POPs;
3318     STRLEN len;
3319     const U8 *s = (U8*)SvPV_const(argsv, len);
3320
3321     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3322         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3323         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3324         argsv = tmpsv;
3325     }
3326
3327     XPUSHu(DO_UTF8(argsv) ?
3328            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3329            (*s & 0xff));
3330
3331     RETURN;
3332 }
3333
3334 PP(pp_chr)
3335 {
3336     dVAR; dSP; dTARGET;
3337     char *tmps;
3338     UV value;
3339
3340     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3341          ||
3342          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3343         if (IN_BYTES) {
3344             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3345         } else {
3346             (void) POPs; /* Ignore the argument value. */
3347             value = UNICODE_REPLACEMENT;
3348         }
3349     } else {
3350         value = POPu;
3351     }
3352
3353     SvUPGRADE(TARG,SVt_PV);
3354
3355     if (value > 255 && !IN_BYTES) {
3356         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3357         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3358         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3359         *tmps = '\0';
3360         (void)SvPOK_only(TARG);
3361         SvUTF8_on(TARG);
3362         XPUSHs(TARG);
3363         RETURN;
3364     }
3365
3366     SvGROW(TARG,2);
3367     SvCUR_set(TARG, 1);
3368     tmps = SvPVX(TARG);
3369     *tmps++ = (char)value;
3370     *tmps = '\0';
3371     (void)SvPOK_only(TARG);
3372
3373     if (PL_encoding && !IN_BYTES) {
3374         sv_recode_to_utf8(TARG, PL_encoding);
3375         tmps = SvPVX(TARG);
3376         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3377             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3378             SvGROW(TARG, 2);
3379             tmps = SvPVX(TARG);
3380             SvCUR_set(TARG, 1);
3381             *tmps++ = (char)value;
3382             *tmps = '\0';
3383             SvUTF8_off(TARG);
3384         }
3385     }
3386
3387     XPUSHs(TARG);
3388     RETURN;
3389 }
3390
3391 PP(pp_crypt)
3392 {
3393 #ifdef HAS_CRYPT
3394     dVAR; dSP; dTARGET;
3395     dPOPTOPssrl;
3396     STRLEN len;
3397     const char *tmps = SvPV_const(left, len);
3398
3399     if (DO_UTF8(left)) {
3400          /* If Unicode, try to downgrade.
3401           * If not possible, croak.
3402           * Yes, we made this up.  */
3403          SV* const tsv = sv_2mortal(newSVsv(left));
3404
3405          SvUTF8_on(tsv);
3406          sv_utf8_downgrade(tsv, FALSE);
3407          tmps = SvPV_const(tsv, len);
3408     }
3409 #   ifdef USE_ITHREADS
3410 #     ifdef HAS_CRYPT_R
3411     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3412       /* This should be threadsafe because in ithreads there is only
3413        * one thread per interpreter.  If this would not be true,
3414        * we would need a mutex to protect this malloc. */
3415         PL_reentrant_buffer->_crypt_struct_buffer =
3416           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3417 #if defined(__GLIBC__) || defined(__EMX__)
3418         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3419             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3420             /* work around glibc-2.2.5 bug */
3421             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3422         }
3423 #endif
3424     }
3425 #     endif /* HAS_CRYPT_R */
3426 #   endif /* USE_ITHREADS */
3427 #   ifdef FCRYPT
3428     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3429 #   else
3430     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3431 #   endif
3432     SETs(TARG);
3433     RETURN;
3434 #else
3435     DIE(aTHX_
3436       "The crypt() function is unimplemented due to excessive paranoia.");
3437 #endif
3438 }
3439
3440 PP(pp_ucfirst)
3441 {
3442     dVAR;
3443     dSP;
3444     SV *source = TOPs;
3445     STRLEN slen;
3446     STRLEN need;
3447     SV *dest;
3448     bool inplace = TRUE;
3449     bool doing_utf8;
3450     const int op_type = PL_op->op_type;
3451     const U8 *s;
3452     U8 *d;
3453     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3454     STRLEN ulen;
3455     STRLEN tculen;
3456
3457     SvGETMAGIC(source);
3458     if (SvOK(source)) {
3459         s = (const U8*)SvPV_nomg_const(source, slen);
3460     } else {
3461         s = (const U8*)"";
3462         slen = 0;
3463     }
3464
3465     if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3466         doing_utf8 = TRUE;
3467         utf8_to_uvchr(s, &ulen);
3468         if (op_type == OP_UCFIRST) {
3469             toTITLE_utf8(s, tmpbuf, &tculen);
3470         } else {
3471             toLOWER_utf8(s, tmpbuf, &tculen);
3472         }
3473         /* If the two differ, we definately cannot do inplace.  */
3474         inplace = (ulen == tculen);
3475         need = slen + 1 - ulen + tculen;
3476     } else {
3477         doing_utf8 = FALSE;
3478         need = slen + 1;
3479     }
3480
3481     if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3482         /* We can convert in place.  */
3483
3484         dest = source;
3485         s = d = (U8*)SvPV_force_nomg(source, slen);
3486     } else {
3487         dTARGET;
3488
3489         dest = TARG;
3490
3491         SvUPGRADE(dest, SVt_PV);
3492         d = (U8*)SvGROW(dest, need);
3493         (void)SvPOK_only(dest);
3494
3495         SETs(dest);
3496
3497         inplace = FALSE;
3498     }
3499
3500     if (doing_utf8) {
3501         if(!inplace) {
3502             /* slen is the byte length of the whole SV.
3503              * ulen is the byte length of the original Unicode character
3504              * stored as UTF-8 at s.
3505              * tculen is the byte length of the freshly titlecased (or
3506              * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3507              * We first set the result to be the titlecased (/lowercased)
3508              * character, and then append the rest of the SV data. */
3509             sv_setpvn(dest, (char*)tmpbuf, tculen);
3510             if (slen > ulen)
3511                 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3512             SvUTF8_on(dest);
3513         }
3514         else {
3515             Copy(tmpbuf, d, tculen, U8);
3516             SvCUR_set(dest, need - 1);
3517         }
3518     }
3519     else {
3520         if (*s) {
3521             if (IN_LOCALE_RUNTIME) {
3522                 TAINT;
3523                 SvTAINTED_on(dest);
3524                 *d = (op_type == OP_UCFIRST)
3525                     ? toUPPER_LC(*s) : toLOWER_LC(*s);
3526             }
3527             else
3528                 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3529         } else {
3530             /* See bug #39028  */
3531             *d = *s;
3532         }
3533
3534         if (SvUTF8(source))
3535             SvUTF8_on(dest);
3536
3537         if (!inplace) {
3538             /* This will copy the trailing NUL  */
3539             Copy(s + 1, d + 1, slen, U8);
3540             SvCUR_set(dest, need - 1);
3541         }
3542     }
3543     SvSETMAGIC(dest);
3544     RETURN;
3545 }
3546
3547 /* There's so much setup/teardown code common between uc and lc, I wonder if
3548    it would be worth merging the two, and just having a switch outside each
3549    of the three tight loops.  */
3550 PP(pp_uc)
3551 {
3552     dVAR;
3553     dSP;
3554     SV *source = TOPs;
3555     STRLEN len;
3556     STRLEN min;
3557     SV *dest;
3558     const U8 *s;
3559     U8 *d;
3560
3561     SvGETMAGIC(source);
3562
3563     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3564         && !DO_UTF8(source)) {
3565         /* We can convert in place.  */
3566
3567         dest = source;
3568         s = d = (U8*)SvPV_force_nomg(source, len);
3569         min = len + 1;
3570     } else {
3571         dTARGET;
3572
3573         dest = TARG;
3574
3575         /* The old implementation would copy source into TARG at this point.
3576            This had the side effect that if source was undef, TARG was now
3577            an undefined SV with PADTMP set, and they don't warn inside
3578            sv_2pv_flags(). However, we're now getting the PV direct from
3579            source, which doesn't have PADTMP set, so it would warn. Hence the
3580            little games.  */
3581
3582         if (SvOK(source)) {
3583             s = (const U8*)SvPV_nomg_const(source, len);
3584         } else {
3585             s = (const U8*)"";
3586             len = 0;
3587         }
3588         min = len + 1;
3589
3590         SvUPGRADE(dest, SVt_PV);
3591         d = (U8*)SvGROW(dest, min);
3592         (void)SvPOK_only(dest);
3593
3594         SETs(dest);
3595     }
3596
3597     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3598        to check DO_UTF8 again here.  */
3599
3600     if (DO_UTF8(source)) {
3601         const U8 *const send = s + len;
3602         U8 tmpbuf[UTF8_MAXBYTES+1];
3603
3604         while (s < send) {
3605             const STRLEN u = UTF8SKIP(s);
3606             STRLEN ulen;
3607
3608             toUPPER_utf8(s, tmpbuf, &ulen);
3609             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3610                 /* If the eventually required minimum size outgrows
3611                  * the available space, we need to grow. */
3612                 const UV o = d - (U8*)SvPVX_const(dest);
3613
3614                 /* If someone uppercases one million U+03B0s we SvGROW() one
3615                  * million times.  Or we could try guessing how much to
3616                  allocate without allocating too much.  Such is life. */
3617                 SvGROW(dest, min);
3618                 d = (U8*)SvPVX(dest) + o;
3619             }
3620             Copy(tmpbuf, d, ulen, U8);
3621             d += ulen;
3622             s += u;
3623         }
3624         SvUTF8_on(dest);
3625         *d = '\0';
3626         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3627     } else {
3628         if (len) {
3629             const U8 *const send = s + len;
3630             if (IN_LOCALE_RUNTIME) {
3631                 TAINT;
3632                 SvTAINTED_on(dest);
3633                 for (; s < send; d++, s++)
3634                     *d = toUPPER_LC(*s);
3635             }
3636             else {
3637                 for (; s < send; d++, s++)
3638                     *d = toUPPER(*s);
3639             }
3640         }
3641         if (source != dest) {
3642             *d = '\0';
3643             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3644         }
3645     }
3646     SvSETMAGIC(dest);
3647     RETURN;
3648 }
3649
3650 PP(pp_lc)
3651 {
3652     dVAR;
3653     dSP;
3654     SV *source = TOPs;
3655     STRLEN len;
3656     STRLEN min;
3657     SV *dest;
3658     const U8 *s;
3659     U8 *d;
3660
3661     SvGETMAGIC(source);
3662
3663     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3664         && !DO_UTF8(source)) {
3665         /* We can convert in place.  */
3666
3667         dest = source;
3668         s = d = (U8*)SvPV_force_nomg(source, len);
3669         min = len + 1;
3670     } else {
3671         dTARGET;
3672
3673         dest = TARG;
3674
3675         /* The old implementation would copy source into TARG at this point.
3676            This had the side effect that if source was undef, TARG was now
3677            an undefined SV with PADTMP set, and they don't warn inside
3678            sv_2pv_flags(). However, we're now getting the PV direct from
3679            source, which doesn't have PADTMP set, so it would warn. Hence the
3680            little games.  */
3681
3682         if (SvOK(source)) {
3683             s = (const U8*)SvPV_nomg_const(source, len);
3684         } else {
3685             s = (const U8*)"";
3686             len = 0;
3687         }
3688         min = len + 1;
3689
3690         SvUPGRADE(dest, SVt_PV);
3691         d = (U8*)SvGROW(dest, min);
3692         (void)SvPOK_only(dest);
3693
3694         SETs(dest);
3695     }
3696
3697     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3698        to check DO_UTF8 again here.  */
3699
3700     if (DO_UTF8(source)) {
3701         const U8 *const send = s + len;
3702         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3703
3704         while (s < send) {
3705             const STRLEN u = UTF8SKIP(s);
3706             STRLEN ulen;
3707             const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3708
3709 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3710             if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3711                 NOOP;
3712                 /*
3713                  * Now if the sigma is NOT followed by
3714                  * /$ignorable_sequence$cased_letter/;
3715                  * and it IS preceded by /$cased_letter$ignorable_sequence/;
3716                  * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3717                  * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3718                  * then it should be mapped to 0x03C2,
3719                  * (GREEK SMALL LETTER FINAL SIGMA),
3720                  * instead of staying 0x03A3.
3721                  * "should be": in other words, this is not implemented yet.
3722                  * See lib/unicore/SpecialCasing.txt.
3723                  */
3724             }
3725             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3726                 /* If the eventually required minimum size outgrows
3727                  * the available space, we need to grow. */
3728                 const UV o = d - (U8*)SvPVX_const(dest);
3729
3730                 /* If someone lowercases one million U+0130s we SvGROW() one
3731                  * million times.  Or we could try guessing how much to
3732                  allocate without allocating too much.  Such is life. */
3733                 SvGROW(dest, min);
3734                 d = (U8*)SvPVX(dest) + o;
3735             }
3736             Copy(tmpbuf, d, ulen, U8);
3737             d += ulen;
3738             s += u;
3739         }
3740         SvUTF8_on(dest);
3741         *d = '\0';
3742         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3743     } else {
3744         if (len) {
3745             const U8 *const send = s + len;
3746             if (IN_LOCALE_RUNTIME) {
3747                 TAINT;
3748                 SvTAINTED_on(dest);
3749                 for (; s < send; d++, s++)
3750                     *d = toLOWER_LC(*s);
3751             }
3752             else {
3753                 for (; s < send; d++, s++)
3754                     *d = toLOWER(*s);
3755             }
3756         }
3757         if (source != dest) {
3758             *d = '\0';
3759             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3760         }
3761     }
3762     SvSETMAGIC(dest);
3763     RETURN;
3764 }
3765
3766 PP(pp_quotemeta)
3767 {
3768     dVAR; dSP; dTARGET;
3769     SV * const sv = TOPs;
3770     STRLEN len;
3771     register const char *s = SvPV_const(sv,len);
3772
3773     SvUTF8_off(TARG);                           /* decontaminate */
3774     if (len) {
3775         register char *d;
3776         SvUPGRADE(TARG, SVt_PV);
3777         SvGROW(TARG, (len * 2) + 1);
3778         d = SvPVX(TARG);
3779         if (DO_UTF8(sv)) {
3780             while (len) {
3781                 if (UTF8_IS_CONTINUED(*s)) {
3782                     STRLEN ulen = UTF8SKIP(s);
3783                     if (ulen > len)
3784                         ulen = len;
3785                     len -= ulen;
3786                     while (ulen--)
3787                         *d++ = *s++;
3788                 }
3789                 else {
3790                     if (!isALNUM(*s))
3791                         *d++ = '\\';
3792                     *d++ = *s++;
3793                     len--;
3794                 }
3795             }
3796             SvUTF8_on(TARG);
3797         }
3798         else {
3799             while (len--) {
3800                 if (!isALNUM(*s))
3801                     *d++ = '\\';
3802                 *d++ = *s++;
3803             }
3804         }
3805         *d = '\0';
3806         SvCUR_set(TARG, d - SvPVX_const(TARG));
3807         (void)SvPOK_only_UTF8(TARG);
3808     }
3809     else
3810         sv_setpvn(TARG, s, len);
3811     SETs(TARG);
3812     if (SvSMAGICAL(TARG))
3813         mg_set(TARG);
3814     RETURN;
3815 }
3816
3817 /* Arrays. */
3818
3819 PP(pp_aslice)
3820 {
3821     dVAR; dSP; dMARK; dORIGMARK;
3822     register AV* const av = (AV*)POPs;
3823     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3824
3825     if (SvTYPE(av) == SVt_PVAV) {
3826         const I32 arybase = CopARYBASE_get(PL_curcop);
3827         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3828             register SV **svp;
3829             I32 max = -1;
3830             for (svp = MARK + 1; svp <= SP; svp++) {
3831                 const I32 elem = SvIVx(*svp);
3832                 if (elem > max)
3833                     max = elem;
3834             }
3835             if (max > AvMAX(av))
3836                 av_extend(av, max);
3837         }
3838         while (++MARK <= SP) {
3839             register SV **svp;
3840             I32 elem = SvIVx(*MARK);
3841
3842             if (elem > 0)
3843                 elem -= arybase;
3844             svp = av_fetch(av, elem, lval);
3845             if (lval) {
3846                 if (!svp || *svp == &PL_sv_undef)
3847                     DIE(aTHX_ PL_no_aelem, elem);
3848                 if (PL_op->op_private & OPpLVAL_INTRO)
3849                     save_aelem(av, elem, svp);
3850             }
3851             *MARK = svp ? *svp : &PL_sv_undef;
3852         }
3853     }
3854     if (GIMME != G_ARRAY) {
3855         MARK = ORIGMARK;
3856         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3857         SP = MARK;
3858     }
3859     RETURN;
3860 }
3861
3862 /* Associative arrays. */
3863
3864 PP(pp_each)
3865 {
3866     dVAR;
3867     dSP;
3868     HV * hash = (HV*)POPs;
3869     HE *entry;
3870     const I32 gimme = GIMME_V;
3871
3872     PUTBACK;
3873     /* might clobber stack_sp */
3874     entry = hv_iternext(hash);
3875     SPAGAIN;
3876
3877     EXTEND(SP, 2);
3878     if (entry) {
3879         SV* const sv = hv_iterkeysv(entry);
3880         PUSHs(sv);      /* won't clobber stack_sp */
3881         if (gimme == G_ARRAY) {
3882             SV *val;
3883             PUTBACK;
3884             /* might clobber stack_sp */
3885             val = hv_iterval(hash, entry);
3886             SPAGAIN;
3887             PUSHs(val);
3888         }
3889     }
3890     else if (gimme == G_SCALAR)
3891         RETPUSHUNDEF;
3892
3893     RETURN;
3894 }
3895
3896 PP(pp_delete)
3897 {
3898     dVAR;
3899     dSP;
3900     const I32 gimme = GIMME_V;
3901     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3902
3903     if (PL_op->op_private & OPpSLICE) {
3904         dMARK; dORIGMARK;
3905         HV * const hv = (HV*)POPs;
3906         const U32 hvtype = SvTYPE(hv);
3907         if (hvtype == SVt_PVHV) {                       /* hash element */
3908             while (++MARK <= SP) {
3909                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3910                 *MARK = sv ? sv : &PL_sv_undef;
3911             }
3912         }
3913         else if (hvtype == SVt_PVAV) {                  /* array element */
3914             if (PL_op->op_flags & OPf_SPECIAL) {
3915                 while (++MARK <= SP) {
3916                     SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3917                     *MARK = sv ? sv : &PL_sv_undef;
3918                 }
3919             }
3920         }
3921         else
3922             DIE(aTHX_ "Not a HASH reference");
3923         if (discard)
3924             SP = ORIGMARK;
3925         else if (gimme == G_SCALAR) {
3926             MARK = ORIGMARK;
3927             if (SP > MARK)
3928                 *++MARK = *SP;
3929             else
3930                 *++MARK = &PL_sv_undef;
3931             SP = MARK;
3932         }
3933     }
3934     else {
3935         SV *keysv = POPs;
3936         HV * const hv = (HV*)POPs;
3937         SV *sv;
3938         if (SvTYPE(hv) == SVt_PVHV)
3939             sv = hv_delete_ent(hv, keysv, discard, 0);
3940         else if (SvTYPE(hv) == SVt_PVAV) {
3941             if (PL_op->op_flags & OPf_SPECIAL)
3942                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3943             else
3944                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3945         }
3946         else
3947             DIE(aTHX_ "Not a HASH reference");
3948         if (!sv)
3949             sv = &PL_sv_undef;
3950         if (!discard)
3951             PUSHs(sv);
3952     }
3953     RETURN;
3954 }
3955
3956 PP(pp_exists)
3957 {
3958     dVAR;
3959     dSP;
3960     SV *tmpsv;
3961     HV *hv;
3962
3963     if (PL_op->op_private & OPpEXISTS_SUB) {
3964         GV *gv;
3965         SV * const sv = POPs;
3966         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3967         if (cv)
3968             RETPUSHYES;
3969         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3970             RETPUSHYES;
3971         RETPUSHNO;
3972     }
3973     tmpsv = POPs;
3974     hv = (HV*)POPs;
3975     if (SvTYPE(hv) == SVt_PVHV) {
3976         if (hv_exists_ent(hv, tmpsv, 0))
3977             RETPUSHYES;
3978     }
3979     else if (SvTYPE(hv) == SVt_PVAV) {
3980         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3981             if (av_exists((AV*)hv, SvIV(tmpsv)))
3982                 RETPUSHYES;
3983         }
3984     }
3985     else {
3986         DIE(aTHX_ "Not a HASH reference");
3987     }
3988     RETPUSHNO;
3989 }
3990
3991 PP(pp_hslice)
3992 {
3993     dVAR; dSP; dMARK; dORIGMARK;
3994     register HV * const hv = (HV*)POPs;
3995     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3996     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3997     bool other_magic = FALSE;
3998
3999     if (localizing) {
4000         MAGIC *mg;
4001         HV *stash;
4002
4003         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4004             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4005              /* Try to preserve the existenceness of a tied hash
4006               * element by using EXISTS and DELETE if possible.
4007               * Fallback to FETCH and STORE otherwise */
4008              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4009              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4010              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4011     }
4012
4013     while (++MARK <= SP) {
4014         SV * const keysv = *MARK;
4015         SV **svp;
4016         HE *he;
4017         bool preeminent = FALSE;
4018
4019         if (localizing) {
4020             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4021                 hv_exists_ent(hv, keysv, 0);
4022         }
4023
4024         he = hv_fetch_ent(hv, keysv, lval, 0);
4025         svp = he ? &HeVAL(he) : 0;
4026
4027         if (lval) {
4028             if (!svp || *svp == &PL_sv_undef) {
4029                 DIE(aTHX_ PL_no_helem_sv, keysv);
4030             }
4031             if (localizing) {
4032                 if (HvNAME_get(hv) && isGV(*svp))
4033                     save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4034                 else {
4035                     if (preeminent)
4036                         save_helem(hv, keysv, svp);
4037                     else {
4038                         STRLEN keylen;
4039                         const char * const key = SvPV_const(keysv, keylen);
4040                         SAVEDELETE(hv, savepvn(key,keylen),
4041                                    SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4042                     }
4043                 }
4044             }
4045         }
4046         *MARK = svp ? *svp : &PL_sv_undef;
4047     }
4048     if (GIMME != G_ARRAY) {
4049         MARK = ORIGMARK;
4050         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4051         SP = MARK;
4052     }
4053     RETURN;
4054 }
4055
4056 /* List operators. */
4057
4058 PP(pp_list)
4059 {
4060     dVAR; dSP; dMARK;
4061     if (GIMME != G_ARRAY) {
4062         if (++MARK <= SP)
4063             *MARK = *SP;                /* unwanted list, return last item */
4064         else
4065             *MARK = &PL_sv_undef;
4066         SP = MARK;
4067     }
4068     RETURN;
4069 }
4070
4071 PP(pp_lslice)
4072 {
4073     dVAR;
4074     dSP;
4075     SV ** const lastrelem = PL_stack_sp;
4076     SV ** const lastlelem = PL_stack_base + POPMARK;
4077     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4078     register SV ** const firstrelem = lastlelem + 1;
4079     const I32 arybase = CopARYBASE_get(PL_curcop);
4080     I32 is_something_there = FALSE;
4081
4082     register const I32 max = lastrelem - lastlelem;
4083     register SV **lelem;
4084
4085     if (GIMME != G_ARRAY) {
4086         I32 ix = SvIVx(*lastlelem);
4087         if (ix < 0)
4088             ix += max;
4089         else
4090             ix -= arybase;
4091         if (ix < 0 || ix >= max)
4092             *firstlelem = &PL_sv_undef;
4093         else
4094             *firstlelem = firstrelem[ix];
4095         SP = firstlelem;
4096         RETURN;
4097     }
4098
4099     if (max == 0) {
4100         SP = firstlelem - 1;
4101         RETURN;
4102     }
4103
4104     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4105         I32 ix = SvIVx(*lelem);
4106         if (ix < 0)
4107             ix += max;
4108         else
4109             ix -= arybase;
4110         if (ix < 0 || ix >= max)
4111             *lelem = &PL_sv_undef;
4112         else {
4113             is_something_there = TRUE;
4114             if (!(*lelem = firstrelem[ix]))
4115                 *lelem = &PL_sv_undef;
4116         }
4117     }
4118     if (is_something_there)
4119         SP = lastlelem;
4120     else
4121         SP = firstlelem - 1;
4122     RETURN;
4123 }
4124
4125 PP(pp_anonlist)
4126 {
4127     dVAR; dSP; dMARK; dORIGMARK;
4128     const I32 items = SP - MARK;
4129     SV * const av = (SV *) av_make(items, MARK+1);
4130     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4131     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4132                       ? newRV_noinc(av) : av));
4133     RETURN;
4134 }
4135
4136 PP(pp_anonhash)
4137 {
4138     dVAR; dSP; dMARK; dORIGMARK;
4139     HV* const hv = newHV();
4140
4141     while (MARK < SP) {
4142         SV * const key = *++MARK;
4143         SV * const val = newSV(0);
4144         if (MARK < SP)
4145             sv_setsv(val, *++MARK);
4146         else if (ckWARN(WARN_MISC))
4147             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4148         (void)hv_store_ent(hv,key,val,0);
4149     }
4150     SP = ORIGMARK;
4151     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4152                       ? newRV_noinc((SV*) hv) : (SV*)hv));
4153     RETURN;
4154 }
4155
4156 PP(pp_splice)
4157 {
4158     dVAR; dSP; dMARK; dORIGMARK;
4159     register AV *ary = (AV*)*++MARK;
4160     register SV **src;
4161     register SV **dst;
4162     register I32 i;
4163     register I32 offset;
4164     register I32 length;
4165     I32 newlen;
4166     I32 after;
4167     I32 diff;
4168     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4169
4170     if (mg) {
4171         *MARK-- = SvTIED_obj((SV*)ary, mg);
4172         PUSHMARK(MARK);
4173         PUTBACK;
4174         ENTER;
4175         call_method("SPLICE",GIMME_V);
4176         LEAVE;
4177         SPAGAIN;
4178         RETURN;
4179     }
4180
4181     SP++;
4182
4183     if (++MARK < SP) {
4184         offset = i = SvIVx(*MARK);
4185         if (offset < 0)
4186             offset += AvFILLp(ary) + 1;
4187         else
4188             offset -= CopARYBASE_get(PL_curcop);
4189         if (offset < 0)
4190             DIE(aTHX_ PL_no_aelem, i);
4191         if (++MARK < SP) {
4192             length = SvIVx(*MARK++);
4193             if (length < 0) {
4194                 length += AvFILLp(ary) - offset + 1;
4195                 if (length < 0)
4196                     length = 0;
4197             }
4198         }
4199         else
4200             length = AvMAX(ary) + 1;            /* close enough to infinity */
4201     }
4202     else {
4203         offset = 0;
4204         length = AvMAX(ary) + 1;
4205     }
4206     if (offset > AvFILLp(ary) + 1) {
4207         if (ckWARN(WARN_MISC))
4208             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4209         offset = AvFILLp(ary) + 1;
4210     }
4211     after = AvFILLp(ary) + 1 - (offset + length);
4212     if (after < 0) {                            /* not that much array */
4213         length += after;                        /* offset+length now in array */
4214         after = 0;
4215         if (!AvALLOC(ary))
4216             av_extend(ary, 0);
4217     }
4218
4219     /* At this point, MARK .. SP-1 is our new LIST */
4220
4221     newlen = SP - MARK;
4222     diff = newlen - length;
4223     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4224         av_reify(ary);
4225
4226     /* make new elements SVs now: avoid problems if they're from the array */
4227     for (dst = MARK, i = newlen; i; i--) {
4228         SV * const h = *dst;
4229         *dst++ = newSVsv(h);
4230     }
4231
4232     if (diff < 0) {                             /* shrinking the area */
4233         SV **tmparyval = NULL;
4234         if (newlen) {
4235             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4236             Copy(MARK, tmparyval, newlen, SV*);
4237         }
4238
4239         MARK = ORIGMARK + 1;
4240         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4241             MEXTEND(MARK, length);
4242             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4243             if (AvREAL(ary)) {
4244                 EXTEND_MORTAL(length);
4245                 for (i = length, dst = MARK; i; i--) {
4246                     sv_2mortal(*dst);   /* free them eventualy */
4247                     dst++;
4248                 }
4249             }
4250             MARK += length - 1;
4251         }
4252         else {
4253             *MARK = AvARRAY(ary)[offset+length-1];
4254             if (AvREAL(ary)) {
4255                 sv_2mortal(*MARK);
4256                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4257                     SvREFCNT_dec(*dst++);       /* free them now */
4258             }
4259         }
4260         AvFILLp(ary) += diff;
4261
4262         /* pull up or down? */
4263
4264         if (offset < after) {                   /* easier to pull up */
4265             if (offset) {                       /* esp. if nothing to pull */
4266                 src = &AvARRAY(ary)[offset-1];
4267                 dst = src - diff;               /* diff is negative */
4268                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4269                     *dst-- = *src--;
4270             }
4271             dst = AvARRAY(ary);
4272             SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4273             AvMAX(ary) += diff;
4274         }
4275         else {
4276             if (after) {                        /* anything to pull down? */
4277                 src = AvARRAY(ary) + offset + length;
4278                 dst = src + diff;               /* diff is negative */
4279                 Move(src, dst, after, SV*);
4280             }
4281             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4282                                                 /* avoid later double free */
4283         }
4284         i = -diff;
4285         while (i)
4286             dst[--i] = &PL_sv_undef;
4287         
4288         if (newlen) {
4289             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4290             Safefree(tmparyval);
4291         }
4292     }
4293     else {                                      /* no, expanding (or same) */
4294         SV** tmparyval = NULL;
4295         if (length) {
4296             Newx(tmparyval, length, SV*);       /* so remember deletion */
4297             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4298         }
4299
4300         if (diff > 0) {                         /* expanding */
4301             /* push up or down? */
4302             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4303                 if (offset) {
4304                     src = AvARRAY(ary);
4305                     dst = src - diff;
4306                     Move(src, dst, offset, SV*);
4307                 }
4308                 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4309                 AvMAX(ary) += diff;
4310                 AvFILLp(ary) += diff;
4311             }
4312             else {
4313                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4314                     av_extend(ary, AvFILLp(ary) + diff);
4315                 AvFILLp(ary) += diff;
4316
4317                 if (after) {
4318                     dst = AvARRAY(ary) + AvFILLp(ary);
4319                     src = dst - diff;
4320                     for (i = after; i; i--) {
4321                         *dst-- = *src--;
4322                     }
4323                 }
4324             }
4325         }
4326
4327         if (newlen) {
4328             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4329         }
4330
4331         MARK = ORIGMARK + 1;
4332         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4333             if (length) {
4334                 Copy(tmparyval, MARK, length, SV*);
4335                 if (AvREAL(ary)) {
4336                     EXTEND_MORTAL(length);
4337                     for (i = length, dst = MARK; i; i--) {
4338                         sv_2mortal(*dst);       /* free them eventualy */
4339                         dst++;
4340                     }
4341                 }
4342             }
4343             MARK += length - 1;
4344         }
4345         else if (length--) {
4346             *MARK = tmparyval[length];
4347             if (AvREAL(ary)) {
4348                 sv_2mortal(*MARK);
4349                 while (length-- > 0)
4350                     SvREFCNT_dec(tmparyval[length]);
4351             }
4352         }
4353         else
4354             *MARK = &PL_sv_undef;
4355         Safefree(tmparyval);
4356     }
4357     SP = MARK;
4358     RETURN;
4359 }
4360
4361 PP(pp_push)
4362 {
4363     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4364     register AV * const ary = (AV*)*++MARK;
4365     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4366
4367     if (mg) {
4368         *MARK-- = SvTIED_obj((SV*)ary, mg);
4369         PUSHMARK(MARK);
4370         PUTBACK;
4371         ENTER;
4372         call_method("PUSH",G_SCALAR|G_DISCARD);
4373         LEAVE;
4374         SPAGAIN;
4375         SP = ORIGMARK;
4376         PUSHi( AvFILL(ary) + 1 );
4377     }
4378     else {
4379         for (++MARK; MARK <= SP; MARK++) {
4380             SV * const sv = newSV(0);
4381             if (*MARK)
4382                 sv_setsv(sv, *MARK);
4383             av_store(ary, AvFILLp(ary)+1, sv);
4384         }
4385         SP = ORIGMARK;
4386         PUSHi( AvFILLp(ary) + 1 );
4387     }
4388     RETURN;
4389 }
4390
4391 PP(pp_shift)
4392 {
4393     dVAR;
4394     dSP;
4395     AV * const av = (AV*)POPs;
4396     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4397     EXTEND(SP, 1);
4398     assert (sv);
4399     if (AvREAL(av))
4400         (void)sv_2mortal(sv);
4401     PUSHs(sv);
4402     RETURN;
4403 }
4404
4405 PP(pp_unshift)
4406 {
4407     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4408     register AV *ary = (AV*)*++MARK;
4409     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4410
4411     if (mg) {
4412         *MARK-- = SvTIED_obj((SV*)ary, mg);
4413         PUSHMARK(MARK);
4414         PUTBACK;
4415         ENTER;
4416         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4417         LEAVE;
4418         SPAGAIN;
4419     }
4420     else {
4421         register I32 i = 0;
4422         av_unshift(ary, SP - MARK);
4423         while (MARK < SP) {
4424             SV * const sv = newSVsv(*++MARK);
4425             (void)av_store(ary, i++, sv);
4426         }
4427     }
4428     SP = ORIGMARK;
4429     PUSHi( AvFILL(ary) + 1 );
4430     RETURN;
4431 }
4432
4433 PP(pp_reverse)
4434 {
4435     dVAR; dSP; dMARK;
4436     SV ** const oldsp = SP;
4437
4438     if (GIMME == G_ARRAY) {
4439         MARK++;
4440         while (MARK < SP) {
4441             register SV * const tmp = *MARK;
4442             *MARK++ = *SP;
4443             *SP-- = tmp;
4444         }
4445         /* safe as long as stack cannot get extended in the above */
4446         SP = oldsp;
4447     }
4448     else {
4449         register char *up;
4450         register char *down;
4451         register I32 tmp;
4452         dTARGET;
4453         STRLEN len;
4454         PADOFFSET padoff_du;
4455
4456         SvUTF8_off(TARG);                               /* decontaminate */
4457         if (SP - MARK > 1)
4458             do_join(TARG, &PL_sv_no, MARK, SP);
4459         else
4460             sv_setsv(TARG, (SP > MARK)
4461                     ? *SP
4462                     : (padoff_du = find_rundefsvoffset(),
4463                         (padoff_du == NOT_IN_PAD
4464                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4465                         ? DEFSV : PAD_SVl(padoff_du)));
4466         up = SvPV_force(TARG, len);
4467         if (len > 1) {
4468             if (DO_UTF8(TARG)) {        /* first reverse each character */
4469                 U8* s = (U8*)SvPVX(TARG);
4470                 const U8* send = (U8*)(s + len);
4471                 while (s < send) {
4472                     if (UTF8_IS_INVARIANT(*s)) {
4473                         s++;
4474                         continue;
4475                     }
4476                     else {
4477                         if (!utf8_to_uvchr(s, 0))
4478                             break;
4479                         up = (char*)s;
4480                         s += UTF8SKIP(s);
4481                         down = (char*)(s - 1);
4482                         /* reverse this character */
4483                         while (down > up) {
4484                             tmp = *up;
4485                             *up++ = *down;
4486                             *down-- = (char)tmp;
4487                         }
4488                     }
4489                 }
4490                 up = SvPVX(TARG);
4491             }
4492             down = SvPVX(TARG) + len - 1;
4493             while (down > up) {
4494                 tmp = *up;
4495                 *up++ = *down;
4496                 *down-- = (char)tmp;
4497             }
4498             (void)SvPOK_only_UTF8(TARG);
4499         }
4500         SP = MARK + 1;
4501         SETTARG;
4502     }
4503     RETURN;
4504 }
4505
4506 PP(pp_split)
4507 {
4508     dVAR; dSP; dTARG;
4509     AV *ary;
4510     register IV limit = POPi;                   /* note, negative is forever */
4511     SV * const sv = POPs;
4512     STRLEN len;
4513     register const char *s = SvPV_const(sv, len);
4514     const bool do_utf8 = DO_UTF8(sv);
4515     const char *strend = s + len;
4516     register PMOP *pm;
4517     register REGEXP *rx;
4518     register SV *dstr;
4519     register const char *m;
4520     I32 iters = 0;
4521     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4522     I32 maxiters = slen + 10;
4523     const char *orig;
4524     const I32 origlimit = limit;
4525     I32 realarray = 0;
4526     I32 base;
4527     const I32 gimme = GIMME_V;
4528     const I32 oldsave = PL_savestack_ix;
4529     I32 make_mortal = 1;
4530     bool multiline = 0;
4531     MAGIC *mg = NULL;
4532
4533 #ifdef DEBUGGING
4534     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4535 #else
4536     pm = (PMOP*)POPs;
4537 #endif
4538     if (!pm || !s)
4539         DIE(aTHX_ "panic: pp_split");
4540     rx = PM_GETRE(pm);
4541
4542     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4543              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4544
4545     RX_MATCH_UTF8_set(rx, do_utf8);
4546
4547     if (pm->op_pmreplroot) {
4548 #ifdef USE_ITHREADS
4549         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4550 #else
4551         ary = GvAVn((GV*)pm->op_pmreplroot);
4552 #endif
4553     }
4554     else if (gimme != G_ARRAY)
4555         ary = GvAVn(PL_defgv);
4556     else
4557         ary = NULL;
4558     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4559         realarray = 1;
4560         PUTBACK;
4561         av_extend(ary,0);
4562         av_clear(ary);
4563         SPAGAIN;
4564         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4565             PUSHMARK(SP);
4566             XPUSHs(SvTIED_obj((SV*)ary, mg));
4567         }
4568         else {
4569             if (!AvREAL(ary)) {
4570                 I32 i;
4571                 AvREAL_on(ary);
4572                 AvREIFY_off(ary);
4573                 for (i = AvFILLp(ary); i >= 0; i--)
4574                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4575             }
4576             /* temporarily switch stacks */
4577             SAVESWITCHSTACK(PL_curstack, ary);
4578             make_mortal = 0;
4579         }
4580     }
4581     base = SP - PL_stack_base;
4582     orig = s;
4583     if (pm->op_pmflags & PMf_SKIPWHITE) {
4584         if (pm->op_pmflags & PMf_LOCALE) {
4585             while (isSPACE_LC(*s))
4586                 s++;
4587         }
4588         else {
4589             while (isSPACE(*s))
4590                 s++;
4591         }
4592     }
4593     if (pm->op_pmflags & PMf_MULTILINE) {
4594         multiline = 1;
4595     }
4596
4597     if (!limit)
4598         limit = maxiters + 2;
4599     if (pm->op_pmflags & PMf_WHITE) {
4600         while (--limit) {
4601             m = s;
4602             while (m < strend &&
4603                    !((pm->op_pmflags & PMf_LOCALE)
4604                      ? isSPACE_LC(*m) : isSPACE(*m)))
4605                 ++m;
4606             if (m >= strend)
4607                 break;
4608
4609             dstr = newSVpvn(s, m-s);
4610             if (make_mortal)
4611                 sv_2mortal(dstr);
4612             if (do_utf8)
4613                 (void)SvUTF8_on(dstr);
4614             XPUSHs(dstr);
4615
4616             s = m + 1;
4617             while (s < strend &&
4618                    ((pm->op_pmflags & PMf_LOCALE)
4619                     ? isSPACE_LC(*s) : isSPACE(*s)))
4620                 ++s;
4621         }
4622     }
4623     else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4624         while (--limit) {
4625             for (m = s; m < strend && *m != '\n'; m++)
4626                 ;
4627             m++;
4628             if (m >= strend)
4629                 break;
4630             dstr = newSVpvn(s, m-s);
4631             if (make_mortal)
4632                 sv_2mortal(dstr);
4633             if (do_utf8)
4634                 (void)SvUTF8_on(dstr);
4635             XPUSHs(dstr);
4636             s = m;
4637         }
4638     }
4639     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4640              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4641              && (rx->reganch & ROPT_CHECK_ALL)
4642              && !(rx->reganch & ROPT_ANCH)) {
4643         const int tail = (rx->reganch & RE_INTUIT_TAIL);
4644         SV * const csv = CALLREG_INTUIT_STRING(rx);
4645
4646         len = rx->minlen;
4647         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4648             const char c = *SvPV_nolen_const(csv);
4649             while (--limit) {
4650                 for (m = s; m < strend && *m != c; m++)
4651                     ;
4652                 if (m >= strend)
4653                     break;
4654                 dstr = newSVpvn(s, m-s);
4655                 if (make_mortal)
4656                     sv_2mortal(dstr);
4657                 if (do_utf8)
4658                     (void)SvUTF8_on(dstr);
4659                 XPUSHs(dstr);
4660                 /* The rx->minlen is in characters but we want to step
4661                  * s ahead by bytes. */
4662                 if (do_utf8)
4663                     s = (char*)utf8_hop((U8*)m, len);
4664                 else
4665                     s = m + len; /* Fake \n at the end */
4666             }
4667         }
4668         else {
4669             while (s < strend && --limit &&
4670               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4671                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4672             {
4673                 dstr = newSVpvn(s, m-s);
4674                 if (make_mortal)
4675                     sv_2mortal(dstr);
4676                 if (do_utf8)
4677                     (void)SvUTF8_on(dstr);
4678                 XPUSHs(dstr);
4679                 /* The rx->minlen is in characters but we want to step
4680                  * s ahead by bytes. */
4681                 if (do_utf8)
4682                     s = (char*)utf8_hop((U8*)m, len);
4683                 else
4684                     s = m + len; /* Fake \n at the end */
4685             }
4686         }
4687     }
4688     else {
4689         maxiters += slen * rx->nparens;
4690         while (s < strend && --limit)
4691         {
4692             I32 rex_return;
4693             PUTBACK;
4694             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4695                             sv, NULL, 0);
4696             SPAGAIN;
4697             if (rex_return == 0)
4698                 break;
4699