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