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